Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Overview
| Comment: | merge novem |
|---|---|
| Timelines: | family | ancestors | descendants | both | novem-purge-literals |
| Files: | files | file ages | folders |
| SHA3-256: |
a72a317ba0c2cc89e32117dda75541fc |
| User & Date: | dgp 2019-06-12 19:34:43.302 |
Context
|
2019-06-17
| ||
| 18:38 | merge novem Leaf check-in: 5f6508a146 user: dgp tags: novem-purge-literals | |
|
2019-06-12
| ||
| 19:34 | merge novem check-in: a72a317ba0 user: dgp tags: novem-purge-literals | |
| 18:41 | merge trunk check-in: 9b0d0c83a1 user: dgp tags: novem | |
|
2018-03-15
| ||
| 15:43 | merge novem check-in: 700b9a198f user: dgp tags: novem-purge-literals | |
Changes
Deleted .fossil-settings/crnl-glob.
|
| < < < < < < < < < < < < < < < < < < < |
Changes to .fossil-settings/ignore-glob.
| ︙ | ︙ | |||
15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 | */config.log */config.status */tclConfig.sh */tclsh* */tcltest* */versions.vc */version.vc html libtommath/bn.ilg libtommath/bn.ind libtommath/pretty.build libtommath/tommath.src libtommath/*.pdf libtommath/*.pl libtommath/*.sh libtommath/tombc/* libtommath/pre_gen/* libtommath/pics/* libtommath/mtest/* libtommath/logs/* libtommath/etc/* libtommath/demo/* | > > > > | 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 | */config.log */config.status */tclConfig.sh */tclsh* */tcltest* */versions.vc */version.vc */libtcl.vfs */libtcl_*.zip html libtommath/bn.ilg libtommath/bn.ind libtommath/pretty.build libtommath/tommath.src libtommath/*.log libtommath/*.pdf libtommath/*.pl libtommath/*.sh libtommath/doc/* libtommath/tombc/* libtommath/pre_gen/* libtommath/pics/* libtommath/mtest/* libtommath/logs/* libtommath/etc/* libtommath/demo/* |
| ︙ | ︙ |
Added .github/ISSUE_TEMPLATE.md.
> > > | 1 2 3 | 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. |
Added .github/PULL_REQUEST_TEMPLATE.md.
> > > | 1 2 3 | 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. |
Added .travis.yml.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 |
sudo: false
language: c
matrix:
include:
- os: linux
dist: xenial
compiler: clang
env:
- BUILD_DIR=unix
- os: linux
dist: xenial
compiler: clang
env:
- CFGOPT=--disable-shared
- BUILD_DIR=unix
- os: linux
dist: xenial
compiler: gcc
env:
- BUILD_DIR=unix
- os: linux
dist: xenial
compiler: gcc
env:
- CFGOPT=--disable-shared
- BUILD_DIR=unix
- os: linux
dist: xenial
compiler: gcc-4.9
addons:
apt:
sources:
- ubuntu-toolchain-r-test
packages:
- g++-4.9
env:
- BUILD_DIR=unix
- os: linux
dist: xenial
compiler: gcc-5
addons:
apt:
sources:
- ubuntu-toolchain-r-test
packages:
- g++-5
env:
- BUILD_DIR=unix
- os: linux
dist: xenial
compiler: gcc-6
addons:
apt:
sources:
- ubuntu-toolchain-r-test
packages:
- g++-6
env:
- BUILD_DIR=unix
- os: linux
dist: xenial
compiler: gcc-7
addons:
apt:
sources:
- ubuntu-toolchain-r-test
packages:
- g++-7
env:
- BUILD_DIR=unix
- os: linux
dist: xenial
compiler: gcc-7
addons:
apt:
sources:
- ubuntu-toolchain-r-test
packages:
- g++-7
env:
- BUILD_DIR=unix
- CFGOPT=CFLAGS=-DTCL_UTF_MAX=6
- os: linux
dist: xenial
compiler: gcc-7
addons:
apt:
sources:
- ubuntu-toolchain-r-test
packages:
- g++-7
env:
- BUILD_DIR=unix
- CFGOPT=CFLAGS=-DTCL_UTF_MAX=3
- os: linux
dist: xenial
compiler: gcc-7
addons:
apt:
sources:
- ubuntu-toolchain-r-test
packages:
- g++-7
env:
- BUILD_DIR=unix
- CFGOPT=CFLAGS=-DTCL_NO_DEPRECATED=1
- os: osx
osx_image: xcode8
env:
- BUILD_DIR=unix
- os: osx
osx_image: xcode8
env:
- BUILD_DIR=macosx
- NO_DIRECT_CONFIGURE=1
- os: osx
osx_image: xcode9
env:
- BUILD_DIR=macosx
- NO_DIRECT_CONFIGURE=1
- os: osx
osx_image: xcode10.2
env:
- BUILD_DIR=macosx
- NO_DIRECT_CONFIGURE=1
### C builds not currently supported on Windows instances
# - os: windows
# env:
# - BUILD_DIR=win
### ... so proxy with a Mingw cross-compile
# Test with mingw-w64 (32 bit)
- os: linux
dist: xenial
compiler: i686-w64-mingw32-gcc
addons:
apt:
packages:
- gcc-mingw-w64-base
- binutils-mingw-w64-i686
- gcc-mingw-w64-i686
- gcc-mingw-w64
- gcc-multilib
- wine
env:
- BUILD_DIR=win
- CFGOPT=--host=i686-w64-mingw32
- NO_DIRECT_TEST=1
- os: linux
dist: xenial
compiler: i686-w64-mingw32-gcc
addons:
apt:
packages:
- gcc-mingw-w64-base
- binutils-mingw-w64-i686
- gcc-mingw-w64-i686
- gcc-mingw-w64
- gcc-multilib
- wine
env:
- BUILD_DIR=win
- CFGOPT="--host=i686-w64-mingw32 --disable-shared"
- NO_DIRECT_TEST=1
- os: linux
dist: xenial
compiler: i686-w64-mingw32-gcc
addons:
apt:
packages:
- gcc-mingw-w64-base
- binutils-mingw-w64-i686
- gcc-mingw-w64-i686
- gcc-mingw-w64
- gcc-multilib
- wine
env:
- BUILD_DIR=win
- CFGOPT="--host=i686-w64-mingw32 CFLAGS=-DTCL_UTF_MAX=6"
- NO_DIRECT_TEST=1
- os: linux
dist: xenial
compiler: i686-w64-mingw32-gcc
addons:
apt:
packages:
- gcc-mingw-w64-base
- binutils-mingw-w64-i686
- gcc-mingw-w64-i686
- gcc-mingw-w64
- gcc-multilib
- wine
env:
- BUILD_DIR=win
- CFGOPT="--host=i686-w64-mingw32 CFLAGS=-DTCL_UTF_MAX=3"
- NO_DIRECT_TEST=1
- os: linux
dist: xenial
compiler: i686-w64-mingw32-gcc
addons:
apt:
packages:
- gcc-mingw-w64-base
- binutils-mingw-w64-i686
- gcc-mingw-w64-i686
- gcc-mingw-w64
- gcc-multilib
- wine
env:
- BUILD_DIR=win
- CFGOPT="--host=i686-w64-mingw32 CFLAGS=-DTCL_NO_DEPRECATED=1"
- NO_DIRECT_TEST=1
# Test with mingw-w64 (64 bit)
- os: linux
dist: xenial
compiler: x86_64-w64-mingw32-gcc
addons:
apt:
packages:
- gcc-mingw-w64-base
- binutils-mingw-w64-x86-64
- gcc-mingw-w64-x86-64
- gcc-mingw-w64
- wine
env:
- BUILD_DIR=win
- CFGOPT="--host=x86_64-w64-mingw32 --enable-64bit"
- NO_DIRECT_TEST=1
- os: linux
dist: xenial
compiler: x86_64-w64-mingw32-gcc
addons:
apt:
packages:
- gcc-mingw-w64-base
- binutils-mingw-w64-x86-64
- gcc-mingw-w64-x86-64
- gcc-mingw-w64
- wine
env:
- BUILD_DIR=win
- CFGOPT="--host=x86_64-w64-mingw32 --enable-64bit --disable-shared"
- NO_DIRECT_TEST=1
- os: linux
dist: xenial
compiler: x86_64-w64-mingw32-gcc
addons:
apt:
packages:
- gcc-mingw-w64-base
- binutils-mingw-w64-x86-64
- gcc-mingw-w64-x86-64
- gcc-mingw-w64
- wine
env:
- BUILD_DIR=win
- CFGOPT="--host=x86_64-w64-mingw32 --enable-64bit CFLAGS=-DTCL_UTF_MAX=6"
- NO_DIRECT_TEST=1
- os: linux
dist: xenial
compiler: x86_64-w64-mingw32-gcc
addons:
apt:
packages:
- gcc-mingw-w64-base
- binutils-mingw-w64-x86-64
- gcc-mingw-w64-x86-64
- gcc-mingw-w64
- wine
env:
- BUILD_DIR=win
- CFGOPT="--host=x86_64-w64-mingw32 --enable-64bit CFLAGS=-DTCL_UTF_MAX=3"
- NO_DIRECT_TEST=1
- os: linux
dist: xenial
compiler: x86_64-w64-mingw32-gcc
addons:
apt:
packages:
- gcc-mingw-w64-base
- binutils-mingw-w64-x86-64
- gcc-mingw-w64-x86-64
- gcc-mingw-w64
- wine
env:
- BUILD_DIR=win
- CFGOPT="--host=x86_64-w64-mingw32 --enable-64bit CFLAGS=-DTCL_NO_DEPRECATED=1"
- NO_DIRECT_TEST=1
before_install:
- export ERROR_ON_FAILURES=1
- cd ${BUILD_DIR}
install:
- test -n "$NO_DIRECT_CONFIGURE" || ./configure ${CFGOPT}
script:
- make
# The styles=develop avoids some weird problems on OSX
- test -n "$NO_DIRECT_TEST" || make test styles=develop
|
Changes to ChangeLog.
1 2 | A NOTE ON THE CHANGELOG: Starting in early 2011, Tcl source code has been under the management of | | | 1 2 3 4 5 6 7 8 9 10 | A NOTE ON THE CHANGELOG: Starting in early 2011, Tcl source code has been under the management of fossil, hosted at https://core.tcl-lang.org/tcl/ . Fossil presents a "Timeline" view of changes made that is superior in every way to a hand edited log file. 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 <dgp@users.sourceforge.net> |
| ︙ | ︙ |
Changes to ChangeLog.2007.
| ︙ | ︙ | |||
1422 1423 1424 1425 1426 1427 1428 | an expr syntax error (masked by a [catch]). * 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 | | | 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 | an expr syntax error (masked by a [catch]). * 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. 2007-08-22 Miguel Sofer <msofer@users.sf.net> * generic/tclExecute.c (TEBC): disable the new shortcut to frequent INSTs for debug builds. REVERTED (collision with alternative fix) 2007-08-21 Don Porter <dgp@users.sourceforge.net> |
| ︙ | ︙ |
Name change from README to README.md.
|
| | > | | | > > > | < | | | | | | | | | | | < | < < < | < | < | | < | | < < | < | > < | < | | | | < | | < < | | | | | | | | < < | | < < | | | < | | < < | < < | | < | | < < | < < | | < < | < | | < < | | < | < | | > > | | < < | < | < < | | | < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 | # README: Tcl This is the **Tcl 9.0a0** source distribution. You can get any source release of Tcl from [our distribution site](https://sourceforge.net/projects/tcl/files/Tcl/). [](https://travis-ci.org/tcltk/tcl) ## Contents 1. [Introduction](#intro) 2. [Documentation](#doc) 3. [Compiling and installing Tcl](#build) 4. [Development tools](#devtools) 5. [Tcl newsgroup](#complangtcl) 6. [The Tcler's Wiki](#wiki) 7. [Mailing lists](#email) 8. [Support and Training](#support) 9. [Tracking Development](#watch) 10. [Thank You](#thanks) ## <a id="intro">1.</a> Introduction Tcl provides a powerful platform for creating integration applications that tie together diverse applications, protocols, devices, and frameworks. When paired with the Tk toolkit, Tcl provides the fastest and most powerful way to create GUI applications that run on PCs, Unix, and Mac OS X. Tcl can also be used for a variety of web-related tasks and for creating powerful command languages for applications. Tcl is maintained, enhanced, and distributed freely by the Tcl community. Source code development and tracking of bug reports and feature requests takes place at [core.tcl-lang.org](https://core.tcl-lang.org/). Tcl/Tk release and mailing list services are [hosted by SourceForge](https://sourceforge.net/projects/tcl/) with the Tcl Developer Xchange hosted at [www.tcl-lang.org](https://www.tcl-lang.org). Tcl is a freely available open source package. You can do virtually anything you like with it, such as modifying it, redistributing it, and selling it either in whole or in part. See the file `license.terms` for complete information. ## <a id="doc">2.</a> Documentation Extensive documentation is available at our website. The home page for this release, including new features, is [here](https://www.tcl.tk/software/tcltk/9.0.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/). ### <a id="doc.unix">2a.</a> Unix Documentation The `doc` subdirectory in this release contains a complete set of reference manual entries for Tcl. Files with extension "`.1`" are for programs (for example, `tclsh.1`); files with extension "`.3`" are for C library procedures; and files with extension "`.n`" describe Tcl commands. The file "`doc/Tcl.n`" gives a quick summary of the Tcl language syntax. To print any of the man pages on Unix, cd to the "doc" directory and invoke your favorite variant of troff using the normal -man macros, for example groff -man -Tpdf Tcl.n >output.pdf to print Tcl.n to PDF. If Tcl has been installed correctly and your "man" program supports it, you should be able to access the Tcl manual entries using the normal "man" mechanisms, such as man Tcl ### <a id="doc.win">2b.</a> Windows Documentation The "doc" subdirectory in this release contains a complete set of Windows help files for Tcl. Once you install this Tcl release, a shortcut to the Windows help Tcl documentation will appear in the "Start" menu: Start | Programs | Tcl | Tcl Help ## <a id="build">3.</a> Compiling and installing Tcl There are brief notes in the `unix/README`, `win/README`, and `macosx/README` about compiling on these different platforms. There is additional information about building Tcl from sources [online](https://www.tcl-lang.org/doc/howto/compile.html). ## <a id="devtools">4.</a> Development tools ActiveState produces a high quality set of commercial quality development tools that is available to accelerate your Tcl application development. Tcl Dev Kit builds on the earlier TclPro toolset and provides a debugger, static code checker, single-file wrapping utility, bytecode compiler and more. More information can be found at http://www.ActiveState.com/Tcl ## <a id="complangtcl">5.</a> Tcl newsgroup There is a USENET news group, "`comp.lang.tcl`", intended for the exchange of information about Tcl, Tk, and related applications. The newsgroup is a great place to ask general information questions. For bug reports, please see the "Support and bug fixes" section below. ## <a id="wiki">6.</a> Tcl'ers Wiki There is a [wiki-based open community site](https://wiki.tcl-lang.org/) covering all aspects of Tcl/Tk. It is dedicated to the Tcl programming language and its extensions. A wealth of useful information can be found there. It contains code snippets, references to papers, books, and FAQs, as well as pointers to development tools, extensions, and applications. You can also recommend additional URLs by editing the wiki yourself. ## <a id="email">7.</a> Mailing lists Several mailing lists are hosted at SourceForge to discuss development or use issues (like Macintosh and Windows topics). For more information and to subscribe, visit [here](https://sourceforge.net/projects/tcl/) and go to the Mailing Lists page. ## <a id="support">8.</a> Support and Training We are very interested in receiving bug reports, patches, and suggestions for improvements. We prefer that you send this information to us as tickets entered into [our issue tracker](https://core.tcl-lang.org/tcl/reportlist). We will log and follow-up on each bug, although we cannot promise a specific turn-around time. Enhancements may take longer and may not happen at all unless there is widespread support for them (we're trying to slow the rate at which Tcl/Tk turns into a kitchen sink). It's very difficult to make incompatible changes to Tcl/Tk at this point, due to the size of the installed base. The Tcl community is too large for us to provide much individual support for users. If you need help we suggest that you post questions to `comp.lang.tcl` or ask a question on [Stack Overflow](https://stackoverflow.com/questions/tagged/tcl). We read the newsgroup and will attempt to answer esoteric questions for which no one else is likely to know the answer. In addition, see the wiki for [links to other organizations](https://wiki.tcl-lang.org/training) that offer Tcl/Tk training. ## <a id="watch">9.</a> Tracking Development Tcl is developed in public. You can keep an eye on how Tcl is changing at [core.tcl-lang.org](https://core.tcl-lang.org/). ## <a id="thanks">10.</a> Thank You We'd like to express our thanks to the Tcl community for all the helpful suggestions, bug reports, and patches we have received. Tcl/Tk has improved vastly and will continue to do so with your help. |
Changes to changes.
| ︙ | ︙ | |||
8827 8828 8829 8830 8831 8832 8833 8834 8835 8836 8837 8838 8839 8840 8841 8842 8843 8844 8845 8846 8847 8848 8849 8850 8851 |
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 --- http://core.tcl.tk/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)
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | 8827 8828 8829 8830 8831 8832 8833 8834 8835 8836 8837 8838 8839 8840 8841 8842 8843 8844 8845 8846 8847 8848 8849 8850 8851 8852 8853 8854 8855 8856 8857 8858 8859 8860 8861 8862 8863 8864 8865 8866 8867 8868 8869 8870 8871 8872 8873 8874 8875 8876 8877 8878 8879 8880 8881 8882 8883 8884 8885 8886 8887 8888 8889 8890 8891 8892 8893 8894 8895 8896 8897 8898 8899 8900 8901 8902 8903 8904 8905 8906 8907 8908 8909 8910 8911 8912 8913 8914 8915 8916 8917 8918 8919 8920 8921 8922 8923 |
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 --- http://core.tcl.tk/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/ -
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)
|
| ︙ | ︙ | |||
8880 8881 8882 8883 8884 8885 8886 | --- Released 8.7a1, September 8, 2017 --- http://core.tcl.tk/tcl/ for details 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 | > > | 8944 8945 8946 8947 8948 8949 8950 8951 8952 | --- Released 8.7a1, September 8, 2017 --- http://core.tcl.tk/tcl/ for details 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 - Released 8.7a3, Nov 30, 2018 --- http://core.tcl-lang.org/tcl/ for details - |
Deleted compat/fixstrtod.c.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Changes to compat/opendir.c.
| ︙ | ︙ | |||
24 25 26 27 28 29 30 |
register int fd;
char *myname;
myname = ((*name == '\0') ? "." : name);
if ((fd = open(myname, 0, 0)) == -1) {
return NULL;
}
| | | 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 |
register int fd;
char *myname;
myname = ((*name == '\0') ? "." : name);
if ((fd = open(myname, 0, 0)) == -1) {
return NULL;
}
dirp = (DIR *) Tcl_Alloc(sizeof(DIR));
if (dirp == NULL) {
/* unreachable? */
close(fd);
return NULL;
}
dirp->dd_fd = fd;
dirp->dd_loc = 0;
|
| ︙ | ︙ | |||
102 103 104 105 106 107 108 |
void
closedir(
register DIR *dirp)
{
close(dirp->dd_fd);
dirp->dd_fd = -1;
dirp->dd_loc = 0;
| | | 102 103 104 105 106 107 108 109 110 |
void
closedir(
register DIR *dirp)
{
close(dirp->dd_fd);
dirp->dd_fd = -1;
dirp->dd_loc = 0;
Tcl_Free(dirp);
}
|
Changes to compat/stdlib.h.
| ︙ | ︙ | |||
25 26 27 28 29 30 31 | extern void exit(int status); extern int free(char *blockPtr); 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); | < | 25 26 27 28 29 30 31 32 33 34 35 | extern void exit(int status); extern int free(char *blockPtr); 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 long strtol(const char *string, char **endPtr, int base); extern unsigned long strtoul(const char *string, char **endPtr, int base); #endif /* _STDLIB */ |
Deleted compat/strtod.c.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Changes to compat/strtol.c.
| ︙ | ︙ | |||
49 50 51 52 53 54 55 |
long result;
/*
* Skip any leading blanks.
*/
p = string;
| | | 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 |
long result;
/*
* Skip any leading blanks.
*/
p = string;
while (TclIsSpaceProc(*p)) {
p += 1;
}
/*
* Check for a sign.
*/
|
| ︙ | ︙ |
Changes to compat/strtoul.c.
| ︙ | ︙ | |||
70 71 72 73 74 75 76 |
int overflow=0;
/*
* Skip any leading blanks.
*/
p = string;
| | | 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 |
int overflow=0;
/*
* Skip any leading blanks.
*/
p = string;
while (TclIsSpaceProc(*p)) {
p += 1;
}
if (*p == '-') {
negative = 1;
p += 1;
} else {
if (*p == '+') {
|
| ︙ | ︙ |
Deleted compat/unistd.h.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Changes to compat/waitpid.c.
| ︙ | ︙ | |||
96 97 98 99 100 101 102 |
result = waitPtr->pid;
*statusPtr = *((int *) &waitPtr->status);
if (prevPtr == NULL) {
deadList = waitPtr->nextPtr;
} else {
prevPtr->nextPtr = waitPtr->nextPtr;
}
| | | 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 |
result = waitPtr->pid;
*statusPtr = *((int *) &waitPtr->status);
if (prevPtr == NULL) {
deadList = waitPtr->nextPtr;
} else {
prevPtr->nextPtr = waitPtr->nextPtr;
}
Tcl_Free(waitPtr);
return result;
}
/*
* Wait for any process to stop or exit. If it's an acceptable one then
* return it to the caller; otherwise store information about it in the
* list of exited processes and try again. On systems that have only wait
|
| ︙ | ︙ | |||
152 153 154 155 156 157 158 |
saveInfo:
for (waitPtr = deadList; waitPtr != NULL; waitPtr = waitPtr->nextPtr) {
if (waitPtr->pid == result) {
waitPtr->status = status;
goto waitAgain;
}
}
| | | 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 |
saveInfo:
for (waitPtr = deadList; waitPtr != NULL; waitPtr = waitPtr->nextPtr) {
if (waitPtr->pid == result) {
waitPtr->status = status;
goto waitAgain;
}
}
waitPtr = (WaitInfo *) Tcl_Alloc(sizeof(WaitInfo));
waitPtr->pid = result;
waitPtr->status = status;
waitPtr->nextPtr = deadList;
deadList = waitPtr;
waitAgain:
continue;
}
}
|
Changes to compat/zlib/contrib/minizip/crypt.h.
| ︙ | ︙ | |||
24 25 26 27 28 29 30 31 32 33 34 35 36 37 |
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
| > > > > > > | 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 |
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))
#ifdef Z_U4
typedef Z_U4 z_crc_t;
#else
typedef unsigned long z_crc_t;
#endif
/***********************************************************************
* 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
|
| ︙ | ︙ |
Changes to compat/zlib/contrib/minizip/miniunz.c.
| ︙ | ︙ | |||
93 94 95 96 97 98 99 |
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
| | | 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 |
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;
|
| ︙ | ︙ |
Changes to compat/zlib/contrib/minizip/minizip.c.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 |
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 )
*/
| < | | < | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 |
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(__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 <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <time.h>
#include <errno.h>
#include <fcntl.h>
|
| ︙ | ︙ | |||
90 91 92 93 94 95 96 |
FindClose(hFind);
ret = 1;
}
}
return ret;
}
#else
| | | 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 |
FindClose(hFind);
ret = 1;
}
}
return ret;
}
#else
#if defined(unix) || defined(__APPLE__)
uLong filetime(f, tmzip, dt)
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() */
|
| ︙ | ︙ | |||
168 169 170 171 172 173 174 175 176 177 178 179 180 181 |
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" \
" -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");
}
| > | 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 |
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");
}
|
| ︙ | ︙ | |||
238 239 240 241 242 243 244 245 246 247 248 249 250 |
largeFile = 1;
fclose(pFile);
}
return largeFile;
}
int main(argc,argv)
int argc;
char *argv[];
{
int i;
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 |
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;
|
| ︙ | ︙ | |||
281 282 283 284 285 286 287 |
opt_overwrite = 1;
if ((c=='a') || (c=='A'))
opt_overwrite = 2;
if ((c>='0') && (c<='9'))
opt_compress_level = c-'0';
if ((c=='j') || (c=='J'))
opt_exclude_path = 1;
| | > | 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 |
opt_overwrite = 1;
if ((c=='a') || (c=='A'))
opt_overwrite = 2;
if ((c>='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<argc))
{
password=argv[i+1];
i++;
}
}
}
|
| ︙ | ︙ | |||
388 389 390 391 392 393 394 395 396 397 |
for (i=zipfilenamearg+1;(i<argc) && (err==ZIP_OK);i++)
{
if (!((((*(argv[i]))=='-') || ((*(argv[i]))=='/')) &&
((argv[i][1]=='o') || (argv[i][1]=='O') ||
(argv[i][1]=='a') || (argv[i][1]=='A') ||
(argv[i][1]=='p') || (argv[i][1]=='P') ||
((argv[i][1]>='0') || (argv[i][1]<='9'))) &&
(strlen(argv[i]) == 2)))
{
| > < < < < < < < | < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 |
for (i=zipfilenamearg+1;(i<argc) && (err==ZIP_OK);i++)
{
if (!((((*(argv[i]))=='-') || ((*(argv[i]))=='/')) &&
((argv[i][1]=='o') || (argv[i][1]=='O') ||
(argv[i][1]=='a') || (argv[i][1]=='A') ||
(argv[i][1]=='p') || (argv[i][1]=='P') ||
(argv[i][1]=='r') || (argv[i][1]=='R') ||
((argv[i][1]>='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);
}
|
| ︙ | ︙ |
Added compat/zlib/contrib/minizip/tinydir.h.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 |
/*
Copyright (c) 2013-2017, tinydir authors:
- Cong Xu
- Lautis Sun
- Baudouin Feildel
- Andargor <andargor@yahoo.com>
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 <errno.h>
#include <stdlib.h>
#include <string.h>
#ifdef _MSC_VER
# define WIN32_LEAN_AND_MEAN
# include <windows.h>
# include <tchar.h>
# pragma warning(push)
# pragma warning (disable : 4996)
#else
# include <dirent.h>
# include <libgen.h>
# include <sys/stat.h>
# include <stddef.h>
#endif
#ifdef __MINGW32__
# include <tchar.h>
#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 <windows.h>
# define _TINYDIR_PATH_MAX MAX_PATH
#elif defined __linux__
# include <limits.h>
# define _TINYDIR_PATH_MAX PATH_MAX
#elif defined(__unix__) || (defined(__APPLE__) && defined(__MACH__))
# include <sys/param.h>
# if defined(BSD)
# include <limits.h>
# 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 <unistd.h>
#endif
#if _BSD_SOURCE || _SVID_SOURCE || \
(_POSIX_C_SOURCE >= 200809L || _XOPEN_SOURCE >= 700)
# define _TINYDIR_HAS_DIRFD
# include <sys/types.h>
#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 <ben@decadent.org.uk>
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
|
compat/zlib/win32/zdll.lib became a regular file.
cannot compute difference between binary files
Changes to doc/AddErrInfo.3.
| ︙ | ︙ | |||
54 55 56 57 58 59 60 | this points to the first byte of an array of \fIlength\fR bytes containing a string to append to the \fB\-errorinfo\fR return option. This byte array may contain embedded null bytes unless \fIlength\fR is negative. .AP Tcl_Obj *objPtr in A message to be appended to the \fB\-errorinfo\fR return option in the form of a Tcl_Obj value. | | | | 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 | this points to the first byte of an array of \fIlength\fR bytes containing a string to append to the \fB\-errorinfo\fR return option. This byte array may contain embedded null bytes unless \fIlength\fR is negative. .AP Tcl_Obj *objPtr in A message to be appended to the \fB\-errorinfo\fR return option in the form of a Tcl_Obj value. .AP size_t length in The number of bytes to copy from \fImessage\fR when appending to the \fB\-errorinfo\fR return option. If TCL_AUTO_LENGTH, 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 |
| ︙ | ︙ |
Changes to doc/Alloc.3.
1 2 3 4 5 6 7 8 9 10 | '\" '\" Copyright (c) 1995-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH Tcl_Alloc 3 7.5 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME | | | | < < < < < < | < < < | < < < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 | '\" '\" Copyright (c) 1995-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH Tcl_Alloc 3 7.5 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_Alloc, Tcl_Free, Tcl_Realloc, Tcl_AttemptAlloc, Tcl_AttemptRealloc \- allocate or free heap memory .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp char * \fBTcl_Alloc\fR(\fIsize\fR) .sp void \fBTcl_Free\fR(\fIptr\fR) .sp void * \fBTcl_Realloc\fR(\fIptr, size\fR) .sp void * \fBTcl_AttemptAlloc\fR(\fIsize\fR) .sp void * \fBTcl_AttemptRealloc\fR(\fIptr, size\fR) .SH ARGUMENTS .AS char *size .AP "unsigned int" size in Size in bytes of the memory block to allocate. .AP char *ptr in Pointer to memory block to free or realloc. .BE |
| ︙ | ︙ | |||
75 76 77 78 79 80 81 | function to \fBTcl_Alloc\fR and \fBTcl_Realloc\fR, except that \fBTcl_AttemptAlloc\fR and \fBTcl_AttemptRealloc\fR will not cause the Tcl interpreter to \fBpanic\fR if the memory allocation fails. If the allocation fails, these functions will return NULL. Note that on some platforms, but not all, attempting to allocate a zero-sized block of memory will also cause these functions to return NULL. .PP | < < < < | > > | < < | 60 61 62 63 64 65 66 67 68 69 70 71 72 73 | function to \fBTcl_Alloc\fR and \fBTcl_Realloc\fR, except that \fBTcl_AttemptAlloc\fR and \fBTcl_AttemptRealloc\fR will not cause the Tcl interpreter to \fBpanic\fR if the memory allocation fails. If the allocation fails, these functions will return NULL. Note that on some platforms, but not all, attempting to allocate a zero-sized block of memory will also cause these functions to return NULL. .PP 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. .SH KEYWORDS alloc, allocation, free, malloc, memory, realloc, TCL_MEM_DEBUG |
Changes to doc/AssocData.3.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 | .BS .SH NAME Tcl_GetAssocData, Tcl_SetAssocData, Tcl_DeleteAssocData \- manage associations of string keys and user specified data with Tcl interpreters .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp | | | | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 | .BS .SH NAME Tcl_GetAssocData, Tcl_SetAssocData, Tcl_DeleteAssocData \- manage associations of string keys and user specified data with Tcl interpreters .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp void * \fBTcl_GetAssocData\fR(\fIinterp, key, delProcPtr\fR) .sp \fBTcl_SetAssocData\fR(\fIinterp, key, delProc, clientData\fR) .sp \fBTcl_DeleteAssocData\fR(\fIinterp, key\fR) .SH ARGUMENTS .AS Tcl_InterpDeleteProc **delProcPtr .AP Tcl_Interp *interp in Interpreter in which to execute the specified command. .AP "const char" *key in Key for association with which to store data or from which to delete or retrieve data. Typically the module prefix for a package. .AP Tcl_InterpDeleteProc *delProc in Procedure to call when \fIinterp\fR is deleted. .AP Tcl_InterpDeleteProc **delProcPtr in Pointer to location in which to store address of current deletion procedure for association. Ignored if NULL. .AP void *clientData in Arbitrary one-word value associated with the given key in this interpreter. This data is owned by the caller. .BE .SH DESCRIPTION .PP These procedures allow extensions to associate their own data with |
| ︙ | ︙ | |||
60 61 62 63 64 65 66 | If the \fIdeleteProc\fR argument is non-NULL it specifies the address of a procedure to invoke if the interpreter is deleted before the association is deleted. \fIDeleteProc\fR should have arguments and result that match the type \fBTcl_InterpDeleteProc\fR: .PP .CS typedef void \fBTcl_InterpDeleteProc\fR( | | | 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 |
If the \fIdeleteProc\fR argument is non-NULL it specifies the address of a
procedure to invoke if the interpreter is deleted before the association
is deleted. \fIDeleteProc\fR should have arguments and result that match
the type \fBTcl_InterpDeleteProc\fR:
.PP
.CS
typedef void \fBTcl_InterpDeleteProc\fR(
void *\fIclientData\fR,
Tcl_Interp *\fIinterp\fR);
.CE
.PP
When \fIdeleteProc\fR is invoked the \fIclientData\fR and \fIinterp\fR
arguments will be the same as the corresponding arguments passed to
\fBTcl_SetAssocData\fR.
The deletion procedure will \fInot\fR be invoked if the association
|
| ︙ | ︙ |
Changes to doc/Async.3.
| ︙ | ︙ | |||
26 27 28 29 30 31 32 | .sp int \fBTcl_AsyncReady\fR() .SH ARGUMENTS .AS Tcl_AsyncHandler clientData .AP Tcl_AsyncProc *proc in Procedure to invoke to handle an asynchronous event. | | | 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 | .sp int \fBTcl_AsyncReady\fR() .SH ARGUMENTS .AS Tcl_AsyncHandler clientData .AP Tcl_AsyncProc *proc in Procedure to invoke to handle an asynchronous event. .AP void *clientData in One-word value to pass to \fIproc\fR. .AP Tcl_AsyncHandler async in Token for asynchronous event handler. .AP Tcl_Interp *interp in Tcl interpreter in which command was being evaluated when handler was invoked, or NULL if handler was invoked when there was no interpreter active. |
| ︙ | ︙ | |||
80 81 82 83 84 85 86 | the world is in a safe state, and \fIproc\fR can then carry out the actions associated with the asynchronous event. \fIProc\fR should have arguments and result that match the type \fBTcl_AsyncProc\fR: .PP .CS typedef int \fBTcl_AsyncProc\fR( | | | 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 |
the world is in a safe state, and \fIproc\fR can then carry out
the actions associated with the asynchronous event.
\fIProc\fR should have arguments and result that match the
type \fBTcl_AsyncProc\fR:
.PP
.CS
typedef int \fBTcl_AsyncProc\fR(
void *\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.
|
| ︙ | ︙ |
Changes to doc/ByteArrObj.3.
| ︙ | ︙ | |||
25 26 27 28 29 30 31 | unsigned char * \fBTcl_SetByteArrayLength\fR(\fIobjPtr, length\fR) .SH ARGUMENTS .AS "const unsigned char" *lengthPtr in/out .AP "const unsigned char" *bytes in The array of bytes used to initialize or set a byte-array value. May be NULL even if \fIlength\fR is non-zero. | | | | 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 | unsigned char * \fBTcl_SetByteArrayLength\fR(\fIobjPtr, length\fR) .SH ARGUMENTS .AS "const unsigned char" *lengthPtr in/out .AP "const unsigned char" *bytes in The array of bytes used to initialize or set a byte-array value. May be NULL even if \fIlength\fR is non-zero. .AP size_t length in The length of the array of bytes. .AP Tcl_Obj *objPtr in/out For \fBTcl_SetByteArrayObj\fR, this points to the value to be converted to byte-array type. For \fBTcl_GetByteArrayFromObj\fR and \fBTcl_SetByteArrayLength\fR, this points to the value from which to get the byte-array value; if \fIobjPtr\fR does not already point to a byte-array value, it will be converted to one. .AP int *lengthPtr out |
| ︙ | ︙ |
Changes to doc/CallDel.3.
| ︙ | ︙ | |||
19 20 21 22 23 24 25 | \fBTcl_DontCallWhenDeleted\fR(\fIinterp\fR, \fIproc\fR, \fIclientData\fR) .SH ARGUMENTS .AS Tcl_InterpDeleteProc clientData .AP Tcl_Interp *interp in Interpreter with which to associated callback. .AP Tcl_InterpDeleteProc *proc in Procedure to call when \fIinterp\fR is deleted. | | | | 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 |
\fBTcl_DontCallWhenDeleted\fR(\fIinterp\fR, \fIproc\fR, \fIclientData\fR)
.SH ARGUMENTS
.AS Tcl_InterpDeleteProc clientData
.AP Tcl_Interp *interp in
Interpreter with which to associated callback.
.AP Tcl_InterpDeleteProc *proc in
Procedure to call when \fIinterp\fR is deleted.
.AP void *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,
Tcl_Interp *\fIinterp\fR);
.CE
.PP
The \fIclientData\fR and \fIinterp\fR parameters are
copies of the \fIclientData\fR and \fIinterp\fR arguments given
to \fBTcl_CallWhenDeleted\fR.
Typically, \fIclientData\fR points to an application-specific
|
| ︙ | ︙ |
Changes to doc/Cancel.3.
| ︙ | ︙ | |||
26 27 28 29 30 31 32 | not NULL, this object will have its reference count decremented before \fBTcl_CancelEval\fR returns. .AP int flags in ORed combination of flag bits that specify additional options. For \fBTcl_CancelEval\fR, only \fBTCL_CANCEL_UNWIND\fR is currently supported. For \fBTcl_Canceled\fR, only \fBTCL_LEAVE_ERR_MSG\fR and \fBTCL_CANCEL_UNWIND\fR are currently supported. | | | 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 | not NULL, this object will have its reference count decremented before \fBTcl_CancelEval\fR returns. .AP int flags in ORed combination of flag bits that specify additional options. For \fBTcl_CancelEval\fR, only \fBTCL_CANCEL_UNWIND\fR is currently supported. For \fBTcl_Canceled\fR, only \fBTCL_LEAVE_ERR_MSG\fR and \fBTCL_CANCEL_UNWIND\fR are currently supported. .AP 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 |
| ︙ | ︙ |
Changes to doc/ChnlStack.3.
| ︙ | ︙ | |||
28 29 30 31 32 33 34 | .sp .SH ARGUMENTS .AS Tcl_ChannelType clientData .AP Tcl_Interp *interp in Interpreter for error reporting. .AP "const Tcl_ChannelType" *typePtr in The new channel I/O procedures to use for \fIchannel\fR. | | | 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 | .sp .SH ARGUMENTS .AS Tcl_ChannelType clientData .AP Tcl_Interp *interp in Interpreter for error reporting. .AP "const Tcl_ChannelType" *typePtr in The new channel I/O procedures to use for \fIchannel\fR. .AP void *clientData in Arbitrary one-word value to pass to channel I/O procedures. .AP int mask in Conditions under which \fIchannel\fR will be used: OR-ed combination of \fBTCL_READABLE\fR, \fBTCL_WRITABLE\fR and \fBTCL_EXCEPTION\fR. This can be a subset of the operations currently allowed on \fIchannel\fR. .AP Tcl_Channel channel in An existing Tcl channel such as returned by \fBTcl_CreateChannel\fR. |
| ︙ | ︙ |
Changes to doc/Class.3.
| ︙ | ︙ | |||
37 38 39 40 41 42 43 | .sp Tcl_Object \fBTcl_CopyObjectInstance\fR(\fIinterp, object, name, nsName\fR) .sp int \fBTcl_ObjectDeleted\fR(\fIobject\fR) .sp | | | | | 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 | .sp Tcl_Object \fBTcl_CopyObjectInstance\fR(\fIinterp, object, name, nsName\fR) .sp int \fBTcl_ObjectDeleted\fR(\fIobject\fR) .sp 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. |
| ︙ | ︙ | |||
79 80 81 82 83 84 85 | 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. .AP Tcl_ObjectMetadataType *metaTypePtr in The type of \fImetadata\fR being set with \fBTcl_ClassSetMetadata\fR or retrieved with \fBTcl_ClassGetMetadata\fR. | | | 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 | 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. .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 |
| ︙ | ︙ | |||
167 168 169 170 171 172 173 | .SS "TCL_OBJECTMETADATADELETEPROC FUNCTION SIGNATURE" .PP Functions matching this signature are used to delete metadata associated with a class or object. .PP .CS typedef void \fBTcl_ObjectMetadataDeleteProc\fR( | | | | | 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 |
.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
|
| ︙ | ︙ |
Changes to doc/CrtChannel.3.
| ︙ | ︙ | |||
13 14 15 16 17 18 19 | .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp Tcl_Channel \fBTcl_CreateChannel\fR(\fItypePtr, channelName, instanceData, mask\fR) .sp | | | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 | .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp Tcl_Channel \fBTcl_CreateChannel\fR(\fItypePtr, channelName, instanceData, mask\fR) .sp void * \fBTcl_GetChannelInstanceData\fR(\fIchannel\fR) .sp const Tcl_ChannelType * \fBTcl_GetChannelType\fR(\fIchannel\fR) .sp const char * \fBTcl_GetChannelName\fR(\fIchannel\fR) |
| ︙ | ︙ | |||
124 125 126 127 128 129 130 | can be called to perform I/O and other functions on the channel. .AP "const char" *channelName in The name of this channel, such as \fBfile3\fR; must not be in use by any other channel. Can be NULL, in which case the channel is created without a name. If the created channel is assigned to one of the standard channels (\fBstdin\fR, \fBstdout\fR or \fBstderr\fR), the assigned channel name will be the name of the standard channel. | | | | 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 | can be called to perform I/O and other functions on the channel. .AP "const char" *channelName in The name of this channel, such as \fBfile3\fR; must not be in use by any other channel. Can be NULL, in which case the channel is created without a name. If the created channel is assigned to one of the standard channels (\fBstdin\fR, \fBstdout\fR or \fBstderr\fR), the assigned channel name will be the name of the standard channel. .AP void *instanceData in Arbitrary one-word value to be associated with this channel. This value is passed to procedures in \fItypePtr\fR when they are invoked. .AP int mask in OR-ed combination of \fBTCL_READABLE\fR and \fBTCL_WRITABLE\fR to indicate whether a channel is readable and writable. .AP Tcl_Channel channel in The channel to operate on. .AP int direction in \fBTCL_READABLE\fR means the input handle is wanted; \fBTCL_WRITABLE\fR means the output handle is wanted. .AP void **handlePtr out Points to the location where the desired OS-specific handle should be stored. .AP int size in The size, in bytes, of buffers to allocate in this channel. .AP int mask in An OR-ed combination of \fBTCL_READABLE\fR, \fBTCL_WRITABLE\fR and \fBTCL_EXCEPTION\fR that indicates events that have occurred on |
| ︙ | ︙ | |||
395 396 397 398 399 400 401 | .PP The \fIblockModeProc\fR field contains the address of a function called by the generic layer to set blocking and nonblocking mode on the device. \fIBlockModeProc\fR should match the following prototype: .PP .CS typedef int \fBTcl_DriverBlockModeProc\fR( | | | 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 |
.PP
The \fIblockModeProc\fR field contains the address of a function called by
the generic layer to set blocking and nonblocking mode on the device.
\fIBlockModeProc\fR should match the following prototype:
.PP
.CS
typedef int \fBTcl_DriverBlockModeProc\fR(
void *\fIinstanceData\fR,
int \fImode\fR);
.CE
.PP
The \fIinstanceData\fR is the same as the value passed to
\fBTcl_CreateChannel\fR when this channel was created. The \fImode\fR
argument is either \fBTCL_MODE_BLOCKING\fR or \fBTCL_MODE_NONBLOCKING\fR to
set the device into blocking or nonblocking mode. The function should
|
| ︙ | ︙ | |||
430 431 432 433 434 435 436 | .PP The \fIcloseProc\fR field contains the address of a function called by the generic layer to clean up driver-related information when the channel is closed. \fICloseProc\fR must match the following prototype: .PP .CS typedef int \fBTcl_DriverCloseProc\fR( | | | 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 |
.PP
The \fIcloseProc\fR field contains the address of a function called by the
generic layer to clean up driver-related information when the channel is
closed. \fICloseProc\fR must match the following prototype:
.PP
.CS
typedef int \fBTcl_DriverCloseProc\fR(
void *\fIinstanceData\fR,
Tcl_Interp *\fIinterp\fR);
.CE
.PP
The \fIinstanceData\fR argument is the same as the value provided to
\fBTcl_CreateChannel\fR when the channel was created. The function should
release any storage maintained by the channel driver for this channel, and
close the input and output devices encapsulated by this channel. All queued
|
| ︙ | ︙ | |||
452 453 454 455 456 457 458 | Alternatively, channels that support closing the read and write sides independently may set \fIcloseProc\fR to \fBTCL_CLOSE2PROC\fR and set \fIclose2Proc\fR to the address of a function that matches the following prototype: .PP .CS typedef int \fBTcl_DriverClose2Proc\fR( | | | 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 |
Alternatively, channels that support closing the read and write sides
independently may set \fIcloseProc\fR to \fBTCL_CLOSE2PROC\fR and set
\fIclose2Proc\fR to the address of a function that matches the
following prototype:
.PP
.CS
typedef int \fBTcl_DriverClose2Proc\fR(
void *\fIinstanceData\fR,
Tcl_Interp *\fIinterp\fR,
int \fIflags\fR);
.CE
.PP
The \fIclose2Proc\fR will be called with \fIflags\fR set to an OR'ed
combination of \fBTCL_CLOSE_READ\fR or \fBTCL_CLOSE_WRITE\fR to
indicate that the driver should close the read and/or write side of
|
| ︙ | ︙ | |||
483 484 485 486 487 488 489 | .PP The \fIinputProc\fR field contains the address of a function called by the generic layer to read data from the file or device and store it in an internal buffer. \fIInputProc\fR must match the following prototype: .PP .CS typedef int \fBTcl_DriverInputProc\fR( | | | 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 |
.PP
The \fIinputProc\fR field contains the address of a function called by the
generic layer to read data from the file or device and store it in an
internal buffer. \fIInputProc\fR must match the following prototype:
.PP
.CS
typedef int \fBTcl_DriverInputProc\fR(
void *\fIinstanceData\fR,
char *\fIbuf\fR,
int \fIbufSize\fR,
int *\fIerrorCodePtr\fR);
.CE
.PP
\fIInstanceData\fR is the same as the value passed to
\fBTcl_CreateChannel\fR when the channel was created. The \fIbuf\fR
|
| ︙ | ︙ | |||
527 528 529 530 531 532 533 | .PP The \fIoutputProc\fR field contains the address of a function called by the generic layer to transfer data from an internal buffer to the output device. \fIOutputProc\fR must match the following prototype: .PP .CS typedef int \fBTcl_DriverOutputProc\fR( | | | 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 |
.PP
The \fIoutputProc\fR field contains the address of a function called by the
generic layer to transfer data from an internal buffer to the output device.
\fIOutputProc\fR must match the following prototype:
.PP
.CS
typedef int \fBTcl_DriverOutputProc\fR(
void *\fIinstanceData\fR,
const char *\fIbuf\fR,
int \fItoWrite\fR,
int *\fIerrorCodePtr\fR);
.CE
.PP
\fIInstanceData\fR is the same as the value passed to
\fBTcl_CreateChannel\fR when the channel was created. The \fIbuf\fR
|
| ︙ | ︙ | |||
566 567 568 569 570 571 572 | The \fIseekProc\fR field contains the address of a function called by the generic layer to move the access point at which subsequent input or output operations will be applied. \fISeekProc\fR must match the following prototype: .PP .CS typedef int \fBTcl_DriverSeekProc\fR( | | | 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 |
The \fIseekProc\fR field contains the address of a function called by the
generic layer to move the access point at which subsequent input or output
operations will be applied. \fISeekProc\fR must match the following
prototype:
.PP
.CS
typedef int \fBTcl_DriverSeekProc\fR(
void *\fIinstanceData\fR,
long \fIoffset\fR,
int \fIseekMode\fR,
int *\fIerrorCodePtr\fR);
.CE
.PP
The \fIinstanceData\fR argument is the same as the value given to
\fBTcl_CreateChannel\fR when this channel was created. \fIOffset\fR and
|
| ︙ | ︙ | |||
596 597 598 599 600 601 602 | within files larger than 2GB. The \fIwideSeekProc\fR will be called in preference to the \fIseekProc\fR, but both must be defined if the \fIwideSeekProc\fR is defined. \fIWideSeekProc\fR must match the following prototype: .PP .CS typedef Tcl_WideInt \fBTcl_DriverWideSeekProc\fR( | | | 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 |
within files larger than 2GB. The \fIwideSeekProc\fR will be called
in preference to the \fIseekProc\fR, but both must be defined if the
\fIwideSeekProc\fR is defined. \fIWideSeekProc\fR must match the
following prototype:
.PP
.CS
typedef Tcl_WideInt \fBTcl_DriverWideSeekProc\fR(
void *\fIinstanceData\fR,
Tcl_WideInt \fIoffset\fR,
int \fIseekMode\fR,
int *\fIerrorCodePtr\fR);
.CE
.PP
The arguments and return values mean the same thing as with
\fIseekProc\fR above, except that the type of offsets and the return
|
| ︙ | ︙ | |||
618 619 620 621 622 623 624 | .PP The \fIsetOptionProc\fR field contains the address of a function called by the generic layer to set a channel type specific option on a channel. \fIsetOptionProc\fR must match the following prototype: .PP .CS typedef int \fBTcl_DriverSetOptionProc\fR( | | | 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 |
.PP
The \fIsetOptionProc\fR field contains the address of a function called by
the generic layer to set a channel type specific option on a channel.
\fIsetOptionProc\fR must match the following prototype:
.PP
.CS
typedef int \fBTcl_DriverSetOptionProc\fR(
void *\fIinstanceData\fR,
Tcl_Interp *\fIinterp\fR,
const char *\fIoptionName\fR,
const char *\fInewValue\fR);
.CE
.PP
\fIoptionName\fR is the name of an option to set, and \fInewValue\fR is
the new value for that option, as a string. The \fIinstanceData\fR is the
|
| ︙ | ︙ | |||
659 660 661 662 663 664 665 | .PP The \fIgetOptionProc\fR field contains the address of a function called by the generic layer to get the value of a channel type specific option on a channel. \fIgetOptionProc\fR must match the following prototype: .PP .CS typedef int \fBTcl_DriverGetOptionProc\fR( | | | 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 |
.PP
The \fIgetOptionProc\fR field contains the address of a function called by
the generic layer to get the value of a channel type specific option on a
channel. \fIgetOptionProc\fR must match the following prototype:
.PP
.CS
typedef int \fBTcl_DriverGetOptionProc\fR(
void *\fIinstanceData\fR,
Tcl_Interp *\fIinterp\fR,
const char *\fIoptionName\fR,
Tcl_DString *\fIoptionValue\fR);
.CE
.PP
\fIOptionName\fR is the name of an option supported by this type of
channel. If the option name is not NULL, the function stores its current
|
| ︙ | ︙ | |||
697 698 699 700 701 702 703 | The \fIwatchProc\fR field contains the address of a function called by the generic layer to initialize the event notification mechanism to notice events of interest on this channel. \fIWatchProc\fR should match the following prototype: .PP .CS typedef void \fBTcl_DriverWatchProc\fR( | | | 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 |
The \fIwatchProc\fR field contains the address of a function called
by the generic layer to initialize the event notification mechanism to
notice events of interest on this channel.
\fIWatchProc\fR should match the following prototype:
.PP
.CS
typedef void \fBTcl_DriverWatchProc\fR(
void *\fIinstanceData\fR,
int \fImask\fR);
.CE
.PP
The \fIinstanceData\fR is the same as the value passed to
\fBTcl_CreateChannel\fR when this channel was created. The \fImask\fR
argument is an OR-ed combination of \fBTCL_READABLE\fR, \fBTCL_WRITABLE\fR
and \fBTCL_EXCEPTION\fR; it indicates events the caller is interested in
|
| ︙ | ︙ | |||
728 729 730 731 732 733 734 | .PP The \fIgetHandleProc\fR field contains the address of a function called by the generic layer to retrieve a device-specific handle from the channel. \fIGetHandleProc\fR should match the following prototype: .PP .CS typedef int \fBTcl_DriverGetHandleProc\fR( | | | | 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 |
.PP
The \fIgetHandleProc\fR field contains the address of a function called by
the generic layer to retrieve a device-specific handle from the channel.
\fIGetHandleProc\fR should match the following prototype:
.PP
.CS
typedef int \fBTcl_DriverGetHandleProc\fR(
void *\fIinstanceData\fR,
int \fIdirection\fR,
void **\fIhandlePtr\fR);
.CE
.PP
\fIInstanceData\fR is the same as the value passed to
\fBTcl_CreateChannel\fR when this channel was created. The \fIdirection\fR
argument is either \fBTCL_READABLE\fR to retrieve the handle used
for input, or \fBTCL_WRITABLE\fR to retrieve the handle used for
output.
|
| ︙ | ︙ | |||
757 758 759 760 761 762 763 | .PP The \fIflushProc\fR field is currently reserved for future use. It should be set to NULL. \fIFlushProc\fR should match the following prototype: .PP .CS typedef int \fBTcl_DriverFlushProc\fR( | | | | 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 |
.PP
The \fIflushProc\fR field is currently reserved for future use.
It should be set to NULL.
\fIFlushProc\fR should match the following prototype:
.PP
.CS
typedef int \fBTcl_DriverFlushProc\fR(
void *\fIinstanceData\fR);
.CE
.PP
This value can be retrieved with \fBTcl_ChannelFlushProc\fR, which returns
a pointer to the function.
.SS HANDLERPROC
.PP
The \fIhandlerProc\fR field contains the address of a function called by
the generic layer to notify the channel that an event occurred. It should
be defined for stacked channel drivers that wish to be notified of events
that occur on the underlying (stacked) channel.
\fIHandlerProc\fR should match the following prototype:
.PP
.CS
typedef int \fBTcl_DriverHandlerProc\fR(
void *\fIinstanceData\fR,
int \fIinterestMask\fR);
.CE
.PP
\fIInstanceData\fR is the same as the value passed to \fBTcl_CreateChannel\fR
when this channel was created. The \fIinterestMask\fR is an OR-ed
combination of \fBTCL_READABLE\fR or \fBTCL_WRITABLE\fR; it indicates what
type of event occurred on this channel.
|
| ︙ | ︙ | |||
801 802 803 804 805 806 807 | The action \fITCL_CHANNEL_THREAD_INSERT\fR is used to notify the driver that it should update or initialize any thread-specific data it might be maintaining using the calling thread as the associate. See \fBTcl_CutChannel\fR and \fBTcl_SpliceChannel\fR for more detail. .PP .CS typedef void \fBTcl_DriverThreadActionProc\fR( | | | | 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 |
The action \fITCL_CHANNEL_THREAD_INSERT\fR is used to notify the
driver that it should update or initialize any thread-specific data it
might be maintaining using the calling thread as the associate. See
\fBTcl_CutChannel\fR and \fBTcl_SpliceChannel\fR for more detail.
.PP
.CS
typedef void \fBTcl_DriverThreadActionProc\fR(
void *\fIinstanceData\fR,
int \fIaction\fR);
.CE
.PP
\fIInstanceData\fR is the same as the value passed to
\fBTcl_CreateChannel\fR when this channel was created.
.PP
These values can be retrieved with \fBTcl_ChannelThreadActionProc\fR,
which returns a pointer to the function.
.SS "TRUNCATEPROC"
.PP
The \fItruncateProc\fR field contains the address of the function
called by the generic layer when a channel is truncated to some
length. It can be NULL.
.PP
.CS
typedef int \fBTcl_DriverTruncateProc\fR(
void *\fIinstanceData\fR,
Tcl_WideInt \fIlength\fR);
.CE
.PP
\fIInstanceData\fR is the same as the value passed to
\fBTcl_CreateChannel\fR when this channel was created, and
\fIlength\fR is the new length of the underlying file, which should
not be negative. The result should be 0 on success or an errno code
|
| ︙ | ︙ |
Changes to doc/CrtChnlHdlr.3.
| ︙ | ︙ | |||
28 29 30 31 32 33 34 | .AP int mask in Conditions under which \fIproc\fR should be called: OR-ed combination of \fBTCL_READABLE\fR, \fBTCL_WRITABLE\fR and \fBTCL_EXCEPTION\fR. Specify a zero value to temporarily disable an existing handler. .AP Tcl_FileProc *proc in Procedure to invoke whenever the channel indicated by \fIchannel\fR meets the conditions specified by \fImask\fR. | | | | 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 |
.AP int mask in
Conditions under which \fIproc\fR should be called: OR-ed combination of
\fBTCL_READABLE\fR, \fBTCL_WRITABLE\fR and \fBTCL_EXCEPTION\fR. Specify
a zero value to temporarily disable an existing handler.
.AP Tcl_FileProc *proc in
Procedure to invoke whenever the channel indicated by \fIchannel\fR meets
the conditions specified by \fImask\fR.
.AP void *clientData in
Arbitrary one-word value to pass to \fIproc\fR.
.BE
.SH DESCRIPTION
.PP
\fBTcl_CreateChannelHandler\fR arranges for \fIproc\fR to be called in the
future whenever input or output becomes possible on the channel identified
by \fIchannel\fR, or whenever an exceptional condition exists for
\fIchannel\fR. The conditions of interest under which \fIproc\fR will be
invoked are specified by the \fImask\fR argument.
See the manual entry for \fBfileevent\fR for a precise description of
what it means for a channel to be readable or writable.
\fIProc\fR must conform to the following prototype:
.PP
.CS
typedef void \fBTcl_ChannelProc\fR(
void *\fIclientData\fR,
int \fImask\fR);
.CE
.PP
The \fIclientData\fR argument is the same as the value passed to
\fBTcl_CreateChannelHandler\fR when the handler was created. Typically,
\fIclientData\fR points to a data structure containing application-specific
information about the channel. \fIMask\fR is an integer mask indicating
|
| ︙ | ︙ |
Changes to doc/CrtCloseHdlr.3.
| ︙ | ︙ | |||
22 23 24 25 26 27 28 | .sp .SH ARGUMENTS .AS Tcl_CloseProc clientData .AP Tcl_Channel channel in The channel for which to create or delete a close callback. .AP Tcl_CloseProc *proc in The procedure to call as the callback. | | | | 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 |
.sp
.SH ARGUMENTS
.AS Tcl_CloseProc clientData
.AP Tcl_Channel channel in
The channel for which to create or delete a close callback.
.AP Tcl_CloseProc *proc in
The procedure to call as the callback.
.AP void *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);
.CE
.PP
The \fIclientData\fR is the same as the value provided in the call to
\fBTcl_CreateCloseHandler\fR.
.PP
\fBTcl_DeleteCloseHandler\fR removes a close callback for \fIchannel\fR.
The \fIproc\fR and \fIclientData\fR identify which close callback to
|
| ︙ | ︙ |
Changes to doc/CrtCommand.3.
| ︙ | ︙ | |||
21 22 23 24 25 26 27 | .AP Tcl_Interp *interp in Interpreter in which to create new command. .AP "const char" *cmdName in Name of command. .AP Tcl_CmdProc *proc in Implementation of new command: \fIproc\fR will be called whenever \fIcmdName\fR is invoked as a command. | | | 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 | .AP Tcl_Interp *interp in Interpreter in which to create new command. .AP "const char" *cmdName in Name of command. .AP Tcl_CmdProc *proc in Implementation of new command: \fIproc\fR will be called whenever \fIcmdName\fR is invoked as a command. .AP voie *clientData in Arbitrary one-word value to pass to \fIproc\fR and \fIdeleteProc\fR. .AP Tcl_CmdDeleteProc *deleteProc in Procedure to call before \fIcmdName\fR is deleted from the interpreter; allows for command-specific cleanup. If NULL, then no procedure is called before the command is deleted. .BE .SH DESCRIPTION |
| ︙ | ︙ | |||
71 72 73 74 75 76 77 | the process of being deleted, then it does not create a new command and it returns NULL. \fIProc\fR should have arguments and result that match the type \fBTcl_CmdProc\fR: .PP .CS typedef int \fBTcl_CmdProc\fR( | | | 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 |
the process of being deleted, then it does not create a new command
and it returns NULL.
\fIProc\fR should have arguments and result that match the type
\fBTcl_CmdProc\fR:
.PP
.CS
typedef int \fBTcl_CmdProc\fR(
void *\fIclientData\fR,
Tcl_Interp *\fIinterp\fR,
int \fIargc\fR,
const char *\fIargv\fR[]);
.CE
.PP
When \fIproc\fR is invoked the \fIclientData\fR and \fIinterp\fR
parameters will be copies of the \fIclientData\fR and \fIinterp\fR
|
| ︙ | ︙ | |||
127 128 129 130 131 132 133 | \fIDeleteProc\fR is invoked before the command is deleted, and gives the application an opportunity to release any structures associated with the command. \fIDeleteProc\fR should have arguments and result that match the type \fBTcl_CmdDeleteProc\fR: .PP .CS typedef void \fBTcl_CmdDeleteProc\fR( | | | 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 |
\fIDeleteProc\fR is invoked before the command is deleted, and gives the
application an opportunity to release any structures associated
with the command. \fIDeleteProc\fR should have arguments and
result that match the type \fBTcl_CmdDeleteProc\fR:
.PP
.CS
typedef void \fBTcl_CmdDeleteProc\fR(
void *\fIclientData\fR);
.CE
.PP
The \fIclientData\fR argument will be the same as the \fIclientData\fR
argument passed to \fBTcl_CreateCommand\fR.
.SH "SEE ALSO"
Tcl_CreateObjCommand, Tcl_DeleteCommand, Tcl_GetCommandInfo,
Tcl_SetCommandInfo, Tcl_GetCommandName, Tcl_SetObjResult
.SH KEYWORDS
bind, command, create, delete, interpreter, namespace
|
Changes to doc/CrtFileHdlr.3.
| ︙ | ︙ | |||
25 26 27 28 29 30 31 | Conditions under which \fIproc\fR should be called: OR-ed combination of \fBTCL_READABLE\fR, \fBTCL_WRITABLE\fR, and \fBTCL_EXCEPTION\fR. May be set to 0 to temporarily disable a handler. .AP Tcl_FileProc *proc in Procedure to invoke whenever the file or device indicated by \fIfile\fR meets the conditions specified by \fImask\fR. | | | 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 | Conditions under which \fIproc\fR should be called: OR-ed combination of \fBTCL_READABLE\fR, \fBTCL_WRITABLE\fR, and \fBTCL_EXCEPTION\fR. May be set to 0 to temporarily disable a handler. .AP Tcl_FileProc *proc in Procedure to invoke whenever the file or device indicated by \fIfile\fR meets the conditions specified by \fImask\fR. .AP void *clientData in Arbitrary one-word value to pass to \fIproc\fR. .BE .SH DESCRIPTION .PP \fBTcl_CreateFileHandler\fR arranges for \fIproc\fR to be invoked in the future whenever I/O becomes possible on a file or an exceptional condition exists for the file. The file |
| ︙ | ︙ | |||
47 48 49 50 51 52 53 | as \fBvwait\fR. .PP \fIProc\fR should have arguments and result that match the type \fBTcl_FileProc\fR: .PP .CS typedef void \fBTcl_FileProc\fR( | | | 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 |
as \fBvwait\fR.
.PP
\fIProc\fR should have arguments and result that match the
type \fBTcl_FileProc\fR:
.PP
.CS
typedef void \fBTcl_FileProc\fR(
void *\fIclientData\fR,
int \fImask\fR);
.CE
.PP
The \fIclientData\fR parameter to \fIproc\fR is a copy
of the \fIclientData\fR
argument given to \fBTcl_CreateFileHandler\fR when the callback
was created. Typically, \fIclientData\fR points to a data
|
| ︙ | ︙ |
Changes to doc/CrtObjCmd.3.
1 2 3 4 5 6 7 8 9 10 | '\" '\" Copyright (c) 1996-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH Tcl_CreateObjCommand 3 8.0 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | '\" '\" 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 .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp Tcl_Command \fBTcl_CreateObjCommand\fR(\fIinterp, cmdName, proc, clientData, deleteProc\fR) .sp |
| ︙ | ︙ | |||
38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 | \fBTcl_GetCommandName\fR(\fIinterp, token\fR) .sp void \fBTcl_GetCommandFullName\fR(\fIinterp, token, objPtr\fR) .sp Tcl_Command \fBTcl_GetCommandFromObj\fR(\fIinterp, objPtr\fR) .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. | > > > > > > > > | > > > | 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 | \fBTcl_GetCommandName\fR(\fIinterp, token\fR) .sp 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 Arbitrary one-word value to pass to \fIproc\fR and \fIdeleteProc\fR. .AP Tcl_CmdDeleteProc *deleteProc in Procedure to call before \fIcmdName\fR is deleted from the interpreter; allows for command-specific cleanup. If NULL, then no procedure is called before the command is deleted. .AP Tcl_Command token in Token for command, returned by previous call to \fBTcl_CreateObjCommand\fR. 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. .BE .SH DESCRIPTION .PP \fBTcl_CreateObjCommand\fR defines a new command in \fIinterp\fR and associates it with procedure \fIproc\fR such that whenever \fIname\fR is invoked as a Tcl command (e.g., via a call to \fBTcl_EvalObjEx\fR) |
| ︙ | ︙ | |||
87 88 89 90 91 92 93 | the process of being deleted, then it does not create a new command and it returns NULL. \fIproc\fR should have arguments and result that match the type \fBTcl_ObjCmdProc\fR: .PP .CS typedef int \fBTcl_ObjCmdProc\fR( | | | 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 |
the process of being deleted, then it does not create a new command
and it returns NULL.
\fIproc\fR should have arguments and result that match the type
\fBTcl_ObjCmdProc\fR:
.PP
.CS
typedef int \fBTcl_ObjCmdProc\fR(
void *\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
|
| ︙ | ︙ | |||
160 161 162 163 164 165 166 | \fIDeleteProc\fR is invoked before the command is deleted, and gives the application an opportunity to release any structures associated with the command. \fIDeleteProc\fR should have arguments and result that match the type \fBTcl_CmdDeleteProc\fR: .PP .CS typedef void \fBTcl_CmdDeleteProc\fR( | | | 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 |
\fIDeleteProc\fR is invoked before the command is deleted, and gives the
application an opportunity to release any structures associated
with the command. \fIDeleteProc\fR should have arguments and
result that match the type \fBTcl_CmdDeleteProc\fR:
.PP
.CS
typedef void \fBTcl_CmdDeleteProc\fR(
void *\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
|
| ︙ | ︙ | |||
202 203 204 205 206 207 208 |
pointed to by \fIinfoPtr\fR and returns 1.
A \fBTcl_CmdInfo\fR structure has the following fields:
.PP
.CS
typedef struct Tcl_CmdInfo {
int \fIisNativeObjectProc\fR;
Tcl_ObjCmdProc *\fIobjProc\fR;
| | | | | 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 |
pointed to by \fIinfoPtr\fR and returns 1.
A \fBTcl_CmdInfo\fR structure has the following fields:
.PP
.CS
typedef struct Tcl_CmdInfo {
int \fIisNativeObjectProc\fR;
Tcl_ObjCmdProc *\fIobjProc\fR;
void *\fIobjClientData\fR;
Tcl_CmdProc *\fIproc\fR;
void *\fIclientData\fR;
Tcl_CmdDeleteProc *\fIdeleteProc\fR;
void *\fIdeleteData\fR;
Tcl_Namespace *\fInamespacePtr\fR;
} \fBTcl_CmdInfo\fR;
.CE
.PP
The \fIisNativeObjectProc\fR field has the value 1
if \fBTcl_CreateObjCommand\fR was called to register the command;
it is 0 if only \fBTcl_CreateCommand\fR was called.
|
| ︙ | ︙ | |||
232 233 234 235 236 237 238 | that implements the command. If \fBTcl_CreateCommand\fR was called for this command, this is the procedure passed to it; otherwise, this is a compatibility procedure registered by \fBTcl_CreateObjCommand\fR that simply calls the command's value-based procedure after converting its string arguments to Tcl values. | | | | | | 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 | that implements the command. If \fBTcl_CreateCommand\fR was called for this command, this is the procedure passed to it; otherwise, this is a compatibility procedure registered by \fBTcl_CreateObjCommand\fR that simply calls the command's value-based procedure after converting its string arguments to Tcl values. The field \fIdeleteData\fR is the clientData value to pass to \fIdeleteProc\fR; it is normally the same as \fIclientData\fR but may be set independently using the \fBTcl_SetCommandInfo\fR procedure. The field \fInamespacePtr\fR holds a pointer to the Tcl_Namespace that contains the command. .PP \fBTcl_GetCommandInfoFromToken\fR is identical to \fBTcl_GetCommandInfo\fR except that it uses a command token returned from \fBTcl_CreateObjCommand\fR in place of the command name. If the \fItoken\fR parameter is NULL, it returns 0; otherwise, it returns 1 and fills in the structure designated by \fIinfoPtr\fR. .PP \fBTcl_SetCommandInfo\fR is used to modify the procedures and clientData values associated with a command. Its \fIcmdName\fR argument is the name of a command in \fIinterp\fR. \fIcmdName\fR may include \fB::\fR namespace qualifiers to identify a command in a particular namespace. If this command does not exist then \fBTcl_SetCommandInfo\fR returns 0. Otherwise, it copies the information from \fI*infoPtr\fR to Tcl's internal structure for the command and returns 1. .PP \fBTcl_SetCommandInfoFromToken\fR is identical to \fBTcl_SetCommandInfo\fR except that it takes a command token as returned by \fBTcl_CreateObjCommand\fR instead of the command name. If the \fItoken\fR parameter is NULL, it returns 0. Otherwise, it copies the information from \fI*infoPtr\fR to Tcl's internal structure for the command and returns 1. .PP Note that \fBTcl_SetCommandInfo\fR and \fBTcl_SetCommandInfoFromToken\fR both allow the clientData for a command's deletion procedure to be given a different value than the clientData for its command procedure. .PP Note that neither \fBTcl_SetCommandInfo\fR nor \fBTcl_SetCommandInfoFromToken\fR will change a command's namespace. Use \fBTcl_Eval\fR to call the \fBrename\fR command to do that. .PP \fBTcl_GetCommandName\fR provides a mechanism for tracking commands that have been renamed. |
| ︙ | ︙ | |||
292 293 294 295 296 297 298 299 300 301 302 | The name, including all namespace prefixes, is appended to the value 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. .SH "SEE ALSO" Tcl_CreateCommand(3), Tcl_ResetResult(3), Tcl_SetObjResult(3) .SH KEYWORDS bind, command, create, delete, namespace, value | > > > > > > > > > > > > > > > > | 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 | The name, including all namespace prefixes, is appended to the value 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) .SH KEYWORDS bind, command, create, delete, namespace, value |
Changes to doc/CrtTimerHdlr.3.
| ︙ | ︙ | |||
20 21 22 23 24 25 26 | \fBTcl_DeleteTimerHandler\fR(\fItoken\fR) .SH ARGUMENTS .AS Tcl_TimerToken milliseconds .AP int milliseconds in How many milliseconds to wait before invoking \fIproc\fR. .AP Tcl_TimerProc *proc in Procedure to invoke after \fImilliseconds\fR have elapsed. | | | 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 | \fBTcl_DeleteTimerHandler\fR(\fItoken\fR) .SH ARGUMENTS .AS Tcl_TimerToken milliseconds .AP int milliseconds in How many milliseconds to wait before invoking \fIproc\fR. .AP Tcl_TimerProc *proc in Procedure to invoke after \fImilliseconds\fR have elapsed. .AP void *clientData in Arbitrary one-word value to pass to \fIproc\fR. .AP Tcl_TimerToken token in Token for previously created timer handler (the return value from some previous call to \fBTcl_CreateTimerHandler\fR). .BE .SH DESCRIPTION .PP |
| ︙ | ︙ | |||
47 48 49 50 51 52 53 | \fIproc\fR, then the call to \fIproc\fR will be delayed. .PP \fIProc\fR should have arguments and return value that match the type \fBTcl_TimerProc\fR: .PP .CS typedef void \fBTcl_TimerProc\fR( | | | 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 |
\fIproc\fR, then the call to \fIproc\fR will be delayed.
.PP
\fIProc\fR should have arguments and return value that match
the type \fBTcl_TimerProc\fR:
.PP
.CS
typedef void \fBTcl_TimerProc\fR(
void *\fIclientData\fR);
.CE
.PP
The \fIclientData\fR parameter to \fIproc\fR is a
copy of the \fIclientData\fR argument given to
\fBTcl_CreateTimerHandler\fR when the callback
was created. Typically, \fIclientData\fR points to a data
structure containing application-specific information about
|
| ︙ | ︙ |
Changes to doc/CrtTrace.3.
| ︙ | ︙ | |||
37 38 39 40 41 42 43 | Flags governing the trace execution. See below for details. .AP Tcl_CmdObjTraceProc *objProc in Procedure to call for each command that is executed. See below for details of the calling sequence. .AP Tcl_CmdTraceProc *proc in Procedure to call for each command that is executed. See below for details on the calling sequence. | | | 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 | Flags governing the trace execution. See below for details. .AP Tcl_CmdObjTraceProc *objProc in Procedure to call for each command that is executed. See below for details of the calling sequence. .AP Tcl_CmdTraceProc *proc in Procedure to call for each command that is executed. See below for details on the calling sequence. .AP void *clientData in Arbitrary one-word value to pass to \fIobjProc\fR or \fIproc\fR. .AP Tcl_CmdObjTraceDeleteProc *deleteProc in Procedure to call when the trace is deleted. See below for details of the calling sequence. A NULL pointer is permissible and results in no callback when the trace is deleted. .AP Tcl_Trace trace in Token for trace to be removed (return value from previous call |
| ︙ | ︙ | |||
62 63 64 65 66 67 68 | interpreter. .PP \fIobjProc\fR should have arguments and result that match the type, \fBTcl_CmdObjTraceProc\fR: .PP .CS typedef int \fBTcl_CmdObjTraceProc\fR( | | | | 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 |
interpreter.
.PP
\fIobjProc\fR should have arguments and result that match the type,
\fBTcl_CmdObjTraceProc\fR:
.PP
.CS
typedef int \fBTcl_CmdObjTraceProc\fR(
\fBvoid *\fR \fIclientData\fR,
\fBTcl_Interp\fR* \fIinterp\fR,
int \fIlevel\fR,
const char *\fIcommand\fR,
\fBTcl_Command\fR \fIcommandToken\fR,
int \fIobjc\fR,
\fBTcl_Obj\fR *const \fIobjv\fR[]);
.CE
.PP
The \fIclientData\fR and \fIinterp\fR parameters are copies of the
corresponding arguments given to \fBTcl_CreateTrace\fR.
\fIclientData\fR typically points to an application-specific data
structure that describes what to do when \fIobjProc\fR is invoked. The
\fIlevel\fR parameter gives the nesting level of the command (1 for
top-level commands passed to \fBTcl_Eval\fR by the application, 2 for
the next-level commands passed to \fBTcl_Eval\fR as part of parsing or
interpreting level-1 commands, and so on). The \fIcommand\fR parameter
points to a string containing the text of the command, before any
argument substitution. The \fIcommandToken\fR parameter is a Tcl
|
| ︙ | ︙ | |||
140 141 142 143 144 145 146 | When \fBTcl_DeleteTrace\fR is called, the interpreter invokes the \fIdeleteProc\fR that was passed as a parameter to \fBTcl_CreateObjTrace\fR. The \fIdeleteProc\fR must match the type, \fBTcl_CmdObjTraceDeleteProc\fR: .PP .CS typedef void \fBTcl_CmdObjTraceDeleteProc\fR( | | | | | 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 |
When \fBTcl_DeleteTrace\fR is called, the interpreter invokes the
\fIdeleteProc\fR that was passed as a parameter to
\fBTcl_CreateObjTrace\fR. The \fIdeleteProc\fR must match the type,
\fBTcl_CmdObjTraceDeleteProc\fR:
.PP
.CS
typedef void \fBTcl_CmdObjTraceDeleteProc\fR(
\fBvoid *\fR \fIclientData\fR);
.CE
.PP
The \fIclientData\fR parameter will be the same as the
\fIclientData\fR parameter that was originally passed to
\fBTcl_CreateObjTrace\fR.
.PP
\fBTcl_CreateTrace\fR is an alternative interface for command tracing,
\fInot recommended for new applications\fR. It is provided for backward
compatibility with code that was developed for older versions of the
Tcl interpreter. It is similar to \fBTcl_CreateObjTrace\fR, except
that its \fIproc\fR parameter should have arguments and result that
match the type \fBTcl_CmdTraceProc\fR:
.PP
.CS
typedef void \fBTcl_CmdTraceProc\fR(
void *\fIclientData\fR,
Tcl_Interp *\fIinterp\fR,
int \fIlevel\fR,
char *\fIcommand\fR,
Tcl_CmdProc *\fIcmdProc\fR,
void *\fIcmdClientData\fR,
int \fIargc\fR,
const char *\fIargv\fR[]);
.CE
.PP
The parameters to the \fIproc\fR callback are similar to those of the
\fIobjProc\fR callback above. The \fIcommandToken\fR is
replaced with \fIcmdProc\fR, a pointer to the (string-based) command
|
| ︙ | ︙ |
Changes to doc/DString.3.
| ︙ | ︙ | |||
22 23 24 25 26 27 28 | char * \fBTcl_DStringAppendElement\fR(\fIdsPtr, element\fR) .sp \fBTcl_DStringStartSublist\fR(\fIdsPtr\fR) .sp \fBTcl_DStringEndSublist\fR(\fIdsPtr\fR) .sp | | | | | | 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 | char * \fBTcl_DStringAppendElement\fR(\fIdsPtr, element\fR) .sp \fBTcl_DStringStartSublist\fR(\fIdsPtr\fR) .sp \fBTcl_DStringEndSublist\fR(\fIdsPtr\fR) .sp size_t \fBTcl_DStringLength\fR(\fIdsPtr\fR) .sp char * \fBTcl_DStringValue\fR(\fIdsPtr\fR) .sp \fBTcl_DStringSetLength\fR(\fIdsPtr, newLength\fR) .sp \fBTcl_DStringFree\fR(\fIdsPtr\fR) .sp \fBTcl_DStringResult\fR(\fIinterp, dsPtr\fR) .sp \fBTcl_DStringGetResult\fR(\fIinterp, dsPtr\fR) .SH ARGUMENTS .AS Tcl_DString newLength in/out .AP Tcl_DString *dsPtr in/out Pointer to structure that is used to manage a dynamic string. .AP "const char" *bytes in Pointer to characters to append to dynamic string. .AP "const char" *element in Pointer to characters to append as list element to dynamic string. .AP size_t length in Number of bytes from \fIbytes\fR to add to dynamic string. If TCL_AUTO_LENGTH, add all characters up to null terminating character. .AP size_t newLength in New length for dynamic string, not including null terminating character. .AP Tcl_Interp *interp in/out Interpreter whose result is to be set from or moved to the dynamic string. .BE |
| ︙ | ︙ |
Changes to doc/DoWhenIdle.3.
| ︙ | ︙ | |||
17 18 19 20 21 22 23 | \fBTcl_DoWhenIdle\fR(\fIproc, clientData\fR) .sp \fBTcl_CancelIdleCall\fR(\fIproc, clientData\fR) .SH ARGUMENTS .AS Tcl_IdleProc clientData .AP Tcl_IdleProc *proc in Procedure to invoke. | | | 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 | \fBTcl_DoWhenIdle\fR(\fIproc, clientData\fR) .sp \fBTcl_CancelIdleCall\fR(\fIproc, clientData\fR) .SH ARGUMENTS .AS Tcl_IdleProc clientData .AP Tcl_IdleProc *proc in Procedure to invoke. .AP coid *clientData in Arbitrary one-word value to pass to \fIproc\fR. .BE .SH DESCRIPTION .PP \fBTcl_DoWhenIdle\fR arranges for \fIproc\fR to be invoked when the application becomes idle. The application is considered to be idle when \fBTcl_DoOneEvent\fR has been |
| ︙ | ︙ | |||
39 40 41 42 43 44 45 | use \fBTcl_DoOneEvent\fR to dispatch events. .PP \fIProc\fR should have arguments and result that match the type \fBTcl_IdleProc\fR: .PP .CS typedef void \fBTcl_IdleProc\fR( | | | 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 |
use \fBTcl_DoOneEvent\fR to dispatch events.
.PP
\fIProc\fR should have arguments and result that match the
type \fBTcl_IdleProc\fR:
.PP
.CS
typedef void \fBTcl_IdleProc\fR(
void *\fIclientData\fR);
.CE
.PP
The \fIclientData\fR parameter to \fIproc\fR is a copy of the \fIclientData\fR
argument given to \fBTcl_DoWhenIdle\fR. Typically, \fIclientData\fR
points to a data structure containing application-specific information about
what \fIproc\fR should do.
.PP
|
| ︙ | ︙ |
Changes to doc/DumpActiveMemory.3.
| ︙ | ︙ | |||
39 40 41 42 43 44 45 | They are only functional when Tcl has been compiled with \fBTCL_MEM_DEBUG\fR defined at compile-time. When \fBTCL_MEM_DEBUG\fR is not defined, these functions are all no-ops. .PP \fBTcl_DumpActiveMemory\fR will output a list of all currently allocated memory to the specified file. The information output for each allocated block of memory is: starting and ending addresses | | | | | 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 | They are only functional when Tcl has been compiled with \fBTCL_MEM_DEBUG\fR defined at compile-time. When \fBTCL_MEM_DEBUG\fR is not defined, these functions are all no-ops. .PP \fBTcl_DumpActiveMemory\fR will output a list of all currently allocated memory to the specified file. The information output for each allocated block of memory is: starting and ending addresses (excluding guard zone), size, source file where \fBTcl_Alloc\fR was called to allocate the block and line number in that file. It is especially useful to call \fBTcl_DumpActiveMemory\fR after the Tcl interpreter has been deleted. .PP \fBTcl_InitMemory\fR adds the Tcl \fBmemory\fR command to the interpreter given by \fIinterp\fR. \fBTcl_InitMemory\fR is called by \fBTcl_Main\fR. .PP \fBTcl_ValidateAllMemory\fR forces a validation of the guard zones of all currently allocated blocks of memory. Normally validation of a block occurs when its freed, unless full validation is enabled, in which case validation of all blocks occurs when \fBTcl_Alloc\fR and \fBTcl_Free\fR are called. This function forces the validation to occur at any point. .SH "SEE ALSO" TCL_MEM_DEBUG, memory .SH KEYWORDS memory, debug |
| ︙ | ︙ |
Changes to doc/Encoding.3.
| ︙ | ︙ | |||
79 80 81 82 83 84 85 | .AP "const char" *src in For the \fBTcl_ExternalToUtf\fR functions, an array of bytes in the specified encoding that are to be converted to UTF-8. For the \fBTcl_UtfToExternal\fR and \fBTcl_WinUtfToTChar\fR functions, an array of UTF-8 characters to be converted to the specified encoding. .AP "const TCHAR" *tsrc in An array of Windows TCHAR characters to convert to UTF-8. | | | 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 | .AP "const char" *src in For the \fBTcl_ExternalToUtf\fR functions, an array of bytes in the specified encoding that are to be converted to UTF-8. For the \fBTcl_UtfToExternal\fR and \fBTcl_WinUtfToTChar\fR functions, an array of UTF-8 characters to be converted to the specified encoding. .AP "const TCHAR" *tsrc in An array of Windows TCHAR characters to convert to UTF-8. .AP size_t 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. |
| ︙ | ︙ | |||
304 305 306 307 308 309 310 |
.PP
.CS
typedef struct Tcl_EncodingType {
const char *\fIencodingName\fR;
Tcl_EncodingConvertProc *\fItoUtfProc\fR;
Tcl_EncodingConvertProc *\fIfromUtfProc\fR;
Tcl_EncodingFreeProc *\fIfreeProc\fR;
| | | 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 |
.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;
.CE
.PP
The \fIencodingName\fR provides a string name for the encoding, by
which it can be referred in other procedures such as
\fBTcl_GetEncoding\fR. The \fItoUtfProc\fR refers to a callback
|
| ︙ | ︙ | |||
335 336 337 338 339 340 341 | CNS11643) are not accepted. .PP The callback procedures \fItoUtfProc\fR and \fIfromUtfProc\fR should match the type \fBTcl_EncodingConvertProc\fR: .PP .CS typedef int \fBTcl_EncodingConvertProc\fR( | | | 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 |
CNS11643) are not accepted.
.PP
The callback procedures \fItoUtfProc\fR and \fIfromUtfProc\fR should match the
type \fBTcl_EncodingConvertProc\fR:
.PP
.CS
typedef int \fBTcl_EncodingConvertProc\fR(
void *\fIclientData\fR,
const char *\fIsrc\fR,
int \fIsrcLen\fR,
int \fIflags\fR,
Tcl_EncodingState *\fIstatePtr\fR,
char *\fIdst\fR,
int \fIdstLen\fR,
int *\fIsrcReadPtr\fR,
|
| ︙ | ︙ | |||
367 368 369 370 371 372 373 | procedure will be a non-NULL location. .PP The callback procedure \fIfreeProc\fR, if non-NULL, should match the type \fBTcl_EncodingFreeProc\fR: .PP .CS typedef void \fBTcl_EncodingFreeProc\fR( | | | 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 |
procedure will be a non-NULL location.
.PP
The callback procedure \fIfreeProc\fR, if non-NULL, should match the type
\fBTcl_EncodingFreeProc\fR:
.PP
.CS
typedef void \fBTcl_EncodingFreeProc\fR(
void *\fIclientData\fR);
.CE
.PP
This \fIfreeProc\fR function is called when the encoding is deleted. The
\fIclientData\fR parameter is the same as the \fIclientData\fR field
specified to \fBTcl_CreateEncoding\fR when the encoding was created.
.PP
\fBTcl_GetEncodingSearchPath\fR and \fBTcl_SetEncodingSearchPath\fR
|
| ︙ | ︙ |
Changes to doc/Exit.3.
| ︙ | ︙ | |||
38 39 40 41 42 43 44 | Exact meaning may be platform-specific. 0 usually means a normal exit, any nonzero value usually means that an error occurred. .AP Tcl_ExitProc *proc in Procedure to invoke before exiting application, or (for \fBTcl_SetExitProc\fR) NULL to uninstall the current application exit procedure. | | | 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 | Exact meaning may be platform-specific. 0 usually means a normal exit, any nonzero value usually means that an error occurred. .AP Tcl_ExitProc *proc in Procedure to invoke before exiting application, or (for \fBTcl_SetExitProc\fR) NULL to uninstall the current application exit procedure. .AP void *clientData in Arbitrary one-word value to pass to \fIproc\fR. .BE .SH DESCRIPTION .PP The procedures described here provide a graceful mechanism to end the execution of a \fBTcl\fR application. Exit handlers are invoked to cleanup the |
| ︙ | ︙ | |||
60 61 62 63 64 65 66 | Note that if other code invokes \fBexit\fR system procedure directly, or otherwise causes the application to terminate without calling \fBTcl_Exit\fR, the exit handlers will not be run. \fBTcl_Exit\fR internally invokes the \fBexit\fR system call, thus it never returns control to its caller. If an application exit handler has been installed (see \fBTcl_SetExitProc\fR), that handler is invoked with an argument | | | 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 | Note that if other code invokes \fBexit\fR system procedure directly, or otherwise causes the application to terminate without calling \fBTcl_Exit\fR, the exit handlers will not be run. \fBTcl_Exit\fR internally invokes the \fBexit\fR system call, thus it never returns control to its caller. If an application exit handler has been installed (see \fBTcl_SetExitProc\fR), that handler is invoked with an argument consisting of the exit status (cast to void *); the application exit handler should not return control to Tcl. .PP \fBTcl_Finalize\fR is similar to \fBTcl_Exit\fR except that it does not exit from the current process. It is useful for cleaning up when a process is finished using \fBTcl\fR but wishes to continue executing, and when \fBTcl\fR is used in a dynamically loaded extension that is about to be unloaded. |
| ︙ | ︙ | |||
89 90 91 92 93 94 95 | by \fBTcl_FinalizeThread\fR and \fBTcl_ExitThread\fR. This provides a hook for cleanup operations such as flushing buffers and freeing global memory. \fIProc\fR should match the type \fBTcl_ExitProc\fR: .PP .CS typedef void \fBTcl_ExitProc\fR( | | | 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 |
by \fBTcl_FinalizeThread\fR and \fBTcl_ExitThread\fR.
This provides a hook for cleanup operations such as flushing buffers
and freeing global memory.
\fIProc\fR should match the type \fBTcl_ExitProc\fR:
.PP
.CS
typedef void \fBTcl_ExitProc\fR(
void *\fIclientData\fR);
.CE
.PP
The \fIclientData\fR parameter to \fIproc\fR is a
copy of the \fIclientData\fR argument given to
\fBTcl_CreateExitHandler\fR or \fBTcl_CreateThreadExitHandler\fR when
the callback
was created. Typically, \fIclientData\fR points to a data
|
| ︙ | ︙ | |||
129 130 131 132 133 134 135 | \fBTcl_SetExitProc\fR installs an application exit handler, returning the previously-installed application exit handler or NULL if no application handler was installed. If an application exit handler is installed, that exit handler takes over complete responsibility for finalization of Tcl's subsystems via \fBTcl_Finalize\fR at an appropriate time. The argument passed to \fIproc\fR when it is invoked will be the exit status code (as passed to \fBTcl_Exit\fR) | | > > | 129 130 131 132 133 134 135 136 137 138 139 140 141 142 | \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) .SH KEYWORDS abort, callback, cleanup, dynamic loading, end application, exit, unloading, thread |
Changes to doc/FileSystem.3.
| ︙ | ︙ | |||
16 17 18 19 20 21 22 | .sp int \fBTcl_FSRegister\fR(\fIclientData, fsPtr\fR) .sp int \fBTcl_FSUnregister\fR(\fIfsPtr\fR) .sp | | | 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 | .sp int \fBTcl_FSRegister\fR(\fIclientData, fsPtr\fR) .sp int \fBTcl_FSUnregister\fR(\fIfsPtr\fR) .sp void * \fBTcl_FSData\fR(\fIfsPtr\fR) .sp void \fBTcl_FSMountsChanged\fR(\fIfsPtr\fR) .sp const Tcl_Filesystem * \fBTcl_FSGetFileSystemForPath\fR(\fIpathPtr\fR) |
| ︙ | ︙ | |||
121 122 123 124 125 126 127 | .sp Tcl_Obj * \fBTcl_FSJoinToPath\fR(\fIbasePtr, objc, objv\fR) .sp int \fBTcl_FSConvertToPathType\fR(\fIinterp, pathPtr\fR) .sp | | | 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 | .sp Tcl_Obj * \fBTcl_FSJoinToPath\fR(\fIbasePtr, objc, objv\fR) .sp int \fBTcl_FSConvertToPathType\fR(\fIinterp, pathPtr\fR) .sp void * \fBTcl_FSGetInternalRep\fR(\fIpathPtr, fsPtr\fR) .sp Tcl_Obj * \fBTcl_FSGetTranslatedPath\fR(\fIinterp, pathPtr\fR) .sp const char * \fBTcl_FSGetTranslatedStringPath\fR(\fIinterp, pathPtr\fR) |
| ︙ | ︙ | |||
208 209 210 211 212 213 214 | Only files or directories matching this pattern will be returned. .AP Tcl_GlobTypeData *types in Only files or directories matching the type descriptions contained in this structure will be returned. This parameter may be NULL. .AP Tcl_Interp *interp in Interpreter to use either for results, evaluation, or reporting error messages. | | | 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 | Only files or directories matching this pattern will be returned. .AP Tcl_GlobTypeData *types in Only files or directories matching the type descriptions contained in this structure will be returned. This parameter may be NULL. .AP Tcl_Interp *interp in Interpreter to use either for results, evaluation, or reporting error messages. .AP void *clientData in The native description of the path value to create. .AP Tcl_Obj *firstPtr in The first of two path values to compare. The value may be converted to \fBpath\fR type. .AP Tcl_Obj *secondPtr in The second of two path values to compare. The value may be converted to \fBpath\fR type. |
| ︙ | ︙ | |||
245 246 247 248 249 250 251 | Name of a procedure to look up in the file's symbol table .AP "const char" *sym2 in Name of a procedure to look up in the file's symbol table .AP Tcl_PackageInitProc **proc1Ptr out Filled with the init function for this code. .AP Tcl_PackageInitProc **proc2Ptr out Filled with the safe-init function for this code. | | | 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 | Name of a procedure to look up in the file's symbol table .AP "const char" *sym2 in Name of a procedure to look up in the file's symbol table .AP Tcl_PackageInitProc **proc1Ptr out Filled with the init function for this code. .AP Tcl_PackageInitProc **proc2Ptr out Filled with the safe-init function for this code. .AP void **clientDataPtr out Filled with the clientData value to pass to this code's unload function when it is called. .AP Tcl_LoadHandle *loadHandlePtr out Filled with an abstract token representing the loaded file. .AP Tcl_FSUnloadFileProc **unloadProcPtr out Filled with the function to use to unload this piece of code. .AP Tcl_LoadHandle loadHandle in |
| ︙ | ︙ | |||
720 721 722 723 724 725 726 | freed. This function is of little practical use, and \fBTcl_FSGetNormalizedPath\fR or \fBTcl_FSGetNativePath\fR are usually better functions to use for most purposes. .PP \fBTcl_FSGetTranslatedStringPath\fR does the same as \fBTcl_FSGetTranslatedPath\fR, but returns a character string or NULL. The string returned is dynamically allocated and owned by the caller, | | | 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 | freed. This function is of little practical use, and \fBTcl_FSGetNormalizedPath\fR or \fBTcl_FSGetNativePath\fR are usually better functions to use for most purposes. .PP \fBTcl_FSGetTranslatedStringPath\fR does the same as \fBTcl_FSGetTranslatedPath\fR, but returns a character string or NULL. The string returned is dynamically allocated and owned by the caller, which must store it or call \fBTcl_Free\fR to ensure it is freed. Again, \fBTcl_FSGetNormalizedPath\fR or \fBTcl_FSGetNativePath\fR are usually better functions to use for most purposes. .PP \fBTcl_FSNewNativePath\fR performs something like the reverse of the usual obj->path->nativerep conversions. If some code retrieves a path in native form (from, e.g.\ \fBreadlink\fR or a native dialog), and that path is to be used at the Tcl level, then calling this function is an |
| ︙ | ︙ | |||
787 788 789 790 791 792 793 | absolute. .PP It returns one of \fBTCL_PATH_ABSOLUTE\fR, \fBTCL_PATH_RELATIVE\fR, or \fBTCL_PATH_VOLUME_RELATIVE\fR .SS "PORTABLE STAT RESULT API" .PP \fBTcl_AllocStatBuf\fR allocates a \fITcl_StatBuf\fR on the system heap (which | | | 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 | 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 .VS 8.6 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 |
| ︙ | ︙ | |||
837 838 839 840 841 842 843 | not check if the same filesystem is registered multiple times (and in general that is not a good thing to do). \fBTCL_OK\fR will be returned. .PP \fBTcl_FSUnregister\fR removes the given filesystem structure from the list of known filesystems, if it is known, and returns \fBTCL_OK\fR. If the filesystem is not currently registered, \fBTCL_ERROR\fR is returned. .PP | | | 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 | not check if the same filesystem is registered multiple times (and in general that is not a good thing to do). \fBTCL_OK\fR will be returned. .PP \fBTcl_FSUnregister\fR removes the given filesystem structure from the list of known filesystems, if it is known, and returns \fBTCL_OK\fR. If the filesystem is not currently registered, \fBTCL_ERROR\fR is returned. .PP \fBTcl_FSData\fR will return the clientData associated with the given filesystem, if that filesystem is registered. Otherwise it will return NULL. .PP \fBTcl_FSMountsChanged\fR is used to inform the Tcl's core that the set of mount points for the given (already registered) filesystem have changed, and that cached file representations may therefore no longer be correct. |
| ︙ | ︙ | |||
1014 1015 1016 1017 1018 1019 1020 |
cache the fact that this path belongs to this filesystem. Such caches
are invalidated when filesystem structures are added or removed from
Tcl's internal list of known filesystems.
.PP
.CS
typedef int \fBTcl_FSPathInFilesystemProc\fR(
Tcl_Obj *\fIpathPtr\fR,
| | | | | | | | 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 |
cache the fact that this path belongs to this filesystem. Such caches
are invalidated when filesystem structures are added or removed from
Tcl's internal list of known filesystems.
.PP
.CS
typedef int \fBTcl_FSPathInFilesystemProc\fR(
Tcl_Obj *\fIpathPtr\fR,
void **\fIclientDataPtr\fR);
.CE
.SS DUPINTERNALREPPROC
.PP
This function makes a copy of a path's internal representation, and is
called when Tcl needs to duplicate a path value. If NULL, Tcl will
simply not copy the internal representation, which may then need to be
regenerated later.
.PP
.CS
typedef void *\fBTcl_FSDupInternalRepProc\fR(
void *\fIclientData\fR);
.CE
.SS FREEINTERNALREPPROC
Free the internal representation. This must be implemented if internal
representations need freeing (i.e.\ if some memory is allocated when an
internal representation is generated), but may otherwise be NULL.
.PP
.CS
typedef void \fBTcl_FSFreeInternalRepProc\fR(
void *\fIclientData\fR);
.CE
.SS INTERNALTONORMALIZEDPROC
.PP
Function to convert internal representation to a normalized path. Only
required if the filesystem creates pure path values with no string/path
representation. The return value is a Tcl value whose string
representation is the normalized path.
.PP
.CS
typedef Tcl_Obj *\fBTcl_FSInternalToNormalizedProc\fR(
void *\fIclientData\fR);
.CE
.SS CREATEINTERNALREPPROC
.PP
Function to take a path value, and calculate an internal
representation for it, and store that native representation in the
value. May be NULL if paths have no internal representation, or if
the \fITcl_FSPathInFilesystemProc\fR for this filesystem always
immediately creates an internal representation for paths it accepts.
.PP
.CS
typedef void *\fBTcl_FSCreateInternalRepProc\fR(
Tcl_Obj *\fIpathPtr\fR);
.CE
.SS NORMALIZEPATHPROC
.PP
Function to normalize a path. Should be implemented for all
filesystems which can have multiple string representations for the same
path value. In Tcl, every
|
| ︙ | ︙ |
Changes to doc/FindExec.3.
| ︙ | ︙ | |||
54 55 56 57 58 59 60 | .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. | | > | 54 55 56 57 58 59 60 61 62 63 64 | .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 |
Changes to doc/GetOpnFl.3.
| ︙ | ︙ | |||
24 25 26 27 28 29 30 | String identifying channel, such as \fBstdin\fR or \fBfile4\fR. .AP int write in Non-zero means the file will be used for writing, zero means it will be used for reading. .AP int checkUsage in If non-zero, then an error will be generated if the file was not opened for the access indicated by \fIwrite\fR. | | | 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 | String identifying channel, such as \fBstdin\fR or \fBfile4\fR. .AP int write in Non-zero means the file will be used for writing, zero means it will be used for reading. .AP int checkUsage in If non-zero, then an error will be generated if the file was not opened for the access indicated by \fIwrite\fR. .AP void **filePtr out Points to word in which to store pointer to FILE structure for the file given by \fIchanID\fR. .BE .SH DESCRIPTION .PP \fBTcl_GetOpenFile\fR takes as argument a file identifier of the form |
| ︙ | ︙ |
Changes to doc/GetTime.3.
| ︙ | ︙ | |||
23 24 25 26 27 28 29 | .AP Tcl_Time *timePtr out Points to memory in which to store the date and time information. .AP Tcl_GetTimeProc getProc in Pointer to handler function replacing \fBTcl_GetTime\fR's access to the OS. .AP Tcl_ScaleTimeProc scaleProc in Pointer to handler function for the conversion of time delays in the virtual domain to real-time. | | | | 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 | .AP Tcl_Time *timePtr out Points to memory in which to store the date and time information. .AP Tcl_GetTimeProc getProc in Pointer to handler function replacing \fBTcl_GetTime\fR's access to the OS. .AP Tcl_ScaleTimeProc scaleProc in Pointer to handler function for the conversion of time delays in the virtual domain to real-time. .AP void *clientData in Value passed through to the two handler functions. .AP Tcl_GetTimeProc *getProcPtr out Pointer to place the currently registered get handler function into. .AP Tcl_ScaleTimeProc *scaleProcPtr out Pointer to place the currently registered scale handler function into. .AP void **clientDataPtr out Pointer to place the currently registered pass-through value into. .BE .SH DESCRIPTION .PP The \fBTcl_GetTime\fR function retrieves the current time as a \fITcl_Time\fR structure in memory the caller provides. This structure has the following definition: |
| ︙ | ︙ | |||
79 80 81 82 83 84 85 |
any argument which is NULL is ignored and not set.
.PP
The signatures of the handler functions are as follows:
.PP
.CS
typedef void \fBTcl_GetTimeProc\fR(
Tcl_Time *\fItimebuf\fR,
| | | | 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 |
any argument which is NULL is ignored and not set.
.PP
The signatures of the handler functions are as follows:
.PP
.CS
typedef void \fBTcl_GetTimeProc\fR(
Tcl_Time *\fItimebuf\fR,
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
|
| ︙ | ︙ |
Changes to doc/Hash.3.
| ︙ | ︙ | |||
26 27 28 29 30 31 32 | \fBTcl_CreateHashEntry\fR(\fItablePtr, key, newPtr\fR) .sp \fBTcl_DeleteHashEntry\fR(\fIentryPtr\fR) .sp Tcl_HashEntry * \fBTcl_FindHashEntry\fR(\fItablePtr, key\fR) .sp | | | 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 | \fBTcl_CreateHashEntry\fR(\fItablePtr, key, newPtr\fR) .sp \fBTcl_DeleteHashEntry\fR(\fIentryPtr\fR) .sp Tcl_HashEntry * \fBTcl_FindHashEntry\fR(\fItablePtr, key\fR) .sp void * \fBTcl_GetHashValue\fR(\fIentryPtr\fR) .sp \fBTcl_SetHashValue\fR(\fIentryPtr, value\fR) .sp void * \fBTcl_GetHashKey\fR(\fItablePtr, entryPtr\fR) .sp |
| ︙ | ︙ | |||
62 63 64 65 66 67 68 | Key to use for probe into table. Exact form depends on \fIkeyType\fR used to create table. .AP int *newPtr out The word at \fI*newPtr\fR is set to 1 if a new entry was created and 0 if there was already an entry for \fIkey\fR. .AP Tcl_HashEntry *entryPtr in Pointer to hash table entry. | | | < | 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 | 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 Tcl_HashSearch *searchPtr in Pointer to record to use to keep track of progress in enumerating all the entries in a hash table. .BE .SH DESCRIPTION .PP A hash table consists of zero or more entries, each consisting of a |
| ︙ | ︙ | |||
182 183 184 185 186 187 188 | .PP \fBTcl_FindHashEntry\fR is similar to \fBTcl_CreateHashEntry\fR except that it does not create a new entry if the key doesn't exist; instead, it returns NULL as result. .PP \fBTcl_GetHashValue\fR and \fBTcl_SetHashValue\fR are used to read and write an entry's value, respectively. | < < < < < | 181 182 183 184 185 186 187 188 189 190 191 192 193 194 | .PP \fBTcl_FindHashEntry\fR is similar to \fBTcl_CreateHashEntry\fR except that it does not create a new entry if the key doesn't exist; instead, it returns NULL as result. .PP \fBTcl_GetHashValue\fR and \fBTcl_SetHashValue\fR are used to read and write an entry's value, respectively. .PP \fBTcl_GetHashKey\fR returns the key for a given hash table entry, either as a pointer to a string, a one-word .PQ "char *" key, or as a pointer to the first word of an array of integers, depending on the \fIkeyType\fR used to create a hash table. |
| ︙ | ︙ | |||
225 226 227 228 229 230 231 | \fBTcl_FirstHashEntry\fR or \fBTcl_NextHashEntry\fR. .PP \fBTcl_HashStats\fR returns a dynamically-allocated string with overall information about a hash table, such as the number of entries it contains, the number of buckets in its hash array, and the utilization of the buckets. It is the caller's responsibility to free the result string | | | 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 | \fBTcl_FirstHashEntry\fR or \fBTcl_NextHashEntry\fR. .PP \fBTcl_HashStats\fR returns a dynamically-allocated string with overall information about a hash table, such as the number of entries it contains, the number of buckets in its hash array, and the utilization of the buckets. It is the caller's responsibility to free the result string by passing it to \fBTcl_Free\fR. .PP The header file \fBtcl.h\fR defines the actual data structures used to implement hash tables. This is necessary so that clients can allocate Tcl_HashTable structures and so that macros can be used to read and write the values of entries. However, users of the hashing routines should never refer directly |
| ︙ | ︙ |
Changes to doc/IntObj.3.
1 2 3 4 5 6 7 8 9 10 | '\" '\" Copyright (c) 1996-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH Tcl_IntObj 3 8.5 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | '\" '\" 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 .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp Tcl_Obj * \fBTcl_NewIntObj\fR(\fIintValue\fR) .sp |
| ︙ | ︙ | |||
27 28 29 30 31 32 33 34 35 36 37 38 39 40 | \fBTcl_SetLongObj\fR(\fIobjPtr, longValue\fR) .sp \fBTcl_SetWideIntObj\fR(\fIobjPtr, wideValue\fR) .sp int \fBTcl_GetIntFromObj\fR(\fIinterp, objPtr, intPtr\fR) .sp int \fBTcl_GetLongFromObj\fR(\fIinterp, objPtr, longPtr\fR) .sp int \fBTcl_GetWideIntFromObj\fR(\fIinterp, objPtr, widePtr\fR) .sp .sp | > > > | 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 | \fBTcl_SetLongObj\fR(\fIobjPtr, longValue\fR) .sp \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 |
| ︙ | ︙ | |||
51 52 53 54 55 56 57 58 59 60 61 62 63 64 | int \fBTcl_TakeBignumFromObj\fR(\fIinterp, objPtr, bigValue\fR) .sp int \fBTcl_InitBignumFromDouble\fR(\fIinterp, doubleValue, bigValue\fR) .SH ARGUMENTS .AS Tcl_WideInt doubleValue in/out .AP int intValue in Integer value used to initialize or set a Tcl value. .AP long longValue in Long integer value used to initialize or set a Tcl value. .AP Tcl_WideInt wideValue in Wide integer value used to initialize or set a Tcl value. .AP Tcl_Obj *objPtr in/out | > > | 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 | int \fBTcl_TakeBignumFromObj\fR(\fIinterp, objPtr, bigValue\fR) .sp int \fBTcl_InitBignumFromDouble\fR(\fIinterp, doubleValue, bigValue\fR) .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. .AP long longValue in Long integer value used to initialize or set a Tcl value. .AP Tcl_WideInt wideValue in Wide integer value used to initialize or set a Tcl value. .AP Tcl_Obj *objPtr in/out |
| ︙ | ︙ | |||
110 111 112 113 114 115 116 117 118 119 120 121 122 123 | and \fBTcl_SetBignumObj\fR routines each set the value of an existing Tcl value pointed to by \fIobjPtr\fR to the integral value provided by the other argument. The \fIobjPtr\fR argument must point to an unshared Tcl value. Any attempt to set the value of a shared Tcl value violates Tcl's copy-on-write policy. Any existing string representation or internal representation in the unshared Tcl value will be freed as a consequence of setting the new value. .PP The \fBTcl_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 attempt succeeds, then \fBTCL_OK\fR is returned, and the value is written to the storage provided by the caller. The attempt might | > > > > > > > > > > | 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 | and \fBTcl_SetBignumObj\fR routines each set the value of an existing Tcl value pointed to by \fIobjPtr\fR to the integral value provided by the other argument. The \fIobjPtr\fR argument must point to an unshared Tcl value. Any attempt to set the value of a shared Tcl value violates Tcl's copy-on-write policy. Any existing string representation or internal representation in the unshared Tcl value will be freed as a consequence of setting the new value. .PP The \fBTcl_GetIntForIndex\fR routine attempts to retrieve an index value from the Tcl value \fIobjPtr\fR. If the attempt succeeds, then \fBTCL_OK\fR is returned, and the value is written to the storage provided by the caller. The attempt might fail if \fIobjPtr\fR does not hold an index value. If the attempt fails, then \fBTCL_ERROR\fR is returned, and if \fIinterp\fR is non-NULL, 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 attempt succeeds, then \fBTCL_OK\fR is returned, and the value is written to the storage provided by the caller. The attempt might |
| ︙ | ︙ |
Changes to doc/Limit.3.
| ︙ | ︙ | |||
79 80 81 82 83 84 85 | Function to call when a particular limit is exceeded. If the \fIhandlerProc\fR removes or raises the limit during its processing, the limited interpreter will be permitted to continue to process after the handler returns. Many handlers may be attached to the same interpreter limit; their order of execution is not defined, and they must be identified by \fIhandlerProc\fR and \fIclientData\fR when they are deleted. | | | 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 | Function to call when a particular limit is exceeded. If the \fIhandlerProc\fR removes or raises the limit during its processing, the limited interpreter will be permitted to continue to process after the handler returns. Many handlers may be attached to the same interpreter limit; their order of execution is not defined, and they must be identified by \fIhandlerProc\fR and \fIclientData\fR when they are deleted. .AP void *clientData in Arbitrary pointer-sized word used to pass some context to the \fIhandlerProc\fR function. .AP Tcl_LimitHandlerDeleteProc *deleteProc in Function to call whenever a handler is deleted. May be NULL if the \fIclientData\fR requires no deletion. .BE .SH DESCRIPTION |
| ︙ | ︙ | |||
158 159 160 161 162 163 164 | To add a handler callback to be invoked when a limit is exceeded, call \fBTcl_LimitAddHandler\fR. The \fIhandlerProc\fR argument describes the function that will actually be called; it should have the following prototype: .PP .CS typedef void \fBTcl_LimitHandlerProc\fR( | | | | 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 |
To add a handler callback to be invoked when a limit is exceeded, call
\fBTcl_LimitAddHandler\fR. The \fIhandlerProc\fR argument describes
the function that will actually be called; it should have the
following prototype:
.PP
.CS
typedef void \fBTcl_LimitHandlerProc\fR(
void *\fIclientData\fR,
Tcl_Interp *\fIinterp\fR);
.CE
.PP
The \fIclientData\fR argument to the handler will be whatever is
passed to the \fIclientData\fR argument to \fBTcl_LimitAddHandler\fR,
and the \fIinterp\fR is the interpreter that had its limit exceeded.
.PP
The \fIdeleteProc\fR argument to \fBTcl_LimitAddHandler\fR is a
function to call to delete the \fIclientData\fR value. It may be
\fBTCL_STATIC\fR or NULL if no deletion action is necessary, or
\fBTCL_DYNAMIC\fR if all that is necessary is to free the structure with
\fBTcl_Free\fR. Otherwise, it should refer to a function with the
following prototype:
.PP
.CS
typedef void \fBTcl_LimitHandlerDeleteProc\fR(
void *\fIclientData\fR);
.CE
.PP
A limit handler may be deleted using \fBTcl_LimitRemoveHandler\fR; the
handler removed will be the first one found (out of the handlers added
with \fBTcl_LimitAddHandler\fR) with exactly matching \fItype\fR,
\fIhandlerProc\fR and \fIclientData\fR arguments. This function
always invokes the \fIdeleteProc\fR on the \fIclientData\fR (unless
the \fIdeleteProc\fR was NULL or \fBTCL_STATIC\fR).
.SH KEYWORDS
interpreter, resource, limit, commands, time, callback
|
Changes to doc/LinkVar.3.
1 2 3 4 5 6 7 8 9 10 11 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH Tcl_LinkVar 3 7.5 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME | | > > > > > | | > > > > > > | | | > > > > > > > > > > | | > > > > > > > > > > > > > | > | > | > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > | > | > | > | > | > | > > | > | | | > | > | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 | '\" '\" 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 .SH SYNOPSIS .nf \fB#include <tcl.h>\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 .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 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, \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" .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. Whenever the Tcl variable is read the value of the C variable will be returned, and whenever the Tcl variable is written the C variable will be updated to have the same value. \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. 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/binary prefix) are accepted as if they are valid too. .TP \fBTCL_LINK_UINT\fR . The C variable, or each element of the C array, is of type \fBunsigned int\fR. Any value written into the Tcl variable must have a proper unsigned integer form acceptable to \fBTcl_GetWideIntFromObj\fR and in the platform's defined range for the \fBunsigned int\fR type; attempts to write non-integer values (or values outside the range) into \fIvarName\fR will be rejected with Tcl errors. Incomplete integer representations (like the empty string, '+', '-' or the hex/octal/binary prefix) are accepted as if they are valid too. .TP \fBTCL_LINK_CHAR\fR . The C variable, or each element of the C array, is of type \fBchar\fR. Any value written into the Tcl variable must have a proper integer form acceptable to \fBTcl_GetIntFromObj\fR and be in the range of the \fBchar\fR datatype; attempts to write non-integer or out-of-range values into \fIvarName\fR will be rejected with Tcl errors. Incomplete integer representations (like the empty string, '+', '-' or the hex/octal/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" .TP \fBTCL_LINK_UCHAR\fR . The C variable, or each element of the C array, is of type \fBunsigned char\fR. Any value written into the Tcl variable must have a proper unsigned integer form acceptable to \fBTcl_GetIntFromObj\fR and in the platform's defined range for the \fBunsigned char\fR type; attempts to write non-integer values (or values outside the range) into \fIvarName\fR will be rejected with Tcl errors. Incomplete integer representations (like the empty string, '+', '-' or the hex/octal/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" .TP \fBTCL_LINK_SHORT\fR . The C variable, or each element of the C array, is of type \fBshort\fR. Any value written into the Tcl variable must have a proper integer form acceptable to \fBTcl_GetIntFromObj\fR and be in the range of the \fBshort\fR datatype; attempts to write non-integer or out-of-range values into \fIvarName\fR will be rejected with Tcl errors. Incomplete integer representations (like the empty string, '+', '-' or the hex/octal/binary prefix) are accepted as if they are valid too. .TP \fBTCL_LINK_USHORT\fR . The C variable, or each element of the C array, is of type \fBunsigned short\fR. Any value written into the Tcl variable must have a proper unsigned integer form acceptable to \fBTcl_GetIntFromObj\fR and in the platform's defined range for the \fBunsigned short\fR type; attempts to write non-integer values (or values outside the range) into \fIvarName\fR will be rejected with Tcl errors. Incomplete integer representations (like the empty string, '+', '-' or the hex/octal/binary prefix) are accepted as if they are valid too. .TP \fBTCL_LINK_LONG\fR . The C variable, or each element of the C array, is of type \fBlong\fR. Any value written into the Tcl variable must have a proper integer form acceptable to \fBTcl_GetLongFromObj\fR; attempts to write non-integer or out-of-range values into \fIvarName\fR will be rejected with Tcl errors. Incomplete integer representations (like the empty string, '+', '-' or the hex/octal/binary prefix) are accepted as if they are valid too. .TP \fBTCL_LINK_ULONG\fR . The C variable, or each element of the C array, is of type \fBunsigned long\fR. Any value written into the Tcl variable must have a proper unsigned integer form acceptable to \fBTcl_GetWideIntFromObj\fR and in the platform's defined range for the \fBunsigned long\fR type; attempts to write non-integer values (or values outside the range) into \fIvarName\fR will be rejected with Tcl errors. Incomplete integer representations (like the empty string, '+', '-' or the hex/octal/binary prefix) are accepted as if they are valid too. .TP \fBTCL_LINK_DOUBLE\fR . The C variable, or each element of the C array, is of type \fBdouble\fR. Any value written into the Tcl variable must have a proper real form acceptable to \fBTcl_GetDoubleFromObj\fR; attempts to write non-real values into \fIvarName\fR will be rejected with Tcl errors. Incomplete integer or real representations (like the empty string, '.', '+', '-' or the hex/octal/binary prefix) are accepted as if they are valid too. .TP \fBTCL_LINK_FLOAT\fR . The C variable, or each element of the C array, is of type \fBfloat\fR. Any value written into the Tcl variable must have a proper real form acceptable to \fBTcl_GetDoubleFromObj\fR and must be within the range acceptable for a \fBfloat\fR; attempts to write non-real values (or values outside the range) into \fIvarName\fR will be rejected with Tcl errors. Incomplete integer or real representations (like the empty string, '.', '+', '-' or the hex/octal/binary prefix) are accepted as if they are valid too. .TP \fBTCL_LINK_WIDE_INT\fR . The C variable, or each element of the C array, is of type \fBTcl_WideInt\fR (which is an integer type at least 64-bits wide on all platforms that can support it.) Any value written into the Tcl variable must have a proper integer form acceptable to \fBTcl_GetWideIntFromObj\fR; attempts to write non-integer values into \fIvarName\fR will be rejected with Tcl errors. Incomplete integer representations (like the empty string, '+', '-' or the hex/octal/binary prefix) are accepted as if they are valid too. .TP \fBTCL_LINK_WIDE_UINT\fR . The C variable, or each element of the C array, is of type \fBTcl_WideUInt\fR (which is an unsigned integer type at least 64-bits wide on all platforms that can support it.) Any value written into the Tcl variable must have a proper unsigned integer form acceptable to \fBTcl_GetWideIntFromObj\fR (it will be cast to unsigned); .\" FIXME! Use bignums instead. attempts to write non-integer values into \fIvarName\fR will be rejected with Tcl errors. Incomplete integer representations (like the empty string, '+', '-' or the hex/octal/binary prefix) are accepted as if they are valid too. .TP \fBTCL_LINK_BOOLEAN\fR . The C variable, or each element of the C array, is of type \fBint\fR. If its value is zero then it will read from Tcl as .QW 0 ; otherwise it will read from Tcl as .QW 1 . Whenever \fIvarName\fR is modified, the C variable will be set to a 0 or 1 value. Any value written into the Tcl variable must have a proper boolean form acceptable to \fBTcl_GetBooleanFromObj\fR; attempts to write non-boolean values into \fIvarName\fR will be rejected with Tcl errors. .TP \fBTCL_LINK_STRING\fR . The C variable is of type \fBchar *\fR. If its value is not NULL then it must be a pointer to a string allocated with \fBTcl_Alloc\fR. 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. .PP \fBTcl_UnlinkVar\fR removes the link previously set up for the |
| ︙ | ︙ |
Changes to doc/Method.3.
1 2 3 4 5 6 7 8 9 10 11 | '\" '\" Copyright (c) 2007 Donal K. Fellows '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH Tcl_Method 3 0.1 TclOO "TclOO Library Functions" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME | | | | | | > > > > > | | | > > > | > | > | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 |
'\"
'\" 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 <tclOO.h>\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
|
| ︙ | ︙ | |||
101 102 103 104 105 106 107 | 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 | | | > > > > | > > > > | | 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 | 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 |
| ︙ | ︙ | |||
191 192 193 194 195 196 197 | that the \fIclientData\fR can just be copied directly. .SS "TCL_METHODCALLPROC FUNCTION SIGNATURE" .PP Functions matching this signature are called when the method is invoked. .PP .CS typedef int \fBTcl_MethodCallProc\fR( | | | | | | 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 |
that the \fIclientData\fR can just be copied directly.
.SS "TCL_METHODCALLPROC FUNCTION SIGNATURE"
.PP
Functions matching this signature are called when the method is invoked.
.PP
.CS
typedef int \fBTcl_MethodCallProc\fR(
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
|
| ︙ | ︙ |
Changes to doc/NRE.3.
1 2 | .\" .\" Copyright (c) 2008 by Kevin B. Kenny. | | | 1 2 3 4 5 6 7 8 9 10 | .\" .\" 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 |
| ︙ | ︙ | |||
45 46 47 48 49 50 51 | .AP Tcl_ObjCmdProc *proc in Called in order to evaluate a command. Is often just a small wrapper that uses \fBTcl_NRCallObjProc\fR to call \fInreProc\fR using a new trampoline. Behaves in the same way as the \fIproc\fR argument to \fBTcl_CreateObjCommand\fR(3) (\fIq.v.\fR). .AP Tcl_ObjCmdProc *nreProc in Called instead of \fIproc\fR when a trampoline is already in use. | | | 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 | .AP Tcl_ObjCmdProc *proc in Called in order to evaluate a command. Is often just a small wrapper that uses \fBTcl_NRCallObjProc\fR to call \fInreProc\fR using a new trampoline. Behaves in the same way as the \fIproc\fR argument to \fBTcl_CreateObjCommand\fR(3) (\fIq.v.\fR). .AP Tcl_ObjCmdProc *nreProc in Called instead of \fIproc\fR when a trampoline is already in use. .AP 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. |
| ︙ | ︙ | |||
68 69 70 71 72 73 74 | Token to use instead of one derived from the first word of \fIobjv\fR in order to evaluate a command. .AP Tcl_Obj *resultPtr out Pointer to an unshared Tcl_Obj where the result of the evaluation is stored if the return code is TCL_OK. .AP Tcl_NRPostProc *postProcPtr in A function to push. | | | | | | 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 | Token to use instead of one derived from the first word of \fIobjv\fR in order to evaluate a command. .AP Tcl_Obj *resultPtr out Pointer to an unshared Tcl_Obj where the result of the evaluation is stored if the return code is TCL_OK. .AP Tcl_NRPostProc *postProcPtr in A function to push. .AP 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 |
| ︙ | ︙ | |||
126 127 128 129 130 131 132 | .PP \fBTcl_NRAddCallback\fR pushes \fIpostProcPtr\fR. The signature for \fBTcl_NRPostProc\fR is: .PP .CS typedef int \fBTcl_NRPostProc\fR( | | | | 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 |
.PP
\fBTcl_NRAddCallback\fR pushes \fIpostProcPtr\fR. The signature for
\fBTcl_NRPostProc\fR is:
.PP
.CS
typedef int
\fBTcl_NRPostProc\fR(
\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;
|
| ︙ | ︙ | |||
173 174 175 176 177 178 179 | trampoline instead of consuming space on the C stack. A new version of \fITheCmdOldObjProc\fR is just a a wrapper that uses \fBTcl_NRCallObjProc\fR to call \fITheCmdNRObjProc\fR: .PP .CS int \fITheCmdOldObjProc\fR( | | | | | 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 |
trampoline instead of consuming space on the C stack. A new version of
\fITheCmdOldObjProc\fR is just a a wrapper that uses \fBTcl_NRCallObjProc\fR to
call \fITheCmdNRObjProc\fR:
.PP
.CS
int
\fITheCmdOldObjProc\fR(
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
|
| ︙ | ︙ |
Changes to doc/Namespace.3.
| ︙ | ︙ | |||
53 54 55 56 57 58 59 | .SH ARGUMENTS .AS Tcl_NamespaceDeleteProc allowOverwrite in/out .AP Tcl_Interp *interp in/out The interpreter in which the namespace exists and where name lookups are performed. Also where error result messages are written. .AP "const char" *name in The name of the namespace or command to be created or accessed. | | | 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 | .SH ARGUMENTS .AS Tcl_NamespaceDeleteProc allowOverwrite in/out .AP Tcl_Interp *interp in/out The interpreter in which the namespace exists and where name lookups are performed. Also where error result messages are written. .AP "const char" *name in The name of the namespace or command to be created or accessed. .AP void *clientData in A context pointer by the creator of the namespace. Not interpreted by Tcl at all. .AP Tcl_NamespaceDeleteProc *deleteProc in A pointer to function to call when the namespace is deleted, or NULL if no such callback is to be performed. .AP Tcl_Namespace *nsPtr in The namespace to be manipulated, or NULL (for other than |
| ︙ | ︙ | |||
113 114 115 116 117 118 119 | the global namespace.) .PP \fBTcl_CreateNamespace\fR creates a new namespace. The \fIdeleteProc\fR will have the following type signature: .PP .CS typedef void \fBTcl_NamespaceDeleteProc\fR( | | | 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 |
the global namespace.)
.PP
\fBTcl_CreateNamespace\fR creates a new namespace. The
\fIdeleteProc\fR will have the following type signature:
.PP
.CS
typedef void \fBTcl_NamespaceDeleteProc\fR(
void *\fIclientData\fR);
.CE
.PP
\fBTcl_DeleteNamespace\fR deletes a namespace, calling the
\fIdeleteProc\fR defined for the namespace (if any).
.PP
\fBTcl_AppendExportList\fR retrieves the export patterns for a
namespace given namespace and appends them (as list items) to
|
| ︙ | ︙ |
Changes to doc/Notifier.3.
| ︙ | ︙ | |||
34 35 36 37 38 39 40 | .sp Tcl_ThreadId \fBTcl_GetCurrentThread\fR() .sp void \fBTcl_DeleteEvents\fR(\fIdeleteProc, clientData\fR) .sp | | | 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 | .sp Tcl_ThreadId \fBTcl_GetCurrentThread\fR() .sp void \fBTcl_DeleteEvents\fR(\fIdeleteProc, clientData\fR) .sp void * \fBTcl_InitNotifier\fR() .sp void \fBTcl_FinalizeNotifier\fR(\fIclientData\fR) .sp int \fBTcl_WaitForEvent\fR(\fItimePtr\fR) |
| ︙ | ︙ | |||
74 75 76 77 78 79 80 | .AS Tcl_EventDeleteProc *notifierProcPtr .AP Tcl_EventSetupProc *setupProc in Procedure to invoke to prepare for event wait in \fBTcl_DoOneEvent\fR. .AP Tcl_EventCheckProc *checkProc in Procedure for \fBTcl_DoOneEvent\fR to invoke after waiting for events. Checks to see if any events have occurred and, if so, queues them. | | | | 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 | .AS Tcl_EventDeleteProc *notifierProcPtr .AP Tcl_EventSetupProc *setupProc in Procedure to invoke to prepare for event wait in \fBTcl_DoOneEvent\fR. .AP Tcl_EventCheckProc *checkProc in Procedure for \fBTcl_DoOneEvent\fR to invoke after waiting for events. Checks to see if any events have occurred and, if so, queues them. .AP void *clientData in Arbitrary one-word value to pass to \fIsetupProc\fR, \fIcheckProc\fR, or \fIdeleteProc\fR. .AP "const Tcl_Time" *timePtr in Indicates the maximum amount of time to wait for an event. This is specified as an interval (how long to wait), not an absolute time (when to wakeup). If the pointer passed to \fBTcl_WaitForEvent\fR is NULL, it means there is no maximum wait time: wait forever if necessary. .AP Tcl_Event *evPtr in An event to add to the event queue. The storage for the event must have been allocated by the caller using \fBTcl_Alloc\fR. .AP Tcl_QueuePosition position in Where to add the new event in the queue: \fBTCL_QUEUE_TAIL\fR, \fBTCL_QUEUE_HEAD\fR, or \fBTCL_QUEUE_MARK\fR. .AP Tcl_ThreadId threadId in A unique identifier for a thread. .AP Tcl_EventDeleteProc *deleteProc in Procedure to invoke for each queued event in \fBTcl_DeleteEvents\fR. |
| ︙ | ︙ | |||
226 227 228 229 230 231 232 | The procedure \fBTcl_CreateEventSource\fR creates a new event source. Its arguments specify the setup procedure and check procedure for the event source. \fISetupProc\fR should match the following prototype: .PP .CS typedef void \fBTcl_EventSetupProc\fR( | | | 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 |
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,
int \fIflags\fR);
.CE
.PP
The \fIclientData\fR argument will be the same as the \fIclientData\fR
argument to \fBTcl_CreateEventSource\fR; it is typically used to
point to private information managed by the event source.
The \fIflags\fR argument will be the same as the \fIflags\fR
|
| ︙ | ︙ | |||
304 305 306 307 308 309 310 | The second procedure provided by each event source is its check procedure, indicated by the \fIcheckProc\fR argument to \fBTcl_CreateEventSource\fR. \fICheckProc\fR must match the following prototype: .PP .CS typedef void \fBTcl_EventCheckProc\fR( | | | 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 |
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,
int \fIflags\fR);
.CE
.PP
The arguments to this procedure are the same as those for \fIsetupProc\fR.
\fBCheckProc\fR is invoked by \fBTcl_DoOneEvent\fR after it has waited
for events. Presumably at least one event source is now prepared to
queue an event. \fBTcl_DoOneEvent\fR calls each of the event sources
|
| ︙ | ︙ | |||
395 396 397 398 399 400 401 | Another example of deferring events happens in Tk if \fBTk_RestrictEvents\fR has been invoked to defer certain kinds of window events. .PP When \fIproc\fR returns 1, \fBTcl_ServiceEvent\fR will remove the event from the event queue and free its storage. Note that the storage for an event must be allocated by | | | 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 | Another example of deferring events happens in Tk if \fBTk_RestrictEvents\fR has been invoked to defer certain kinds of window events. .PP When \fIproc\fR returns 1, \fBTcl_ServiceEvent\fR will remove the event from the event queue and free its storage. Note that the storage for an event must be allocated by the event source (using \fBTcl_Alloc\fR) before calling \fBTcl_QueueEvent\fR, but it will be freed by \fBTcl_ServiceEvent\fR, not by the event source. .PP 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 |
| ︙ | ︙ | |||
424 425 426 427 428 429 430 |
for each event in the queue, deleting those for with the procedure
returns 1. Events for which the procedure returns 0 are left in the
queue. \fIProc\fR should match the following prototype:
.PP
.CS
typedef int \fBTcl_EventDeleteProc\fR(
Tcl_Event *\fIevPtr\fR,
| | | 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 |
for each event in the queue, deleting those for with the procedure
returns 1. Events for which the procedure returns 0 are left in the
queue. \fIProc\fR should match the following prototype:
.PP
.CS
typedef int \fBTcl_EventDeleteProc\fR(
Tcl_Event *\fIevPtr\fR,
void *\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
|
| ︙ | ︙ |
Changes to doc/Object.3.
| ︙ | ︙ | |||
107 108 109 110 111 112 113 |
.SH "THE TCL_OBJ STRUCTURE"
.PP
Each Tcl value is represented by a \fBTcl_Obj\fR structure
which is defined as follows.
.PP
.CS
typedef struct Tcl_Obj {
| | | | 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 |
.SH "THE TCL_OBJ STRUCTURE"
.PP
Each Tcl value is represented by a \fBTcl_Obj\fR structure
which is defined as follows.
.PP
.CS
typedef struct Tcl_Obj {
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 {
|
| ︙ | ︙ |
Changes to doc/ObjectType.3.
| ︙ | ︙ | |||
182 183 184 185 186 187 188 | We require the string representation's byte array to have a null after the last byte, at offset \fIlength\fR, and to have no null bytes before that; this allows string representations to be treated as conventional null character-terminated C strings. These restrictions are easily met by using Tcl's internal UTF encoding for the string representation, same as one would do for other Tcl routines accepting string values as arguments. | | | | 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 | We require the string representation's byte array to have a null after the last byte, at offset \fIlength\fR, and to have no null bytes before that; this allows string representations to be treated as conventional null character-terminated C strings. These restrictions are easily met by using Tcl's internal UTF encoding for the string representation, same as one would do for other Tcl routines accepting string values as arguments. Storage for the byte array must be allocated in the heap by \fBTcl_Alloc\fR. Note that \fIupdateStringProc\fRs must allocate enough storage for the string's bytes and the terminating null byte. .PP The \fIupdateStringProc\fR for Tcl's built-in double type, for example, calls Tcl_PrintDouble to write to a buffer of size TCL_DOUBLE_SPACE, then allocates and copies the string representation to just enough space to hold it. A pointer to the allocated space is stored in the \fIbytes\fR member. |
| ︙ | ︙ |
Changes to doc/OpenFileChnl.3.
| ︙ | ︙ | |||
49 50 51 52 53 54 55 | .sp int \fBTcl_ReadChars\fR(\fIchannel, readObjPtr, charsToRead, appendFlag\fR) .sp int \fBTcl_Read\fR(\fIchannel, readBuf, bytesToRead\fR) .sp | | | | | | | | | | 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 | .sp int \fBTcl_ReadChars\fR(\fIchannel, readObjPtr, charsToRead, appendFlag\fR) .sp int \fBTcl_Read\fR(\fIchannel, readBuf, bytesToRead\fR) .sp size_t \fBTcl_GetsObj\fR(\fIchannel, lineObjPtr\fR) .sp size_t \fBTcl_Gets\fR(\fIchannel, lineRead\fR) .sp size_t \fBTcl_Ungets\fR(\fIchannel, input, inputLen, addAtEnd\fR) .sp size_t \fBTcl_WriteObj\fR(\fIchannel, writeObjPtr\fR) .sp size_t \fBTcl_WriteChars\fR(\fIchannel, charBuf, bytesToWrite\fR) .sp size_t \fBTcl_Write\fR(\fIchannel, byteBuf, bytesToWrite\fR) .sp size_t \fBTcl_ReadRaw\fR(\fIchannel, readBuf, bytesToRead\fR) .sp size_t \fBTcl_WriteRaw\fR(\fIchannel, byteBuf, bytesToWrite\fR) .sp int \fBTcl_Eof\fR(\fIchannel\fR) .sp int \fBTcl_Flush\fR(\fIchannel\fR) |
| ︙ | ︙ | |||
130 131 132 133 134 135 136 | \fBTCL_ENFORCE_MODE\fR. If \fBTCL_STDIN\fR is set, stdin for the first child in the pipe is the pipe channel, otherwise it is the same as the standard input of the invoking process; likewise for \fBTCL_STDOUT\fR and \fBTCL_STDERR\fR. If \fBTCL_ENFORCE_MODE\fR is not set, then the pipe can redirect stdio handles to override the stdio handles for which \fBTCL_STDIN\fR, \fBTCL_STDOUT\fR and \fBTCL_STDERR\fR have been set. If it is set, then such redirections cause an error. | | | | | | | 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 | \fBTCL_ENFORCE_MODE\fR. If \fBTCL_STDIN\fR is set, stdin for the first child in the pipe is the pipe channel, otherwise it is the same as the standard input of the invoking process; likewise for \fBTCL_STDOUT\fR and \fBTCL_STDERR\fR. If \fBTCL_ENFORCE_MODE\fR is not set, then the pipe can redirect stdio handles to override the stdio handles for which \fBTCL_STDIN\fR, \fBTCL_STDOUT\fR and \fBTCL_STDERR\fR have been set. If it is set, then such redirections cause an error. .AP void *handle in Operating system specific handle for I/O to a file. For Unix this is a file descriptor, for Windows it is a HANDLE. .AP int readOrWrite in OR-ed combination of \fBTCL_READABLE\fR and \fBTCL_WRITABLE\fR to indicate what operations are valid on \fIhandle\fR. .AP "const char" *channelName in The name of the channel. .AP int *modePtr out Points at an integer variable that will receive an OR-ed combination of \fBTCL_READABLE\fR and \fBTCL_WRITABLE\fR denoting whether the channel is open for reading and writing. .AP "const char" *pattern in The pattern to match on, passed to Tcl_StringMatch, or NULL. .AP Tcl_Channel channel in A Tcl channel for input or output. Must have been the return value from a procedure such as \fBTcl_OpenFileChannel\fR. .AP Tcl_Obj *readObjPtr in/out A pointer to a Tcl value in which to store the characters read from the channel. .AP 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 channel. .AP int appendFlag in If non-zero, data read from the channel will be appended to the value. Otherwise, the data will replace the existing contents of the value. .AP char *readBuf out A buffer in which to store the bytes read from the channel. .AP size_t bytesToRead in The number of bytes to read from the channel. The buffer \fIreadBuf\fR must be large enough to hold this many bytes. .AP Tcl_Obj *lineObjPtr in/out A pointer to a Tcl value in which to store the line read from the channel. The line read will be appended to the current value of the value. .AP Tcl_DString *lineRead in/out A pointer to a Tcl dynamic string in which to store the line read from the channel. Must have been initialized by the caller. The line read will be appended to any data already in the dynamic string. .AP "const char" *input in The input to add to a channel buffer. .AP size_t inputLen in Length of the input .AP int addAtEnd in Flag indicating whether the input should be added to the end or beginning of the channel buffer. .AP Tcl_Obj *writeObjPtr in A pointer to a Tcl value whose contents will be output to the channel. .AP "const char" *charBuf in A buffer containing the characters to output to the channel. .AP "const char" *byteBuf in A buffer containing the bytes to output to the channel. .AP size_t bytesToWrite in The number of bytes to consume from \fIcharBuf\fR or \fIbyteBuf\fR and output to the channel. .AP Tcl_WideInt offset in How far to move the access point in the channel at which the next input or output operation will be applied, measured in bytes from the position given by \fIseekMode\fR. May be either positive or negative. .AP int seekMode in |
| ︙ | ︙ |
Changes to doc/OpenTcp.3.
| ︙ | ︙ | |||
46 47 48 49 50 51 52 | for the local end of the connection. If NULL, a default interface is chosen. .AP int async in If nonzero, the client socket is connected asynchronously to the server. .AP "unsigned int" flags in ORed combination of \fBTCL_TCPSERVER\fR flags that specify additional informations about the socket being created. | | | | 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 | for the local end of the connection. If NULL, a default interface is chosen. .AP int async in If nonzero, the client socket is connected asynchronously to the server. .AP "unsigned int" flags in ORed combination of \fBTCL_TCPSERVER\fR flags that specify additional informations about the socket being created. .AP void *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 Arbitrary one-word value to pass to \fIproc\fR. .BE .SH DESCRIPTION .PP These functions are convenience procedures for creating channels that communicate over TCP sockets. The operations on a channel |
| ︙ | ︙ | |||
123 124 125 126 127 128 129 | allow connections from any network interface. Each time a client connects to this socket, Tcl creates a channel for the new connection and invokes \fIproc\fR with information about the channel. \fIProc\fR must match the following prototype: .PP .CS typedef void \fBTcl_TcpAcceptProc\fR( | | | 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 |
allow connections from any network interface.
Each time a client connects to this socket, Tcl creates a channel
for the new connection and invokes \fIproc\fR with information about
the channel. \fIProc\fR must match the following prototype:
.PP
.CS
typedef void \fBTcl_TcpAcceptProc\fR(
void *\fIclientData\fR,
Tcl_Channel \fIchannel\fR,
char *\fIhostName\fR,
int \fIport\fR);
.CE
.PP
The \fIclientData\fR argument will be the same as the \fIclientData\fR
argument to \fBTcl_OpenTcpServer\fR, \fIchannel\fR will be the handle
|
| ︙ | ︙ |
Changes to doc/Panic.3.
1 2 3 4 5 6 7 8 9 | '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH Tcl_Panic 3 8.4 Tcl "Tcl Library Procedures" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME | | > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 | '\" '\" 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 .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp void \fBTcl_Panic\fR(\fIformat\fR, \fIarg\fR, \fIarg\fR, \fI...\fR) .sp void \fBTcl_SetPanicProc\fR(\fIpanicProc\fR) .sp void \fBTcl_ConsolePanic\fR(\fIformat\fR, \fIarg\fR, \fIarg\fR, \fI...\fR) .sp .SH ARGUMENTS .AS Tcl_PanicProc *panicProc .AP "const char*" format in A printf-style format string. .AP "" arg in Arguments matching the format string. .AP va_list argList in |
| ︙ | ︙ | |||
46 47 48 49 50 51 52 53 54 55 56 57 58 59 | 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 in stead. 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 \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( | > > > > > > > > | 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 | 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 in stead. 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 (in stead of the stderr channel of the C runtime used by Tcl), you can call \fBTcl_SetPanicProc\fR with \fBTcl_ConsolePanic\fR as its argument. On platforms which only have one C runtime (almost all platforms except Windows) \fBTcl_ConsolePanic\fR is equivalent to NULL. .PP \fBTcl_SetPanicProc\fR may be used to modify the behavior of \fBTcl_Panic\fR. The \fIpanicProc\fR argument should match the type \fBTcl_PanicProc\fR: .PP .CS typedef void \fBTcl_PanicProc\fR( |
| ︙ | ︙ | |||
73 74 75 76 77 78 79 80 81 82 83 | application or the platform. .PP Although the primary callers of \fBTcl_Panic\fR are the procedures of the Tcl library, \fBTcl_Panic\fR is a public function and may be called by any extension or application that wishes to abort the process and have a panic message displayed the same way that panic messages from Tcl will be displayed. .SH "SEE ALSO" abort(3), printf(3), exec(n), format(n) .SH KEYWORDS abort, fatal, error | > > | 84 85 86 87 88 89 90 91 92 93 94 95 96 | application or the platform. .PP Although the primary callers of \fBTcl_Panic\fR are the procedures of the Tcl library, \fBTcl_Panic\fR is a public function and may be called by any extension or application that wishes to abort the process and have a panic message displayed the same way that panic messages from Tcl will be displayed. .PP This function can not be used in stub-enabled extensions. .SH "SEE ALSO" abort(3), printf(3), exec(n), format(n) .SH KEYWORDS abort, fatal, error |
Changes to doc/ParseArgs.3.
| ︙ | ︙ | |||
27 28 29 30 31 32 33 | stored in \fIremObjv\fR. .AP "Tcl_Obj *const" *objv in The array of arguments to be parsed. .AP Tcl_Obj ***remObjv out Pointer to a variable that will hold the array of unprocessed arguments. Should be NULL if no return of unprocessed arguments is required. If \fIobjcPtr\fR is updated to a non-zero value, the array returned through this | | | 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 | stored in \fIremObjv\fR. .AP "Tcl_Obj *const" *objv in The array of arguments to be parsed. .AP Tcl_Obj ***remObjv out Pointer to a variable that will hold the array of unprocessed arguments. Should be NULL if no return of unprocessed arguments is required. If \fIobjcPtr\fR is updated to a non-zero value, the array returned through this must be deallocated using \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 |
| ︙ | ︙ | |||
80 81 82 83 84 85 86 |
.CS
typedef struct {
int \fItype\fR;
const char *\fIkeyStr\fR;
void *\fIsrcPtr\fR;
void *\fIdstPtr\fR;
const char *\fIhelpStr\fR;
| | | | | 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 |
.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 \fIsrcPtr\fR field (casted to \fIint\fR) 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
|
| ︙ | ︙ | |||
123 124 125 126 127 128 129 | This argument optionally takes a following value argument; it is up to the handler callback function passed in \fIsrcPtr\fR to decide. That function will have the following signature: .RS .PP .CS typedef int (\fBTcl_ArgvFuncProc\fR)( | | | 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 |
This argument optionally takes a following value argument; it is up to the
handler callback function passed in \fIsrcPtr\fR to decide. That function will
have the following signature:
.RS
.PP
.CS
typedef int (\fBTcl_ArgvFuncProc\fR)(
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
|
| ︙ | ︙ | |||
145 146 147 148 149 150 151 | function passed in \fIsrcPtr\fR returns how many (or a negative number to signal an error, in which case it should also set the interpreter result). The function will have the following signature: .RS .PP .CS typedef int (\fBTcl_ArgvGenFuncProc\fR)( | | | 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 |
function passed in \fIsrcPtr\fR returns how many (or a negative number to
signal an error, in which case it should also set the interpreter result). The
function will have the following signature:
.RS
.PP
.CS
typedef int (\fBTcl_ArgvGenFuncProc\fR)(
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
|
| ︙ | ︙ |
Changes to doc/ParseCmd.3.
| ︙ | ︙ | |||
204 205 206 207 208 209 210 |
int \fInumTokens\fR;
...
} \fBTcl_Parse\fR;
typedef struct Tcl_Token {
int \fItype\fR;
const char *\fIstart\fR;
| | | | 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 |
int \fInumTokens\fR;
...
} \fBTcl_Parse\fR;
typedef struct Tcl_Token {
int \fItype\fR;
const char *\fIstart\fR;
size_t \fIsize\fR;
size_t \fInumComponents\fR;
} \fBTcl_Token\fR;
.CE
.PP
The first five fields of a Tcl_Parse structure
are filled in only by \fBTcl_ParseCommand\fR.
These fields are not used by the other parsing procedures.
.PP
|
| ︙ | ︙ |
Changes to doc/Preserve.3.
| ︙ | ︙ | |||
17 18 19 20 21 22 23 | \fBTcl_Preserve\fR(\fIclientData\fR) .sp \fBTcl_Release\fR(\fIclientData\fR) .sp \fBTcl_EventuallyFree\fR(\fIclientData, freeProc\fR) .SH ARGUMENTS .AS Tcl_FreeProc clientData | | | 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 | \fBTcl_Preserve\fR(\fIclientData\fR) .sp \fBTcl_Release\fR(\fIclientData\fR) .sp \fBTcl_EventuallyFree\fR(\fIclientData, freeProc\fR) .SH ARGUMENTS .AS Tcl_FreeProc clientData .AP void *clientData in Token describing structure to be freed or reallocated. Usually a pointer to memory for structure. .AP Tcl_FreeProc *freeProc in Procedure to invoke to free \fIclientData\fR. .BE .SH DESCRIPTION .PP |
| ︙ | ︙ | |||
87 88 89 90 91 92 93 | same as the \fIclientData\fR argument to \fBTcl_EventuallyFree\fR. The type of \fIblockPtr\fR (\fBchar *\fR) is different than the type of the \fIclientData\fR argument to \fBTcl_EventuallyFree\fR for historical reasons, but the value is the same. .PP When the \fIclientData\fR argument to \fBTcl_EventuallyFree\fR refers to storage allocated and returned by a prior call to | | | 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 | same as the \fIclientData\fR argument to \fBTcl_EventuallyFree\fR. The type of \fIblockPtr\fR (\fBchar *\fR) is different than the type of the \fIclientData\fR argument to \fBTcl_EventuallyFree\fR for historical reasons, but the value is the same. .PP When the \fIclientData\fR argument to \fBTcl_EventuallyFree\fR refers to storage allocated and returned by a prior call to \fBTcl_Alloc\fR or another function of the Tcl library, then the \fIfreeProc\fR argument should be given the special value of \fBTCL_DYNAMIC\fR. .PP This mechanism can be used to solve the problem described above by placing \fBTcl_Preserve\fR and \fBTcl_Release\fR calls around actions that may cause undesired storage re-allocation. The mechanism is intended only for short-term use (i.e. while procedures |
| ︙ | ︙ |
Changes to doc/RegExp.3.
| ︙ | ︙ | |||
60 61 62 63 64 65 66 | by \fBTcl_GetRegExpFromObj\fR or \fBTcl_RegExpCompile\fR. .AP char *start in If \fItext\fR is just a portion of some other string, this argument identifies the beginning of the larger string. If it is not the same as \fItext\fR, then no .QW \fB^\fR matches will be allowed. | | | | | | 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 | by \fBTcl_GetRegExpFromObj\fR or \fBTcl_RegExpCompile\fR. .AP char *start in If \fItext\fR is just a portion of some other string, this argument identifies the beginning of the larger string. If it is not the same as \fItext\fR, then no .QW \fB^\fR matches will be allowed. .AP size_t index in Specifies which range is desired: 0 means the range of the entire match, 1 or greater means the range that matched a parenthesized sub-expression. .AP "const char" **startPtr out The address of the first character in the range is stored here, or NULL if there is no such range. .AP "const char" **endPtr out The address of the character just after the last one in the range is stored here, or NULL if there is no such range. .AP int cflags in OR-ed combination of the compilation flags \fBTCL_REG_ADVANCED\fR, \fBTCL_REG_EXTENDED\fR, \fBTCL_REG_BASIC\fR, \fBTCL_REG_EXPANDED\fR, \fBTCL_REG_QUOTE\fR, \fBTCL_REG_NOCASE\fR, \fBTCL_REG_NEWLINE\fR, \fBTCL_REG_NLSTOP\fR, \fBTCL_REG_NLANCH\fR, \fBTCL_REG_NOSUB\fR, and \fBTCL_REG_CANMATCH\fR. See below for more information. .AP size_t 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 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 all of the matching subexpressions will be remembered. Any other value will be taken as the maximum number of subexpressions to remember. .AP int eflags in OR-ed combination of the execution flags \fBTCL_REG_NOTBOL\fR and \fBTCL_REG_NOTEOL\fR. See below for more information. .AP Tcl_RegExpInfo *infoPtr out |
| ︙ | ︙ | |||
333 334 335 336 337 338 339 |
\fBTcl_RegExpGetInfo\fR retrieves information about the last match
performed with a given regular expression \fIregexp\fR. The
\fIinfoPtr\fR argument contains a pointer to a structure that is
defined as follows:
.PP
.CS
typedef struct Tcl_RegExpInfo {
| | | | | | 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 |
\fBTcl_RegExpGetInfo\fR retrieves information about the last match
performed with a given regular expression \fIregexp\fR. The
\fIinfoPtr\fR argument contains a pointer to a structure that is
defined as follows:
.PP
.CS
typedef struct Tcl_RegExpInfo {
size_t \fInsubs\fR;
Tcl_RegExpIndices *\fImatches\fR;
size_t \fIextendStart\fR;
} \fBTcl_RegExpInfo\fR;
.CE
.PP
The \fInsubs\fR field contains a count of the number of parenthesized
subexpressions within the regular expression. If the \fBTCL_REG_NOSUB\fR
was used, then this value will be zero. The \fImatches\fR field
points to an array of \fInsubs\fR+1 values that indicate the bounds of each
subexpression matched. The first element in the array refers to the
range matched by the entire regular expression, and subsequent elements
refer to the parenthesized subexpressions in the order that they
appear in the pattern. Each element is a structure that is defined as
follows:
.PP
.CS
typedef struct Tcl_RegExpIndices {
size_t \fIstart\fR;
size_t \fIend\fR;
} \fBTcl_RegExpIndices\fR;
.CE
.PP
The \fIstart\fR and \fIend\fR values are Unicode character indices
relative to the offset location within \fIobjPtr\fR where matching began.
The \fIstart\fR index identifies the first character of the matched
subexpression. The \fIend\fR index identifies the first character
|
| ︙ | ︙ |
Changes to doc/SaveResult.3.
1 2 3 4 5 6 7 8 9 10 11 | '\" '\" Copyright (c) 1997 by Sun Microsystems, Inc. '\" Contributions from Don Porter, NIST, 2004. (not subject to US copyright) '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH Tcl_SaveResult 3 8.1 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME | > | > > | | | | < | | < < | < > > | | < | < | < | < < < < | < < < < < > > | < < < < < | | < > < < < < < < < < < < < < < < < < < | | < | > | | < | | < | < < | < > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 | '\" '\" 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. .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp Tcl_InterpState \fBTcl_SaveInterpState\fR(\fIinterp, status\fR) .sp int \fBTcl_RestoreInterpState\fR(\fIinterp, state\fR) .sp \fBTcl_DiscardInterpState\fR(\fIstate\fR) .sp \fBTcl_SaveResult\fR(\fIinterp, savedPtr\fR) .sp \fBTcl_RestoreResult\fR(\fIinterp, savedPtr\fR) .sp \fBTcl_DiscardResult\fR(\fIsavedPtr\fR) .SH ARGUMENTS .AS Tcl_InterpState savedPtr .AP Tcl_Interp *interp in The interpreter for the operation. .AP int status in The return code for the state. .AP Tcl_InterpState state in A token for saved state. .AP Tcl_SavedResult *savedPtr in A pointer to storage for saved state. .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. .SH KEYWORDS result, state, interp |
Changes to doc/SplitList.3.
| ︙ | ︙ | |||
16 17 18 19 20 21 22 | .sp int \fBTcl_SplitList\fR(\fIinterp, list, argcPtr, argvPtr\fR) .sp char * \fBTcl_Merge\fR(\fIargc, argv\fR) .sp | | | | | | 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 | .sp int \fBTcl_SplitList\fR(\fIinterp, list, argcPtr, argvPtr\fR) .sp char * \fBTcl_Merge\fR(\fIargc, argv\fR) .sp size_t \fBTcl_ScanElement\fR(\fIsrc, flagsPtr\fR) .sp size_t \fBTcl_ScanCountedElement\fR(\fIsrc, length, flagsPtr\fR) .sp size_t \fBTcl_ConvertElement\fR(\fIsrc, dst, flags\fR) .sp size_t \fBTcl_ConvertCountedElement\fR(\fIsrc, length, dst, flags\fR) .SH ARGUMENTS .AS "const char *const" ***argvPtr out .AP Tcl_Interp *interp out Interpreter to use for error reporting. If NULL, then no error message is left. .AP char *list in |
| ︙ | ︙ | |||
51 52 53 54 55 56 57 | Array of strings to merge together into a single list. Each string will become a separate element of the list. .AP "const char" *src in String that is to become an element of a list. .AP int *flagsPtr in Pointer to word to fill in with information about \fIsrc\fR. The value of *\fIflagsPtr\fR must be passed to \fBTcl_ConvertElement\fR. | | | 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 | Array of strings to merge together into a single list. Each string will become a separate element of the list. .AP "const char" *src in String that is to become an element of a list. .AP int *flagsPtr in Pointer to word to fill in with information about \fIsrc\fR. The value of *\fIflagsPtr\fR must be passed to \fBTcl_ConvertElement\fR. .AP size_t length in Number of bytes in string \fIsrc\fR. .AP char *dst in Place to copy converted list element. Must contain enough characters to hold converted string. .AP int flags in Information about \fIsrc\fR. Must be value returned by previous call to \fBTcl_ScanElement\fR, possibly OR-ed |
| ︙ | ︙ |
Changes to doc/StaticPkg.3.
| ︙ | ︙ | |||
60 61 62 63 64 65 66 67 68 69 70 | 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. .SH KEYWORDS initialization procedure, package, static linking .SH "SEE ALSO" load(n), package(n), Tcl_PkgRequire(3) | > > | 60 61 62 63 64 65 66 67 68 69 70 71 72 | 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 This function can not be used in stub-enabled extensions. .SH KEYWORDS initialization procedure, package, static linking .SH "SEE ALSO" load(n), package(n), Tcl_PkgRequire(3) |
Changes to doc/StringObj.3.
| ︙ | ︙ | |||
33 34 35 36 37 38 39 | .sp Tcl_UniChar * \fBTcl_GetUnicodeFromObj\fR(\fIobjPtr, lengthPtr\fR) .sp Tcl_UniChar * \fBTcl_GetUnicode\fR(\fIobjPtr\fR) .sp | | | 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 | .sp Tcl_UniChar * \fBTcl_GetUnicodeFromObj\fR(\fIobjPtr, lengthPtr\fR) .sp Tcl_UniChar * \fBTcl_GetUnicode\fR(\fIobjPtr\fR) .sp int \fBTcl_GetUniChar\fR(\fIobjPtr, index\fR) .sp int \fBTcl_GetCharLength\fR(\fIobjPtr\fR) .sp Tcl_Obj * \fBTcl_GetRange\fR(\fIobjPtr, first, last\fR) |
| ︙ | ︙ | |||
83 84 85 86 87 88 89 | \fBTcl_ConcatObj\fR(\fIobjc, objv\fR) .SH ARGUMENTS .AS "const Tcl_UniChar" *appendObjPtr in/out .AP "const char" *bytes in Points to the first byte of an array of UTF-8-encoded bytes used to set or append to a string value. This byte array may contain embedded null characters | | | | | | | | | | | | 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 | \fBTcl_ConcatObj\fR(\fIobjc, objv\fR) .SH ARGUMENTS .AS "const Tcl_UniChar" *appendObjPtr in/out .AP "const char" *bytes in Points to the first byte of an array of UTF-8-encoded bytes used to set or append to a string value. This byte array may contain embedded null characters unless \fInumChars\fR is TCL_AUTO_LENGTH. (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 The number of bytes to copy from \fIbytes\fR when initializing, setting, or appending to a string value. If TCL_AUTO_LENGTH, all bytes up to the first null are used. .AP "const Tcl_UniChar" *unicode in Points to the first byte of an array of Unicode characters used to set or append to a string value. This byte array may contain embedded null characters unless \fInumChars\fR is negative. .AP size_t numChars in The number of Unicode characters to copy from \fIunicode\fR when initializing, setting, or appending to a string value. If TCL_AUTO_LENGTH, all characters up to the first null character are used. .AP size_t index in The index of the Unicode character to return. .AP size_t 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 The index of the last Unicode character in the Unicode range to be returned as a new value. .AP Tcl_Obj *objPtr in/out Points to a value to manipulate. .AP Tcl_Obj *appendObjPtr in The value to append to \fIobjPtr\fR in \fBTcl_AppendObjToObj\fR. .AP int *lengthPtr out If non-NULL, the location where \fBTcl_GetStringFromObj\fR will store the length of a value's string representation. .AP "const char" *string in Null-terminated string value to append to \fIobjPtr\fR. .AP va_list argList in An argument list which must have been initialized using \fBva_start\fR, and cleared using \fBva_end\fR. .AP size_t limit in Maximum number of bytes to be appended. .AP "const char" *ellipsis in Suffix to append when the limit leads to string truncation. If NULL is passed then the suffix .QW "..." is used. .AP "const char" *format in Format control string including % conversion specifiers. .AP int objc in The number of elements to format or concatenate. .AP Tcl_Obj *objv[] in The array of values to format or concatenate. .AP size_t newLength in New length for the string value of \fIobjPtr\fR, not including the final null character. .BE .SH DESCRIPTION .PP The procedures described in this manual entry allow Tcl values to be manipulated as string values. They use the internal representation |
| ︙ | ︙ | |||
197 198 199 200 201 202 203 | \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 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 | | > | 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 | \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 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; .PP \fBTcl_GetRange\fR returns a newly created value comprised of the characters between \fIfirst\fR and \fIlast\fR (inclusive) in the value's Unicode representation. If the value's Unicode representation is invalid, the Unicode representation is regenerated from the value's string representation. .PP |
| ︙ | ︙ |
Changes to doc/TCL_MEM_DEBUG.3.
| ︙ | ︙ | |||
30 31 32 33 34 35 36 | .PP Once memory debugging support has been compiled into Tcl, the C functions \fBTcl_ValidateAllMemory\fR, and \fBTcl_DumpActiveMemory\fR, and the Tcl \fBmemory\fR command can be used to validate and examine memory usage. .SH "GUARD ZONES" .PP | | | | | | | | 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 | .PP Once memory debugging support has been compiled into Tcl, the C functions \fBTcl_ValidateAllMemory\fR, and \fBTcl_DumpActiveMemory\fR, and the Tcl \fBmemory\fR command can be used to validate and examine memory usage. .SH "GUARD ZONES" .PP When memory debugging is enabled, whenever a call to \fBTcl_Alloc\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 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. This allows you to detect the common sorts of one-off problems, where not enough space was allocated to contain the data written, for example. .SH "DEBUGGING DIFFICULT MEMORY CORRUPTION PROBLEMS" .PP Normally, Tcl compiled with memory debugging enabled will make it easy to isolate a corruption problem. Turning on memory validation with the memory command can help isolate difficult problems. If you suspect (or know) that corruption is occurring before the Tcl interpreter comes up far enough for you to issue commands, you can set \fBMEM_VALIDATE\fR define, recompile tclCkalloc.c and rebuild Tcl. This will enable memory validation from the first call to \fBTcl_Alloc\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 \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 .SH KEYWORDS memory, debug |
Changes to doc/Tcl.n.
| ︙ | ︙ | |||
24 25 26 27 28 29 30 | (see below) unless quoted. .IP "[2] \fBEvaluation.\fR" A command is evaluated in two steps. First, the Tcl interpreter breaks the command into \fIwords\fR and performs substitutions as described below. These substitutions are performed in the same way for all commands. | | | | | | 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 | (see below) unless quoted. .IP "[2] \fBEvaluation.\fR" A command is evaluated in two steps. First, the Tcl interpreter breaks the command into \fIwords\fR and performs substitutions as described below. These substitutions are performed in the same way for all commands. Secondly, the first word is used to locate a routine to carry out the command, and the remaining words of the command are passed to that routine. The routine is free to interpret each of its words in any way it likes, such as an integer, variable name, list, or Tcl script. Different commands interpret their words differently. .IP "[3] \fBWords.\fR" Words of a command are separated by white space (except for newlines, which are command separators). .IP "[4] \fBDouble quotes.\fR" |
| ︙ | ︙ |
Changes to doc/TclZlib.3.
| ︙ | ︙ | |||
84 85 86 87 88 89 90 | section \fBGZIP OPTIONS DICTIONARY\fR for details about the contents of this dictionary. .AP "unsigned int" initValue in The initial value for the checksum algorithm. .AP "unsigned char" *bytes in An array of bytes to run the checksum algorithm over, or NULL to get the recommended initial value for the checksum algorithm. | | | | | | 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 | section \fBGZIP OPTIONS DICTIONARY\fR for details about the contents of this dictionary. .AP "unsigned int" initValue in The initial value for the checksum algorithm. .AP "unsigned char" *bytes in An array of bytes to run the checksum algorithm over, or NULL to get the recommended initial value for the checksum algorithm. .AP 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_AUTO_LENGTH to get all remaining bytes from the stream's buffers. .AP Tcl_Obj *compDict in A byte array value that is the compression dictionary to use with the stream. Note that this is \fInot a Tcl dictionary\fR, and it is recommended that this only ever be used with streams that were created with their \fIformat\fR set to \fBTCL_ZLIB_FORMAT_ZLIB\fR because the other formats have no mechanism to indicate whether a compression dictionary was present other than to fail on decompression. |
| ︙ | ︙ |
Changes to doc/Tcl_Main.3.
| ︙ | ︙ | |||
185 186 187 188 189 190 191 192 193 194 195 196 | evaluated. In interactive mode, if an EOF or channel error is encountered on the standard input channel, then \fBTcl_Main\fR itself will evaluate the \fBexit\fR command after the main loop procedure (if any) returns. In non-interactive mode, after \fBTcl_Main\fR evaluates the startup script, and the main loop procedure (if any) returns, \fBTcl_Main\fR will also evaluate the \fBexit\fR command. .SH "SEE ALSO" tclsh(1), Tcl_GetStdChannel(3), Tcl_StandardChannels(3), Tcl_AppInit(3), exit(n), encoding(n) .SH KEYWORDS application-specific initialization, command-line arguments, main program | > > | 185 186 187 188 189 190 191 192 193 194 195 196 197 198 | evaluated. In interactive mode, if an EOF or channel error is encountered on the standard input channel, then \fBTcl_Main\fR itself will evaluate the \fBexit\fR command after the main loop procedure (if any) returns. In non-interactive mode, after \fBTcl_Main\fR evaluates the startup script, and the main loop procedure (if any) returns, \fBTcl_Main\fR will also evaluate the \fBexit\fR command. .PP This function can not be used in stub-enabled extensions. .SH "SEE ALSO" tclsh(1), Tcl_GetStdChannel(3), Tcl_StandardChannels(3), Tcl_AppInit(3), exit(n), encoding(n) .SH KEYWORDS application-specific initialization, command-line arguments, main program |
Changes to doc/Thread.3.
| ︙ | ︙ | |||
41 42 43 44 45 46 47 | int \fBTcl_JoinThread\fR(\fIid, result\fR) .SH ARGUMENTS .AS Tcl_CreateThreadProc proc out .AP Tcl_Condition *condPtr in A condition variable, which must be associated with a mutex lock. .AP Tcl_Mutex *mutexPtr in | > | > | | 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 | int \fBTcl_JoinThread\fR(\fIid, result\fR) .SH ARGUMENTS .AS Tcl_CreateThreadProc proc 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 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 a different block of storage with this key. .AP int *size in The size of the thread local storage block. This amount of data is allocated and initialized to zero the first time each thread calls \fBTcl_GetThreadData\fR. .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 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 int stackSize in The size of the stack given to the new thread. .AP int flags in Bitmask containing flags allowing the caller to modify behavior of the new thread. .AP int *result out |
| ︙ | ︙ | |||
136 137 138 139 140 141 142 | the \fBNotifier\fR manual page for more information on these procedures. .PP 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. | > | < > > > > | 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 | the \fBNotifier\fR manual page for more information on these procedures. .PP 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 \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. .PP A condition variable is used as a signaling mechanism: |
| ︙ | ︙ | |||
198 199 200 201 202 203 204 | .PP It should then be defined like this example, which just counts up to a given value and then finishes. .PP .CS static \fBTcl_ThreadCreateType\fR MyThreadImplFunc( | | | | 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 |
.PP
It should then be defined like this example, which just counts up to a given
value and then finishes.
.PP
.CS
static \fBTcl_ThreadCreateType\fR
MyThreadImplFunc(
void *clientData)
{
int i, limit = (int) clientData;
for (i=0 ; i<limit ; i++) {
/* doing nothing at all here */
}
\fBTCL_THREAD_CREATE_RETURN\fR;
}
.CE
.PP
To create the above thread, make it execute, and wait for it to finish, we
would do this:
.PP
.CS
int limit = 1000000000;
void *limitData = (void*)((intptr_t) limit);
Tcl_ThreadId id; \fI/* holds identity of thread created */\fR
int result;
if (\fBTcl_CreateThread\fR(&id, MyThreadImplFunc, limitData,
\fBTCL_THREAD_STACK_DEFAULT\fR,
\fBTCL_THREAD_JOINABLE\fR) != TCL_OK) {
\fI/* Thread did not create correctly */\fR
|
| ︙ | ︙ |
Changes to doc/ToUpper.3.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 | .BS .SH NAME Tcl_UniCharToUpper, Tcl_UniCharToLower, Tcl_UniCharToTitle, Tcl_UtfToUpper, Tcl_UtfToLower, Tcl_UtfToTitle \- routines for manipulating the case of Unicode characters and UTF-8 strings .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp | | | | | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 | .BS .SH NAME Tcl_UniCharToUpper, Tcl_UniCharToLower, Tcl_UniCharToTitle, Tcl_UtfToUpper, Tcl_UtfToLower, Tcl_UtfToTitle \- routines for manipulating the case of Unicode characters and UTF-8 strings .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp int \fBTcl_UniCharToUpper\fR(\fIch\fR) .sp int \fBTcl_UniCharToLower\fR(\fIch\fR) .sp int \fBTcl_UniCharToTitle\fR(\fIch\fR) .sp int \fBTcl_UtfToUpper\fR(\fIstr\fR) .sp int \fBTcl_UtfToLower\fR(\fIstr\fR) |
| ︙ | ︙ | |||
74 75 76 77 78 79 80 | \fBTcl_UtfToLower\fR is the same as \fBTcl_UtfToUpper\fR except it turns each character in the string into its lower-case equivalent. .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. | < < < < < < | 74 75 76 77 78 79 80 81 82 | \fBTcl_UtfToLower\fR is the same as \fBTcl_UtfToUpper\fR except it turns each character in the string into its lower-case equivalent. .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 KEYWORDS utf, unicode, toupper, tolower, totitle, case |
Changes to doc/TraceCmd.3.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 | .BS .SH NAME Tcl_CommandTraceInfo, Tcl_TraceCommand, Tcl_UntraceCommand \- monitor renames and deletes of a command .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp | | | | | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 | .BS .SH NAME Tcl_CommandTraceInfo, Tcl_TraceCommand, Tcl_UntraceCommand \- monitor renames and deletes of a command .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp void * \fBTcl_CommandTraceInfo(\fIinterp, cmdName, flags, proc, prevClientData\fB)\fR .sp int \fBTcl_TraceCommand(\fIinterp, cmdName, flags, proc, clientData\fB)\fR .sp void \fBTcl_UntraceCommand(\fIinterp, cmdName, flags, proc, clientData\fB)\fR .SH ARGUMENTS .AS Tcl_CommandTraceProc prevClientData .AP Tcl_Interp *interp in Interpreter containing the command. .AP "const char" *cmdName in Name of command. .AP int flags in OR'ed collection of the values \fBTCL_TRACE_RENAME\fR and \fBTCL_TRACE_DELETE\fR. .AP Tcl_CommandTraceProc *proc in Procedure to call when specified operations occur to \fIcmdName\fR. .AP void *clientData in Arbitrary argument to pass to \fIproc\fR. .AP void *prevClientData in If non-NULL, gives last value returned by \fBTcl_CommandTraceInfo\fR, so this call will return information about next trace. If NULL, this call will return information about first trace. .BE .SH DESCRIPTION .PP \fBTcl_TraceCommand\fR allows a C procedure to monitor operations |
| ︙ | ︙ | |||
61 62 63 64 65 66 67 | .PP Whenever one of the specified operations occurs to the command, \fIproc\fR will be invoked. It should have arguments and result that match the type \fBTcl_CommandTraceProc\fR: .PP .CS typedef void \fBTcl_CommandTraceProc\fR( | | | | 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 |
.PP
Whenever one of the specified operations occurs to the command,
\fIproc\fR will be invoked. It should have arguments and result that
match the type \fBTcl_CommandTraceProc\fR:
.PP
.CS
typedef void \fBTcl_CommandTraceProc\fR(
void *\fIclientData\fR,
Tcl_Interp *\fIinterp\fR,
const char *\fIoldName\fR,
const char *\fInewName\fR,
int \fIflags\fR);
.CE
.PP
The \fIclientData\fR and \fIinterp\fR parameters will have the same
values as those passed to \fBTcl_TraceCommand\fR when the trace was
created. \fIclientData\fR typically points to an application-specific
data structure that describes what to do when \fIproc\fR is invoked.
\fIOldName\fR gives the name of the command being renamed, and
\fInewName\fR gives the name that the command is being renamed to (or
NULL when the command is being deleted.)
\fIFlags\fR is an OR'ed combination of bits potentially providing
several pieces of information. One of the bits \fBTCL_TRACE_RENAME\fR and
\fBTCL_TRACE_DELETE\fR will be set in \fIflags\fR to indicate which
|
| ︙ | ︙ |
Changes to doc/TraceVar.3.
| ︙ | ︙ | |||
20 21 22 23 24 25 26 | int \fBTcl_TraceVar2(\fIinterp, name1, name2, flags, proc, clientData\fB)\fR .sp \fBTcl_UntraceVar(\fIinterp, varName, flags, proc, clientData\fB)\fR .sp \fBTcl_UntraceVar2(\fIinterp, name1, name2, flags, proc, clientData\fB)\fR .sp | | | | | | | 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 | int \fBTcl_TraceVar2(\fIinterp, name1, name2, flags, proc, clientData\fB)\fR .sp \fBTcl_UntraceVar(\fIinterp, varName, flags, proc, clientData\fB)\fR .sp \fBTcl_UntraceVar2(\fIinterp, name1, name2, flags, proc, clientData\fB)\fR .sp void * \fBTcl_VarTraceInfo(\fIinterp, varName, flags, proc, prevClientData\fB)\fR .sp void * \fBTcl_VarTraceInfo2(\fIinterp, name1, name2, flags, proc, prevClientData\fB)\fR .SH ARGUMENTS .AS void *prevClientData .AP Tcl_Interp *interp in Interpreter containing variable. .AP "const char" *varName in Name of variable. May refer to a scalar variable, to an array variable with no index, or to an array variable with a parenthesized index. .AP int flags in OR-ed combination of the values \fBTCL_TRACE_READS\fR, \fBTCL_TRACE_WRITES\fR, \fBTCL_TRACE_UNSETS\fR, \fBTCL_TRACE_ARRAY\fR, \fBTCL_GLOBAL_ONLY\fR, \fBTCL_NAMESPACE_ONLY\fR, \fBTCL_TRACE_RESULT_DYNAMIC\fR and \fBTCL_TRACE_RESULT_OBJECT\fR. Not all flags are used by all procedures. See below for more information. .AP Tcl_VarTraceProc *proc in Procedure to invoke whenever one of the traced operations occurs. .AP void *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 If non-NULL, gives last value returned by \fBTcl_VarTraceInfo\fR or \fBTcl_VarTraceInfo2\fR, so this call will return information about next trace. If NULL, this call will return information about first trace. .BE .SH DESCRIPTION .PP |
| ︙ | ︙ | |||
103 104 105 106 107 108 109 | This gives the trace procedure a chance to update the array before array names or array get is called. Note that this is called before an array set, but that will trigger write traces. .TP \fBTCL_TRACE_RESULT_DYNAMIC\fR The result of invoking the \fIproc\fR is a dynamically allocated string that will be released by the Tcl library via a call to | | | | | 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 |
This gives the trace procedure a chance to update the array before
array names or array get is called. Note that this is called
before an array set, but that will trigger write traces.
.TP
\fBTCL_TRACE_RESULT_DYNAMIC\fR
The result of invoking the \fIproc\fR is a dynamically allocated
string that will be released by the Tcl library via a call to
\fBTcl_Free\fR. Must not be specified at the same time as
\fBTCL_TRACE_RESULT_OBJECT\fR.
.TP
\fBTCL_TRACE_RESULT_OBJECT\fR
The result of invoking the \fIproc\fR is a Tcl_Obj* (cast to a char*)
with a reference count of at least one. The ownership of that
reference will be transferred to the Tcl core for release (when the
core has finished with it) via a call to \fBTcl_DecrRefCount\fR. Must
not be specified at the same time as \fBTCL_TRACE_RESULT_DYNAMIC\fR.
.PP
Whenever one of the specified operations occurs on the variable,
\fIproc\fR will be invoked.
It should have arguments and result that match the type
\fBTcl_VarTraceProc\fR:
.PP
.CS
typedef char *\fBTcl_VarTraceProc\fR(
void *\fIclientData\fR,
Tcl_Interp *\fIinterp\fR,
char *\fIname1\fR,
char *\fIname2\fR,
int \fIflags\fR);
.CE
.PP
The \fIclientData\fR and \fIinterp\fR parameters will
have the same values as those passed to \fBTcl_TraceVar\fR when the
trace was created.
\fIclientData\fR typically points to an application-specific
data structure that describes what to do when \fIproc\fR
is invoked.
\fIName1\fR and \fIname2\fR give the name of the traced variable
in the normal two-part form (see the description of \fBTcl_TraceVar2\fR
below for details).
\fIFlags\fR is an OR-ed combination of bits providing several
pieces of information.
|
| ︙ | ︙ | |||
308 309 310 311 312 313 314 | successful completion. If \fIproc\fR returns a non-NULL value it signifies that an error occurred. The return value must be a pointer to a static character string containing an error message, unless (\fIexactly\fR one of) the \fBTCL_TRACE_RESULT_DYNAMIC\fR and \fBTCL_TRACE_RESULT_OBJECT\fR flags is set, which specify that the result is | | | | | | | 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 | successful completion. If \fIproc\fR returns a non-NULL value it signifies that an error occurred. The return value must be a pointer to a static character string containing an error message, unless (\fIexactly\fR one of) the \fBTCL_TRACE_RESULT_DYNAMIC\fR and \fBTCL_TRACE_RESULT_OBJECT\fR flags is set, which specify that the result is either a dynamic string (to be released with \fBTcl_Free\fR) or a Tcl_Obj* (cast to char* and to be released with \fBTcl_DecrRefCount\fR) containing the error message. If a trace procedure returns an error, no further traces are invoked for the access and the traced access aborts with the given message. Trace procedures can use this facility to make variables read-only, for example (but note that the value of the variable will already have been modified before the trace procedure is called, so the trace procedure will have to restore the correct value). .PP The return value from \fIproc\fR is only used during read and write tracing. During unset traces, the return value is ignored and all relevant trace procedures will always be invoked. .SH "RESTRICTIONS" .PP A trace procedure can be called at any time, even when there are partially formed results stored in the interpreter. If the trace procedure does anything that could damage this result (such as calling \fBTcl_Eval\fR) then it must use the \fBTcl_SaveInterpState\fR and related routines to save and restore the original state of the interpreter before it returns. .SH "UNDEFINED VARIABLES" .PP It is legal to set a trace on an undefined variable. The variable will still appear to be undefined until the first time its value is set. If an undefined variable is traced and then unset, the unset will fail with an error |
| ︙ | ︙ |
Changes to doc/Utf.3.
| ︙ | ︙ | |||
27 28 29 30 31 32 33 | Tcl_UniChar * \fBTcl_UtfToUniCharDString\fR(\fIsrc, length, dsPtr\fR) .sp int \fBTcl_UniCharLen\fR(\fIuniStr\fR) .sp int | | | | | | | | 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 | Tcl_UniChar * \fBTcl_UtfToUniCharDString\fR(\fIsrc, length, dsPtr\fR) .sp int \fBTcl_UniCharLen\fR(\fIuniStr\fR) .sp int \fBTcl_UniCharNcmp\fR(\fIucs, uct, uniLength\fR) .sp int \fBTcl_UniCharNcasecmp\fR(\fIucs, uct, uniLength\fR) .sp int \fBTcl_UniCharCaseMatch\fR(\fIuniStr, uniPattern, nocase\fR) .sp int \fBTcl_UtfNcmp\fR(\fIcs, ct, length\fR) .sp int \fBTcl_UtfNcasecmp\fR(\fIcs, ct, length\fR) .sp int \fBTcl_UtfCharComplete\fR(\fIsrc, length\fR) .sp int \fBTcl_NumUtfChars\fR(\fIsrc, length\fR) .sp const char * \fBTcl_UtfFindFirst\fR(\fIsrc, ch\fR) .sp const char * \fBTcl_UtfFindLast\fR(\fIsrc, ch\fR) .sp const char * \fBTcl_UtfNext\fR(\fIsrc\fR) .sp const char * \fBTcl_UtfPrev\fR(\fIsrc, start\fR) .sp int \fBTcl_UniCharAtIndex\fR(\fIsrc, index\fR) .sp const char * \fBTcl_UtfAtIndex\fR(\fIsrc, index\fR) .sp size_t \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 \fBTCL_UTF_MAX\fR bytes are stored in the buffer. .AP int ch in |
| ︙ | ︙ | |||
90 91 92 93 94 95 96 | A null-terminated Unicode string. .AP "const Tcl_UniChar" *ucs in A null-terminated Unicode string. .AP "const Tcl_UniChar" *uct in A null-terminated Unicode string. .AP "const Tcl_UniChar" *uniPattern in A null-terminated Unicode string. | | | | | < < < | | | | | > > > > > > > | 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 | A null-terminated Unicode string. .AP "const Tcl_UniChar" *ucs in A null-terminated Unicode string. .AP "const Tcl_UniChar" *uct in A null-terminated Unicode string. .AP "const Tcl_UniChar" *uniPattern in A null-terminated Unicode string. .AP size_t length in The length of the UTF-8 string in bytes (not UTF-8 characters). If TCL_AUTO_LENGTH, all bytes up to the first null byte are used. .AP size_t uniLength in The length of the Unicode string in characters. .AP "Tcl_DString" *dsPtr in/out A pointer to a previously initialized \fBTcl_DString\fR. .AP "const char" *start in Pointer to the beginning of a UTF-8 string. .AP size_t 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 \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 characters. An 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 character \fIch\fR as a UTF-8 string in starting at \fIbuf\fR. The return value is the number of bytes stored in \fIbuf\fR. If ch is a high surrogate (range U+D800 - U+DBFF), then the return value will be 1 and a single byte in the range 0xF0 - 0xF4 will be stored. If you still want to produce UTF-8 output for it (even though knowing it's an illegal code-point on its own), just call \fBTcl_UniCharToUtf\fR again specifying ch = -1. .PP \fBTcl_UtfToUniChar\fR reads one UTF-8 character starting at \fIsrc\fR and stores it as a Tcl_UniChar in \fI*chPtr\fR. The return value is the number of bytes read from \fIsrc\fR. The caller must ensure that the source buffer is long enough such that this routine does not run off the end and dereference non-existent or random memory; if the source buffer is known to be null-terminated, this will not happen. If the input is a byte in the range 0x80 - 0x9F, \fBTcl_UtfToUniChar\fR assumes the cp1252 encoding, stores the corresponding Tcl_UniChar in \fI*chPtr\fR and returns 1. If the input is otherwise not in proper UTF-8 format, \fBTcl_UtfToUniChar\fR will store the first byte of \fIsrc\fR in \fI*chPtr\fR as a Tcl_UniChar between 0x0000 and 0x00ff and return 1. .PP \fBTcl_UniCharToUtfDString\fR converts the given Unicode string to UTF-8, storing the result in a previously initialized \fBTcl_DString\fR. You must specify \fIuniLength\fR, the length of the given Unicode string. |
| ︙ | ︙ | |||
165 166 167 168 169 170 171 | \fBTcl_UniCharLen\fR corresponds to \fBstrlen\fR for Unicode characters. It accepts a null-terminated Unicode string and returns the number of Unicode characters (not bytes) in that string. .PP \fBTcl_UniCharNcmp\fR and \fBTcl_UniCharNcasecmp\fR correspond to \fBstrncmp\fR and \fBstrncasecmp\fR, respectively, for Unicode characters. They accept two null-terminated Unicode strings and the number of characters | | | | | | | 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 | \fBTcl_UniCharLen\fR corresponds to \fBstrlen\fR for Unicode characters. It accepts a null-terminated Unicode string and returns the number of Unicode characters (not bytes) in that string. .PP \fBTcl_UniCharNcmp\fR and \fBTcl_UniCharNcasecmp\fR correspond to \fBstrncmp\fR and \fBstrncasecmp\fR, respectively, for Unicode characters. They accept two null-terminated Unicode strings and the number of characters to compare. Both strings are assumed to be at least \fIuniLength\fR characters long. \fBTcl_UniCharNcmp\fR compares the two strings character-by-character according to the Unicode character ordering. It returns an integer greater than, equal to, or less than 0 if the first string is greater than, equal to, or less than the second string respectively. \fBTcl_UniCharNcasecmp\fR is the Unicode case insensitive version. .PP \fBTcl_UniCharCaseMatch\fR is the Unicode equivalent to \fBTcl_StringCaseMatch\fR. It accepts a null-terminated Unicode string, a Unicode pattern, and a boolean value specifying whether the match should be case sensitive and returns whether the string matches the pattern. .PP \fBTcl_UtfNcmp\fR corresponds to \fBstrncmp\fR for UTF-8 strings. It accepts two null-terminated UTF-8 strings and the number of characters to compare. (Both strings are assumed to be at least \fIlength\fR characters long.) \fBTcl_UtfNcmp\fR compares the two strings character-by-character according to the Unicode character ordering. It returns an integer greater than, equal to, or less than 0 if the first string is greater than, equal to, or less than the second string respectively. .PP \fBTcl_UtfNcasecmp\fR corresponds to \fBstrncasecmp\fR for UTF-8 strings. It is similar to \fBTcl_UtfNcmp\fR except comparisons ignore 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. .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 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 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 |
| ︙ | ︙ | |||
231 232 233 234 235 236 237 | the start of the UTF-8 string. If \fIsrc\fR was already at \fIstart\fR, the return value will be \fIstart\fR. .PP \fBTcl_UniCharAtIndex\fR corresponds to a C string array dereference or 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 | | | | 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 | the start of the UTF-8 string. If \fIsrc\fR was already at \fIstart\fR, the return value will be \fIstart\fR. .PP \fBTcl_UniCharAtIndex\fR corresponds to a C string array dereference or 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. .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_UtfNext\fR \fIindex\fR times. If \fIindex\fR is TCL_INDEX_NONE, 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 \fBTCL_UTF_MAX\fR bytes are stored in the buffer. \fBTcl_UtfBackslash\fR modifies \fI*readPtr\fR to contain the number |
| ︙ | ︙ |
Added doc/abstract.n.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 |
'\"
'\" 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:
|
Changes to doc/append.n.
| ︙ | ︙ | |||
16 17 18 19 20 21 22 23 24 25 26 27 28 29 | .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. 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, .QW "\fBappend a $b\fR" is much more efficient than | > > > > > | 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 | .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, .QW "\fBappend a $b\fR" is much more efficient than |
| ︙ | ︙ | |||
40 41 42 43 44 45 46 | 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 | | | > | | 45 46 47 48 49 50 51 52 53 54 55 | 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: |
Changes to doc/array.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1993-1994 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | '\" '\" Copyright (c) 1993-1994 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH array n 8.7 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME array \- Manipulate array variables .SH SYNOPSIS \fBarray \fIoption arrayName\fR ?\fIarg arg ...\fR? |
| ︙ | ︙ | |||
31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 | \fISearchId\fR indicates which search on \fIarrayName\fR to check, and must have been the return value from a previous 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 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 been the return value from a previous invocation of \fBarray startsearch\fR. Returns an empty string. .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 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. If \fIpattern\fR is not specified, then all of the elements of the array are included in the result. | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 |
\fISearchId\fR indicates which search on \fIarrayName\fR to
check, and must have been the return value from a previous
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
been the return value from a previous invocation of
\fBarray startsearch\fR. Returns an empty string.
.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.
If \fIpattern\fR is not specified, then all of the elements of the
array are included in the result.
|
| ︙ | ︙ | |||
181 182 183 184 185 186 187 |
number of buckets with 10 or more entries: 0
average search distance for entry: 1.2
.CE
.SH "SEE ALSO"
list(n), string(n), variable(n), trace(n), foreach(n)
.SH KEYWORDS
array, element names, search
| > > > > | 237 238 239 240 241 242 243 244 245 246 247 |
number of buckets with 10 or more entries: 0
average search distance for entry: 1.2
.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:
|
Added doc/callback.n.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 |
'\"
'\" 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:
|
Changes to doc/cd.n.
| ︙ | ︙ | |||
37 38 39 40 41 42 43 | .CS \fBcd\fR ../lib .CE .SH "SEE ALSO" filename(n), glob(n), pwd(n) .SH KEYWORDS working directory | > > > > | 37 38 39 40 41 42 43 44 45 46 47 | .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: |
Added doc/classvariable.n.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 |
'\"
'\" 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:
|
Changes to doc/clock.n.
| ︙ | ︙ | |||
448 449 450 451 452 453 454 455 456 457 458 459 460 461 | If a format string lacks a \fB%z\fR or \fB%Z\fR format group, it is possible for the time to be ambiguous because it appears twice 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.) .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, receives an abbreviation (\fIe.g.,\fR \fBMon\fR) for the day | > > > > > > > > > > > > > | 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 | If a format string lacks a \fB%z\fR or \fB%Z\fR format group, it is possible for the time to be ambiguous because it appears twice 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, receives an abbreviation (\fIe.g.,\fR \fBMon\fR) for the day |
| ︙ | ︙ | |||
869 870 871 872 873 874 875 | time. This is useful for determining the time on a specific day or doing other date-relative conversions. .PP The \fIinputString\fR argument consists of zero or more specifications of the following form: .TP \fItime\fR | > | > > | | > | | | | | | > | > | 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 | time. This is useful for determining the time on a specific day or doing other date-relative conversions. .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 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" , and .QW "\fIdd\fB-\fImonthname\fB-\fR?\fICC\fR?\fIyy\fR" . The default year is the current year. If the year is less than 100, we treat the years 00-68 as 2000-2068 and the years 69-99 as 1969-1999. Not all platforms can represent the years 38-70, so an error may result if these years are used. .TP \fIISO 8601 point-in-time\fR . An ISO 8601 point-in-time specification, such as .QW \fICCyymmdd\fBT\fIhhmmss\fR, where \fBT\fR is the literal .QW T , .QW "\fICCyymmdd hhmmss\fR" , or .QW \fICCyymmdd\fBT\fIhh\fB:\fImm\fB:\fIss\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. .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. These modifiers may also be specified: \fBtomorrow\fR, \fByesterday\fR, \fBtoday\fR, \fBnow\fR, |
| ︙ | ︙ |
Added doc/cookiejar.n.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 |
'\"
'\" 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:
|
Changes to doc/coroutine.n.
| ︙ | ︙ | |||
10 11 12 13 14 15 16 | '\" Note: do not modify the .SH NAME line immediately below! .SH NAME coroutine, yield, yieldto \- Create and produce values from coroutines .SH SYNOPSIS .nf \fBcoroutine \fIname command\fR ?\fIarg...\fR? \fByield\fR ?\fIvalue\fR? | < > | > > > | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 | '\" Note: do not modify the .SH NAME line immediately below! .SH NAME coroutine, yield, yieldto \- 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 |
| ︙ | ︙ | |||
35 36 37 38 39 40 41 | 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 | < | | < > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 |
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 {} {
|
| ︙ | ︙ | |||
134 135 136 137 138 139 140 |
}
}} allNumbers
for {set i 1} {$i <= 20} {incr i} {
puts "prime#$i = [\fIeratosthenes\fR]"
}
.CE
.PP
| < | > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > | 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 |
}
}} 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} {
|
| ︙ | ︙ |
Changes to doc/define.n.
1 | '\" | | | 1 2 3 4 5 6 7 8 9 | '\" '\" 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 |
| ︙ | ︙ | |||
30 31 32 33 34 35 36 | 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. | > > > > | > > > > > > > > > > > > > > > > > > > > > | < | < > | < < > | 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 | 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 |
| ︙ | ︙ | |||
76 77 78 79 80 81 82 | \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. | < < < < < < < < < < < < < > > > > > > > > > > > > > > > > | | > > > > | < > | | > > | < < < | < | > | < > > | | < < < > > > > > > > | > > | 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 | \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 . |
| ︙ | ︙ | |||
155 156 157 158 159 160 161 162 163 164 | .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 .RE .TP \fBsuperclass\fR ?\fI\-slotOperation\fR? ?\fIclassName ...\fR? | > > > > > < > < < < < > > | > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | < < < < < < < < < < < < < < < < < < < < < < < < < < > > > > > > > | | > > > > > > > > > > > > > < > < < < < < < < < < < > | < | > > | > > > > > > > > | < > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | < > > > > > > > > | | | | | | | < > < < > | | | > > > > > > > | > > > > > > > > > > > > > > > > > > > < > | > > > > > > > > > > > > > > > > > | | | 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 |
.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"
}
|
| ︙ | ︙ | |||
405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 |
}
\fBoo::objdefine\fR inst {
\fBmixin -append\fR B
}
inst m1 \fI\(-> prints "red brick"\fR
inst m2 \fI\(-> prints "blue brick"\fR
.CE
.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:
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 |
}
\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:
|
Changes to doc/dict.n.
| ︙ | ︙ | |||
23 24 25 26 27 28 29 30 31 32 33 34 35 36 | \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. .TP \fBdict create \fR?\fIkey value ...\fR? . Return 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 | > > > > > | 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 | \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 \fIdictionaryVarable\fR indicates an element that does not exist of an array that has a default value set, the default value and will be used as the value of the dictionary prior to the appending operation. .VE TIP508 .TP \fBdict create \fR?\fIkey value ...\fR? . Return a new dictionary that contains each of the key/value mappings listed as arguments (keys and values alternating, with each key being followed by its associated value.) .TP |
| ︙ | ︙ | |||
110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 | elements in a manner similar to \fBarray get\fR. That is, the first element of each pair would be the key and the second element would be the value for that key. .PP It is an error to attempt to retrieve a value for a key that is not present in the dictionary. .RE .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. .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 | > > > > > > > > > > > > > > > > > > > > > | 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 | elements in a manner similar to \fBarray get\fR. That is, the first element of each pair would be the key and the second element would be the value for that key. .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 \fIdictionaryVarable\fR indicates an element that does not exist of an array that has a default value set, the default value and will be used as the value of the dictionary prior to the incrementing operation. .VE TIP508 .TP \fBdict info \fIdictionaryValue\fR . This returns information (intended for display to people) about the 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 |
| ︙ | ︙ | |||
145 146 147 148 149 150 151 152 153 154 155 156 157 158 |
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.
.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,
| > > > > > | 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 |
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 \fIdictionaryVarable\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,
|
| ︙ | ︙ | |||
202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 | \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. .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. .TP \fBdict update \fIdictionaryVariable key varName \fR?\fIkey varName ...\fR? \fIbody\fR . Execute the Tcl script in \fIbody\fR with the value for each \fIkey\fR (as found by reading the dictionary value in \fIdictionaryVariable\fR) mapped to the variable \fIvarName\fR. There may be multiple \fIkey\fR/\fIvarName\fR pairs. If a \fIkey\fR does not have a mapping, that corresponds to an unset \fIvarName\fR. When \fIbody\fR terminates, any changes made to the \fIvarName\fRs is reflected back to the dictionary within \fIdictionaryVariable\fR (unless \fIdictionaryVariable\fR itself becomes unreadable, when all updates are silently discarded), even if the result of \fIbody\fR is an error or some other kind of exceptional exit. The result of \fBdict update\fR is (unless some kind of error occurs) the result of the evaluation of \fIbody\fR. .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 this, the variables set by \fBdict update\fR will continue to exist after the command finishes (unless explicitly \fBunset\fR). | > > > > > > > > > > > > > > > | 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 | \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 \fIdictionaryVarable\fR indicates an element that does not exist of an array that has a default value set, the default value and will be used as the value of the dictionary prior to the value insert/update operation. .VE TIP508 .TP \fBdict size \fIdictionaryValue\fR . Return the number of key/value mappings in the given dictionary value. .TP \fBdict unset \fIdictionaryVariable key \fR?\fIkey ...\fR? . This operation (the companion to \fBdict set\fR) takes the name of a variable containing a dictionary value and places an updated dictionary value in that variable that does not contain a mapping for the given key. Where multiple keys are present, this describes a path through nested dictionaries to the mapping to remove. At least one key must be specified, but the last key on the key-path need not exist. All other components on the path must exist. The updated dictionary value is returned. .VS TIP508 If \fIdictionaryVarable\fR indicates an element that does not exist of an array that has a default value set, the default value and will be used as the value of the dictionary prior to the value remove operation. .VE TIP508 .TP \fBdict update \fIdictionaryVariable key varName \fR?\fIkey varName ...\fR? \fIbody\fR . Execute the Tcl script in \fIbody\fR with the value for each \fIkey\fR (as found by reading the dictionary value in \fIdictionaryVariable\fR) mapped to the variable \fIvarName\fR. There may be multiple \fIkey\fR/\fIvarName\fR pairs. If a \fIkey\fR does not have a mapping, that corresponds to an unset \fIvarName\fR. When \fIbody\fR terminates, any changes made to the \fIvarName\fRs is reflected back to the dictionary within \fIdictionaryVariable\fR (unless \fIdictionaryVariable\fR itself becomes unreadable, when all updates are silently discarded), even if the result of \fIbody\fR is an error or some other kind of exceptional exit. The result of \fBdict update\fR is (unless some kind of error occurs) the result of the evaluation of \fIbody\fR. .VS TIP508 If \fIdictionaryVarable\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 this, the variables set by \fBdict update\fR will continue to exist after the command finishes (unless explicitly \fBunset\fR). |
| ︙ | ︙ | |||
266 267 268 269 270 271 272 273 274 275 276 277 278 279 | for the execution of \fIbody\fR. As with \fBdict update\fR, making \fIdictionaryVariable\fR unreadable will make the updates to the dictionary be discarded, and this also happens if the contents of \fIdictionaryVariable\fR are adjusted so that the chain of dictionaries no longer exists. The result of \fBdict with\fR is (unless some kind of error occurs) the result of the evaluation of \fIbody\fR. .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 this, the variables set by \fBdict with\fR will continue to exist after the command finishes (unless explicitly \fBunset\fR). | > > > > > | 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 | for the execution of \fIbody\fR. As with \fBdict update\fR, making \fIdictionaryVariable\fR unreadable will make the updates to the dictionary be discarded, and this also happens if the contents of \fIdictionaryVariable\fR are adjusted so that the chain of dictionaries no longer exists. The result of \fBdict with\fR is (unless some kind of error occurs) the result of the evaluation of \fIbody\fR. .VS TIP508 If \fIdictionaryVarable\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 this, the variables set by \fBdict with\fR will continue to exist after the command finishes (unless explicitly \fBunset\fR). |
| ︙ | ︙ |
Changes to doc/eof.n.
| ︙ | ︙ | |||
55 56 57 58 59 60 61 |
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
| > > > > | 55 56 57 58 59 60 61 62 63 64 65 |
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:
|
Changes to doc/exec.n.
| ︙ | ︙ | |||
212 213 214 215 216 217 218 219 220 221 222 223 224 225 | .QW \fB@\0\fIfileId\fR notation, does not work. When reading from a socket, a 16-bit DOS application will hang and a 32-bit application will return immediately with end-of-file. When either type of application writes to a socket, the information is instead sent to the console, if one is present, or is discarded. .RS .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. .PP Either forward or backward slashes are accepted as path separators for | > > > > > > > > > > > > > | 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 | .QW \fB@\0\fIfileId\fR notation, does not work. When reading from a socket, a 16-bit DOS application will hang and a 32-bit application will return immediately with end-of-file. When either type of application writes to a socket, the information is instead sent to the console, if one is present, or is discarded. .RS .PP Note that the current escape resp. quoting of arguments for windows works only with executables using CommandLineToArgv, CRT-library or similar, as well as 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 processor (\fBcmd.exe /c\fR), because this causes truncation of command-line (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. .PP Either forward or backward slashes are accepted as path separators for |
| ︙ | ︙ | |||
405 406 407 408 409 410 411 412 413 414 415 416 417 418 | .CS \fBexec\fR cmp.bat somefile.c -o somefile .CE .PP With the file \fIcmp.bat\fR looking something like: .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 | > > > > | 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 | .CS \fBexec\fR cmp.bat somefile.c -o somefile .CE .PP With the file \fIcmp.bat\fR looking something like: .PP .CS @gcc %* .CE or like another variant using single parameters: .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 |
| ︙ | ︙ |
Changes to doc/exit.n.
| ︙ | ︙ | |||
45 46 47 48 49 50 51 |
\fBexit\fR 2
}
.CE
.SH "SEE ALSO"
exec(n)
.SH KEYWORDS
abort, exit, process
| > > > > | 45 46 47 48 49 50 51 52 53 54 55 |
\fBexit\fR 2
}
.CE
.SH "SEE ALSO"
exec(n)
.SH KEYWORDS
abort, exit, process
'\" Local Variables:
'\" mode: nroff
'\" fill-column: 78
'\" End:
|
Changes to doc/expr.n.
| ︙ | ︙ | |||
91 92 93 94 95 96 97 | \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. .PP .CS | | | 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 |
\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.
.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
.SS OPERATORS
.PP
|
| ︙ | ︙ | |||
120 121 122 123 124 125 126 | . 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. .TP 20 \fB**\fR . | | > | 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 | . 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. .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. .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. .RS |
| ︙ | ︙ | |||
183 184 185 186 187 188 189 | \fB|\fR . Bit-wise OR. Valid for integer operands. .TP 20 \fB&&\fR . Logical AND. If both operands are true, the result is 1, or 0 otherwise. | | > > > > > | > > | 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 |
\fB|\fR
.
Bit-wise OR. Valid for integer operands.
.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
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
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
.PP
.CS
\fBexpr\fR {4*2 < 7}
.CE
.PP
is 0, while the value of
.PP
|
| ︙ | ︙ | |||
330 331 332 333 334 335 336 | 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. .PP In the following example, the value of the expression is 11 because the Tcl parser first | | > > > | > > < | | > > > > > > > > > > > > > > > > > > > > > > | 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 |
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.
.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.
.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.
.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.
.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
the varying part must itself be evaluated as a separate expression. Thus, in
this example the result is 20 and the outer expression benefits from fully
cached bytecode compilation.
.PP
.CS
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.
.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
Define a procedure that computes an
.QW interesting
mathematical function:
|
| ︙ | ︙ |
Changes to doc/fblocked.n.
| ︙ | ︙ | |||
61 62 63 64 65 66 67 | 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 | > > > > | 61 62 63 64 65 66 67 68 69 70 71 | 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: |
Changes to doc/file.n.
| ︙ | ︙ | |||
428 429 430 431 432 433 434 435 436 437 438 439 440 441 | \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, \fBfile tail a/b\fR, \fBfile tail a/b/\fR and \fBfile tail b\fR all return \fBb\fR. .TP \fBfile tempfile\fR ?\fInameVar\fR? ?\fItemplate\fR? '\" TIP #210 .VS 8.6 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 | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 | \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, \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 .VS 8.6 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 |
| ︙ | ︙ |
Changes to doc/fileevent.n.
| ︙ | ︙ | |||
150 151 152 153 154 155 156 | \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. | > > > > | 150 151 152 153 154 155 156 157 158 159 160 | \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: |
Changes to doc/filename.n.
| ︙ | ︙ | |||
172 173 174 175 176 177 178 | .QW .....abc is illegal. .SH "SEE ALSO" file(n), glob(n) .SH KEYWORDS current directory, absolute file name, relative file name, volume-relative file name, portability | > > > > | 172 173 174 175 176 177 178 179 180 181 182 | .QW .....abc is illegal. .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: |
Changes to doc/flush.n.
| ︙ | ︙ | |||
39 40 41 42 43 44 45 | 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 | > > > > | 39 40 41 42 43 44 45 46 47 48 49 | 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: |
Changes to doc/foreach.n.
| ︙ | ︙ | |||
98 99 100 101 102 103 104 | .CE .SH "SEE ALSO" for(n), while(n), break(n), continue(n) .SH KEYWORDS foreach, iteration, list, loop | > > > > | 98 99 100 101 102 103 104 105 106 107 108 | .CE .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: |
Changes to doc/global.n.
| ︙ | ︙ | |||
52 53 54 55 56 57 58 |
append accumulator $string \en
}
.CE
.SH "SEE ALSO"
namespace(n), upvar(n), variable(n)
.SH KEYWORDS
global, namespace, procedure, variable
| > > > > | 52 53 54 55 56 57 58 59 60 61 62 |
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:
|
Changes to doc/history.n.
| ︙ | ︙ | |||
96 97 98 99 100 101 102 | is modified to eliminate the history command and replace it with the result of the history command. 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 | > > > > | 96 97 98 99 100 101 102 103 104 105 106 | is modified to eliminate the history command and replace it with the result of the history command. 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: |
Changes to doc/http.n.
1 2 3 4 5 6 7 8 | '\" '\" Copyright (c) 1995-1997 Sun Microsystems, Inc. '\" 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. '\" | | | | > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 | '\" '\" Copyright (c) 1995-1997 Sun Microsystems, Inc. '\" 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" .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.8\fR? .\" See Also -useragent option documentation in body! .sp \fB::http::config\fR ?\fI\-option value\fR ...? .sp \fB::http::geturl \fIurl\fR ?\fI\-option value\fR ...? .sp \fB::http::formatQuery\fR \fIkey value\fR ?\fIkey value\fR ...? .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 .sp |
| ︙ | ︙ | |||
40 41 42 43 44 45 46 47 48 49 50 51 | .sp \fB::http::error \fItoken\fR .sp \fB::http::cleanup \fItoken\fR .sp \fB::http::register \fIproto port command\fR .sp \fB::http::unregister \fIproto\fR .BE .SH DESCRIPTION .PP The \fBhttp\fR package provides the client side of the HTTP/1.1 | > > | | 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 | .sp \fB::http::error \fItoken\fR .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. 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 additional HTTP transport protocols, such as HTTPS, by providing a custom \fBsocket\fR command, via \fB::http::register\fR. |
| ︙ | ︙ | |||
90 91 92 93 94 95 96 97 98 99 100 101 102 103 | \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 comma-separated list of mime type patterns that you are willing to receive. For example, .QW "image/gif, image/jpeg, text/*" . .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 | > > > > > > > > > > > > > > > > > > > > > > | 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 | \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 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 |
| ︙ | ︙ | |||
111 112 113 114 115 116 117 118 119 120 121 | 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 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\-urlencoding\fR \fIencoding\fR . The \fIencoding\fR used for creating the x-url-encoded URLs with | > > > > > > > > > > > > > | | | | > > > > > > > > > > | > > > > | 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 |
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
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
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.
.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.8.12 Tcl/8.6.8\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.
.RE
.TP
\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;
|
| ︙ | ︙ | |||
223 224 225 226 227 228 229 | .CS Pragma: no-cache .CE .RE .TP \fB\-keepalive\fR \fIboolean\fR . | | | 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 | .CS Pragma: no-cache .CE .RE .TP \fB\-keepalive\fR \fIboolean\fR . If boolean \fBtrue\fR, 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. |
| ︙ | ︙ | |||
329 330 331 332 333 334 335 336 337 338 339 340 341 342 | \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::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. .TP | > > > > > | 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 | \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. .TP |
| ︙ | ︙ | |||
410 411 412 413 414 415 416 417 418 419 420 421 422 423 | package require tls ::http::register https 443 ::tls::socket set token [::http::geturl https://my.secure.site/] .CE .RE .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 | > > > > > > > > > > > | 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 | package require tls ::http::register https 443 ::tls::socket 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 |
| ︙ | ︙ | |||
500 501 502 503 504 505 506 507 508 509 510 511 512 513 | 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 \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 . | > > > > > > > > | 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 | 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 . |
| ︙ | ︙ | |||
598 599 600 601 602 603 604 605 606 607 608 609 610 611 |
.
A copy of the \fBContent-Type\fR meta-data value.
.TP
\fBurl\fR
.
The requested URL.
.RE
.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} } {
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 |
.
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} } {
|
| ︙ | ︙ |
Added doc/idna.n.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 | '\" '\" 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: |
Changes to doc/incr.n.
| ︙ | ︙ | |||
23 24 25 26 27 28 29 30 31 32 33 34 35 36 | 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 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. .SH EXAMPLES .PP Add one to the contents of the variable \fIx\fR: .PP .CS \fBincr\fR x .CE | > > > > > | 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 | 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 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 .SH EXAMPLES .PP Add one to the contents of the variable \fIx\fR: .PP .CS \fBincr\fR x .CE |
| ︙ | ︙ | |||
55 56 57 58 59 60 61 | .CS \fBincr\fR x 0 .CE .SH "SEE ALSO" expr(n), set(n) .SH KEYWORDS add, increment, variable, value | > > > > | 60 61 62 63 64 65 66 67 68 69 70 | .CS \fBincr\fR x 0 .CE .SH "SEE ALSO" expr(n), set(n) .SH KEYWORDS add, increment, variable, value .\" Local variables: .\" mode: nroff .\" fill-column: 78 .\" End: |
Changes to doc/info.n.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 | '\" 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 | | | < < | < < | < < > | | < | > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > < | < < < | < < < < < < < | < < > | < < | < < | | < < < > | | | < | | < | | < < > | | | | | | | | < | < | | > | | | < | < < < > | < < < | < < < < | < | < < | | | > | | | < | < | | | | | | < < < < < < | | < | | < < < | < | | > > | | | | < | | | | | | | | | | < | < | < < | < > | < | | < < | | < < < | | < < | < | < < > | | | < < | < | < > | | < | | < < | < < < | | | < < | | < < | | | | < | | | < | | | < < | < | < < < < < > | < | | < < < | < < < > | > > > > | > > > > < < > < < > > > > > > > > > > > > > > > > > > | < > < < > < < > < < > < < > | < > > | > > | < > > | > > | | > > > > > > > > > > > > > > > > > > > > | > < > < < > < < > < < > < | < > > > > > < < > | > > > > | > > > > < < > | > > > > > > > > > > > | < > < < > < < > < < > < < > < < > < < > < < > < < > < < > | < > > | > > | < > > | > > | | > > > > > > > > > > > > > > > > > > > > | > < > < < > < < > < | < > > > > | < > < | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 |
'\" 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
.SH SYNOPSIS
\fBinfo \fIoption \fR?\fIarg arg ...\fR?
.BE
.SH DESCRIPTION
.PP
Available commands:
.TP
\fBinfo args \fIprocname\fR
.
Returns the names of the parameters to the procedure named \fIprocname\fR.
.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.
.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 \fBslave\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
.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.
.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
.QW "foo [bar [x]]" ,
only
.QW x
is seen by \fBinfo frame\fR invoked within
.QW x .
.PP
The dictionary may contain the following keys:
.TP
\fBtype\fR
.
Always present. Possible 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
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.
.TP
\fBeval\fR\0\0\0\0\0\0\0\0
.
The body of a script provided to \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.
.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.
.TP
\fBfile\fR
.
For type \fBsource\fR, provides the normalized path of the file that contains
the command.
.TP
\fBcmd\fR
.
The command before substitutions were performed.
.TP
\fBproc\fR
.
For type \fBprod\fR, the name of the procedure containing the command.
.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.
.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
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
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
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
functions currently defined.
If \fIpattern\fR is given, returns only those names that match
\fIpattern\fR according to \fBstring match\fR.
.TP
\fBinfo globals \fR?\fIpattern\fR?
.
If \fIpattern\fR is not given, 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
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
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
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.
.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.
.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 \fInterp\fR, the empty string is the current interpreter.
.TP
\fBinfo locals \fR?\fIpattern\fR?
.
If \fIpattern\fR is given, returns the name of each local variable matching
\fIpattern\fR according to \fBstring match\fR. Otherwise, returns the name of
each local variable. A variables defined with the \fBglobal\fR, \fBupvar\fR or
\fBvariable\fR is not local.
.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.
.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.
.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.
.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.
.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.
.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.
.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
\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
This command prints out a procedure suitable for saving in a Tcl
script:
.PP
.CS
proc printProc {procName} {
|
| ︙ | ︙ | |||
699 700 701 702 703 704 705 |
lappend formals [list $var]
}
}
puts [lappend result $formals [\fBinfo body\fR $procName]]
}
.CE
.SS "EXAMPLES WITH OBJECTS"
| < > > | 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 |
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"
|
| ︙ | ︙ | |||
744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 |
.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
| > > > < < < < < < | | 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 |
.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)
.SH KEYWORDS
command, information, interpreter, introspection, level, namespace,
object, procedure, variable
'\" Local Variables:
'\" mode: nroff
'\" fill-column: 78
'\" End:
|
Changes to doc/interp.n.
| ︙ | ︙ | |||
197 198 199 200 201 202 203 | \fBinterp\fR \fBdebug \fIpath\fR ?\fB\-frame\fR ?\fIbool\fR?? . Controls whether frame-level stack information is captured in the slave interpreter identified by \fIpath\fR. If no arguments are given, option and current setting are returned. If \fB\-frame\fR is given, the debug setting is set to the given boolean if provided and the current setting is returned. | | | 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 | \fBinterp\fR \fBdebug \fIpath\fR ?\fB\-frame\fR ?\fIbool\fR?? . Controls whether frame-level stack information is captured in the slave interpreter identified by \fIpath\fR. If no arguments are given, option and current setting are returned. If \fB\-frame\fR is given, the debug setting is set to the given boolean if provided and the current setting is returned. This only affects the output of \fBinfo frame\fR, in that exact frame-level information for command invocation at the bytecode level is only captured with this setting on. .RS .PP For example, with code like .PP .CS |
| ︙ | ︙ | |||
232 233 234 235 236 237 238 | 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 | | | 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 | 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? . Deletes zero or more interpreters given by the optional \fIpath\fR 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 |
| ︙ | ︙ |
Changes to doc/join.n.
| ︙ | ︙ | |||
38 39 40 41 42 43 44 |
\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
| > > > > | 38 39 40 41 42 43 44 45 46 47 48 |
\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:
|
Changes to doc/lappend.n.
| ︙ | ︙ | |||
18 19 20 21 22 23 24 25 26 27 28 29 30 31 | .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. \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" | > > > > > > | 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 | .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" |
| ︙ | ︙ | |||
43 44 45 46 47 48 49 | 1 2 3 4 5 .CE .SH "SEE ALSO" list(n), lindex(n), linsert(n), llength(n), lset(n), lsort(n), lrange(n) .SH KEYWORDS append, element, list, variable | > > > > | 49 50 51 52 53 54 55 56 57 58 59 | 1 2 3 4 5 .CE .SH "SEE ALSO" 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: |
Changes to doc/lindex.n.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 | .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 | | | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 | .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? .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 the list. The indices may be presented either consecutively on the command line, or grouped in a |
| ︙ | ︙ |
Added doc/link.n.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 |
'\"
'\" 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:
|
Changes to doc/llength.n.
| ︙ | ︙ | |||
49 50 51 52 53 54 55 | 1,0 .CE .SH "SEE ALSO" list(n), lappend(n), lindex(n), linsert(n), lsearch(n), lset(n), lsort(n), lrange(n), lreplace(n) .SH KEYWORDS element, list, length | > > > > | 49 50 51 52 53 54 55 56 57 58 59 | 1,0 .CE .SH "SEE ALSO" 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: |
Changes to doc/load.n.
| ︙ | ︙ | |||
150 151 152 153 154 155 156 | .SH EXAMPLE .PP The following is a minimal extension: .PP .CS #include <tcl.h> #include <stdio.h> | | | 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 |
.SH EXAMPLE
.PP
The following is a minimal extension:
.PP
.CS
#include <tcl.h>
#include <stdio.h>
static int fooCmd(void *clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) {
printf("called with %d arguments\en", objc);
return TCL_OK;
}
int Foo_Init(Tcl_Interp *interp) {
if (Tcl_InitStubs(interp, "8.1", 0) == NULL) {
return TCL_ERROR;
|
| ︙ | ︙ |
Added doc/lpop.n.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 |
'\"
'\" 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), lindex(n), linsert(n), llength(n), lsearch(n),
lsort(n), lrange(n), lreplace(n), lset(n)
string(n)
.SH KEYWORDS
element, index, list, remove, pop, stack, queue
'\"Local Variables:
'\"mode: nroff
'\"End:
|
Changes to doc/lrange.n.
| ︙ | ︙ | |||
68 69 70 71 72 73 74 |
% lindex $var 1
elements to
% \fBlrange\fR $var 1 1
{elements to}
.CE
.SH "SEE ALSO"
list(n), lappend(n), lindex(n), linsert(n), llength(n), lsearch(n),
| | > > > > | 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 |
% lindex $var 1
elements to
% \fBlrange\fR $var 1 1
{elements to}
.CE
.SH "SEE ALSO"
list(n), lappend(n), lindex(n), linsert(n), llength(n), lsearch(n),
lset(n), lremove(n), lreplace(n), lsort(n),
string(n)
.SH KEYWORDS
element, list, range, sublist
'\" Local Variables:
'\" mode: nroff
'\" fill-column: 78
'\" End:
|
Added doc/lremove.n.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 |
'\"
'\" 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), lrange(n), lsearch(n), lsearch(n)
.SH KEYWORDS
element, list, remove
.\" Local variables:
.\" mode: nroff
.\" fill-column: 78
.\" End:
|
Changes to doc/lrepeat.n.
| ︙ | ︙ | |||
29 30 31 32 33 34 35 |
\fBlrepeat\fR 3 a b c
\fI\(-> a b c a b c a b c\fR
\fBlrepeat\fR 3 [\fBlrepeat\fR 2 a] b c
\fI\(-> {a a} b c {a a} b c {a a} b c\fR
.CE
.SH "SEE ALSO"
list(n), lappend(n), linsert(n), llength(n), lset(n)
| < > > > > | 29 30 31 32 33 34 35 36 37 38 39 40 41 |
\fBlrepeat\fR 3 a b c
\fI\(-> a b c a b c a b c\fR
\fBlrepeat\fR 3 [\fBlrepeat\fR 2 a] b c
\fI\(-> {a a} b c {a a} b c {a a} b c\fR
.CE
.SH "SEE ALSO"
list(n), lappend(n), linsert(n), llength(n), lset(n)
.SH KEYWORDS
element, index, list
'\" Local Variables:
'\" mode: nroff
'\" fill-column: 78
'\" End:
|
Changes to doc/lreplace.n.
| ︙ | ︙ | |||
13 14 15 16 17 18 19 | .SH NAME lreplace \- Replace elements in a list with new elements .SH SYNOPSIS \fBlreplace \fIlist first last \fR?\fIelement element ...\fR? .BE .SH DESCRIPTION .PP | | < | | > > | | > > > | | | < | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 |
.SH NAME
lreplace \- Replace elements in a list with new elements
.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
\fIlist\fR with the \fIelement\fR arguments.
\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.
.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
.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
with no elements being deleted.
.PP
The \fIelement\fR arguments specify zero or more new elements 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.
.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
|
| ︙ | ︙ | |||
74 75 76 77 78 79 80 81 82 |
.CS
proc lremove {listVariable value} {
upvar 1 $listVariable var
set idx [lsearch -exact $var $value]
set var [\fBlreplace\fR $var $idx $idx]
}
.CE
.SH "SEE ALSO"
list(n), lappend(n), lindex(n), linsert(n), llength(n), lsearch(n),
| > > > > > > > > > > > > > | > > > > | 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 |
.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), lindex(n), linsert(n), llength(n), lsearch(n),
lset(n), lrange(n), lremove(n), lsort(n),
string(n)
.SH KEYWORDS
element, list, replace
.\" Local variables:
.\" mode: nroff
.\" fill-column: 78
.\" End:
|
Changes to doc/mathop.n.
| ︙ | ︙ | |||
147 148 149 150 151 152 153 | Returns the result of raising each value to the power of the result of recursively operating on the result of processing the following arguments, so .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 | > | | | | | 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 | Returns the result of raising each value to the power of the result of recursively operating on the result of processing the following arguments, so .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. .SS "COMPARISON OPERATORS" .PP The behaviors of the comparison operator commands (most of which operate preferentially on numeric arguments) are as follows: .TP \fB==\fR ?\fIarg\fR ...? . |
| ︙ | ︙ |
Changes to doc/memory.n.
| ︙ | ︙ | |||
21 22 23 24 25 26 27 | .TP \fBmemory active\fR \fIfile\fR . Write a list of all currently allocated memory to the specified \fIfile\fR. .TP \fBmemory break_on_malloc\fR \fIcount\fR . | | | | | 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 | .TP \fBmemory active\fR \fIfile\fR . Write a list of all currently allocated memory to the specified \fIfile\fR. .TP \fBmemory break_on_malloc\fR \fIcount\fR . After the \fIcount\fR allocations have been performed, \fBTcl_Alloc\fR outputs a message to this effect and that it is now attempting to enter the C debugger. Tcl will then issue a \fISIGINT\fR signal against itself. If you are running Tcl under a C debugger, it should then enter the debugger command mode. .TP \fBmemory info\fR . Returns a report containing the total allocations and frees since Tcl began, the current packets allocated (the current number of calls to \fBTcl_Alloc\fR not met by a corresponding call to \fBTcl_Free\fR), the current bytes allocated, and the maximum number of packets and bytes allocated. .TP \fBmemory init \fR[\fBon\fR|\fBoff\fR] . Turn on or off the pre-initialization of all allocated memory with bogus bytes. Useful for detecting the use of uninitialized values. |
| ︙ | ︙ | |||
55 56 57 58 59 60 61 | . Causes a list of all allocated memory to be written to the specified \fIfile\fR during the finalization of Tcl's memory subsystem. Useful for checking that memory is properly cleaned up during process exit. .TP \fBmemory tag\fR \fIstring\fR . | | | | | | | | | | | | | | | 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 | . Causes a list of all allocated memory to be written to the specified \fIfile\fR during the finalization of Tcl's memory subsystem. Useful for checking that memory is properly cleaned up during process exit. .TP \fBmemory tag\fR \fIstring\fR . Each packet of memory allocated by \fBTcl_Alloc\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. .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 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 .CE .PP Calls to \fBTcl_Free\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. 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 being displayed for all allocations and frees. Since there can be a lot of memory activity before a problem occurs, judicious use of this option can reduce the slowdown caused by tracing (and the amount of trace information produced), if you can identify a number of allocations that occur before the problem sets in. The current number of memory allocations that have occurred since Tcl started is printed on a guard zone failure. .TP \fBmemory validate \fR[\fBon\fR|\fBoff\fR] . Turns memory validation on or off. When memory validation is enabled, on every call to \fBTcl_Alloc\fR or \fBTcl_Free\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 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 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 .SH KEYWORDS memory, debug '\"Local Variables: '\"mode: nroff '\"End: |
Changes to doc/msgcat.n.
| ︙ | ︙ | |||
124 125 126 127 128 129 130 | .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). | < > | 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 | .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 |
| ︙ | ︙ |
Changes to doc/my.n.
1 2 3 4 5 6 7 8 9 10 11 | '\" '\" Copyright (c) 2007 Donal K. Fellows '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH my n 0.1 TclOO "TclOO Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME | | > | | > > > > > | > > > > > | > > > > > | | > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 |
'\"
'\" 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 he \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:
|
Changes to doc/next.n.
| ︙ | ︙ | |||
108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 |
.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
| > > | 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 |
.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
|
| ︙ | ︙ | |||
163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 |
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
| > > > | 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 |
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
|
| ︙ | ︙ |
Changes to doc/open.n.
| ︙ | ︙ | |||
162 163 164 165 166 167 168 | .SH "SERIAL COMMUNICATIONS" .PP 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 | | | > | 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 | .SH "SERIAL COMMUNICATIONS" .PP 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): .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, |
| ︙ | ︙ | |||
244 245 246 247 248 249 250 251 252 253 254 255 256 257 |
.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\-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
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 |
.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
|
| ︙ | ︙ | |||
271 272 273 274 275 276 277 | \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. See below for an explanation of the various error codes. | | | 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 | \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. See below for an explanation of the various error codes. .SS "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 |
| ︙ | ︙ | |||
312 313 314 315 316 317 318 | .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. | | | 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 | .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)" .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 |
| ︙ | ︙ | |||
355 356 357 358 359 360 361 | 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) may cause this error. .TP 10 \fBBREAK\fR . A BREAK condition has been detected by your UART (see above). | | | 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 | 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) may cause this error. .TP 10 \fBBREAK\fR . A BREAK condition has been detected by your UART (see above). .SS "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 |
| ︙ | ︙ | |||
404 405 406 407 408 409 410 | 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. .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 | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > | 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 |
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.
.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"
.PP
Open a command pipeline and catch any errors:
.PP
.CS
set fl [\fBopen\fR "| ls this_file_does_not_exist"]
set data [read $fl]
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):
.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
}
.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:
|
Changes to doc/packagens.n.
| ︙ | ︙ | |||
44 45 46 47 48 49 50 | specified. .PP 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 | > > > > | 44 45 46 47 48 49 50 51 52 53 54 | specified. .PP 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: |
Changes to doc/pid.n.
| ︙ | ︙ | |||
39 40 41 42 43 44 45 | puts [string repeat - 70] puts [read $pipeline] close $pipeline .CE .SH "SEE ALSO" exec(n), open(n) | < > > > > | 39 40 41 42 43 44 45 46 47 48 49 50 51 | puts [string repeat - 70] puts [read $pipeline] close $pipeline .CE .SH "SEE ALSO" exec(n), open(n) .SH KEYWORDS file, pipeline, process identifier '\" Local Variables: '\" mode: nroff '\" fill-column: 78 '\" End: |
Changes to doc/platform.n.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 | .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 | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME platform \- System identification support code and utilities .SH SYNOPSIS .nf \fBpackage require platform\fR ?\fB1.0.10\fR? .sp \fBplatform::generic\fR \fBplatform::identify\fR \fBplatform::patterns \fIidentifier\fR .fi .BE .SH DESCRIPTION |
| ︙ | ︙ |
Changes to doc/platform_shell.n.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 | .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 | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME platform::shell \- System identification support code and utilities .SH SYNOPSIS .nf \fBpackage require platform::shell\fR ?\fB1.1.4\fR? .sp \fBplatform::shell::generic \fIshell\fR \fBplatform::shell::identify \fIshell\fR \fBplatform::shell::platform \fIshell\fR .fi .BE .SH DESCRIPTION |
| ︙ | ︙ | |||
51 52 53 54 55 56 57 | for the specified Tcl shell, in contrast to the running shell. .TP \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 | > > > > | 51 52 53 54 55 56 57 58 59 60 61 | for the specified Tcl shell, in contrast to the running shell. .TP \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: |
Changes to doc/prefix.n.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 | .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 | | | | | | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 | .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.) |
| ︙ | ︙ |
Added doc/process.n.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 |
'\"
'\" 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:
|
Changes to doc/puts.n.
| ︙ | ︙ | |||
92 93 94 95 96 97 98 | \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 | > > > > | 92 93 94 95 96 97 98 99 100 101 102 | \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: |
Changes to doc/pwd.n.
| ︙ | ︙ | |||
33 34 35 36 37 38 39 | exec tar -xf $tarFile cd $savedDir .CE .SH "SEE ALSO" file(n), cd(n), glob(n), filename(n) .SH KEYWORDS working directory | > > > > | 33 34 35 36 37 38 39 40 41 42 43 | 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: |
Changes to doc/re_syntax.n.
| ︙ | ︙ | |||
371 372 373 374 375 376 377 | for a Unicode extension up to 21 bits. The digits are parsed until the first non-hexadecimal character is encountered, the maximun of eight hexadecimal digits are reached, or an overflow would occur in the maximum value of \fBU+\fI10ffff\fR. .TP \fB\ev\fR . | | | 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 | for a Unicode extension up to 21 bits. The digits are parsed until the first non-hexadecimal character is encountered, the maximun of eight hexadecimal digits are reached, or an overflow would occur in the maximum value of \fBU+\fI10ffff\fR. .TP \fB\ev\fR . vertical tab, as in C .TP \fB\ex\fIhh\fR . (where \fIhh\fR is one or two hexadecimal digits) the character whose hexadecimal value is \fB0x\fIhh\fR. .TP \fB\e0\fR |
| ︙ | ︙ |
Changes to doc/rename.n.
| ︙ | ︙ | |||
39 40 41 42 43 44 45 |
uplevel 1 ::theRealSource $args
}
.CE
.SH "SEE ALSO"
namespace(n), proc(n)
.SH KEYWORDS
command, delete, namespace, rename
| > > > > | 39 40 41 42 43 44 45 46 47 48 49 |
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:
|
Changes to doc/self.n.
| ︙ | ︙ | |||
28 29 30 31 32 33 34 | \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<constructor>\fR and \fB<destructor>\fR | > > > > > | | 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 | \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<constructor>\fR and \fB<destructor>\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 |
| ︙ | ︙ |
Changes to doc/set.n.
| ︙ | ︙ | |||
69 70 71 72 73 74 75 |
\fBset\fR vbl in[expr {rand() >= 0.5}]
\fBset\fR out [\fBset\fR $vbl]
.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
| > > > > | 69 70 71 72 73 74 75 76 77 78 79 |
\fBset\fR vbl in[expr {rand() >= 0.5}]
\fBset\fR out [\fBset\fR $vbl]
.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:
|
Added doc/singleton.n.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 |
'\"
'\" 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<cloned>\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:
|
Changes to doc/source.n.
| ︙ | ︙ | |||
65 66 67 68 69 70 71 |
\fBsource\fR $scriptFile
}
.CE
.SH "SEE ALSO"
file(n), cd(n), encoding(n), info(n)
.SH KEYWORDS
file, script
| > > > > | 65 66 67 68 69 70 71 72 73 74 75 |
\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:
|
Changes to doc/string.n.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 | .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 | | < > < | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 | .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? .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 . 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 |
| ︙ | ︙ | |||
84 85 86 87 88 89 90 91 92 93 94 95 96 97 | string. \fIcharIndex\fR may be specified as described in the \fBSTRING INDICES\fR section. .RS .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 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 | > > > > > > > > > > > > > > > > > > | 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 | string. \fIcharIndex\fR may be specified as described in the \fBSTRING INDICES\fR section. .RS .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" .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 |
| ︙ | ︙ | |||
107 108 109 110 111 112 113 114 115 116 117 | .IP \fBascii\fR 12 Any character with a value less than \eu0080 (those that are in the 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 \fBdigit\fR 12 Any Unicode digit character. Note that this includes characters outside of the [0\-9] range. .IP \fBdouble\fR 12 | > > > > > > > > | < < < > < | | 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 | .IP \fBascii\fR 12 Any character with a value less than \eu0080 (those that are in the 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. .IP \fBinteger\fR 12 Any of the valid string formats for a 32-bit integer value in Tcl, with optional surrounding whitespace. In case of overflow in the value, 0 is returned and the \fIvarname\fR will contain \-1. .IP \fBlist\fR 12 Any proper list structure, with optional surrounding whitespace. In case of improper list structure, 0 is returned and the \fIvarname\fR will contain the index of the .QW element where the list parsing fails, or \-1 if this cannot be determined. |
| ︙ | ︙ | |||
152 153 154 155 156 157 158 | .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. .IP \fBwideinteger\fR 12 Any of the valid forms for a wide integer in Tcl, with optional | | | 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 | .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. .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. .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]). .PP |
| ︙ | ︙ | |||
266 267 268 269 270 271 272 | \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 | | > > | > > | > | 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 | \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 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. .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 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 |
| ︙ | ︙ |
Changes to doc/tclsh.1.
| ︙ | ︙ | |||
139 140 141 142 143 144 145 146 147 148 149 | 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 "SEE ALSO" auto_path(n), encoding(n), env(n), fconfigure(n) .SH KEYWORDS application, argument, interpreter, prompt, script file, shell | > > > > > > > > > | 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 | The variable \fBtcl_prompt2\fR is used in a similar way when a newline is typed but the current command is not yet complete; if \fBtcl_prompt2\fR is not set then no prompt is output for incomplete commands. .SH "STANDARD CHANNELS" .PP See \fBTcl_StandardChannels\fR for more explanations. .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) .SH KEYWORDS application, argument, interpreter, prompt, script file, shell |
Changes to doc/tcltest.n.
1 2 3 4 5 6 7 8 9 10 | '\" '\" Copyright (c) 1990-1994 The Regents of the University of California '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" Copyright (c) 1998-1999 Scriptics Corporation '\" Copyright (c) 2000 Ajuba Solutions '\" Contributions from Don Porter, NIST, 2002. (not subject to US copyright) '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 | '\" '\" Copyright (c) 1990-1994 The Regents of the University of California '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" Copyright (c) 1998-1999 Scriptics Corporation '\" Copyright (c) 2000 Ajuba Solutions '\" Contributions from Don Porter, NIST, 2002. (not subject to US copyright) '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH "tcltest" n 2.5 tcltest "Tcl Bundled Packages" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME tcltest \- Test harness support code and utilities .SH SYNOPSIS .nf \fBpackage require tcltest\fR ?\fB2.5\fR? \fBtcltest::test \fIname description\fR ?\fI\-option value ...\fR? \fBtcltest::test \fIname description\fR ?\fIconstraints\fR? \fIbody result\fR \fBtcltest::loadTestedCommands\fR \fBtcltest::makeDirectory \fIname\fR ?\fIdirectory\fR? \fBtcltest::removeDirectory \fIname\fR ?\fIdirectory\fR? |
| ︙ | ︙ | |||
450 451 452 453 454 455 456 457 458 459 460 461 462 463 |
?\fB\-setup \fIsetupScript\fR?
?\fB\-body \fItestScript\fR?
?\fB\-cleanup \fIcleanupScript\fR?
?\fB\-result \fIexpectedAnswer\fR?
?\fB\-output \fIexpectedOutput\fR?
?\fB\-errorOutput \fIexpectedError\fR?
?\fB\-returnCodes \fIcodeList\fR?
?\fB\-match \fImode\fR?
.CE
.PP
The \fIname\fR may be any string. It is conventional to choose
a \fIname\fR according to the pattern:
.PP
.CS
| > | 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 |
?\fB\-setup \fIsetupScript\fR?
?\fB\-body \fItestScript\fR?
?\fB\-cleanup \fIcleanupScript\fR?
?\fB\-result \fIexpectedAnswer\fR?
?\fB\-output \fIexpectedOutput\fR?
?\fB\-errorOutput \fIexpectedError\fR?
?\fB\-returnCodes \fIcodeList\fR?
?\fB\-errorCode \fIexpectedErrorCode\fR?
?\fB\-match \fImode\fR?
.CE
.PP
The \fIname\fR may be any string. It is conventional to choose
a \fIname\fR according to the pattern:
.PP
.CS
|
| ︙ | ︙ | |||
573 574 575 576 577 578 579 580 581 582 583 584 585 586 | a list of return codes that may be accepted from evaluation of the \fB\-body\fR script. If evaluation of the \fB\-body\fR script returns a code not in the \fIexpectedCodeList\fR, the test fails. All return codes known to \fBreturn\fR, in both numeric and symbolic form, including extended return codes, are acceptable elements in the \fIexpectedCodeList\fR. Default value is .QW "\fBok return\fR" . .PP To pass, a test must successfully evaluate its \fB\-setup\fR, \fB\-body\fR, and \fB\-cleanup\fR scripts. The return code of the \fB\-body\fR script and its result must match expected values, and if specified, output and error data from the test must match expected \fB\-output\fR and \fB\-errorOutput\fR values. If any of these conditions are not met, then the test fails. Note that all scripts are evaluated in the context of the caller | > > > > > > > > > | 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 | a list of return codes that may be accepted from evaluation of the \fB\-body\fR script. If evaluation of the \fB\-body\fR script returns a code not in the \fIexpectedCodeList\fR, the test fails. All return codes known to \fBreturn\fR, in both numeric and symbolic form, including extended return codes, are acceptable elements in the \fIexpectedCodeList\fR. Default value is .QW "\fBok return\fR" . .TP \fB\-errorCode \fIexpectedErrorCode\fR . The optional \fB\-errorCode\fR attribute supplies \fIexpectedErrorCode\fR, a glob pattern that should match the error code reported from evaluation of the \fB\-body\fR script. If evaluation of the \fB\-body\fR script returns a code not matching \fIexpectedErrorCode\fR, the test fails. Default value is .QW "\fB*\fR" . If \fB\-returnCodes\fR does not include \fBerror\fR it is set to \fBerror\fR. .PP To pass, a test must successfully evaluate its \fB\-setup\fR, \fB\-body\fR, and \fB\-cleanup\fR scripts. The return code of the \fB\-body\fR script and its result must match expected values, and if specified, output and error data from the test must match expected \fB\-output\fR and \fB\-errorOutput\fR values. If any of these conditions are not met, then the test fails. Note that all scripts are evaluated in the context of the caller |
| ︙ | ︙ |
Changes to doc/tell.n.
| ︙ | ︙ | |||
42 43 44 45 46 47 48 |
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
| > > > > | 42 43 44 45 46 47 48 49 50 51 52 |
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:
|
Added doc/timerate.n.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 |
'\"
'\" Copyright (c) 2005 Sergey Brester aka sebres.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.TH timerate n "" Tcl "Tcl Built-In Commands"
.so man.macros
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
timerate \- Calibrated performance measurements of script execution time
.SH SYNOPSIS
\fBtimerate \fIscript\fR ?\fItime\fR? ?\fImax-count\fR?
.sp
\fBtimerate \fR?\fB\-direct\fR? ?\fB\-overhead\fI double\fR? \fIscript\fR ?\fItime\fR? ?\fImax-count\fR?
.sp
\fBtimerate \fR?\fB\-calibrate\fR? ?\fB\-direct\fR? \fIscript\fR ?\fItime\fR? ?\fImax-count\fR?
.BE
.SH DESCRIPTION
.PP
The \fBtimerate\fR command does calibrated performance measurement of a Tcl
command or script, \fIscript\fR. The \fIscript\fR should be written so that it
can be executed multiple times during the performance measurement process.
Time is measured in elapsed time using the finest timer resolution as possible,
not CPU time; if \fIscript\fR interacts with the OS, the cost of that
interaction is included.
This command may be used to provide information as to how well a script or
Tcl command is performing, and can help determine bottlenecks and fine-tune
application performance.
.PP
The first and second form will evaluate \fIscript\fR until the interval
\fItime\fR given in milliseconds elapses, or for 1000 milliseconds (1 second)
if \fItime\fR is not specified.
.sp
The parameter \fImax-count\fR could additionally impose a further restriction
by the maximal number of iterations to evaluate the script.
If \fImax-count\fR is specified, the evalution will stop either this count of
iterations is reached or the time is exceeded.
.sp
It will then return a canonical tcl-list of the form:
.PP
.CS
\fB0.095977 \(mcs/# 52095836 # 10419167 #/sec 5000.000 net-ms\fR
.CE
.PP
which indicates:
.IP \(bu 3
the average amount of time required per iteration, in microseconds ([\fBlindex\fR $result 0])
.IP \(bu 3
the count how many times it was executed ([\fBlindex\fR $result 2])
.IP \(bu 3
the estimated rate per second ([\fBlindex\fR $result 4])
.IP \(bu 3
the estimated real execution time without measurement overhead ([\fBlindex\fR $result 6])
.PP
The following options may be supplied to the \fBtimerate\fR command:
.TP
\fB\-calibrate\fR
.
To measure very fast scripts as exactly as possible, a calibration process
may be required.
The \fB\-calibrate\fR option is used to calibrate \fBtimerate\fR itself,
calculating the estimated overhead of the given script as the default overhead
for future invocations of the \fBtimerate\fR command. If the \fItime\fR
parameter is not specified, the calibrate procedure runs for up to 10 seconds.
.RS
.PP
Note that calibration is not thread safe in the current implementation.
.RE
.TP
\fB\-overhead \fIdouble\fR
.
The \fB\-overhead\fR parameter supplies an estimate (in microseconds) of the
measurement overhead of each iteration of the tested script. This quantity
will be subtracted from the measured time prior to reporting results. This can
be useful for removing the cost of interpreter state reset commands from the
script being measured.
.TP
\fB\-direct\fR
.
The \fB-direct\fR option causes direct execution of the supplied script,
without compilation, in a manner similar to the \fBtime\fR command. It can be
used to measure the cost of \fBTcl_EvalObjEx\fR, of the invocation of canonical
lists, and of the uncompiled versions of bytecoded commands.
.PP
As opposed to the \fBtime\fR commmand, which runs the tested script for a fixed
number of iterations, the timerate command runs it for a fixed time.
Additionally, the compiled variant of the script will be used during the entire
measurement, as if the script were part of a compiled procedure, if the \fB\-direct\fR
option is not specified. The fixed time period and possibility of compilation allow
for more precise results and prevent very long execution times by slow scripts, making
it practical for measuring scripts with highly uncertain execution times.
.SH EXAMPLES
Estimate how fast it takes for a simple Tcl \fBfor\fR loop (including
operations on variable \fIi\fR) to count to ten:
.PP
.CS
\fI# calibrate\fR
\fBtimerate\fR -calibrate {}
\fI# measure\fR
\fBtimerate\fR { for {set i 0} {$i<10} {incr i} {} } 5000
.CE
.PP
Estimate how fast it takes for a simple Tcl \fBfor\fR loop, ignoring the
overhead of the management of the variable that controls the loop:
.PP
.CS
\fI# calibrate for overhead of variable operations\fR
set i 0; \fBtimerate\fR -calibrate {expr {$i<10}; incr i} 1000
\fI# measure\fR
\fBtimerate\fR {
for {set i 0} {$i<10} {incr i} {}
} 5000
.CE
.PP
Estimate the speed of calculating the hour of the day using \fBclock format\fR only,
ignoring overhead of the portion of the script that prepares the time for it to
calculate:
.PP
.CS
\fI# calibrate\fR
\fBtimerate\fR -calibrate {}
\fI# estimate overhead\fR
set tm 0
set ovh [lindex [\fBtimerate\fR {
incr tm [expr {24*60*60}]
}] 0]
\fI# measure using estimated overhead\fR
set tm 0
\fBtimerate\fR -overhead $ovh {
clock format $tm -format %H
incr tm [expr {24*60*60}]; # overhead for this is ignored
} 5000
.CE
.SH "SEE ALSO"
time(n)
.SH KEYWORDS
performance measurement, script, time
.\" Local Variables:
.\" mode: nroff
.\" End:
|
Changes to doc/trace.n.
| ︙ | ︙ | |||
16 17 18 19 20 21 22 | \fBtrace \fIoption\fR ?\fIarg arg ...\fR? .BE .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 | | > | 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 | \fBtrace \fIoption\fR ?\fIarg arg ...\fR? .BE .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? . Where \fItype\fR is \fBcommand\fR, \fBexecution\fR, or \fBvariable\fR. .RS .TP \fBtrace add command\fR \fIname ops commandPrefix\fR . Arrange for \fIcommandPrefix\fR to be executed (with additional arguments) whenever command \fIname\fR is modified in one of the ways given by the list |
| ︙ | ︙ |
Changes to doc/unknown.n.
| ︙ | ︙ | |||
85 86 87 88 89 90 91 |
uplevel 1 [list _original_unknown {*}$args]
}
.CE
.SH "SEE ALSO"
info(n), proc(n), interp(n), library(n), namespace(n)
.SH KEYWORDS
error, non-existent command, unknown
| > > > > | 85 86 87 88 89 90 91 92 93 94 95 |
uplevel 1 [list _original_unknown {*}$args]
}
.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:
|
Changes to doc/update.n.
| ︙ | ︙ | |||
59 60 61 62 63 64 65 |
\fBupdate\fR
}
.CE
.SH "SEE ALSO"
after(n), interp(n)
.SH KEYWORDS
asynchronous I/O, event, flush, handler, idle, update
| > > > > | 59 60 61 62 63 64 65 66 67 68 69 |
\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:
|
Changes to doc/uplevel.n.
| ︙ | ︙ | |||
20 21 22 23 24 25 26 | been passed to \fBconcat\fR; the result is then evaluated in the variable context indicated by \fIlevel\fR. \fBUplevel\fR returns 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 | | | | 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 | been passed to \fBconcat\fR; the result is then evaluated in the variable context indicated by \fIlevel\fR. \fBUplevel\fR returns 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 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. .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 in the variable context of \fBb\fR. If \fIlevel\fR is \fB2\fR or \fB#1\fR then the command will be executed in the variable context of \fBa\fR. |
| ︙ | ︙ |
Changes to doc/while.n.
| ︙ | ︙ | |||
59 60 61 62 63 64 65 |
puts "[incr lineCount]: $line"
}
.CE
.SH "SEE ALSO"
break(n), continue(n), for(n), foreach(n)
.SH KEYWORDS
boolean, loop, test, while
| > > > > | 59 60 61 62 63 64 65 66 67 68 69 |
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:
|
Added doc/zipfs.3.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 | '\" '\" Copyright (c) 2015 Jan Nijtmans <jan.nijtmans@gmail.com> '\" Copyright (c) 2015 Christian Werner <chw@ch-werner.de> '\" Copyright (c) 2017 Sean Woods <yoda@etoyoc.com> '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH Tclzipfs 3 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 in stead 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 |
Added doc/zipfs.n.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 |
'\"
'\" Copyright (c) 2015 Jan Nijtmans <jan.nijtmans@gmail.com>
'\" Copyright (c) 2015 Christian Werner <chw@ch-werner.de>
'\" Copyright (c) 2015 Sean Woods <yoda@etoyoc.com>
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.TH 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:
|
Changes to generic/regc_locale.c.
| ︙ | ︙ | |||
133 134 135 136 137 138 139 |
* Unicode: alphabetic characters.
*/
static const crange alphaRangeTable[] = {
{0x41, 0x5a}, {0x61, 0x7a}, {0xc0, 0xd6}, {0xd8, 0xf6},
{0xf8, 0x2c1}, {0x2c6, 0x2d1}, {0x2e0, 0x2e4}, {0x370, 0x374},
{0x37a, 0x37d}, {0x388, 0x38a}, {0x38e, 0x3a1}, {0x3a3, 0x3f5},
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < < < < | | | | | > | | | > > | | | | | | > | > | | | | | | < | | | | | | > | | | | > | | | | | | | | | | | | | | | > | | 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 |
* Unicode: alphabetic characters.
*/
static const crange alphaRangeTable[] = {
{0x41, 0x5a}, {0x61, 0x7a}, {0xc0, 0xd6}, {0xd8, 0xf6},
{0xf8, 0x2c1}, {0x2c6, 0x2d1}, {0x2e0, 0x2e4}, {0x370, 0x374},
{0x37a, 0x37d}, {0x388, 0x38a}, {0x38e, 0x3a1}, {0x3a3, 0x3f5},
{0x3f7, 0x481}, {0x48a, 0x52f}, {0x531, 0x556}, {0x560, 0x588},
{0x5d0, 0x5ea}, {0x5ef, 0x5f2}, {0x620, 0x64a}, {0x671, 0x6d3},
{0x6fa, 0x6fc}, {0x712, 0x72f}, {0x74d, 0x7a5}, {0x7ca, 0x7ea},
{0x800, 0x815}, {0x840, 0x858}, {0x860, 0x86a}, {0x8a0, 0x8b4},
{0x8b6, 0x8bd}, {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}, {0xd05, 0xd0c},
{0xd0e, 0xd10}, {0xd12, 0xd3a}, {0xd54, 0xd56}, {0xd5f, 0xd61},
{0xd7a, 0xd7f}, {0xd85, 0xd96}, {0xd9a, 0xdb1}, {0xdb3, 0xdbb},
{0xdc0, 0xdc6}, {0xe01, 0xe30}, {0xe40, 0xe46}, {0xe86, 0xe8a},
{0xe8c, 0xea3}, {0xea7, 0xeb0}, {0xec0, 0xec4}, {0xedc, 0xedf},
{0xf40, 0xf47}, {0xf49, 0xf6c}, {0xf88, 0xf8c}, {0x1000, 0x102a},
{0x1050, 0x1055}, {0x105a, 0x105d}, {0x106e, 0x1070}, {0x1075, 0x1081},
{0x10a0, 0x10c5}, {0x10d0, 0x10fa}, {0x10fc, 0x1248}, {0x124a, 0x124d},
{0x1250, 0x1256}, {0x125a, 0x125d}, {0x1260, 0x1288}, {0x128a, 0x128d},
{0x1290, 0x12b0}, {0x12b2, 0x12b5}, {0x12b8, 0x12be}, {0x12c2, 0x12c5},
{0x12c8, 0x12d6}, {0x12d8, 0x1310}, {0x1312, 0x1315}, {0x1318, 0x135a},
{0x1380, 0x138f}, {0x13a0, 0x13f5}, {0x13f8, 0x13fd}, {0x1401, 0x166c},
{0x166f, 0x167f}, {0x1681, 0x169a}, {0x16a0, 0x16ea}, {0x16f1, 0x16f8},
{0x1700, 0x170c}, {0x170e, 0x1711}, {0x1720, 0x1731}, {0x1740, 0x1751},
{0x1760, 0x176c}, {0x176e, 0x1770}, {0x1780, 0x17b3}, {0x1820, 0x1878},
{0x1880, 0x1884}, {0x1887, 0x18a8}, {0x18b0, 0x18f5}, {0x1900, 0x191e},
{0x1950, 0x196d}, {0x1970, 0x1974}, {0x1980, 0x19ab}, {0x19b0, 0x19c9},
{0x1a00, 0x1a16}, {0x1a20, 0x1a54}, {0x1b05, 0x1b33}, {0x1b45, 0x1b4b},
{0x1b83, 0x1ba0}, {0x1bba, 0x1be5}, {0x1c00, 0x1c23}, {0x1c4d, 0x1c4f},
{0x1c5a, 0x1c7d}, {0x1c80, 0x1c88}, {0x1c90, 0x1cba}, {0x1cbd, 0x1cbf},
{0x1ce9, 0x1cec}, {0x1cee, 0x1cf3}, {0x1d00, 0x1dbf}, {0x1e00, 0x1f15},
{0x1f18, 0x1f1d}, {0x1f20, 0x1f45}, {0x1f48, 0x1f4d}, {0x1f50, 0x1f57},
{0x1f5f, 0x1f7d}, {0x1f80, 0x1fb4}, {0x1fb6, 0x1fbc}, {0x1fc2, 0x1fc4},
{0x1fc6, 0x1fcc}, {0x1fd0, 0x1fd3}, {0x1fd6, 0x1fdb}, {0x1fe0, 0x1fec},
{0x1ff2, 0x1ff4}, {0x1ff6, 0x1ffc}, {0x2090, 0x209c}, {0x210a, 0x2113},
{0x2119, 0x211d}, {0x212a, 0x212d}, {0x212f, 0x2139}, {0x213c, 0x213f},
{0x2145, 0x2149}, {0x2c00, 0x2c2e}, {0x2c30, 0x2c5e}, {0x2c60, 0x2ce4},
{0x2ceb, 0x2cee}, {0x2d00, 0x2d25}, {0x2d30, 0x2d67}, {0x2d80, 0x2d96},
{0x2da0, 0x2da6}, {0x2da8, 0x2dae}, {0x2db0, 0x2db6}, {0x2db8, 0x2dbe},
{0x2dc0, 0x2dc6}, {0x2dc8, 0x2dce}, {0x2dd0, 0x2dd6}, {0x2dd8, 0x2dde},
{0x3031, 0x3035}, {0x3041, 0x3096}, {0x309d, 0x309f}, {0x30a1, 0x30fa},
{0x30fc, 0x30ff}, {0x3105, 0x312f}, {0x3131, 0x318e}, {0x31a0, 0x31ba},
{0x31f0, 0x31ff}, {0x3400, 0x4db5}, {0x4e00, 0x9fef}, {0xa000, 0xa48c},
{0xa4d0, 0xa4fd}, {0xa500, 0xa60c}, {0xa610, 0xa61f}, {0xa640, 0xa66e},
{0xa67f, 0xa69d}, {0xa6a0, 0xa6e5}, {0xa717, 0xa71f}, {0xa722, 0xa788},
{0xa78b, 0xa7bf}, {0xa7c2, 0xa7c6}, {0xa7f7, 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, 0xab67},
{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}, {0x10f00, 0x10f1c},
{0x10f30, 0x10f45}, {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}, {0x11480, 0x114af},
{0x11580, 0x115ae}, {0x115d8, 0x115db}, {0x11600, 0x1162f}, {0x11680, 0x116aa},
{0x11700, 0x1171a}, {0x11800, 0x1182b}, {0x118a0, 0x118df}, {0x119a0, 0x119a7},
{0x119aa, 0x119d0}, {0x11a0b, 0x11a32}, {0x11a5c, 0x11a89}, {0x11ac0, 0x11af8},
{0x11c00, 0x11c08}, {0x11c0a, 0x11c2e}, {0x11c72, 0x11c8f}, {0x11d00, 0x11d06},
{0x11d0b, 0x11d30}, {0x11d60, 0x11d65}, {0x11d6a, 0x11d89}, {0x11ee0, 0x11ef2},
{0x12000, 0x12399}, {0x12480, 0x12543}, {0x13000, 0x1342e}, {0x14400, 0x14646},
{0x16800, 0x16a38}, {0x16a40, 0x16a5e}, {0x16ad0, 0x16aed}, {0x16b00, 0x16b2f},
{0x16b40, 0x16b43}, {0x16b63, 0x16b77}, {0x16b7d, 0x16b8f}, {0x16e40, 0x16e7f},
{0x16f00, 0x16f4a}, {0x16f93, 0x16f9f}, {0x17000, 0x187f7}, {0x18800, 0x18af2},
{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, 0x2a6d6}, {0x2a700, 0x2b734}, {0x2b740, 0x2b81d}, {0x2b820, 0x2cea1},
{0x2ceb0, 0x2ebe0}, {0x2f800, 0x2fa1d}
#endif
};
#define NUM_ALPHA_RANGE (sizeof(alphaRangeTable)/sizeof(crange))
static const chr alphaCharTable[] = {
0xaa, 0xb5, 0xba, 0x2ec, 0x2ee, 0x376, 0x377, 0x37f, 0x386,
0x38c, 0x559, 0x66e, 0x66f, 0x6d5, 0x6e5, 0x6e6, 0x6ee, 0x6ef,
0x6ff, 0x710, 0x7b1, 0x7f4, 0x7f5, 0x7fa, 0x81a, 0x824, 0x828,
0x93d, 0x950, 0x98f, 0x990, 0x9b2, 0x9bd, 0x9ce, 0x9dc, 0x9dd,
0x9f0, 0x9f1, 0x9fc, 0xa0f, 0xa10, 0xa32, 0xa33, 0xa35, 0xa36,
0xa38, 0xa39, 0xa5e, 0xab2, 0xab3, 0xabd, 0xad0, 0xae0, 0xae1,
0xaf9, 0xb0f, 0xb10, 0xb32, 0xb33, 0xb3d, 0xb5c, 0xb5d, 0xb71,
0xb83, 0xb99, 0xb9a, 0xb9c, 0xb9e, 0xb9f, 0xba3, 0xba4, 0xbd0,
0xc3d, 0xc60, 0xc61, 0xc80, 0xcbd, 0xcde, 0xce0, 0xce1, 0xcf1,
0xcf2, 0xd3d, 0xd4e, 0xdbd, 0xe32, 0xe33, 0xe81, 0xe82, 0xe84,
0xea5, 0xeb2, 0xeb3, 0xebd, 0xec6, 0xf00, 0x103f, 0x1061, 0x1065,
0x1066, 0x108e, 0x10c7, 0x10cd, 0x1258, 0x12c0, 0x17d7, 0x17dc, 0x18aa,
0x1aa7, 0x1bae, 0x1baf, 0x1cf5, 0x1cf6, 0x1cfa, 0x1f59, 0x1f5b, 0x1f5d,
0x1fbe, 0x2071, 0x207f, 0x2102, 0x2107, 0x2115, 0x2124, 0x2126, 0x2128,
0x214e, 0x2183, 0x2184, 0x2cf2, 0x2cf3, 0x2d27, 0x2d2d, 0x2d6f, 0x2e2f,
0x3005, 0x3006, 0x303b, 0x303c, 0xa62a, 0xa62b, 0xa8fb, 0xa8fd, 0xa8fe,
0xa9cf, 0xaa7a, 0xaab1, 0xaab5, 0xaab6, 0xaac0, 0xaac2, 0xfb1d, 0xfb3e,
0xfb40, 0xfb41, 0xfb43, 0xfb44
#if CHRBITS > 16
,0x1003c, 0x1003d, 0x10808, 0x10837, 0x10838, 0x1083c, 0x108f4, 0x108f5, 0x109be,
0x109bf, 0x10a00, 0x10f27, 0x11144, 0x11176, 0x111da, 0x111dc, 0x11288, 0x1130f,
0x11310, 0x11332, 0x11333, 0x1133d, 0x11350, 0x1145f, 0x114c4, 0x114c5, 0x114c7,
0x11644, 0x116b8, 0x118ff, 0x119e1, 0x119e3, 0x11a00, 0x11a3a, 0x11a50, 0x11a9d,
0x11c40, 0x11d08, 0x11d09, 0x11d46, 0x11d67, 0x11d68, 0x11d98, 0x16f50, 0x16fe0,
0x16fe1, 0x16fe3, 0x1d49e, 0x1d49f, 0x1d4a2, 0x1d4a5, 0x1d4a6, 0x1d4bb, 0x1d546,
0x1e14e, 0x1e94b, 0x1ee21, 0x1ee22, 0x1ee24, 0x1ee27, 0x1ee39, 0x1ee3b, 0x1ee42,
0x1ee47, 0x1ee49, 0x1ee4b, 0x1ee51, 0x1ee52, 0x1ee54, 0x1ee57, 0x1ee59, 0x1ee5b,
0x1ee5d, 0x1ee5f, 0x1ee61, 0x1ee62, 0x1ee64, 0x1ee7e
#endif
};
#define NUM_ALPHA_CHAR (sizeof(alphaCharTable)/sizeof(chr))
/*
* Unicode: control characters.
*/
static const crange controlRangeTable[] = {
{0x0, 0x1f}, {0x7f, 0x9f}, {0x600, 0x605}, {0x200b, 0x200f},
{0x202a, 0x202e}, {0x2060, 0x2064}, {0x2066, 0x206f}, {0xe000, 0xf8ff},
{0xfff9, 0xfffb}
#if CHRBITS > 16
,{0x13430, 0x13438}, {0x1bca0, 0x1bca3}, {0x1d173, 0x1d17a}, {0xe0020, 0xe007f},
{0xf0000, 0xffffd}, {0x100000, 0x10fffd}
#endif
};
#define NUM_CONTROL_RANGE (sizeof(controlRangeTable)/sizeof(crange))
static const chr controlCharTable[] = {
0xad, 0x61c, 0x6dd, 0x70f, 0x8e2, 0x180e, 0xfeff
#if CHRBITS > 16
,0x110bd, 0x110cd, 0xe0001
#endif
};
#define NUM_CONTROL_CHAR (sizeof(controlCharTable)/sizeof(chr))
/*
* Unicode: decimal digit characters.
*/
static const crange digitRangeTable[] = {
{0x30, 0x39}, {0x660, 0x669}, {0x6f0, 0x6f9}, {0x7c0, 0x7c9},
{0x966, 0x96f}, {0x9e6, 0x9ef}, {0xa66, 0xa6f}, {0xae6, 0xaef},
{0xb66, 0xb6f}, {0xbe6, 0xbef}, {0xc66, 0xc6f}, {0xce6, 0xcef},
{0xd66, 0xd6f}, {0xde6, 0xdef}, {0xe50, 0xe59}, {0xed0, 0xed9},
{0xf20, 0xf29}, {0x1040, 0x1049}, {0x1090, 0x1099}, {0x17e0, 0x17e9},
{0x1810, 0x1819}, {0x1946, 0x194f}, {0x19d0, 0x19d9}, {0x1a80, 0x1a89},
{0x1a90, 0x1a99}, {0x1b50, 0x1b59}, {0x1bb0, 0x1bb9}, {0x1c40, 0x1c49},
{0x1c50, 0x1c59}, {0xa620, 0xa629}, {0xa8d0, 0xa8d9}, {0xa900, 0xa909},
{0xa9d0, 0xa9d9}, {0xa9f0, 0xa9f9}, {0xaa50, 0xaa59}, {0xabf0, 0xabf9},
{0xff10, 0xff19}
#if CHRBITS > 16
,{0x104a0, 0x104a9}, {0x10d30, 0x10d39}, {0x11066, 0x1106f}, {0x110f0, 0x110f9},
{0x11136, 0x1113f}, {0x111d0, 0x111d9}, {0x112f0, 0x112f9}, {0x11450, 0x11459},
{0x114d0, 0x114d9}, {0x11650, 0x11659}, {0x116c0, 0x116c9}, {0x11730, 0x11739},
{0x118e0, 0x118e9}, {0x11c50, 0x11c59}, {0x11d50, 0x11d59}, {0x11da0, 0x11da9},
{0x16a60, 0x16a69}, {0x16b50, 0x16b59}, {0x1d7ce, 0x1d7ff}, {0x1e140, 0x1e149},
{0x1e2f0, 0x1e2f9}, {0x1e950, 0x1e959}
#endif
};
#define NUM_DIGIT_RANGE (sizeof(digitRangeTable)/sizeof(crange))
/*
* no singletons of digit characters.
|
| ︙ | ︙ | |||
344 345 346 347 348 349 350 |
{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},
| | | | | | | | > | | | | | | | | > | | > | | 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 |
{0x55a, 0x55f}, {0x66a, 0x66d}, {0x700, 0x70d}, {0x7f7, 0x7f9},
{0x830, 0x83e}, {0xf04, 0xf12}, {0xf3a, 0xf3d}, {0xfd0, 0xfd4},
{0x104a, 0x104f}, {0x1360, 0x1368}, {0x16eb, 0x16ed}, {0x17d4, 0x17d6},
{0x17d8, 0x17da}, {0x1800, 0x180a}, {0x1aa0, 0x1aa6}, {0x1aa8, 0x1aad},
{0x1b5a, 0x1b60}, {0x1bfc, 0x1bff}, {0x1c3b, 0x1c3f}, {0x1cc0, 0x1cc7},
{0x2010, 0x2027}, {0x2030, 0x2043}, {0x2045, 0x2051}, {0x2053, 0x205e},
{0x2308, 0x230b}, {0x2768, 0x2775}, {0x27e6, 0x27ef}, {0x2983, 0x2998},
{0x29d8, 0x29db}, {0x2cf9, 0x2cfc}, {0x2e00, 0x2e2e}, {0x2e30, 0x2e4f},
{0x3001, 0x3003}, {0x3008, 0x3011}, {0x3014, 0x301f}, {0xa60d, 0xa60f},
{0xa6f2, 0xa6f7}, {0xa874, 0xa877}, {0xa8f8, 0xa8fa}, {0xa9c1, 0xa9cd},
{0xaa5c, 0xaa5f}, {0xfe10, 0xfe19}, {0xfe30, 0xfe52}, {0xfe54, 0xfe61},
{0xff01, 0xff03}, {0xff05, 0xff0a}, {0xff0c, 0xff0f}, {0xff3b, 0xff3d},
{0xff5f, 0xff65}
#if CHRBITS > 16
,{0x10100, 0x10102}, {0x10a50, 0x10a58}, {0x10af0, 0x10af6}, {0x10b39, 0x10b3f},
{0x10b99, 0x10b9c}, {0x10f55, 0x10f59}, {0x11047, 0x1104d}, {0x110be, 0x110c1},
{0x11140, 0x11143}, {0x111c5, 0x111c8}, {0x111dd, 0x111df}, {0x11238, 0x1123d},
{0x1144b, 0x1144f}, {0x115c1, 0x115d7}, {0x11641, 0x11643}, {0x11660, 0x1166c},
{0x1173c, 0x1173e}, {0x11a3f, 0x11a46}, {0x11a9a, 0x11a9c}, {0x11a9e, 0x11aa2},
{0x11c41, 0x11c45}, {0x12470, 0x12474}, {0x16b37, 0x16b3b}, {0x16e97, 0x16e9a},
{0x1da87, 0x1da8b}
#endif
};
#define NUM_PUNCT_RANGE (sizeof(punctRangeTable)/sizeof(crange))
static const chr punctCharTable[] = {
0x3a, 0x3b, 0x3f, 0x40, 0x5f, 0x7b, 0x7d, 0xa1, 0xa7,
0xab, 0xb6, 0xb7, 0xbb, 0xbf, 0x37e, 0x387, 0x589, 0x58a,
0x5be, 0x5c0, 0x5c3, 0x5c6, 0x5f3, 0x5f4, 0x609, 0x60a, 0x60c,
0x60d, 0x61b, 0x61e, 0x61f, 0x6d4, 0x85e, 0x964, 0x965, 0x970,
0x9fd, 0xa76, 0xaf0, 0xc77, 0xc84, 0xdf4, 0xe4f, 0xe5a, 0xe5b,
0xf14, 0xf85, 0xfd9, 0xfda, 0x10fb, 0x1400, 0x166e, 0x169b, 0x169c,
0x1735, 0x1736, 0x1944, 0x1945, 0x1a1e, 0x1a1f, 0x1c7e, 0x1c7f, 0x1cd3,
0x207d, 0x207e, 0x208d, 0x208e, 0x2329, 0x232a, 0x27c5, 0x27c6, 0x29fc,
0x29fd, 0x2cfe, 0x2cff, 0x2d70, 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, 0x110bb, 0x110bc,
0x11174, 0x11175, 0x111cd, 0x111db, 0x112a9, 0x1145b, 0x1145d, 0x114c6, 0x1183b,
0x119e2, 0x11c70, 0x11c71, 0x11ef7, 0x11ef8, 0x11fff, 0x16a6e, 0x16a6f, 0x16af5,
0x16b44, 0x16fe2, 0x1bc9f, 0x1e95e, 0x1e95f
#endif
};
#define NUM_PUNCT_CHAR (sizeof(punctCharTable)/sizeof(chr))
/*
* Unicode: white space characters.
|
| ︙ | ︙ | |||
409 410 411 412 413 414 415 |
* Unicode: lowercase characters.
*/
static const crange lowerRangeTable[] = {
{0x61, 0x7a}, {0xdf, 0xf6}, {0xf8, 0xff}, {0x17e, 0x180},
{0x199, 0x19b}, {0x1bd, 0x1bf}, {0x233, 0x239}, {0x24f, 0x293},
{0x295, 0x2af}, {0x37b, 0x37d}, {0x3ac, 0x3ce}, {0x3d5, 0x3d7},
| | | | | | | | | | | | | | | | | | | | 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 |
* Unicode: lowercase characters.
*/
static const crange lowerRangeTable[] = {
{0x61, 0x7a}, {0xdf, 0xf6}, {0xf8, 0xff}, {0x17e, 0x180},
{0x199, 0x19b}, {0x1bd, 0x1bf}, {0x233, 0x239}, {0x24f, 0x293},
{0x295, 0x2af}, {0x37b, 0x37d}, {0x3ac, 0x3ce}, {0x3d5, 0x3d7},
{0x3ef, 0x3f3}, {0x430, 0x45f}, {0x560, 0x588}, {0x10d0, 0x10fa},
{0x10fd, 0x10ff}, {0x13f8, 0x13fd}, {0x1c80, 0x1c88}, {0x1d00, 0x1d2b},
{0x1d6b, 0x1d77}, {0x1d79, 0x1d9a}, {0x1e95, 0x1e9d}, {0x1eff, 0x1f07},
{0x1f10, 0x1f15}, {0x1f20, 0x1f27}, {0x1f30, 0x1f37}, {0x1f40, 0x1f45},
{0x1f50, 0x1f57}, {0x1f60, 0x1f67}, {0x1f70, 0x1f7d}, {0x1f80, 0x1f87},
{0x1f90, 0x1f97}, {0x1fa0, 0x1fa7}, {0x1fb0, 0x1fb4}, {0x1fc2, 0x1fc4},
{0x1fd0, 0x1fd3}, {0x1fe0, 0x1fe7}, {0x1ff2, 0x1ff4}, {0x2146, 0x2149},
{0x2c30, 0x2c5e}, {0x2c76, 0x2c7b}, {0x2d00, 0x2d25}, {0xa72f, 0xa731},
{0xa771, 0xa778}, {0xa793, 0xa795}, {0xab30, 0xab5a}, {0xab60, 0xab67},
{0xab70, 0xabbf}, {0xfb00, 0xfb06}, {0xfb13, 0xfb17}, {0xff41, 0xff5a}
#if CHRBITS > 16
,{0x10428, 0x1044f}, {0x104d8, 0x104fb}, {0x10cc0, 0x10cf2}, {0x118c0, 0x118df},
{0x16e60, 0x16e7f}, {0x1d41a, 0x1d433}, {0x1d44e, 0x1d454}, {0x1d456, 0x1d467},
{0x1d482, 0x1d49b}, {0x1d4b6, 0x1d4b9}, {0x1d4bd, 0x1d4c3}, {0x1d4c5, 0x1d4cf},
{0x1d4ea, 0x1d503}, {0x1d51e, 0x1d537}, {0x1d552, 0x1d56b}, {0x1d586, 0x1d59f},
{0x1d5ba, 0x1d5d3}, {0x1d5ee, 0x1d607}, {0x1d622, 0x1d63b}, {0x1d656, 0x1d66f},
{0x1d68a, 0x1d6a5}, {0x1d6c2, 0x1d6da}, {0x1d6dc, 0x1d6e1}, {0x1d6fc, 0x1d714},
{0x1d716, 0x1d71b}, {0x1d736, 0x1d74e}, {0x1d750, 0x1d755}, {0x1d770, 0x1d788},
{0x1d78a, 0x1d78f}, {0x1d7aa, 0x1d7c2}, {0x1d7c4, 0x1d7c9}, {0x1e922, 0x1e943}
#endif
};
#define NUM_LOWER_RANGE (sizeof(lowerRangeTable)/sizeof(crange))
static const chr lowerCharTable[] = {
0xb5, 0x101, 0x103, 0x105, 0x107, 0x109, 0x10b, 0x10d, 0x10f,
|
| ︙ | ︙ | |||
497 498 499 500 501 502 503 |
0xa691, 0xa693, 0xa695, 0xa697, 0xa699, 0xa69b, 0xa723, 0xa725, 0xa727,
0xa729, 0xa72b, 0xa72d, 0xa733, 0xa735, 0xa737, 0xa739, 0xa73b, 0xa73d,
0xa73f, 0xa741, 0xa743, 0xa745, 0xa747, 0xa749, 0xa74b, 0xa74d, 0xa74f,
0xa751, 0xa753, 0xa755, 0xa757, 0xa759, 0xa75b, 0xa75d, 0xa75f, 0xa761,
0xa763, 0xa765, 0xa767, 0xa769, 0xa76b, 0xa76d, 0xa76f, 0xa77a, 0xa77c,
0xa77f, 0xa781, 0xa783, 0xa785, 0xa787, 0xa78c, 0xa78e, 0xa791, 0xa797,
0xa799, 0xa79b, 0xa79d, 0xa79f, 0xa7a1, 0xa7a3, 0xa7a5, 0xa7a7, 0xa7a9,
| | | > | | | | | | | | | | | | | > | 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 |
0xa691, 0xa693, 0xa695, 0xa697, 0xa699, 0xa69b, 0xa723, 0xa725, 0xa727,
0xa729, 0xa72b, 0xa72d, 0xa733, 0xa735, 0xa737, 0xa739, 0xa73b, 0xa73d,
0xa73f, 0xa741, 0xa743, 0xa745, 0xa747, 0xa749, 0xa74b, 0xa74d, 0xa74f,
0xa751, 0xa753, 0xa755, 0xa757, 0xa759, 0xa75b, 0xa75d, 0xa75f, 0xa761,
0xa763, 0xa765, 0xa767, 0xa769, 0xa76b, 0xa76d, 0xa76f, 0xa77a, 0xa77c,
0xa77f, 0xa781, 0xa783, 0xa785, 0xa787, 0xa78c, 0xa78e, 0xa791, 0xa797,
0xa799, 0xa79b, 0xa79d, 0xa79f, 0xa7a1, 0xa7a3, 0xa7a5, 0xa7a7, 0xa7a9,
0xa7af, 0xa7b5, 0xa7b7, 0xa7b9, 0xa7bb, 0xa7bd, 0xa7bf, 0xa7c3, 0xa7fa
#if CHRBITS > 16
,0x1d4bb, 0x1d7cb
#endif
};
#define NUM_LOWER_CHAR (sizeof(lowerCharTable)/sizeof(chr))
/*
* Unicode: uppercase characters.
*/
static const crange upperRangeTable[] = {
{0x41, 0x5a}, {0xc0, 0xd6}, {0xd8, 0xde}, {0x189, 0x18b},
{0x18e, 0x191}, {0x196, 0x198}, {0x1b1, 0x1b3}, {0x1f6, 0x1f8},
{0x243, 0x246}, {0x388, 0x38a}, {0x391, 0x3a1}, {0x3a3, 0x3ab},
{0x3d2, 0x3d4}, {0x3fd, 0x42f}, {0x531, 0x556}, {0x10a0, 0x10c5},
{0x13a0, 0x13f5}, {0x1c90, 0x1cba}, {0x1cbd, 0x1cbf}, {0x1f08, 0x1f0f},
{0x1f18, 0x1f1d}, {0x1f28, 0x1f2f}, {0x1f38, 0x1f3f}, {0x1f48, 0x1f4d},
{0x1f68, 0x1f6f}, {0x1fb8, 0x1fbb}, {0x1fc8, 0x1fcb}, {0x1fd8, 0x1fdb},
{0x1fe8, 0x1fec}, {0x1ff8, 0x1ffb}, {0x210b, 0x210d}, {0x2110, 0x2112},
{0x2119, 0x211d}, {0x212a, 0x212d}, {0x2130, 0x2133}, {0x2c00, 0x2c2e},
{0x2c62, 0x2c64}, {0x2c6d, 0x2c70}, {0x2c7e, 0x2c80}, {0xa7aa, 0xa7ae},
{0xa7b0, 0xa7b4}, {0xa7c4, 0xa7c6}, {0xff21, 0xff3a}
#if CHRBITS > 16
,{0x10400, 0x10427}, {0x104b0, 0x104d3}, {0x10c80, 0x10cb2}, {0x118a0, 0x118bf},
{0x16e40, 0x16e5f}, {0x1d400, 0x1d419}, {0x1d434, 0x1d44d}, {0x1d468, 0x1d481},
{0x1d4a9, 0x1d4ac}, {0x1d4ae, 0x1d4b5}, {0x1d4d0, 0x1d4e9}, {0x1d507, 0x1d50a},
{0x1d50d, 0x1d514}, {0x1d516, 0x1d51c}, {0x1d53b, 0x1d53e}, {0x1d540, 0x1d544},
{0x1d54a, 0x1d550}, {0x1d56c, 0x1d585}, {0x1d5a0, 0x1d5b9}, {0x1d5d4, 0x1d5ed},
{0x1d608, 0x1d621}, {0x1d63c, 0x1d655}, {0x1d670, 0x1d689}, {0x1d6a8, 0x1d6c0},
{0x1d6e2, 0x1d6fa}, {0x1d71c, 0x1d734}, {0x1d756, 0x1d76e}, {0x1d790, 0x1d7a8},
{0x1e900, 0x1e921}
#endif
};
#define NUM_UPPER_RANGE (sizeof(upperRangeTable)/sizeof(crange))
static const chr upperCharTable[] = {
0x100, 0x102, 0x104, 0x106, 0x108, 0x10a, 0x10c, 0x10e, 0x110,
|
| ︙ | ︙ | |||
596 597 598 599 600 601 602 |
0xa686, 0xa688, 0xa68a, 0xa68c, 0xa68e, 0xa690, 0xa692, 0xa694, 0xa696,
0xa698, 0xa69a, 0xa722, 0xa724, 0xa726, 0xa728, 0xa72a, 0xa72c, 0xa72e,
0xa732, 0xa734, 0xa736, 0xa738, 0xa73a, 0xa73c, 0xa73e, 0xa740, 0xa742,
0xa744, 0xa746, 0xa748, 0xa74a, 0xa74c, 0xa74e, 0xa750, 0xa752, 0xa754,
0xa756, 0xa758, 0xa75a, 0xa75c, 0xa75e, 0xa760, 0xa762, 0xa764, 0xa766,
0xa768, 0xa76a, 0xa76c, 0xa76e, 0xa779, 0xa77b, 0xa77d, 0xa77e, 0xa780,
0xa782, 0xa784, 0xa786, 0xa78b, 0xa78d, 0xa790, 0xa792, 0xa796, 0xa798,
| | > | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | < < < < | | | | | | | | | | > | | | | | | > | | | | > | | | | > | | | | | | | | | | > > | | | | | | | > > | | | | | | | | | < | | | | | | | > < < | 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 |
0xa686, 0xa688, 0xa68a, 0xa68c, 0xa68e, 0xa690, 0xa692, 0xa694, 0xa696,
0xa698, 0xa69a, 0xa722, 0xa724, 0xa726, 0xa728, 0xa72a, 0xa72c, 0xa72e,
0xa732, 0xa734, 0xa736, 0xa738, 0xa73a, 0xa73c, 0xa73e, 0xa740, 0xa742,
0xa744, 0xa746, 0xa748, 0xa74a, 0xa74c, 0xa74e, 0xa750, 0xa752, 0xa754,
0xa756, 0xa758, 0xa75a, 0xa75c, 0xa75e, 0xa760, 0xa762, 0xa764, 0xa766,
0xa768, 0xa76a, 0xa76c, 0xa76e, 0xa779, 0xa77b, 0xa77d, 0xa77e, 0xa780,
0xa782, 0xa784, 0xa786, 0xa78b, 0xa78d, 0xa790, 0xa792, 0xa796, 0xa798,
0xa79a, 0xa79c, 0xa79e, 0xa7a0, 0xa7a2, 0xa7a4, 0xa7a6, 0xa7a8, 0xa7b6,
0xa7b8, 0xa7ba, 0xa7bc, 0xa7be, 0xa7c2
#if CHRBITS > 16
,0x1d49c, 0x1d49e, 0x1d49f, 0x1d4a2, 0x1d4a5, 0x1d4a6, 0x1d504, 0x1d505, 0x1d538,
0x1d539, 0x1d546, 0x1d7ca
#endif
};
#define NUM_UPPER_CHAR (sizeof(upperCharTable)/sizeof(chr))
/*
* Unicode: unicode print characters excluding space.
*/
static const crange graphRangeTable[] = {
{0x21, 0x7e}, {0xa1, 0xac}, {0xae, 0x377}, {0x37a, 0x37f},
{0x384, 0x38a}, {0x38e, 0x3a1}, {0x3a3, 0x52f}, {0x531, 0x556},
{0x559, 0x58a}, {0x58d, 0x58f}, {0x591, 0x5c7}, {0x5d0, 0x5ea},
{0x5ef, 0x5f4}, {0x606, 0x61b}, {0x61e, 0x6dc}, {0x6de, 0x70d},
{0x710, 0x74a}, {0x74d, 0x7b1}, {0x7c0, 0x7fa}, {0x7fd, 0x82d},
{0x830, 0x83e}, {0x840, 0x85b}, {0x860, 0x86a}, {0x8a0, 0x8b4},
{0x8b6, 0x8bd}, {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}, {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, 0xd03}, {0xd05, 0xd0c}, {0xd0e, 0xd10},
{0xd12, 0xd44}, {0xd46, 0xd48}, {0xd4a, 0xd4f}, {0xd54, 0xd63},
{0xd66, 0xd7f}, {0xd85, 0xd96}, {0xd9a, 0xdb1}, {0xdb3, 0xdbb},
{0xdc0, 0xdc6}, {0xdcf, 0xdd4}, {0xdd8, 0xddf}, {0xde6, 0xdef},
{0xdf2, 0xdf4}, {0xe01, 0xe3a}, {0xe3f, 0xe5b}, {0xe86, 0xe8a},
{0xe8c, 0xea3}, {0xea7, 0xebd}, {0xec0, 0xec4}, {0xec8, 0xecd},
{0xed0, 0xed9}, {0xedc, 0xedf}, {0xf00, 0xf47}, {0xf49, 0xf6c},
{0xf71, 0xf97}, {0xf99, 0xfbc}, {0xfbe, 0xfcc}, {0xfce, 0xfda},
{0x1000, 0x10c5}, {0x10d0, 0x1248}, {0x124a, 0x124d}, {0x1250, 0x1256},
{0x125a, 0x125d}, {0x1260, 0x1288}, {0x128a, 0x128d}, {0x1290, 0x12b0},
{0x12b2, 0x12b5}, {0x12b8, 0x12be}, {0x12c2, 0x12c5}, {0x12c8, 0x12d6},
{0x12d8, 0x1310}, {0x1312, 0x1315}, {0x1318, 0x135a}, {0x135d, 0x137c},
{0x1380, 0x1399}, {0x13a0, 0x13f5}, {0x13f8, 0x13fd}, {0x1400, 0x167f},
{0x1681, 0x169c}, {0x16a0, 0x16f8}, {0x1700, 0x170c}, {0x170e, 0x1714},
{0x1720, 0x1736}, {0x1740, 0x1753}, {0x1760, 0x176c}, {0x176e, 0x1770},
{0x1780, 0x17dd}, {0x17e0, 0x17e9}, {0x17f0, 0x17f9}, {0x1800, 0x180d},
{0x1810, 0x1819}, {0x1820, 0x1878}, {0x1880, 0x18aa}, {0x18b0, 0x18f5},
{0x1900, 0x191e}, {0x1920, 0x192b}, {0x1930, 0x193b}, {0x1944, 0x196d},
{0x1970, 0x1974}, {0x1980, 0x19ab}, {0x19b0, 0x19c9}, {0x19d0, 0x19da},
{0x19de, 0x1a1b}, {0x1a1e, 0x1a5e}, {0x1a60, 0x1a7c}, {0x1a7f, 0x1a89},
{0x1a90, 0x1a99}, {0x1aa0, 0x1aad}, {0x1ab0, 0x1abe}, {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}, {0x2b98, 0x2c2e}, {0x2c30, 0x2c5e}, {0x2c60, 0x2cf3},
{0x2cf9, 0x2d25}, {0x2d30, 0x2d67}, {0x2d7f, 0x2d96}, {0x2da0, 0x2da6},
{0x2da8, 0x2dae}, {0x2db0, 0x2db6}, {0x2db8, 0x2dbe}, {0x2dc0, 0x2dc6},
{0x2dc8, 0x2dce}, {0x2dd0, 0x2dd6}, {0x2dd8, 0x2dde}, {0x2de0, 0x2e4f},
{0x2e80, 0x2e99}, {0x2e9b, 0x2ef3}, {0x2f00, 0x2fd5}, {0x2ff0, 0x2ffb},
{0x3001, 0x303f}, {0x3041, 0x3096}, {0x3099, 0x30ff}, {0x3105, 0x312f},
{0x3131, 0x318e}, {0x3190, 0x31ba}, {0x31c0, 0x31e3}, {0x31f0, 0x321e},
{0x3220, 0x4db5}, {0x4dc0, 0x9fef}, {0xa000, 0xa48c}, {0xa490, 0xa4c6},
{0xa4d0, 0xa62b}, {0xa640, 0xa6f7}, {0xa700, 0xa7bf}, {0xa7c2, 0xa7c6},
{0xa7f7, 0xa82b}, {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, 0xab67}, {0xab70, 0xabed}, {0xabf0, 0xabf9}, {0xac00, 0xd7a3},
{0xd7b0, 0xd7c6}, {0xd7cb, 0xd7fb}, {0xf900, 0xfa6d}, {0xfa70, 0xfad9},
{0xfb00, 0xfb06}, {0xfb13, 0xfb17}, {0xfb1d, 0xfb36}, {0xfb38, 0xfb3c},
{0xfb46, 0xfbc1}, {0xfbd3, 0xfd3f}, {0xfd50, 0xfd8f}, {0xfd92, 0xfdc7},
{0xfdf0, 0xfdfd}, {0xfe00, 0xfe19}, {0xfe20, 0xfe52}, {0xfe54, 0xfe66},
{0xfe68, 0xfe6b}, {0xfe70, 0xfe74}, {0xfe76, 0xfefc}, {0xff01, 0xffbe},
{0xffc2, 0xffc7}, {0xffca, 0xffcf}, {0xffd2, 0xffd7}, {0xffda, 0xffdc},
{0xffe0, 0xffe6}, {0xffe8, 0xffee}
#if CHRBITS > 16
,{0x10000, 0x1000b}, {0x1000d, 0x10026}, {0x10028, 0x1003a}, {0x1003f, 0x1004d},
{0x10050, 0x1005d}, {0x10080, 0x100fa}, {0x10100, 0x10102}, {0x10107, 0x10133},
{0x10137, 0x1018e}, {0x10190, 0x1019b}, {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}, {0x10f00, 0x10f27}, {0x10f30, 0x10f59}, {0x10fe0, 0x10ff6},
{0x11000, 0x1104d}, {0x11052, 0x1106f}, {0x1107f, 0x110bc}, {0x110be, 0x110c1},
{0x110d0, 0x110e8}, {0x110f0, 0x110f9}, {0x11100, 0x11134}, {0x11136, 0x11146},
{0x11150, 0x11176}, {0x11180, 0x111cd}, {0x111d0, 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, 0x11459}, {0x1145d, 0x1145f},
{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}, {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, 0x16fe3}, {0x17000, 0x187f7}, {0x18800, 0x18af2},
{0x1b000, 0x1b11e}, {0x1b150, 0x1b152}, {0x1b164, 0x1b167}, {0x1b170, 0x1b2fb},
{0x1bc00, 0x1bc6a}, {0x1bc70, 0x1bc7c}, {0x1bc80, 0x1bc88}, {0x1bc90, 0x1bc99},
{0x1bc9c, 0x1bc9f}, {0x1d000, 0x1d0f5}, {0x1d100, 0x1d126}, {0x1d129, 0x1d172},
{0x1d17b, 0x1d1e8}, {0x1d200, 0x1d245}, {0x1d2e0, 0x1d2f3}, {0x1d300, 0x1d356},
{0x1d360, 0x1d378}, {0x1d400, 0x1d454}, {0x1d456, 0x1d49c}, {0x1d4a9, 0x1d4ac},
{0x1d4ae, 0x1d4b9}, {0x1d4bd, 0x1d4c3}, {0x1d4c5, 0x1d505}, {0x1d507, 0x1d50a},
{0x1d50d, 0x1d514}, {0x1d516, 0x1d51c}, {0x1d51e, 0x1d539}, {0x1d53b, 0x1d53e},
{0x1d540, 0x1d544}, {0x1d54a, 0x1d550}, {0x1d552, 0x1d6a5}, {0x1d6a8, 0x1d7cb},
{0x1d7ce, 0x1da8b}, {0x1da9b, 0x1da9f}, {0x1daa1, 0x1daaf}, {0x1e000, 0x1e006},
{0x1e008, 0x1e018}, {0x1e01b, 0x1e021}, {0x1e026, 0x1e02a}, {0x1e100, 0x1e12c},
{0x1e130, 0x1e13d}, {0x1e140, 0x1e149}, {0x1e2c0, 0x1e2f9}, {0x1e800, 0x1e8c4},
{0x1e8c7, 0x1e8d6}, {0x1e900, 0x1e94b}, {0x1e950, 0x1e959}, {0x1ec71, 0x1ecb4},
{0x1ed01, 0x1ed3d}, {0x1ee00, 0x1ee03}, {0x1ee05, 0x1ee1f}, {0x1ee29, 0x1ee32},
{0x1ee34, 0x1ee37}, {0x1ee4d, 0x1ee4f}, {0x1ee67, 0x1ee6a}, {0x1ee6c, 0x1ee72},
{0x1ee74, 0x1ee77}, {0x1ee79, 0x1ee7c}, {0x1ee80, 0x1ee89}, {0x1ee8b, 0x1ee9b},
{0x1eea1, 0x1eea3}, {0x1eea5, 0x1eea9}, {0x1eeab, 0x1eebb}, {0x1f000, 0x1f02b},
{0x1f030, 0x1f093}, {0x1f0a0, 0x1f0ae}, {0x1f0b1, 0x1f0bf}, {0x1f0c1, 0x1f0cf},
{0x1f0d1, 0x1f0f5}, {0x1f100, 0x1f10c}, {0x1f110, 0x1f16c}, {0x1f170, 0x1f1ac},
{0x1f1e6, 0x1f202}, {0x1f210, 0x1f23b}, {0x1f240, 0x1f248}, {0x1f260, 0x1f265},
{0x1f300, 0x1f6d5}, {0x1f6e0, 0x1f6ec}, {0x1f6f0, 0x1f6fa}, {0x1f700, 0x1f773},
{0x1f780, 0x1f7d8}, {0x1f7e0, 0x1f7eb}, {0x1f800, 0x1f80b}, {0x1f810, 0x1f847},
{0x1f850, 0x1f859}, {0x1f860, 0x1f887}, {0x1f890, 0x1f8ad}, {0x1f900, 0x1f90b},
{0x1f90d, 0x1f971}, {0x1f973, 0x1f976}, {0x1f97a, 0x1f9a2}, {0x1f9a5, 0x1f9aa},
{0x1f9ae, 0x1f9ca}, {0x1f9cd, 0x1fa53}, {0x1fa60, 0x1fa6d}, {0x1fa70, 0x1fa73},
{0x1fa78, 0x1fa7a}, {0x1fa80, 0x1fa82}, {0x1fa90, 0x1fa95}, {0x20000, 0x2a6d6},
{0x2a700, 0x2b734}, {0x2b740, 0x2b81d}, {0x2b820, 0x2cea1}, {0x2ceb0, 0x2ebe0},
{0x2f800, 0x2fa1d}, {0xe0100, 0xe01ef}
#endif
};
#define NUM_GRAPH_RANGE (sizeof(graphRangeTable)/sizeof(crange))
static const chr graphCharTable[] = {
0x38c, 0x85e, 0x98f, 0x990, 0x9b2, 0x9c7, 0x9c8, 0x9d7, 0x9dc,
0x9dd, 0xa0f, 0xa10, 0xa32, 0xa33, 0xa35, 0xa36, 0xa38, 0xa39,
0xa3c, 0xa47, 0xa48, 0xa51, 0xa5e, 0xab2, 0xab3, 0xad0, 0xb0f,
0xb10, 0xb32, 0xb33, 0xb47, 0xb48, 0xb56, 0xb57, 0xb5c, 0xb5d,
0xb82, 0xb83, 0xb99, 0xb9a, 0xb9c, 0xb9e, 0xb9f, 0xba3, 0xba4,
0xbd0, 0xbd7, 0xc55, 0xc56, 0xcd5, 0xcd6, 0xcde, 0xcf1, 0xcf2,
0xd82, 0xd83, 0xdbd, 0xdca, 0xdd6, 0xe81, 0xe82, 0xe84, 0xea5,
0xec6, 0x10c7, 0x10cd, 0x1258, 0x12c0, 0x1772, 0x1773, 0x1940, 0x1f59,
0x1f5b, 0x1f5d, 0x2070, 0x2071, 0x2d27, 0x2d2d, 0x2d6f, 0x2d70, 0xfb3e,
0xfb40, 0xfb41, 0xfb43, 0xfb44, 0xfffc, 0xfffd
#if CHRBITS > 16
,0x1003c, 0x1003d, 0x101a0, 0x1056f, 0x10808, 0x10837, 0x10838, 0x1083c, 0x108f4,
0x108f5, 0x1093f, 0x10a05, 0x10a06, 0x11288, 0x1130f, 0x11310, 0x11332, 0x11333,
0x11347, 0x11348, 0x11350, 0x11357, 0x1145b, 0x118ff, 0x11d08, 0x11d09, 0x11d3a,
0x11d3c, 0x11d3d, 0x11d67, 0x11d68, 0x11d90, 0x11d91, 0x16a6e, 0x16a6f, 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
#endif
};
#define NUM_GRAPH_CHAR (sizeof(graphCharTable)/sizeof(chr))
/*
* End of auto-generated Unicode character ranges declarations.
*/
/*
- element - map collating-element name to celt
^ static celt element(struct vars *, const chr *, const chr *);
*/
static celt
element(
|
| ︙ | ︙ | |||
818 819 820 821 822 823 824 |
NOTE(REG_ULOCALE);
/*
* Search table.
*/
Tcl_DStringInit(&ds);
| | | 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 |
NOTE(REG_ULOCALE);
/*
* Search table.
*/
Tcl_DStringInit(&ds);
np = Tcl_UniCharToUtfDString(startp, len, &ds);
for (cn=cnames; cn->name!=NULL; cn++) {
if (strlen(cn->name)==len && strncmp(cn->name, np, len)==0) {
break; /* NOTE BREAK OUT */
}
}
Tcl_DStringFree(&ds);
if (cn->name != NULL) {
|
| ︙ | ︙ | |||
877 878 879 880 881 882 883 |
nchrs = (b - a + 1)*2 + 4;
cv = getcvec(v, nchrs, 0);
NOERRN();
for (c=a; c<=b; c++) {
addchr(cv, c);
| | | | | 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 |
nchrs = (b - a + 1)*2 + 4;
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);
if (c != lc) {
addchr(cv, lc);
}
if (c != uc) {
addchr(cv, uc);
}
if (c != tc && tc != uc) {
|
| ︙ | ︙ | |||
928 929 930 931 932 933 934 |
/*
* Crude fake equivalence class for testing.
*/
if ((v->cflags®_FAKE) && c == 'x') {
cv = getcvec(v, 4, 0);
| | | | | | > | | 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 |
/*
* Crude fake equivalence class for testing.
*/
if ((v->cflags®_FAKE) && c == 'x') {
cv = getcvec(v, 4, 0);
addchr(cv, 'x');
addchr(cv, 'y');
if (cases) {
addchr(cv, 'X');
addchr(cv, 'Y');
}
return cv;
}
/*
* Otherwise, none.
*/
if (cases) {
return allcases(v, c);
}
cv = getcvec(v, 1, 0);
assert(cv != NULL);
addchr(cv, c);
return cv;
}
/*
- cclass - supply cvec for a character class
* Must include case counterparts on request.
^ static struct cvec *cclass(struct vars *, const chr *, const chr *, int);
*/
static struct cvec *
cclass(
struct vars *v, /* context */
const chr *startp, /* where the name starts */
const chr *endp, /* just past the end of the name */
int cases) /* case-independent? */
{
size_t len;
struct cvec *cv = NULL;
Tcl_DString ds;
const char *np;
const char *const *namePtr;
size_t i;
int index;
/*
* The following arrays define the valid character class names.
*/
static const char *const classNames[] = {
"alnum", "alpha", "ascii", "blank", "cntrl", "digit", "graph",
|
| ︙ | ︙ | |||
990 991 992 993 994 995 996 |
/*
* Extract the class name
*/
len = endp - startp;
Tcl_DStringInit(&ds);
| | | 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 |
/*
* Extract the class name
*/
len = endp - startp;
Tcl_DStringInit(&ds);
np = Tcl_UniCharToUtfDString(startp, len, &ds);
/*
* Map the name to the corresponding enumerated value.
*/
index = -1;
for (namePtr=classNames,i=0 ; *namePtr!=NULL ; namePtr++,i++) {
|
| ︙ | ︙ | |||
1025 1026 1027 1028 1029 1030 1031 |
* Now compute the character class contents.
*/
switch((enum classes) index) {
case CC_ALNUM:
cv = getcvec(v, NUM_ALPHA_CHAR, NUM_DIGIT_RANGE + NUM_ALPHA_RANGE);
if (cv) {
| | | | | | | | | | | | 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 |
* Now compute the character class contents.
*/
switch((enum classes) index) {
case CC_ALNUM:
cv = getcvec(v, NUM_ALPHA_CHAR, NUM_DIGIT_RANGE + NUM_ALPHA_RANGE);
if (cv) {
for (i=0 ; i<NUM_ALPHA_CHAR ; i++) {
addchr(cv, alphaCharTable[i]);
}
for (i=0 ; i<NUM_ALPHA_RANGE ; i++) {
addrange(cv, alphaRangeTable[i].start,
alphaRangeTable[i].end);
}
for (i=0 ; i<NUM_DIGIT_RANGE ; i++) {
addrange(cv, digitRangeTable[i].start,
digitRangeTable[i].end);
}
}
break;
case CC_ALPHA:
cv = getcvec(v, NUM_ALPHA_CHAR, NUM_ALPHA_RANGE);
if (cv) {
for (i=0 ; i<NUM_ALPHA_RANGE ; i++) {
addrange(cv, alphaRangeTable[i].start,
alphaRangeTable[i].end);
}
for (i=0 ; i<NUM_ALPHA_CHAR ; i++) {
addchr(cv, alphaCharTable[i]);
}
}
break;
case CC_ASCII:
cv = getcvec(v, 0, 1);
if (cv) {
addrange(cv, 0, 0x7f);
}
break;
case CC_BLANK:
cv = getcvec(v, 2, 0);
addchr(cv, '\t');
addchr(cv, ' ');
break;
case CC_CNTRL:
cv = getcvec(v, NUM_CONTROL_CHAR, NUM_CONTROL_RANGE);
if (cv) {
for (i=0 ; i<NUM_CONTROL_RANGE ; i++) {
addrange(cv, controlRangeTable[i].start,
controlRangeTable[i].end);
}
for (i=0 ; i<NUM_CONTROL_CHAR ; i++) {
addchr(cv, controlCharTable[i]);
}
}
break;
case CC_DIGIT:
cv = getcvec(v, 0, NUM_DIGIT_RANGE);
if (cv) {
for (i=0 ; i<NUM_DIGIT_RANGE ; i++) {
addrange(cv, digitRangeTable[i].start,
digitRangeTable[i].end);
}
}
break;
case CC_PUNCT:
cv = getcvec(v, NUM_PUNCT_CHAR, NUM_PUNCT_RANGE);
if (cv) {
for (i=0 ; i<NUM_PUNCT_RANGE ; i++) {
addrange(cv, punctRangeTable[i].start,
punctRangeTable[i].end);
}
for (i=0 ; i<NUM_PUNCT_CHAR ; i++) {
addchr(cv, punctCharTable[i]);
}
}
break;
case CC_XDIGIT:
/*
* This is a 3 instead of (NUM_DIGIT_RANGE+2) because I've no idea how
|
| ︙ | ︙ | |||
1114 1115 1116 1117 1118 1119 1120 |
addrange(cv, 'a', 'f');
addrange(cv, 'A', 'F');
}
break;
case CC_SPACE:
cv = getcvec(v, NUM_SPACE_CHAR, NUM_SPACE_RANGE);
if (cv) {
| | | | | | | | | | | | | | 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 |
addrange(cv, 'a', 'f');
addrange(cv, 'A', 'F');
}
break;
case CC_SPACE:
cv = getcvec(v, NUM_SPACE_CHAR, NUM_SPACE_RANGE);
if (cv) {
for (i=0 ; i<NUM_SPACE_RANGE ; i++) {
addrange(cv, spaceRangeTable[i].start,
spaceRangeTable[i].end);
}
for (i=0 ; i<NUM_SPACE_CHAR ; i++) {
addchr(cv, spaceCharTable[i]);
}
}
break;
case CC_LOWER:
cv = getcvec(v, NUM_LOWER_CHAR, NUM_LOWER_RANGE);
if (cv) {
for (i=0 ; i<NUM_LOWER_RANGE ; i++) {
addrange(cv, lowerRangeTable[i].start,
lowerRangeTable[i].end);
}
for (i=0 ; i<NUM_LOWER_CHAR ; i++) {
addchr(cv, lowerCharTable[i]);
}
}
break;
case CC_UPPER:
cv = getcvec(v, NUM_UPPER_CHAR, NUM_UPPER_RANGE);
if (cv) {
for (i=0 ; i<NUM_UPPER_RANGE ; i++) {
addrange(cv, upperRangeTable[i].start,
upperRangeTable[i].end);
}
for (i=0 ; i<NUM_UPPER_CHAR ; i++) {
addchr(cv, upperCharTable[i]);
}
}
break;
case CC_PRINT:
cv = getcvec(v, NUM_SPACE_CHAR + NUM_GRAPH_CHAR, NUM_SPACE_RANGE + NUM_GRAPH_RANGE - 1);
if (cv) {
for (i=1 ; i<NUM_SPACE_RANGE ; i++) {
addrange(cv, spaceRangeTable[i].start,
spaceRangeTable[i].end);
}
for (i=0 ; i<NUM_SPACE_CHAR ; i++) {
addchr(cv, spaceCharTable[i]);
}
for (i=0 ; i<NUM_GRAPH_RANGE ; i++) {
addrange(cv, graphRangeTable[i].start,
graphRangeTable[i].end);
}
for (i=0 ; i<NUM_GRAPH_CHAR ; i++) {
addchr(cv, graphCharTable[i]);
}
}
break;
case CC_GRAPH:
cv = getcvec(v, NUM_GRAPH_CHAR, NUM_GRAPH_RANGE);
if (cv) {
for (i=0 ; i<NUM_GRAPH_RANGE ; i++) {
addrange(cv, graphRangeTable[i].start,
graphRangeTable[i].end);
}
for (i=0 ; i<NUM_GRAPH_CHAR ; i++) {
addchr(cv, graphCharTable[i]);
}
}
break;
}
if (cv == NULL) {
ERR(REG_ESPACE);
|
| ︙ | ︙ | |||
1200 1201 1202 1203 1204 1205 1206 |
struct vars *v, /* context */
pchr pc) /* character to get case equivs of */
{
struct cvec *cv;
chr c = (chr)pc;
chr lc, uc, tc;
| | | | | 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 |
struct vars *v, /* context */
pchr pc) /* character to get case equivs of */
{
struct cvec *cv;
chr c = (chr)pc;
chr lc, uc, tc;
lc = Tcl_UniCharToLower(c);
uc = Tcl_UniCharToUpper(c);
tc = Tcl_UniCharToTitle(c);
if (tc != uc) {
cv = getcvec(v, 3, 0);
addchr(cv, tc);
} else {
cv = getcvec(v, 2, 0);
}
|
| ︙ | ︙ |
Changes to generic/regcomp.c.
| ︙ | ︙ | |||
35 36 37 38 39 40 41 | /* * forward declarations, up here so forward datatypes etc. are defined early */ /* =====^!^===== begin forwards =====^!^===== */ /* automatically gathered by fwd; do not hand-edit */ /* === regcomp.c === */ int compile(regex_t *, const chr *, size_t, int); | | | 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 | /* * forward declarations, up here so forward datatypes etc. are defined early */ /* =====^!^===== begin forwards =====^!^===== */ /* automatically gathered by fwd; do not hand-edit */ /* === regcomp.c === */ int compile(regex_t *, const chr *, size_t, int); static void moresubs(struct vars *, size_t); static int freev(struct vars *, int); static void makesearch(struct vars *, struct nfa *); static struct subre *parse(struct vars *, int, int, struct state *, struct state *); static struct subre *parsebranch(struct vars *, int, int, struct state *, struct state *, int); static void parseqatom(struct vars *, int, int, struct state *, struct state *, struct subre *); static void nonword(struct vars *, int, struct state *, struct state *); static void word(struct vars *, int, struct state *, struct state *); |
| ︙ | ︙ | |||
202 203 204 205 206 207 208 |
const chr *stop; /* end of string */
const chr *savenow; /* saved now and stop for "subroutine call" */
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 */
| | | | 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 |
const chr *stop; /* end of string */
const chr *savenow; /* saved now and stop for "subroutine call" */
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 */
int nextvalue; /* value (if any) of next token */
int lexcon; /* lexical context type (see lex.c) */
int nsubexp; /* subexpression count */
struct subre **subs; /* subRE pointer vector */
int nsubs; /* length of vector */
struct subre *sub10[10]; /* initial vector, enough for most */
struct nfa *nfa; /* the NFA */
struct colormap *cm; /* character color map */
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 */
|
| ︙ | ︙ | |||
283 284 285 286 287 288 289 |
regex_t *re,
const chr *string,
size_t len,
int flags)
{
AllocVars(v);
struct guts *g;
| | < | 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 |
regex_t *re,
const chr *string,
size_t len,
int flags)
{
AllocVars(v);
struct guts *g;
int i, j;
FILE *debug = (flags®_PROGRESS) ? stdout : NULL;
#define CNOERR() { if (ISERR()) return freev(v, v->err); }
/*
* Sanity checks.
*/
|
| ︙ | ︙ | |||
335 336 337 338 339 340 341 |
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 */
| < | 334 335 336 337 338 339 340 341 342 343 344 345 346 347 |
v->cv = NULL;
v->cv2 = NULL;
v->lacons = NULL;
v->nlacons = 0;
v->spaceused = 0;
re->re_magic = REMAGIC;
re->re_info = 0; /* bits get set during parse */
re->re_guts = NULL;
re->re_fns = (void*)(&functions);
/*
* More complex setup, malloced things.
*/
|
| ︙ | ︙ | |||
465 466 467 468 469 470 471 |
assert(v->err == 0);
return freev(v, 0);
}
/*
- moresubs - enlarge subRE vector
| | | | | | | | 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 |
assert(v->err == 0);
return freev(v, 0);
}
/*
- moresubs - enlarge subRE vector
^ static void moresubs(struct vars *, size_t);
*/
static void
moresubs(
struct vars *v,
size_t wanted) /* want enough room for this one */
{
struct subre **p;
int n;
assert(wanted > 0 && wanted >= v->nsubs);
n = wanted * 3 / 2 + 1;
if (v->subs == v->sub10) {
p = (struct subre **) MALLOC(n * sizeof(struct subre *));
if (p != NULL) {
memcpy(p, v->subs, v->nsubs * sizeof(struct subre *));
}
} else {
p = (struct subre **) REALLOC(v->subs, n*sizeof(struct subre *));
}
if (p == NULL) {
ERR(REG_ESPACE);
return;
}
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);
}
/*
- freev - free vars struct's substructures where necessary
* Optionally does error-number setting, and always returns error code (if
* any), to make error-handling code terser.
^ static int freev(struct vars *, int);
|
| ︙ | ︙ | |||
950 951 952 953 954 955 956 |
*/
case '(': /* value flags as capturing or non */
cap = (type == LACON) ? 0 : v->nextvalue;
if (cap) {
v->nsubexp++;
subno = v->nsubexp;
| | | | 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 |
*/
case '(': /* value flags as capturing or non */
cap = (type == LACON) ? 0 : v->nextvalue;
if (cap) {
v->nsubexp++;
subno = v->nsubexp;
if (subno >= v->nsubs) {
moresubs(v, subno);
}
assert(subno < v->nsubs);
} else {
atomtype = PLAIN; /* something that's not '(' */
}
NEXT();
/*
* Need new endpoints because tree will contain pointers.
|
| ︙ | ︙ | |||
2082 2083 2084 2085 2086 2087 2088 |
g = (struct guts *) re->re_guts;
if (g->magic != GUTSMAGIC) {
fprintf(f, "bad guts magic number (0x%x not 0x%x)\n",
g->magic, GUTSMAGIC);
}
fprintf(f, "\n\n\n========= DUMP ==========\n");
| | | | 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 |
g = (struct guts *) re->re_guts;
if (g->magic != GUTSMAGIC) {
fprintf(f, "bad guts magic number (0x%x not 0x%x)\n",
g->magic, GUTSMAGIC);
}
fprintf(f, "\n\n\n========= DUMP ==========\n");
fprintf(f, "nsub %" TCL_Z_MODIFIER "d, info 0%lo, ntree %d\n",
re->re_nsub, re->re_info, g->ntree);
dumpcolors(&g->cmap, f);
if (!NULLCNFA(g->search)) {
fprintf(f, "\nsearch:\n");
dumpcnfa(&g->search, f);
}
for (i = 1; i < g->nlacons; i++) {
|
| ︙ | ︙ |
Changes to generic/regcustom.h.
| ︙ | ︙ | |||
32 33 34 35 36 37 38 | #include "regex.h" /* * Overrides for regguts.h definitions, if any. */ | | | | < < < < | 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 | #include "regex.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) /* * Do not insert extras between the "begin" and "end" lines - this chunk is * automatically extracted to be fitted into regex.h. */ /* --- begin --- */ /* Ensure certain things don't sneak in from system headers. */ #ifdef __REG_WIDE_T #undef __REG_WIDE_T #endif #ifdef __REG_WIDE_COMPILE #undef __REG_WIDE_COMPILE #endif #ifdef __REG_WIDE_EXEC #undef __REG_WIDE_EXEC #endif #ifdef __REG_NOFRONT #undef __REG_NOFRONT #endif #ifdef __REG_NOCHAR #undef __REG_NOCHAR #endif /* Interface types */ #define __REG_WIDE_T Tcl_UniChar /* Names and declarations */ #define __REG_WIDE_COMPILE TclReComp #define __REG_WIDE_EXEC TclReExec #define __REG_NOFRONT /* Don't want regcomp() and regexec() */ #define __REG_NOCHAR /* Or the char versions */ #define regfree TclReFree #define regerror TclReError |
| ︙ | ︙ | |||
87 88 89 90 91 92 93 | typedef int celt; /* Type to hold chr, or NOCELT */ #define NOCELT (-1) /* Celt value which is not valid chr */ #define CHR(c) (UCHAR(c)) /* Turn char literal into chr literal */ #define DIGITVAL(c) ((c)-'0') /* Turn chr digit into its value */ #if TCL_UTF_MAX > 4 #define CHRBITS 32 /* Bits in a chr; must not use sizeof */ #define CHR_MIN 0x00000000 /* Smallest and largest chr; the value */ | | | 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 | typedef int celt; /* Type to hold chr, or NOCELT */ #define NOCELT (-1) /* Celt value which is not valid chr */ #define CHR(c) (UCHAR(c)) /* Turn char literal into chr literal */ #define DIGITVAL(c) ((c)-'0') /* Turn chr digit into its value */ #if TCL_UTF_MAX > 4 #define CHRBITS 32 /* Bits in a chr; must not use sizeof */ #define CHR_MIN 0x00000000 /* Smallest and largest chr; the value */ #define CHR_MAX 0x10ffff /* CHR_MAX-CHR_MIN+1 should fit in uchr */ #else #define CHRBITS 16 /* Bits in a chr; must not use sizeof */ #define CHR_MIN 0x0000 /* Smallest and largest chr; the value */ #define CHR_MAX 0xffff /* CHR_MAX-CHR_MIN+1 should fit in uchr */ #endif /* |
| ︙ | ︙ |
Changes to generic/regerror.c.
| ︙ | ︙ | |||
84 85 86 87 88 89 90 |
if (r->code == icode) {
break;
}
}
if (r->code >= 0) {
msg = r->name;
} else { /* Unknown; tell him the number */
| | | 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 |
if (r->code == icode) {
break;
}
}
if (r->code >= 0) {
msg = r->name;
} else { /* Unknown; tell him the number */
sprintf(convbuf, "REG_%u", icode);
msg = convbuf;
}
break;
default: /* A real, normal error code */
for (r = rerrs; r->code >= 0; r++) {
if (r->code == code) {
break;
|
| ︙ | ︙ |
Changes to generic/regex.h.
| ︙ | ︙ | |||
85 86 87 88 89 90 91 | #endif #ifdef __REG_WIDE_COMPILE #undef __REG_WIDE_COMPILE #endif #ifdef __REG_WIDE_EXEC #undef __REG_WIDE_EXEC #endif | < < < < < < < < < < < < < < < < > < | | | 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 |
#endif
#ifdef __REG_WIDE_COMPILE
#undef __REG_WIDE_COMPILE
#endif
#ifdef __REG_WIDE_EXEC
#undef __REG_WIDE_EXEC
#endif
#ifdef __REG_NOFRONT
#undef __REG_NOFRONT
#endif
#ifdef __REG_NOCHAR
#undef __REG_NOCHAR
#endif
/* interface types */
#define __REG_WIDE_T Tcl_UniChar
/* names and declarations */
#define __REG_WIDE_COMPILE TclReComp
#define __REG_WIDE_EXEC TclReExec
#define __REG_NOFRONT /* don't want regcomp() and regexec() */
#define __REG_NOCHAR /* or the char versions */
#define regfree TclReFree
#define regerror TclReError
/* --- end --- */
/*
* interface types etc.
*/
/*
* other interface types
*/
/* the biggie, a compiled RE (or rather, a front end to same) */
typedef struct {
int re_magic; /* magic number */
long re_info; /* information about RE */
size_t re_nsub; /* number of subexpressions */
#define REG_UBACKREF 000001
#define REG_ULOOKAHEAD 000002
#define REG_UBOUNDS 000004
#define REG_UBRACES 000010
#define REG_UBSALNUM 000020
#define REG_UPBOTCH 000040
#define REG_UBBS 000100
#define REG_UNONPOSIX 000200
#define REG_UUNSPEC 000400
#define REG_UUNPORT 001000
#define REG_ULOCALE 002000
#define REG_UEMPTYMATCH 004000
#define REG_UIMPOSSIBLE 010000
#define REG_USHORTEST 020000
char *re_endp; /* backward compatibility kludge */
/* the rest is opaque pointers to hidden innards */
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 */
} regmatch_t;
/* supplementary control and reporting */
typedef struct {
regmatch_t rm_extend; /* see REG_EXPECT */
} rm_detail_t;
|
| ︙ | ︙ |
Changes to generic/regexec.c.
| ︙ | ︙ | |||
168 169 170 171 172 173 174 |
rm_detail_t *details,
size_t nmatch,
regmatch_t pmatch[],
int flags)
{
AllocVars(v);
int st, backref;
| | | < < < < | 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 |
rm_detail_t *details,
size_t nmatch,
regmatch_t pmatch[],
int flags)
{
AllocVars(v);
int st, backref;
int n;
int i;
#define LOCALMAT 20
regmatch_t mat[LOCALMAT];
#define LOCALDFAS 40
struct dfa *subdfas[LOCALDFAS];
/*
* Sanity checks.
*/
if (re == NULL || string == NULL || re->re_magic != REMAGIC) {
FreeVars(v);
return REG_INVARG;
}
/*
* Setup.
*/
v->re = re;
v->g = (struct guts *)re->re_guts;
|
| ︙ | ︙ | |||
232 233 234 235 236 237 238 |
v->pmatch = pmatch;
}
v->details = details;
v->start = (chr *)string;
v->stop = (chr *)string + len;
v->err = 0;
assert(v->g->ntree >= 0);
| | | 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 |
v->pmatch = pmatch;
}
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);
|
| ︙ | ︙ | |||
274 275 276 277 278 279 280 |
/*
* Clean up.
*/
if (v->pmatch != pmatch && v->pmatch != mat) {
FREE(v->pmatch);
}
| | | 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 |
/*
* 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->subdfas != subdfas)
FREE(v->subdfas);
FreeVars(v);
|
| ︙ | ︙ | |||
885 886 887 888 889 890 891 |
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 */
| | | 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 |
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) {
|
| ︙ | ︙ |
Changes to generic/tcl.decls.
| ︙ | ︙ | |||
38 39 40 41 42 43 44 |
const char *name, const char *version, int exact,
void *clientDataPtr)
}
declare 2 {
TCL_NORETURN void Tcl_Panic(const char *format, ...)
}
declare 3 {
| | | | | | | | | | 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 |
const char *name, const char *version, int exact,
void *clientDataPtr)
}
declare 2 {
TCL_NORETURN void Tcl_Panic(const char *format, ...)
}
declare 3 {
void *Tcl_Alloc(size_t size)
}
declare 4 {
void Tcl_Free(void *ptr)
}
declare 5 {
void *Tcl_Realloc(void *ptr, size_t size)
}
declare 6 {
void *Tcl_DbCkalloc(size_t size, const char *file, int line)
}
declare 7 {
void Tcl_DbCkfree(void *ptr, const char *file, int line)
}
declare 8 {
void *Tcl_DbCkrealloc(void *ptr, size_t 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)
}
declare 10 unix {
void Tcl_DeleteFileHandler(int fd)
}
declare 11 {
void Tcl_SetTimer(const Tcl_Time *timePtr)
}
declare 12 {
void Tcl_Sleep(int ms)
}
declare 13 {
int Tcl_WaitForEvent(const Tcl_Time *timePtr)
}
declare 14 {
int Tcl_AppendAllObjTypes(Tcl_Interp *interp, Tcl_Obj *objPtr)
}
declare 15 {
void Tcl_AppendStringsToObj(Tcl_Obj *objPtr, ...)
}
declare 16 {
void Tcl_AppendToObj(Tcl_Obj *objPtr, const char *bytes, size_t 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)
|
| ︙ | ︙ | |||
107 108 109 110 111 112 113 |
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 23 {
| | | > | | < > | | | 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 |
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 23 {
Tcl_Obj *Tcl_DbNewByteArrayObj(const unsigned char *bytes, size_t length,
const char *file, int line)
}
declare 24 {
Tcl_Obj *Tcl_DbNewDoubleObj(double doubleValue, const char *file,
int line)
}
declare 25 {
Tcl_Obj *Tcl_DbNewListObj(int objc, Tcl_Obj *const *objv,
const char *file, int line)
}
# Removed in 9.0 (changed to macro):
#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,
const char *file, int line)
}
declare 29 {
Tcl_Obj *Tcl_DuplicateObj(Tcl_Obj *objPtr)
}
# Removed in 9.0
#declare 30 {
# void TclFreeObj(Tcl_Obj *objPtr)
#}
declare 31 {
int Tcl_GetBoolean(Tcl_Interp *interp, const char *src, int *boolPtr)
}
declare 32 {
int Tcl_GetBooleanFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
int *boolPtr)
}
declare 33 {
unsigned char *Tcl_GetByteArrayFromObj(Tcl_Obj *objPtr, int *lengthPtr)
}
declare 34 {
int Tcl_GetDouble(Tcl_Interp *interp, const char *src, double *doublePtr)
}
declare 35 {
int Tcl_GetDoubleFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
double *doublePtr)
}
# Removed in 9.0, replaced by macro.
#declare 36 {deprecated {No longer in use, changed to macro}} {
# int Tcl_GetIndexFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
# const char *const *tablePtr, const char *msg, int flags, int *indexPtr)
#}
declare 37 {
int Tcl_GetInt(Tcl_Interp *interp, const char *src, int *intPtr)
}
declare 38 {
|
| ︙ | ︙ | |||
204 205 206 207 208 209 210 |
int count, int objc, Tcl_Obj *const objv[])
}
# Removed in 9.0 (changed to macro):
#declare 49 {
# Tcl_Obj *Tcl_NewBooleanObj(int boolValue)
#}
declare 50 {
| | | | | | | | | > | | > | | < > | | | | | | | | | | | | | | | | | | | | 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 |
int count, int objc, Tcl_Obj *const objv[])
}
# Removed in 9.0 (changed to macro):
#declare 49 {
# Tcl_Obj *Tcl_NewBooleanObj(int boolValue)
#}
declare 50 {
Tcl_Obj *Tcl_NewByteArrayObj(const unsigned char *bytes, size_t 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 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 55 {
Tcl_Obj *Tcl_NewObj(void)
}
declare 56 {
Tcl_Obj *Tcl_NewStringObj(const char *bytes, size_t length)
}
# Removed in 9.0 (changed to macro):
#declare 57 {
# void Tcl_SetBooleanObj(Tcl_Obj *objPtr, int boolValue)
#}
declare 58 {
unsigned char *Tcl_SetByteArrayLength(Tcl_Obj *objPtr, size_t length)
}
declare 59 {
void Tcl_SetByteArrayObj(Tcl_Obj *objPtr, const unsigned char *bytes,
size_t length)
}
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 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 64 {
void Tcl_SetObjLength(Tcl_Obj *objPtr, size_t length)
}
declare 65 {
void Tcl_SetStringObj(Tcl_Obj *objPtr, const char *bytes, size_t length)
}
# Removed in 9.0, replaced by macro.
#declare 66 {deprecated {No longer in use, changed to macro}} {
# void Tcl_AddErrorInfo(Tcl_Interp *interp, const char *message)
#}
# Removed in 9.0, replaced by macro.
#declare 67 {deprecated {No longer in use, changed to macro}} {
# void Tcl_AddObjErrorInfo(Tcl_Interp *interp, const char *message,
# int length)
#}
declare 68 {
void Tcl_AllowExceptions(Tcl_Interp *interp)
}
declare 69 {
void Tcl_AppendElement(Tcl_Interp *interp, const char *element)
}
declare 70 {
void Tcl_AppendResult(Tcl_Interp *interp, ...)
}
declare 71 {
Tcl_AsyncHandler Tcl_AsyncCreate(Tcl_AsyncProc *proc,
void *clientData)
}
declare 72 {
void Tcl_AsyncDelete(Tcl_AsyncHandler async)
}
declare 73 {
int Tcl_AsyncInvoke(Tcl_Interp *interp, int code)
}
declare 74 {
void Tcl_AsyncMark(Tcl_AsyncHandler async)
}
declare 75 {
int Tcl_AsyncReady(void)
}
# Removed in 9.0
#declare 76 {deprecated {No longer in use, changed to macro}} {
# void Tcl_BackgroundError(Tcl_Interp *interp)
#}
# Removed in 9.0:
#declare 77 {deprecated {Use Tcl_UtfBackslash}} {
# char Tcl_Backslash(const char *src, int *readPtr)
#}
declare 78 {
int Tcl_BadChannelOption(Tcl_Interp *interp, const char *optionName,
const char *optionList)
}
declare 79 {
void Tcl_CallWhenDeleted(Tcl_Interp *interp, Tcl_InterpDeleteProc *proc,
void *clientData)
}
declare 80 {
void Tcl_CancelIdleCall(Tcl_IdleProc *idleProc, void *clientData)
}
declare 81 {
int Tcl_Close(Tcl_Interp *interp, Tcl_Channel chan)
}
declare 82 {
int Tcl_CommandComplete(const char *cmd)
}
declare 83 {
char *Tcl_Concat(int argc, const char *const *argv)
}
declare 84 {
size_t Tcl_ConvertElement(const char *src, char *dst, int flags)
}
declare 85 {
size_t Tcl_ConvertCountedElement(const char *src, size_t length, char *dst,
int flags)
}
declare 86 {
int Tcl_CreateAlias(Tcl_Interp *slave, const char *slaveCmd,
Tcl_Interp *target, const char *targetCmd, int argc,
const char *const *argv)
}
declare 87 {
int Tcl_CreateAliasObj(Tcl_Interp *slave, const char *slaveCmd,
Tcl_Interp *target, const char *targetCmd, int objc,
Tcl_Obj *const objv[])
}
declare 88 {
Tcl_Channel Tcl_CreateChannel(const Tcl_ChannelType *typePtr,
const char *chanName, void *instanceData, int mask)
}
declare 89 {
void Tcl_CreateChannelHandler(Tcl_Channel chan, int mask,
Tcl_ChannelProc *proc, void *clientData)
}
declare 90 {
void Tcl_CreateCloseHandler(Tcl_Channel chan, Tcl_CloseProc *proc,
void *clientData)
}
declare 91 {
Tcl_Command Tcl_CreateCommand(Tcl_Interp *interp, const char *cmdName,
Tcl_CmdProc *proc, void *clientData,
Tcl_CmdDeleteProc *deleteProc)
}
declare 92 {
void Tcl_CreateEventSource(Tcl_EventSetupProc *setupProc,
Tcl_EventCheckProc *checkProc, void *clientData)
}
declare 93 {
void Tcl_CreateExitHandler(Tcl_ExitProc *proc, void *clientData)
}
declare 94 {
Tcl_Interp *Tcl_CreateInterp(void)
}
# Removed in 9.0:
#declare 95 {deprecated {}} {
# void Tcl_CreateMathFunc(Tcl_Interp *interp, const char *name,
# int numArgs, Tcl_ValueType *argTypes,
# Tcl_MathProc *proc, void *clientData)
#}
declare 96 {
Tcl_Command Tcl_CreateObjCommand(Tcl_Interp *interp,
const char *cmdName,
Tcl_ObjCmdProc *proc, void *clientData,
Tcl_CmdDeleteProc *deleteProc)
}
declare 97 {
Tcl_Interp *Tcl_CreateSlave(Tcl_Interp *interp, const char *slaveName,
int isSafe)
}
declare 98 {
Tcl_TimerToken Tcl_CreateTimerHandler(int milliseconds,
Tcl_TimerProc *proc, void *clientData)
}
declare 99 {
Tcl_Trace Tcl_CreateTrace(Tcl_Interp *interp, int level,
Tcl_CmdTraceProc *proc, void *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)
}
declare 102 {
void Tcl_DeleteCloseHandler(Tcl_Channel chan, Tcl_CloseProc *proc,
void *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)
}
declare 106 {
void Tcl_DeleteEventSource(Tcl_EventSetupProc *setupProc,
Tcl_EventCheckProc *checkProc, void *clientData)
}
declare 107 {
void Tcl_DeleteExitHandler(Tcl_ExitProc *proc, void *clientData)
}
declare 108 {
void Tcl_DeleteHashEntry(Tcl_HashEntry *entryPtr)
}
declare 109 {
void Tcl_DeleteHashTable(Tcl_HashTable *tablePtr)
}
|
| ︙ | ︙ | |||
432 433 434 435 436 437 438 |
void Tcl_DeleteTimerHandler(Tcl_TimerToken token)
}
declare 113 {
void Tcl_DeleteTrace(Tcl_Interp *interp, Tcl_Trace trace)
}
declare 114 {
void Tcl_DontCallWhenDeleted(Tcl_Interp *interp,
| | | | | | | | 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 |
void Tcl_DeleteTimerHandler(Tcl_TimerToken token)
}
declare 113 {
void Tcl_DeleteTrace(Tcl_Interp *interp, Tcl_Trace trace)
}
declare 114 {
void Tcl_DontCallWhenDeleted(Tcl_Interp *interp,
Tcl_InterpDeleteProc *proc, void *clientData)
}
declare 115 {
int Tcl_DoOneEvent(int flags)
}
declare 116 {
void Tcl_DoWhenIdle(Tcl_IdleProc *proc, void *clientData)
}
declare 117 {
char *Tcl_DStringAppend(Tcl_DString *dsPtr, const char *bytes, size_t length)
}
declare 118 {
char *Tcl_DStringAppendElement(Tcl_DString *dsPtr, const char *element)
}
declare 119 {
void Tcl_DStringEndSublist(Tcl_DString *dsPtr)
}
declare 120 {
void Tcl_DStringFree(Tcl_DString *dsPtr)
}
declare 121 {
void Tcl_DStringGetResult(Tcl_Interp *interp, Tcl_DString *dsPtr)
}
declare 122 {
void Tcl_DStringInit(Tcl_DString *dsPtr)
}
declare 123 {
void Tcl_DStringResult(Tcl_Interp *interp, Tcl_DString *dsPtr)
}
declare 124 {
void Tcl_DStringSetLength(Tcl_DString *dsPtr, size_t length)
}
declare 125 {
void Tcl_DStringStartSublist(Tcl_DString *dsPtr)
}
declare 126 {
int Tcl_Eof(Tcl_Channel chan)
}
declare 127 {
const char *Tcl_ErrnoId(void)
}
declare 128 {
const char *Tcl_ErrnoMsg(int err)
}
# Removed in 9.0, replaced by macro.
#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 132 {
void Tcl_EventuallyFree(void *clientData, Tcl_FreeProc *freeProc)
}
declare 133 {
TCL_NORETURN void Tcl_Exit(int status)
}
declare 134 {
int Tcl_ExposeCommand(Tcl_Interp *interp, const char *hiddenCmdToken,
const char *cmdName)
|
| ︙ | ︙ | |||
525 526 527 528 529 530 531 |
}
declare 142 {
int Tcl_ExprString(Tcl_Interp *interp, const char *expr)
}
declare 143 {
void Tcl_Finalize(void)
}
| | | 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 |
}
declare 142 {
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 145 {
Tcl_HashEntry *Tcl_FirstHashEntry(Tcl_HashTable *tablePtr,
Tcl_HashSearch *searchPtr)
}
|
| ︙ | ︙ | |||
550 551 552 553 554 555 556 |
}
declare 149 {
int Tcl_GetAliasObj(Tcl_Interp *interp, const char *slaveCmd,
Tcl_Interp **targetInterpPtr, const char **targetCmdPtr,
int *objcPtr, Tcl_Obj ***objv)
}
declare 150 {
| | | | | 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 |
}
declare 149 {
int Tcl_GetAliasObj(Tcl_Interp *interp, const char *slaveCmd,
Tcl_Interp **targetInterpPtr, const char **targetCmdPtr,
int *objcPtr, Tcl_Obj ***objv)
}
declare 150 {
void *Tcl_GetAssocData(Tcl_Interp *interp, const char *name,
Tcl_InterpDeleteProc **procPtr)
}
declare 151 {
Tcl_Channel Tcl_GetChannel(Tcl_Interp *interp, const char *chanName,
int *modePtr)
}
declare 152 {
int Tcl_GetChannelBufferSize(Tcl_Channel chan)
}
declare 153 {
int Tcl_GetChannelHandle(Tcl_Channel chan, int direction,
void **handlePtr)
}
declare 154 {
void *Tcl_GetChannelInstanceData(Tcl_Channel chan)
}
declare 155 {
int Tcl_GetChannelMode(Tcl_Channel chan)
}
declare 156 {
const char *Tcl_GetChannelName(Tcl_Channel chan)
}
|
| ︙ | ︙ | |||
612 613 614 615 616 617 618 |
}
# Tcl_GetOpenFile is only available on unix, but it is a part of the old
# generic interface, so we inlcude it here for compatibility reasons.
declare 167 unix {
int Tcl_GetOpenFile(Tcl_Interp *interp, const char *chanID, int forWriting,
| | | | > | | < > | | | | 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 |
}
# Tcl_GetOpenFile is only available on unix, but it is a part of the old
# 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)
}
# 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)
}
declare 170 {
size_t Tcl_GetsObj(Tcl_Channel chan, Tcl_Obj *objPtr)
}
declare 171 {
int Tcl_GetServiceMode(void)
}
declare 172 {
Tcl_Interp *Tcl_GetSlave(Tcl_Interp *interp, const char *slaveName)
}
declare 173 {
Tcl_Channel Tcl_GetStdChannel(int type)
}
# 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 {deprecated {No longer in use, changed to macro}} {
# const char *Tcl_GetVar(Tcl_Interp *interp, const char *varName,
# int flags)
#}
declare 176 {
const char *Tcl_GetVar2(Tcl_Interp *interp, const char *part1,
const char *part2, int flags)
}
# 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)
#}
|
| ︙ | ︙ | |||
682 683 684 685 686 687 688 |
}
# Obsolete, use Tcl_FSJoinPath
declare 186 {
char *Tcl_JoinPath(int argc, const char *const *argv,
Tcl_DString *resultPtr)
}
declare 187 {
| | | | | 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 |
}
# Obsolete, use Tcl_FSJoinPath
declare 186 {
char *Tcl_JoinPath(int argc, const char *const *argv,
Tcl_DString *resultPtr)
}
declare 187 {
int Tcl_LinkVar(Tcl_Interp *interp, const char *varName, void *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)
}
declare 190 {
int Tcl_MakeSafe(Tcl_Interp *interp)
}
declare 191 {
Tcl_Channel Tcl_MakeTcpClientChannel(void *tcpSocket)
}
declare 192 {
char *Tcl_Merge(int argc, const char *const *argv)
}
declare 193 {
Tcl_HashEntry *Tcl_NextHashEntry(Tcl_HashSearch *searchPtr)
}
|
| ︙ | ︙ | |||
733 734 735 736 737 738 739 |
declare 199 {
Tcl_Channel Tcl_OpenTcpClient(Tcl_Interp *interp, int port,
const char *address, const char *myaddr, int myport, int async)
}
declare 200 {
Tcl_Channel Tcl_OpenTcpServer(Tcl_Interp *interp, int port,
const char *host, Tcl_TcpAcceptProc *acceptProc,
| | | | | 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 |
declare 199 {
Tcl_Channel Tcl_OpenTcpClient(Tcl_Interp *interp, int port,
const char *address, const char *myaddr, int myport, int async)
}
declare 200 {
Tcl_Channel Tcl_OpenTcpServer(Tcl_Interp *interp, int port,
const char *host, Tcl_TcpAcceptProc *acceptProc,
void *callbackData)
}
declare 201 {
void Tcl_Preserve(void *data)
}
declare 202 {
void Tcl_PrintDouble(Tcl_Interp *interp, double value, char *dst)
}
declare 203 {
int Tcl_PutEnv(const char *assignment)
}
declare 204 {
const char *Tcl_PosixError(Tcl_Interp *interp)
}
declare 205 {
void Tcl_QueueEvent(Tcl_Event *evPtr, Tcl_QueuePosition position)
}
declare 206 {
size_t Tcl_Read(Tcl_Channel chan, char *bufPtr, size_t toRead)
}
declare 207 {
void Tcl_ReapDetachedProcs(void)
}
declare 208 {
int Tcl_RecordAndEval(Tcl_Interp *interp, const char *cmd, int flags)
}
|
| ︙ | ︙ | |||
780 781 782 783 784 785 786 |
const char *text, const char *start)
}
declare 214 {
int Tcl_RegExpMatch(Tcl_Interp *interp, const char *text,
const char *pattern)
}
declare 215 {
| | | | | | | 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 |
const char *text, const char *start)
}
declare 214 {
int Tcl_RegExpMatch(Tcl_Interp *interp, const char *text,
const char *pattern)
}
declare 215 {
void Tcl_RegExpRange(Tcl_RegExp regexp, size_t index,
const char **startPtr, const char **endPtr)
}
declare 216 {
void Tcl_Release(void *clientData)
}
declare 217 {
void Tcl_ResetResult(Tcl_Interp *interp)
}
declare 218 {
size_t Tcl_ScanElement(const char *src, int *flagPtr)
}
declare 219 {
size_t Tcl_ScanCountedElement(const char *src, size_t length, int *flagPtr)
}
# Removed in 9.0:
#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)
}
declare 224 {
void Tcl_SetChannelBufferSize(Tcl_Channel chan, int sz)
}
declare 225 {
int Tcl_SetChannelOption(Tcl_Interp *interp, Tcl_Channel chan,
const char *optionName, const char *newValue)
|
| ︙ | ︙ | |||
829 830 831 832 833 834 835 |
}
declare 228 {
void Tcl_SetErrorCode(Tcl_Interp *interp, ...)
}
declare 229 {
void Tcl_SetMaxBlockTime(const Tcl_Time *timePtr)
}
| | | | | | | 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 |
}
declare 228 {
void Tcl_SetErrorCode(Tcl_Interp *interp, ...)
}
declare 229 {
void Tcl_SetMaxBlockTime(const Tcl_Time *timePtr)
}
# Removed in 9.0 (stub entry only)
#declare 230 {
# void Tcl_SetPanicProc(TCL_NORETURN1 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 233 {
int Tcl_SetServiceMode(int mode)
}
declare 234 {
void Tcl_SetObjErrorCode(Tcl_Interp *interp, Tcl_Obj *errorObjPtr)
}
declare 235 {
void Tcl_SetObjResult(Tcl_Interp *interp, Tcl_Obj *resultObjPtr)
}
declare 236 {
void Tcl_SetStdChannel(Tcl_Channel channel, int type)
}
# Removed in 9.0, replaced by macro.
#declare 237 {deprecated {No longer in use, changed to macro}} {
# const char *Tcl_SetVar(Tcl_Interp *interp, const char *varName,
# const char *newValue, int flags)
#}
declare 238 {
const char *Tcl_SetVar2(Tcl_Interp *interp, const char *part1,
const char *part2, const char *newValue, int flags)
}
|
| ︙ | ︙ | |||
879 880 881 882 883 884 885 |
int Tcl_SplitList(Tcl_Interp *interp, const char *listStr, int *argcPtr,
const char ***argvPtr)
}
# Obsolete, use Tcl_FSSplitPath
declare 243 {
void Tcl_SplitPath(const char *path, int *argcPtr, const char ***argvPtr)
}
| > | | | < > > | | < > | | | | | | | | | | | | | | | | | | 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 |
int Tcl_SplitList(Tcl_Interp *interp, const char *listStr, int *argcPtr,
const char ***argvPtr)
}
# Obsolete, use Tcl_FSSplitPath
declare 243 {
void Tcl_SplitPath(const char *path, int *argcPtr, const char ***argvPtr)
}
# 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 {deprecated {No longer in use, changed to macro}} {
# int Tcl_TraceVar(Tcl_Interp *interp, const char *varName, int flags,
# Tcl_VarTraceProc *proc, ClientData clientData)
#}
declare 248 {
int Tcl_TraceVar2(Tcl_Interp *interp, const char *part1, const char *part2,
int flags, Tcl_VarTraceProc *proc, void *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)
}
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 {deprecated {No longer in use, changed to macro}} {
# int Tcl_UnsetVar(Tcl_Interp *interp, const char *varName, int flags)
#}
declare 254 {
int Tcl_UnsetVar2(Tcl_Interp *interp, const char *part1, const char *part2,
int flags)
}
# Removed in 9.0, replaced by macro.
#declare 255 {deprecated {No longer in use, changed to macro}} {
# void Tcl_UntraceVar(Tcl_Interp *interp, const char *varName, int flags,
# Tcl_VarTraceProc *proc, ClientData clientData)
#}
declare 256 {
void Tcl_UntraceVar2(Tcl_Interp *interp, const char *part1,
const char *part2, int flags, Tcl_VarTraceProc *proc,
void *clientData)
}
declare 257 {
void Tcl_UpdateLinkedVar(Tcl_Interp *interp, const char *varName)
}
# Removed in 9.0, replaced by macro.
#declare 258 {deprecated {No longer in use, changed to macro}} {
# int Tcl_UpVar(Tcl_Interp *interp, const char *frameName,
# const char *varName, const char *localName, int flags)
#}
declare 259 {
int Tcl_UpVar2(Tcl_Interp *interp, const char *frameName, const char *part1,
const char *part2, const char *localName, int flags)
}
# Removed in 9.0, replaced by macro.
#declare 260 {
# int Tcl_VarEval(Tcl_Interp *interp, ...)
#}
# Removed in 9.0, replaced by macro.
#declare 261 {deprecated {No longer in use, changed to macro}} {
# ClientData Tcl_VarTraceInfo(Tcl_Interp *interp, const char *varName,
# int flags, Tcl_VarTraceProc *procPtr, ClientData prevClientData)
#}
declare 262 {
void *Tcl_VarTraceInfo2(Tcl_Interp *interp, const char *part1,
const char *part2, int flags, Tcl_VarTraceProc *procPtr,
void *prevClientData)
}
declare 263 {
size_t Tcl_Write(Tcl_Channel chan, const char *s, size_t slen)
}
declare 264 {
void Tcl_WrongNumArgs(Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[], const char *message)
}
declare 265 {
int Tcl_DumpActiveMemory(const char *fileName)
|
| ︙ | ︙ | |||
984 985 986 987 988 989 990 |
declare 269 {
char *Tcl_HashStats(Tcl_HashTable *tablePtr)
}
declare 270 {
const char *Tcl_ParseVar(Tcl_Interp *interp, const char *start,
const char **termPtr)
}
| | | | | | | < > | | | 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 |
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 {deprecated {No longer in use, changed to macro}} {
# const char *Tcl_PkgPresent(Tcl_Interp *interp, const char *name,
# const char *version, int exact)
#}
declare 272 {
const char *Tcl_PkgPresentEx(Tcl_Interp *interp,
const char *name, const char *version, int exact,
void *clientDataPtr)
}
# Removed in 9.0, replaced by macro.
#declare 273 {deprecated {No longer in use, changed to macro}} {
# int Tcl_PkgProvide(Tcl_Interp *interp, const char *name,
# const char *version)
#}
# TIP #268: The internally used new Require function is in slot 573.
# Removed in 9.0, replaced by macro.
#declare 274 {deprecated {No longer in use, changed to macro}} {
# const char *Tcl_PkgRequire(Tcl_Interp *interp, const char *name,
# const char *version, int exact)
#}
# Removed in 9.0:
#declare 275 {
# void Tcl_SetErrorCodeVA(Tcl_Interp *interp, va_list argList)
#}
|
| ︙ | ︙ | |||
1043 1044 1045 1046 1047 1048 1049 |
# to the alphabetical order used elsewhere in this file, but I decided
# against that to ease the maintenance of the patch across new tcl versions
# (patch usually has no problems to integrate the patch file for the last
# version into the new one).
declare 281 {
Tcl_Channel Tcl_StackChannel(Tcl_Interp *interp,
| | | 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 |
# to the alphabetical order used elsewhere in this file, but I decided
# against that to ease the maintenance of the patch across new tcl versions
# (patch usually has no problems to integrate the patch file for the last
# version into the new one).
declare 281 {
Tcl_Channel Tcl_StackChannel(Tcl_Interp *interp,
const Tcl_ChannelType *typePtr, void *instanceData,
int mask, Tcl_Channel prevChan)
}
declare 282 {
int Tcl_UnstackChannel(Tcl_Interp *interp, Tcl_Channel chan)
}
declare 283 {
Tcl_Channel Tcl_GetStackedChannel(Tcl_Channel chan)
|
| ︙ | ︙ | |||
1071 1072 1073 1074 1075 1076 1077 |
declare 286 {
void Tcl_AppendObjToObj(Tcl_Obj *objPtr, Tcl_Obj *appendObjPtr)
}
declare 287 {
Tcl_Encoding Tcl_CreateEncoding(const Tcl_EncodingType *typePtr)
}
declare 288 {
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 |
declare 286 {
void Tcl_AppendObjToObj(Tcl_Obj *objPtr, Tcl_Obj *appendObjPtr)
}
declare 287 {
Tcl_Encoding Tcl_CreateEncoding(const Tcl_EncodingType *typePtr)
}
declare 288 {
void Tcl_CreateThreadExitHandler(Tcl_ExitProc *proc, void *clientData)
}
declare 289 {
void Tcl_DeleteThreadExitHandler(Tcl_ExitProc *proc, void *clientData)
}
# Removed in 9.0, replaced by macro.
#declare 290 {
# void Tcl_DiscardResult(Tcl_SavedResult *statePtr)
#}
declare 291 {
int Tcl_EvalEx(Tcl_Interp *interp, const char *script, size_t numBytes,
int flags)
}
declare 292 {
int Tcl_EvalObjv(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[],
int flags)
}
declare 293 {
int Tcl_EvalObjEx(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags)
}
declare 294 {
TCL_NORETURN void Tcl_ExitThread(int status)
}
declare 295 {
int Tcl_ExternalToUtf(Tcl_Interp *interp, Tcl_Encoding encoding,
const char *src, size_t srcLen, int flags,
Tcl_EncodingState *statePtr, char *dst, size_t dstLen,
int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr)
}
declare 296 {
char *Tcl_ExternalToUtfDString(Tcl_Encoding encoding,
const char *src, size_t srcLen, Tcl_DString *dsPtr)
}
declare 297 {
void Tcl_FinalizeThread(void)
}
declare 298 {
void Tcl_FinalizeNotifier(void *clientData)
}
declare 299 {
void Tcl_FreeEncoding(Tcl_Encoding encoding)
}
declare 300 {
Tcl_ThreadId Tcl_GetCurrentThread(void)
}
declare 301 {
Tcl_Encoding Tcl_GetEncoding(Tcl_Interp *interp, const char *name)
}
declare 302 {
const char *Tcl_GetEncodingName(Tcl_Encoding encoding)
}
declare 303 {
void Tcl_GetEncodingNames(Tcl_Interp *interp)
}
declare 304 {
int Tcl_GetIndexFromObjStruct(Tcl_Interp *interp, Tcl_Obj *objPtr,
const void *tablePtr, size_t offset, const char *msg, int flags,
int *indexPtr)
}
declare 305 {
void *Tcl_GetThreadData(Tcl_ThreadDataKey *keyPtr, size_t size)
}
declare 306 {
Tcl_Obj *Tcl_GetVar2Ex(Tcl_Interp *interp, const char *part1,
const char *part2, int flags)
}
declare 307 {
void *Tcl_InitNotifier(void)
}
declare 308 {
void Tcl_MutexLock(Tcl_Mutex *mutexPtr)
}
declare 309 {
void Tcl_MutexUnlock(Tcl_Mutex *mutexPtr)
}
declare 310 {
void Tcl_ConditionNotify(Tcl_Condition *condPtr)
}
declare 311 {
void Tcl_ConditionWait(Tcl_Condition *condPtr, Tcl_Mutex *mutexPtr,
const Tcl_Time *timePtr)
}
declare 312 {
size_t Tcl_NumUtfChars(const char *src, size_t 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 {deprecated {No longer in use, changed to macro}} {
# void Tcl_RestoreResult(Tcl_Interp *interp, Tcl_SavedResult *statePtr)
#}
# Removed in 9.0, replaced by macro.
#declare 315 {deprecated {No longer in use, changed to macro}} {
# void Tcl_SaveResult(Tcl_Interp *interp, Tcl_SavedResult *statePtr)
#}
declare 316 {
int Tcl_SetSystemEncoding(Tcl_Interp *interp, const char *name)
}
declare 317 {
Tcl_Obj *Tcl_SetVar2Ex(Tcl_Interp *interp, const char *part1,
const char *part2, Tcl_Obj *newValuePtr, int flags)
}
declare 318 {
void Tcl_ThreadAlert(Tcl_ThreadId threadId)
}
declare 319 {
void Tcl_ThreadQueueEvent(Tcl_ThreadId threadId, Tcl_Event *evPtr,
Tcl_QueuePosition position)
}
declare 320 {
int Tcl_UniCharAtIndex(const char *src, size_t index)
}
declare 321 {
int Tcl_UniCharToLower(int ch)
}
declare 322 {
int Tcl_UniCharToTitle(int ch)
}
declare 323 {
int Tcl_UniCharToUpper(int ch)
}
declare 324 {
int Tcl_UniCharToUtf(int ch, char *buf)
}
declare 325 {
const char *Tcl_UtfAtIndex(const char *src, size_t index)
}
declare 326 {
int Tcl_UtfCharComplete(const char *src, size_t length)
}
declare 327 {
size_t Tcl_UtfBackslash(const char *src, int *readPtr, char *dst)
}
declare 328 {
const char *Tcl_UtfFindFirst(const char *src, int ch)
}
declare 329 {
const char *Tcl_UtfFindLast(const char *src, int ch)
}
declare 330 {
const char *Tcl_UtfNext(const char *src)
}
declare 331 {
const char *Tcl_UtfPrev(const char *src, const char *start)
}
declare 332 {
int Tcl_UtfToExternal(Tcl_Interp *interp, Tcl_Encoding encoding,
const char *src, size_t srcLen, int flags,
Tcl_EncodingState *statePtr, char *dst, size_t dstLen,
int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr)
}
declare 333 {
char *Tcl_UtfToExternalDString(Tcl_Encoding encoding,
const char *src, size_t srcLen, Tcl_DString *dsPtr)
}
declare 334 {
int Tcl_UtfToLower(char *src)
}
declare 335 {
int Tcl_UtfToTitle(char *src)
}
declare 336 {
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)
}
declare 339 {
size_t Tcl_WriteObj(Tcl_Channel chan, Tcl_Obj *objPtr)
}
declare 340 {
char *Tcl_GetString(Tcl_Obj *objPtr)
}
# Removed in 9.0:
#declare 341 {deprecated {Use Tcl_GetEncodingSearchPath}} {
# const char *Tcl_GetDefaultEncodingDir(void)
#}
# Removed in 9.0:
#declare 342 {deprecated {Use Tcl_SetEncodingSearchPath}} {
# void Tcl_SetDefaultEncodingDir(const char *path)
#}
declare 343 {
void Tcl_AlertNotifier(void *clientData)
}
declare 344 {
void Tcl_ServiceModeHook(int mode)
}
declare 345 {
int Tcl_UniCharIsAlnum(int ch)
}
|
| ︙ | ︙ | |||
1285 1286 1287 1288 1289 1290 1291 |
declare 350 {
int Tcl_UniCharIsUpper(int ch)
}
declare 351 {
int Tcl_UniCharIsWordChar(int ch)
}
declare 352 {
| | | | | | | | > | | | | | | | | | | | | | > | | < > | | | | | | | 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 |
declare 350 {
int Tcl_UniCharIsUpper(int ch)
}
declare 351 {
int Tcl_UniCharIsWordChar(int ch)
}
declare 352 {
size_t Tcl_UniCharLen(const Tcl_UniChar *uniStr)
}
declare 353 {
int Tcl_UniCharNcmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct,
size_t numChars)
}
declare 354 {
char *Tcl_UniCharToUtfDString(const Tcl_UniChar *uniStr,
size_t uniLength, Tcl_DString *dsPtr)
}
declare 355 {
Tcl_UniChar *Tcl_UtfToUniCharDString(const char *src,
size_t length, Tcl_DString *dsPtr)
}
declare 356 {
Tcl_RegExp Tcl_GetRegExpFromObj(Tcl_Interp *interp, Tcl_Obj *patObj,
int flags)
}
# Removed in 9.0:
#declare 357 {deprecated {Use Tcl_EvalTokensStandard}} {
# Tcl_Obj *Tcl_EvalTokens(Tcl_Interp *interp, Tcl_Token *tokenPtr,
# int count)
#}
declare 358 {
void Tcl_FreeParse(Tcl_Parse *parsePtr)
}
declare 359 {
void Tcl_LogCommandInfo(Tcl_Interp *interp, const char *script,
const char *command, size_t length)
}
declare 360 {
int Tcl_ParseBraces(Tcl_Interp *interp, const char *start,
size_t numBytes, Tcl_Parse *parsePtr, int append,
const char **termPtr)
}
declare 361 {
int Tcl_ParseCommand(Tcl_Interp *interp, const char *start,
size_t numBytes, int nested, Tcl_Parse *parsePtr)
}
declare 362 {
int Tcl_ParseExpr(Tcl_Interp *interp, const char *start, size_t 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)
}
declare 364 {
int Tcl_ParseVarName(Tcl_Interp *interp, const char *start,
size_t numBytes, Tcl_Parse *parsePtr, int append)
}
# These 4 functions are obsolete, use Tcl_FSGetCwd, Tcl_FSChdir,
# Tcl_FSAccess and Tcl_FSStat
declare 365 {
char *Tcl_GetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr)
}
declare 366 {
int Tcl_Chdir(const char *dirName)
}
declare 367 {
int Tcl_Access(const char *path, int mode)
}
declare 368 {
int Tcl_Stat(const char *path, struct stat *bufPtr)
}
declare 369 {
int Tcl_UtfNcmp(const char *s1, const char *s2, size_t n)
}
declare 370 {
int Tcl_UtfNcasecmp(const char *s1, const char *s2, size_t n)
}
declare 371 {
int Tcl_StringCaseMatch(const char *str, const char *pattern, int nocase)
}
declare 372 {
int Tcl_UniCharIsControl(int ch)
}
declare 373 {
int Tcl_UniCharIsGraph(int ch)
}
declare 374 {
int Tcl_UniCharIsPrint(int ch)
}
declare 375 {
int Tcl_UniCharIsPunct(int ch)
}
declare 376 {
int Tcl_RegExpExecObj(Tcl_Interp *interp, Tcl_RegExp regexp,
Tcl_Obj *textObj, size_t offset, size_t 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)
}
declare 379 {
void Tcl_SetUnicodeObj(Tcl_Obj *objPtr, const Tcl_UniChar *unicode,
size_t numChars)
}
declare 380 {
size_t Tcl_GetCharLength(Tcl_Obj *objPtr)
}
declare 381 {
int Tcl_GetUniChar(Tcl_Obj *objPtr, size_t index)
}
# Removed in 9.0, replaced by macro.
#declare 382 {deprecated {No longer in use, changed to macro}} {
# Tcl_UniChar *Tcl_GetUnicode(Tcl_Obj *objPtr)
#}
declare 383 {
Tcl_Obj *Tcl_GetRange(Tcl_Obj *objPtr, size_t first, size_t last)
}
declare 384 {
void Tcl_AppendUnicodeToObj(Tcl_Obj *objPtr, const Tcl_UniChar *unicode,
size_t length)
}
declare 385 {
int Tcl_RegExpMatchObj(Tcl_Interp *interp, Tcl_Obj *textObj,
Tcl_Obj *patternObj)
}
declare 386 {
void Tcl_SetNotifier(Tcl_NotifierProcs *notifierProcPtr)
}
declare 387 {
Tcl_Mutex *Tcl_GetAllocMutex(void)
}
declare 388 {
int Tcl_GetChannelNames(Tcl_Interp *interp)
}
declare 389 {
int Tcl_GetChannelNamesEx(Tcl_Interp *interp, const char *pattern)
}
declare 390 {
int Tcl_ProcObjCmd(void *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)
}
# Introduced in 8.3.2
declare 394 {
size_t Tcl_ReadRaw(Tcl_Channel chan, char *dst, size_t bytesToRead)
}
declare 395 {
size_t Tcl_WriteRaw(Tcl_Channel chan, const char *src, size_t srcLen)
}
declare 396 {
Tcl_Channel Tcl_GetTopChannel(Tcl_Channel chan)
}
declare 397 {
int Tcl_ChannelBuffered(Tcl_Channel chan)
}
|
| ︙ | ︙ | |||
1525 1526 1527 1528 1529 1530 1531 |
void Tcl_ClearChannelHandlers(Tcl_Channel channel)
}
declare 418 {
int Tcl_IsChannelExisting(const char *channelName)
}
declare 419 {
int Tcl_UniCharNcasecmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct,
| | | 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 |
void Tcl_ClearChannelHandlers(Tcl_Channel channel)
}
declare 418 {
int Tcl_IsChannelExisting(const char *channelName)
}
declare 419 {
int Tcl_UniCharNcasecmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct,
size_t numChars)
}
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 {
|
| ︙ | ︙ | |||
1548 1549 1550 1551 1552 1553 1554 |
void Tcl_InitCustomHashTable(Tcl_HashTable *tablePtr, int keyType,
const Tcl_HashKeyType *typePtr)
}
declare 424 {
void Tcl_InitObjHashTable(Tcl_HashTable *tablePtr)
}
declare 425 {
| | | | | | | | | | | | 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 |
void Tcl_InitCustomHashTable(Tcl_HashTable *tablePtr, int keyType,
const Tcl_HashKeyType *typePtr)
}
declare 424 {
void Tcl_InitObjHashTable(Tcl_HashTable *tablePtr)
}
declare 425 {
void *Tcl_CommandTraceInfo(Tcl_Interp *interp, const char *varName,
int flags, Tcl_CommandTraceProc *procPtr,
void *prevClientData)
}
declare 426 {
int Tcl_TraceCommand(Tcl_Interp *interp, const char *varName, int flags,
Tcl_CommandTraceProc *proc, void *clientData)
}
declare 427 {
void Tcl_UntraceCommand(Tcl_Interp *interp, const char *varName,
int flags, Tcl_CommandTraceProc *proc, void *clientData)
}
declare 428 {
void *Tcl_AttemptAlloc(size_t size)
}
declare 429 {
void *Tcl_AttemptDbCkalloc(size_t size, const char *file, int line)
}
declare 430 {
void *Tcl_AttemptRealloc(void *ptr, size_t size)
}
declare 431 {
void *Tcl_AttemptDbCkrealloc(void *ptr, size_t size,
const char *file, int line)
}
declare 432 {
int Tcl_AttemptSetObjLength(Tcl_Obj *objPtr, size_t length)
}
# TIP#10 (thread-aware channels) akupries
declare 433 {
Tcl_ThreadId Tcl_GetChannelThread(Tcl_Channel channel)
}
# introduced in 8.4a3
declare 434 {
Tcl_UniChar *Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr, int *lengthPtr)
}
# TIP#15 (math function introspection) dkf
# Removed in 9.0:
#declare 435 {deprecated {}} {
# 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 {deprecated {}} {
# Tcl_Obj *Tcl_ListMathFuncs(Tcl_Interp *interp, const char *pattern)
#}
# TIP#36 (better access to 'subst') dkf
declare 437 {
|
| ︙ | ︙ | |||
1697 1698 1699 1700 1701 1702 1703 |
Tcl_Obj *Tcl_FSGetNormalizedPath(Tcl_Interp *interp, Tcl_Obj *pathPtr)
}
declare 464 {
Tcl_Obj *Tcl_FSJoinToPath(Tcl_Obj *pathPtr, int objc,
Tcl_Obj *const objv[])
}
declare 465 {
| | | | | | 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 |
Tcl_Obj *Tcl_FSGetNormalizedPath(Tcl_Interp *interp, Tcl_Obj *pathPtr)
}
declare 464 {
Tcl_Obj *Tcl_FSJoinToPath(Tcl_Obj *pathPtr, int objc,
Tcl_Obj *const objv[])
}
declare 465 {
void *Tcl_FSGetInternalRep(Tcl_Obj *pathPtr,
const Tcl_Filesystem *fsPtr)
}
declare 466 {
Tcl_Obj *Tcl_FSGetTranslatedPath(Tcl_Interp *interp, Tcl_Obj *pathPtr)
}
declare 467 {
int Tcl_FSEvalFile(Tcl_Interp *interp, Tcl_Obj *fileName)
}
declare 468 {
Tcl_Obj *Tcl_FSNewNativePath(const Tcl_Filesystem *fromFilesystem,
void *clientData)
}
declare 469 {
const void *Tcl_FSGetNativePath(Tcl_Obj *pathPtr)
}
declare 470 {
Tcl_Obj *Tcl_FSFileSystemInfo(Tcl_Obj *pathPtr)
}
declare 471 {
Tcl_Obj *Tcl_FSPathSeparator(Tcl_Obj *pathPtr)
}
declare 472 {
Tcl_Obj *Tcl_FSListVolumes(void)
}
declare 473 {
int Tcl_FSRegister(void *clientData, const Tcl_Filesystem *fsPtr)
}
declare 474 {
int Tcl_FSUnregister(const Tcl_Filesystem *fsPtr)
}
declare 475 {
void *Tcl_FSData(const 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)
|
| ︙ | ︙ | |||
1753 1754 1755 1756 1757 1758 1759 |
declare 480 {
void Tcl_FSMountsChanged(const Tcl_Filesystem *fsPtr)
}
# TIP#56 (evaluate a parsed script) msofer
declare 481 {
int Tcl_EvalTokensStandard(Tcl_Interp *interp, Tcl_Token *tokenPtr,
| | | | 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 |
declare 480 {
void Tcl_FSMountsChanged(const Tcl_Filesystem *fsPtr)
}
# TIP#56 (evaluate a parsed script) msofer
declare 481 {
int Tcl_EvalTokensStandard(Tcl_Interp *interp, Tcl_Token *tokenPtr,
size_t count)
}
# TIP#73 (access to current time) kbk
declare 482 {
void Tcl_GetTime(Tcl_Time *timeBuf)
}
# TIP#32 (object-enabled traces) kbk
declare 483 {
Tcl_Trace Tcl_CreateObjTrace(Tcl_Interp *interp, int level, int flags,
Tcl_CmdObjTraceProc *objProc, void *clientData,
Tcl_CmdObjTraceDeleteProc *delProc)
}
declare 484 {
int Tcl_GetCommandInfoFromToken(Tcl_Command token, Tcl_CmdInfo *infoPtr)
}
declare 485 {
int Tcl_SetCommandInfoFromToken(Tcl_Command token,
|
| ︙ | ︙ | |||
1862 1863 1864 1865 1866 1867 1868 |
const Tcl_Config *configuration, const char *valEncoding)
}
# TIP #139 (partial exposure of namespace API - transferred from tclInt.decls)
# dkf, API by Brent Welch?
declare 506 {
Tcl_Namespace *Tcl_CreateNamespace(Tcl_Interp *interp, const char *name,
| | | 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 |
const Tcl_Config *configuration, const char *valEncoding)
}
# TIP #139 (partial exposure of namespace API - transferred from tclInt.decls)
# dkf, API by Brent Welch?
declare 506 {
Tcl_Namespace *Tcl_CreateNamespace(Tcl_Interp *interp, const char *name,
void *clientData, Tcl_NamespaceDeleteProc *deleteProc)
}
declare 507 {
void Tcl_DeleteNamespace(Tcl_Namespace *nsPtr)
}
declare 508 {
int Tcl_AppendExportList(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
Tcl_Obj *objPtr)
|
| ︙ | ︙ | |||
1911 1912 1913 1914 1915 1916 1917 |
# TIP#137 (encoding-aware source command) dgp for Anton Kovalenko
declare 518 {
int Tcl_FSEvalFileEx(Tcl_Interp *interp, Tcl_Obj *fileName,
const char *encodingName)
}
| | | | < > | | | 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 |
# TIP#137 (encoding-aware source command) dgp for Anton Kovalenko
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#143 (resource limits) dkf
declare 520 {
void Tcl_LimitAddHandler(Tcl_Interp *interp, int type,
Tcl_LimitHandlerProc *handlerProc, void *clientData,
Tcl_LimitHandlerDeleteProc *deleteProc)
}
declare 521 {
void Tcl_LimitRemoveHandler(Tcl_Interp *interp, int type,
Tcl_LimitHandlerProc *handlerProc, void *clientData)
}
declare 522 {
int Tcl_LimitReady(Tcl_Interp *interp)
}
declare 523 {
int Tcl_LimitCheck(Tcl_Interp *interp)
}
|
| ︙ | ︙ | |||
2037 2038 2039 2040 2041 2042 2043 |
Tcl_Namespace **namespacePtrPtr)
}
# TIP#233 (virtualized time) akupries
declare 552 {
void Tcl_SetTimeProc(Tcl_GetTimeProc *getProc,
Tcl_ScaleTimeProc *scaleProc,
| | | | 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 |
Tcl_Namespace **namespacePtrPtr)
}
# TIP#233 (virtualized time) akupries
declare 552 {
void Tcl_SetTimeProc(Tcl_GetTimeProc *getProc,
Tcl_ScaleTimeProc *scaleProc,
void *clientData)
}
declare 553 {
void Tcl_QueryTimeProc(Tcl_GetTimeProc **getProc,
Tcl_ScaleTimeProc **scaleProc,
void **clientData)
}
# TIP#218 (driver thread actions) davygrvy/akupries ChannelType ver 4
declare 554 {
Tcl_DriverThreadActionProc *Tcl_ChannelThreadActionProc(
const Tcl_ChannelType *chanTypePtr)
}
|
| ︙ | ︙ | |||
2133 2134 2135 2136 2137 2138 2139 |
}
# TIP#270 (utility C routines for string formatting) dgp
declare 574 {
void Tcl_AppendObjToErrorInfo(Tcl_Interp *interp, Tcl_Obj *objPtr)
}
declare 575 {
| | | | 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 |
}
# 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)
}
declare 576 {
Tcl_Obj *Tcl_Format(Tcl_Interp *interp, const char *format, int objc,
Tcl_Obj *const objv[])
}
declare 577 {
int Tcl_AppendFormatToObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
|
| ︙ | ︙ | |||
2156 2157 2158 2159 2160 2161 2162 |
}
# ----- BASELINE -- FOR -- 8.5.0 ----- #
# TIP #285 (script cancellation support) jmistachkin
declare 580 {
int Tcl_CancelEval(Tcl_Interp *interp, Tcl_Obj *resultObjPtr,
| | | | | | | | | 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 |
}
# ----- 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 {
|
| ︙ | ︙ | |||
2286 2287 2288 2289 2290 2291 2292 |
# 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,
| | | | | > | 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 |
# 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)
}
|
| ︙ | ︙ | |||
2371 2372 2373 2374 2375 2376 2377 |
# ----- 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,
| | > > > > > > > > > > > > > > > | > > > | > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | > > > > > > > > > > > > > > > > > | 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 |
# ----- 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)
}
# ----- BASELINE -- FOR -- 8.7.0 ----- #
##############################################################################
# Define the platform specific public Tcl interface. These functions are only
# available on the designated platform.
interface tclPlat
################################
# Unix specific functions
# (none)
################################
# Windows specific functions
# Added in Tcl 8.1
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)
}
################################
# Mac OS X specific functions
declare 0 macosx {
int Tcl_MacOSXOpenBundleResources(Tcl_Interp *interp,
const char *bundleName, int hasResourceFile,
size_t 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)
}
##############################################################################
# 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)
}
export {
const char *Tcl_InitStubs(Tcl_Interp *interp, const char *version,
int exact)
}
export {
const char *TclTomMathInitializeStubs(Tcl_Interp* interp,
const char* version, int epoch, int revision)
|
| ︙ | ︙ |
Changes to generic/tcl.h.
| ︙ | ︙ | |||
38 39 40 41 42 43 44 | * update the version numbers: * * library/init.tcl (1 LOC patch) * unix/configure.ac (2 LOC Major, 2 LOC minor, 1 LOC patch) * win/configure.ac (as above) * win/tcl.m4 (not patchlevel) * README (sections 0 and 2, with and without separator) | < < < < | 38 39 40 41 42 43 44 45 46 47 48 49 50 51 | * update the version numbers: * * library/init.tcl (1 LOC patch) * unix/configure.ac (2 LOC Major, 2 LOC minor, 1 LOC patch) * win/configure.ac (as above) * win/tcl.m4 (not patchlevel) * README (sections 0 and 2, with and without separator) * macosx/Tcl-Common.xcconfig (not patchlevel) 1 LOC * win/README (not patchlevel) (sections 0 and 2) * unix/tcl.spec (1 LOC patch) * tools/tcl.hpj.in (not patchlevel, for windows installer) */ #define TCL_MAJOR_VERSION 9 |
| ︙ | ︙ | |||
68 69 70 71 72 73 74 | * Resource compilers don't like all the C stuff, like typedefs and function * declarations, that occur below, so block them out. */ #ifndef RC_INVOKED /* | | < < < < < < > > | 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 | * Resource compilers don't like all the C stuff, like typedefs and function * declarations, that occur below, so block them out. */ #ifndef RC_INVOKED /* * Special macro to define mutexes. */ #define TCL_DECLARE_MUTEX(name) static Tcl_Mutex name; /* * Tcl's public routine Tcl_FSSeek() uses the values SEEK_SET, SEEK_CUR, and * SEEK_END, all #define'd by stdio.h . * * Also, many extensions need stdio.h, and they've grown accustomed to tcl.h * providing it for them rather than #include-ing it themselves as they * should, so also for their sake, we keep the #include to be consistent with * prior Tcl releases. */ #include <stdio.h> #if defined(__GNUC__) && (__GNUC__ > 2) # define TCL_FORMAT_PRINTF(a,b) __attribute__ ((__format__ (__printf__, a, b))) # define TCL_NORETURN __attribute__ ((noreturn)) # define TCL_NOINLINE __attribute__ ((noinline)) # 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. |
| ︙ | ︙ | |||
360 361 362 363 364 365 366 | *---------------------------------------------------------------------------- * 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 | | | | 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 | *---------------------------------------------------------------------------- * 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); #else typedef void (Tcl_ThreadCreateProc) (void *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. */ |
| ︙ | ︙ | |||
428 429 430 431 432 433 434 |
/*
* Structures filled in by Tcl_RegExpInfo. Note that all offset values are
* relative to the start of the match string, not the beginning of the entire
* string.
*/
typedef struct Tcl_RegExpIndices {
| | | | | < | 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 |
/*
* Structures filled in by Tcl_RegExpInfo. Note that all offset values are
* relative to the start of the match string, not the beginning of the entire
* string.
*/
typedef struct Tcl_RegExpIndices {
size_t start; /* Character offset of first character in
* match. */
size_t end; /* Character offset of first character after
* the match. */
} Tcl_RegExpIndices;
typedef struct Tcl_RegExpInfo {
size_t 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
* might begin. */
} Tcl_RegExpInfo;
/*
* Picky compilers complain if this typdef doesn't appear before the struct's
* reference in tclDecls.h.
*/
|
| ︙ | ︙ | |||
501 502 503 504 505 506 507 | /* *---------------------------------------------------------------------------- * Function types defined by Tcl: */ typedef int (Tcl_AppInitProc) (Tcl_Interp *interp); | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 | /* *---------------------------------------------------------------------------- * 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); /* *---------------------------------------------------------------------------- * 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. |
| ︙ | ︙ | |||
582 583 584 585 586 587 588 589 590 591 592 593 594 595 |
* type's internal representation. */
Tcl_SetFromAnyProc *setFromAnyProc;
/* Called to convert the object's internal rep
* to this type. Frees the internal rep of the
* old type. Returns TCL_ERROR on failure. */
} Tcl_ObjType;
/*
* 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 {
| > > > > > > > > > > > > > > > > > > > > > > > | | | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 |
* type's internal representation. */
Tcl_SetFromAnyProc *setFromAnyProc;
/* Called to convert the object's internal rep
* to this type. Frees the internal rep of the
* old type. Returns TCL_ERROR on failure. */
} 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. */
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
* 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
* including the terminating null. */
const Tcl_ObjType *typePtr; /* Denotes the object's type. Always
* corresponds to the type of the object's
* internal rep. NULL indicates the object has
* no internal rep (has no type). */
Tcl_ObjIntRep internalRep; /* The internal representation: */
} Tcl_Obj;
/*
*----------------------------------------------------------------------------
* The following type contains the state needed by Tcl_SaveResult. It
* is typically allocated on the stack.
*/
|
| ︙ | ︙ | |||
664 665 666 667 668 669 670 |
typedef struct Tcl_Namespace {
char *name; /* The namespace's name within its parent
* namespace. This contains no ::'s. The name
* of the global namespace is "" although "::"
* is an synonym. */
char *fullName; /* The namespace's fully qualified name. This
* starts with ::. */
| | | 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 |
typedef struct Tcl_Namespace {
char *name; /* The namespace's name within its parent
* namespace. This contains no ::'s. The name
* of the global namespace is "" although "::"
* is an synonym. */
char *fullName; /* The namespace's fully qualified name. This
* starts with ::. */
void *clientData; /* Arbitrary value associated with this
* namespace. */
Tcl_NamespaceDeleteProc *deleteProc;
/* Function invoked when deleting the
* namespace to, e.g., free clientData. */
struct Tcl_Namespace *parentPtr;
/* Points to the namespace that contains this
* one. NULL if this is the global
|
| ︙ | ︙ | |||
736 737 738 739 740 741 742 |
typedef struct Tcl_CmdInfo {
int isNativeObjectProc; /* 1 if objProc was registered by a call to
* Tcl_CreateObjCommand; 0 otherwise.
* Tcl_SetCmdInfo does not modify this
* field. */
Tcl_ObjCmdProc *objProc; /* Command's object-based function. */
| | | | | | | 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 |
typedef struct Tcl_CmdInfo {
int isNativeObjectProc; /* 1 if objProc was registered by a call to
* Tcl_CreateObjCommand; 0 otherwise.
* Tcl_SetCmdInfo does not modify this
* field. */
Tcl_ObjCmdProc *objProc; /* Command's object-based function. */
void *objClientData; /* ClientData for object proc. */
Tcl_CmdProc *proc; /* Command's string-based function. */
void *clientData; /* ClientData for string proc. */
Tcl_CmdDeleteProc *deleteProc;
/* Function to call when command is
* deleted. */
void *deleteData; /* Value to pass to deleteProc (usually the
* same as clientData). */
Tcl_Namespace *namespacePtr;/* Points to the namespace that contains this
* command. Note that Tcl_SetCmdInfo will not
* change a command's namespace; use
* TclRenameCommand or Tcl_Eval (of 'rename')
* to do that. */
} Tcl_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
* string. */
size_t 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)
|
| ︙ | ︙ | |||
914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 | #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_READ_ONLY 0x80 /* *---------------------------------------------------------------------------- * Forward declarations of Tcl_HashTable and related types. */ #ifndef TCL_HASH_TYPE | > > | | 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 | #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); |
| ︙ | ︙ | |||
944 945 946 947 948 949 950 |
* should access any of these fields directly; use the macros defined below.
*/
struct Tcl_HashEntry {
Tcl_HashEntry *nextPtr; /* Pointer to next entry in this hash bucket,
* or NULL for end of chain. */
Tcl_HashTable *tablePtr; /* Pointer to table containing entry. */
| | | | 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 |
* should access any of these fields directly; use the macros defined below.
*/
struct Tcl_HashEntry {
Tcl_HashEntry *nextPtr; /* Pointer to next entry in this hash bucket,
* or NULL for end of chain. */
Tcl_HashTable *tablePtr; /* Pointer to table containing entry. */
size_t hash; /* Hash value. */
void *clientData; /* Application stores something here with
* Tcl_SetHashValue. */
union { /* Key has one of these forms: */
char *oneWordValue; /* One-word value for key. */
Tcl_Obj *objPtr; /* Tcl_Obj * key value. */
int words[1]; /* Multiple integer words for key. The actual
* size will be as large as necessary for this
* table's keys. */
|
| ︙ | ︙ | |||
1104 1105 1106 1107 1108 1109 1110 |
* dictionaries. These fields should not be accessed by code outside
* tclDictObj.c
*/
typedef struct {
void *next; /* Search position for underlying hash
* table. */
| | | 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 |
* dictionaries. These fields should not be accessed by code outside
* tclDictObj.c
*/
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. */
Tcl_Dict dictionaryPtr; /* Reference to dictionary being searched. */
} Tcl_DictSearch;
/*
*----------------------------------------------------------------------------
* Flag values to pass to Tcl_DoOneEvent to disable searches for some kinds of
|
| ︙ | ︙ | |||
1170 1171 1172 1173 1174 1175 1176 | typedef void (Tcl_SetTimerProc) (const Tcl_Time *timePtr); typedef int (Tcl_WaitForEventProc) (const Tcl_Time *timePtr); /* * TIP #233 (Virtualized Time) */ | | | | 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 | typedef void (Tcl_SetTimerProc) (const Tcl_Time *timePtr); typedef int (Tcl_WaitForEventProc) (const 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); /* *---------------------------------------------------------------------------- * Bits to pass to Tcl_CreateFileHandler and Tcl_CreateChannelHandler to * indicate what sorts of events are of interest: */ |
| ︙ | ︙ | |||
1230 1231 1232 1233 1234 1235 1236 | #define TCL_CHANNEL_THREAD_INSERT (0) #define TCL_CHANNEL_THREAD_REMOVE (1) /* * Typedefs for the various operations in a channel type: */ | | | | | | | | | | | | | | | | | | 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 | #define TCL_CHANNEL_THREAD_INSERT (0) #define TCL_CHANNEL_THREAD_REMOVE (1) /* * Typedefs for the various operations in a channel type: */ typedef int (Tcl_DriverBlockModeProc) (void *instanceData, int mode); typedef int (Tcl_DriverCloseProc) (void *instanceData, Tcl_Interp *interp); 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 int (Tcl_DriverSeekProc) (void *instanceData, long offset, int mode, int *errorCodePtr); 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); /* * TIP #218, Channel Thread Actions */ typedef void (Tcl_DriverThreadActionProc) (void *instanceData, int action); /* * TIP #208, File Truncation (etc.) */ typedef int (Tcl_DriverTruncateProc) (void *instanceData, Tcl_WideInt length); /* * struct Tcl_ChannelType: * * One such structure exists for each type (kind) of channel. It collects * together in one place all the functions that are part of the specific |
| ︙ | ︙ | |||
1445 1446 1447 1448 1449 1450 1451 | 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, | | | | | | | 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 | 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 struct Tcl_FSVersion_ *Tcl_FSVersion; /* *---------------------------------------------------------------------------- * Data structures related to hooking into the filesystem */ |
| ︙ | ︙ | |||
1481 1482 1483 1484 1485 1486 1487 |
* 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. */
| | | 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 |
* 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
* compatibility can be assured. */
Tcl_FSVersion version; /* Version of the filesystem type. */
Tcl_FSPathInFilesystemProc *pathInFilesystemProc;
/* Function to check whether a path is in this
* filesystem. This is the most important
* filesystem function. */
Tcl_FSDupInternalRepProc *dupInternalRepProc;
|
| ︙ | ︙ | |||
1671 1672 1673 1674 1675 1676 1677 |
* 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. */
| | | | 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 |
* 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,
* this field tells how many of them there are
* (including components of components, etc.).
* The component tokens immediately follow
* this one. */
} Tcl_Token;
/*
|
| ︙ | ︙ | |||
1786 1787 1788 1789 1790 1791 1792 |
*/
#define NUM_STATIC_TOKENS 20
typedef struct Tcl_Parse {
const char *commentStart; /* Pointer to # that begins the first of one
* or more comments preceding the command. */
| | | 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 |
*/
#define NUM_STATIC_TOKENS 20
typedef struct Tcl_Parse {
const char *commentStart; /* Pointer to # that begins the first of one
* or more comments preceding the command. */
size_t commentSize; /* Number of bytes in comments (up through
* newline character that terminates the last
* comment). If there were no comments, this
* field is 0. */
const char *commandStart; /* First character in first word of
* command. */
int commandSize; /* Number of bytes in command, including first
* character of first word, up through the
|
| ︙ | ︙ | |||
1854 1855 1856 1857 1858 1859 1860 |
* 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. */
| | | | 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 |
* 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;
|
| ︙ | ︙ | |||
1952 1953 1954 1955 1956 1957 1958 | #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 | | | | | | 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 | #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 4 and 6 * (or perhaps 1 if we want to support a non-unicode enabled core). If 4, * 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 #endif /* * This represents a Unicode character. Any changes to this should also be * reflected in regcustom.h. */ |
| ︙ | ︙ | |||
2011 2012 2013 2014 2015 2016 2017 | #define TCL_LIMIT_TIME 0x02 /* * Structure containing information about a limit handler to be called when a * command- or time-limit is exceeded by an interpreter. */ | | | | 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 | #define TCL_LIMIT_TIME 0x02 /* * Structure containing information about a limit handler to be called when a * command- or time-limit is exceeded by an interpreter. */ typedef void (Tcl_LimitHandlerProc) (void *clientData, Tcl_Interp *interp); typedef void (Tcl_LimitHandlerDeleteProc) (void *clientData); /* *---------------------------------------------------------------------------- * Override definitions for libtommath. */ typedef struct mp_int mp_int; |
| ︙ | ︙ | |||
2043 2044 2045 2046 2047 2048 2049 |
* 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. */
| | | 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 |
* 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.
*/
|
| ︙ | ︙ | |||
2066 2067 2068 2069 2070 2071 2072 | #define TCL_ARGV_END 23 /* * Types of callback functions for the TCL_ARGV_FUNC and TCL_ARGV_GENFUNC * argument types: */ | | | | 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 | #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 \ |
| ︙ | ︙ | |||
2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 | /* *---------------------------------------------------------------------------- * Definitions needed for the Tcl_OpenTcpServerEx function. [TIP #456] */ #define TCL_TCPSERVER_REUSEADDR (1<<0) #define TCL_TCPSERVER_REUSEPORT (1<<1) /* *---------------------------------------------------------------------------- * Single public declaration for NRE. */ | > > > > > > > > | | | > > > > > | 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 |
/*
*----------------------------------------------------------------------------
* 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);
/*
*----------------------------------------------------------------------------
* The following constant is used to test for older versions of Tcl in the
* stubs tables. If TCL_UTF_MAX>4 use a different value.
*/
#define TCL_STUB_MAGIC ((int) 0xFCA3BACB + (int) sizeof(void *) + (TCL_UTF_MAX>4))
/*
* 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)
|
| ︙ | ︙ | |||
2198 2199 2200 2201 2202 2203 2204 | /* * 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, \ | < < | | < < < < > > > > > > > > > > > | > | < | < < | < | < | < | < | < | < < < < < < < < < < > > > < < < < < < < < < < < < < < < < | | 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 |
/*
* 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)()))
TCLAPI TCL_NORETURN void Tcl_MainEx(int argc, char **argv,
Tcl_AppInitProc *appInitProc, Tcl_Interp *interp);
TCLAPI const char * Tcl_PkgInitStubsCheck(Tcl_Interp *interp,
const char *version, int exact);
TCLAPI void Tcl_GetMemoryInfo(Tcl_DString *dsPtr);
TCLAPI void Tcl_FindExecutable(const char *argv0);
TCLAPI void Tcl_SetPanicProc(
TCL_NORETURN1 Tcl_PanicProc *panicProc);
TCLAPI void Tcl_StaticPackage(Tcl_Interp *interp,
const char *pkgName,
Tcl_PackageInitProc *initProc,
Tcl_PackageInitProc *safeInitProc);
TCLAPI Tcl_ExitProc *Tcl_SetExitProc(TCL_NORETURN1 Tcl_ExitProc *proc);
#ifndef _WIN32
TCLAPI int TclZipfs_AppHook(int *argc, char ***argv);
#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].
*/
#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.
*/
#define ckalloc Tcl_Alloc
#define ckfree Tcl_Free
#define ckrealloc Tcl_Realloc
#define attemptckalloc Tcl_AttemptAlloc
#define attemptckrealloc Tcl_AttemptRealloc
#ifndef 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.
*/
# undef Tcl_InitMemory
# define Tcl_InitMemory(x)
# undef Tcl_DumpActiveMemory
# define Tcl_DumpActiveMemory(x)
# undef Tcl_ValidateAllMemory
# define Tcl_ValidateAllMemory(x,y)
#endif /* !TCL_MEM_DEBUG */
#ifdef TCL_MEM_DEBUG
# undef Tcl_IncrRefCount
# define Tcl_IncrRefCount(objPtr) \
Tcl_DbIncrRefCount(objPtr, __FILE__, __LINE__)
# undef Tcl_DecrRefCount
# define Tcl_DecrRefCount(objPtr) \
Tcl_DbDecrRefCount(objPtr, __FILE__, __LINE__)
# undef Tcl_IsShared
# define Tcl_IsShared(objPtr) \
Tcl_DbIsShared(objPtr, __FILE__, __LINE__)
#endif
/*
* Macros and definitions that help to debug the use of Tcl objects. When
* TCL_MEM_DEBUG is defined, the Tcl_New declarations are overridden to call
* debugging versions of the object creation functions.
*/
#ifdef TCL_MEM_DEBUG
# 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__)
# 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_NewListObj
|
| ︙ | ︙ | |||
2359 2360 2361 2362 2363 2364 2365 | */ #define Tcl_FindHashEntry(tablePtr, key) \ (*((tablePtr)->findProc))(tablePtr, (const char *)(key)) #define Tcl_CreateHashEntry(tablePtr, key, newPtr) \ (*((tablePtr)->createProc))(tablePtr, (const char *)(key), newPtr) | < < < < < < < < < < < < < < < < < < < < < | 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 | */ #define Tcl_FindHashEntry(tablePtr, key) \ (*((tablePtr)->findProc))(tablePtr, (const char *)(key)) #define Tcl_CreateHashEntry(tablePtr, key, newPtr) \ (*((tablePtr)->createProc))(tablePtr, (const char *)(key), newPtr) #endif /* RC_INVOKED */ /* * end block for C++ */ #ifdef __cplusplus |
| ︙ | ︙ |
Changes to generic/tclAlloc.c.
| ︙ | ︙ | |||
18 19 20 21 22 23 24 | /* * Windows and Unix use an alternative allocator when building with threads * that has significantly reduced lock contention. */ #include "tclInt.h" | | | 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 | /* * 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 USE_TCLALLOC /* * We should really make use of AC_CHECK_TYPE(caddr_t) here, but it can wait * until Tcl uses config.h properly. */ |
| ︙ | ︙ | |||
117 118 119 120 121 122 123 | /* * The allocator is protected by a special mutex that must be explicitly * 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. */ | | | 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 | /* * The allocator is protected by a special mutex that must be explicitly * 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 static Tcl_Mutex *allocMutexPtr; #endif static int allocInit = 0; #ifdef MSTATS /* |
| ︙ | ︙ | |||
167 168 169 170 171 172 173 |
*/
void
TclInitAlloc(void)
{
if (!allocInit) {
allocInit = 1;
| | | 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 |
*/
void
TclInitAlloc(void)
{
if (!allocInit) {
allocInit = 1;
#if TCL_THREADS
allocMutexPtr = Tcl_GetAllocMutex();
#endif
}
}
/*
*-------------------------------------------------------------------------
|
| ︙ | ︙ | |||
245 246 247 248 249 250 251 | * * Side effects: * None. * *---------------------------------------------------------------------- */ | | | | | | 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 |
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
void *
TclpAlloc(
size_t numBytes) /* Number of bytes to allocate. */
{
register union overhead *overPtr;
register size_t bucket;
register size_t amount;
struct block *bigBlockPtr = NULL;
if (!allocInit) {
/*
* We have to make the "self initializing" because Tcl_Alloc may be
* used before any other part of Tcl. E.g., see main() for tclsh!
*/
TclInitAlloc();
}
Tcl_MutexLock(allocMutexPtr);
/*
* First the simple case: we simple allocate big blocks directly.
*/
if (numBytes >= MAXMALLOC - OVERHEAD) {
if (numBytes <= UINT_MAX - OVERHEAD -sizeof(struct block)) {
bigBlockPtr = TclpSysAlloc(
sizeof(struct block) + OVERHEAD + numBytes);
}
if (bigBlockPtr == NULL) {
Tcl_MutexUnlock(allocMutexPtr);
return NULL;
}
bigBlockPtr->nextPtr = bigBlocks.nextPtr;
|
| ︙ | ︙ | |||
401 402 403 404 405 406 407 |
size = ((size_t)1) << (bucket + 3);
ASSERT(size > 0);
amount = MAXMALLOC;
numBlocks = amount / size;
ASSERT(numBlocks*size == amount);
| < | | 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 |
size = ((size_t)1) << (bucket + 3);
ASSERT(size > 0);
amount = MAXMALLOC;
numBlocks = amount / size;
ASSERT(numBlocks*size == amount);
blockPtr = TclpSysAlloc(sizeof(struct block) + amount);
/* no more room! */
if (blockPtr == NULL) {
return;
}
blockPtr->nextPtr = blockList;
blockList = blockPtr;
|
| ︙ | ︙ | |||
442 443 444 445 446 447 448 | * None. * *---------------------------------------------------------------------- */ void TclpFree( | | | 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 |
* None.
*
*----------------------------------------------------------------------
*/
void
TclpFree(
void *oldPtr) /* Pointer to memory to free. */
{
register size_t size;
register union overhead *overPtr;
struct block *bigBlockPtr;
if (oldPtr == NULL) {
return;
|
| ︙ | ︙ | |||
505 506 507 508 509 510 511 | * * Side effects: * None. * *---------------------------------------------------------------------- */ | | | | | 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 |
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
void *
TclpRealloc(
void *oldPtr, /* Pointer to alloced block. */
size_t numBytes) /* New size of memory. */
{
int i;
union overhead *overPtr;
struct block *bigBlockPtr;
int expensive;
size_t maxSize;
|
| ︙ | ︙ | |||
600 601 602 603 604 605 606 |
if (newPtr == NULL) {
return NULL;
}
maxSize -= OVERHEAD;
if (maxSize < numBytes) {
numBytes = maxSize;
}
| | | 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 |
if (newPtr == NULL) {
return NULL;
}
maxSize -= OVERHEAD;
if (maxSize < numBytes) {
numBytes = maxSize;
}
memcpy(newPtr, oldPtr, numBytes);
TclpFree(oldPtr);
return newPtr;
}
/*
* Ok, we don't have to copy, it fits as-is
*/
|
| ︙ | ︙ | |||
688 689 690 691 692 693 694 | * * Side effects: * None. * *---------------------------------------------------------------------- */ | > | | | > | | 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 |
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
#undef TclpAlloc
void *
TclpAlloc(
size_t numBytes) /* Number of bytes to allocate. */
{
return malloc(numBytes);
}
/*
*----------------------------------------------------------------------
*
* TclpFree --
*
* Free memory.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
#undef TclpFree
void
TclpFree(
void *oldPtr) /* Pointer to memory to free. */
{
free(oldPtr);
return;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
735 736 737 738 739 740 741 | * * Side effects: * None. * *---------------------------------------------------------------------- */ | | | | | | 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 |
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
void *
TclpRealloc(
void *oldPtr, /* Pointer to alloced block. */
size_t numBytes) /* New size of memory. */
{
return realloc(oldPtr, numBytes);
}
#endif /* !USE_TCLALLOC */
#endif /* !TCL_THREADS */
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclAssembly.c.
| ︙ | ︙ | |||
28 29 30 31 32 33 34 35 36 37 38 39 40 41 |
*- returnCodeBranch
*- tclooNext, tclooNextClass
*/
#include "tclInt.h"
#include "tclCompile.h"
#include "tclOOInt.h"
/*
* Structure that represents a range of instructions in the bytecode.
*/
typedef struct CodeRange {
int startOffset; /* Start offset in the bytecode array */
| > | 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 |
*- returnCodeBranch
*- tclooNext, tclooNextClass
*/
#include "tclInt.h"
#include "tclCompile.h"
#include "tclOOInt.h"
#include <assert.h>
/*
* Structure that represents a range of instructions in the bytecode.
*/
typedef struct CodeRange {
int startOffset; /* Start offset in the bytecode array */
|
| ︙ | ︙ | |||
139 140 141 142 143 144 145 146 147 148 149 150 151 152 |
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. */
| > > | 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 |
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_GET_DEF, /* 'dict getwithdefault' - consumes N+2
* 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. */
|
| ︙ | ︙ | |||
267 268 269 270 271 272 273 | 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); | < < < | 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 | 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); |
| ︙ | ︙ | |||
313 314 315 316 317 318 319 320 321 322 323 324 325 326 |
int codeLen, int flags);
static void UnstackExpiredCatches(CompileEnv*, BasicBlock*, int,
BasicBlock**, int*);
/*
* Tcl_ObjType that describes bytecode emitted by the assembler.
*/
static const Tcl_ObjType assembleCodeType = {
"assemblecode",
FreeAssembleCodeInternalRep, /* freeIntRepProc */
DupAssembleCodeInternalRep, /* dupIntRepProc */
NULL, /* updateStringProc */
NULL /* setFromAnyProc */
| > > > | 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 |
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 */
|
| ︙ | ︙ | |||
357 358 359 360 361 362 363 364 365 366 367 368 369 370 |
{"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},
{"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,
| > | 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 |
{"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,
|
| ︙ | ︙ | |||
507 508 509 510 511 512 513 514 515 516 517 518 519 520 |
* 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_LIST, /* 79 */
INST_OVER, /* 95 */
INST_PUSH_RETURN_OPTIONS, /* 108 */
INST_REVERSE, /* 126 */
INST_NOP, /* 132 */
INST_STR_MAP, /* 143 */
INST_STR_FIND, /* 144 */
| > | 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 |
* 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 */
|
| ︙ | ︙ | |||
612 613 614 615 616 617 618 |
int count) /* Count of operands for variadic insts */
{
int consumed = TalInstructionTable[tblIdx].operandsConsumed;
int produced = TalInstructionTable[tblIdx].operandsProduced;
if (consumed == INT_MIN) {
/*
| | > > > > | 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 |
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'
*/
|
| ︙ | ︙ | |||
796 797 798 799 800 801 802 |
* On failure, report error line.
*/
if (codePtr == NULL) {
Tcl_AddErrorInfo(interp, "\n (\"");
Tcl_AppendObjToErrorInfo(interp, objv[0]);
Tcl_AddErrorInfo(interp, "\" body, line ");
| | | 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 |
* On failure, report error line.
*/
if (codePtr == NULL) {
Tcl_AddErrorInfo(interp, "\n (\"");
Tcl_AppendObjToErrorInfo(interp, objv[0]);
Tcl_AddErrorInfo(interp, "\" body, line ");
backtrace = Tcl_NewWideIntObj(Tcl_GetErrorLine(interp));
Tcl_AppendObjToErrorInfo(interp, backtrace);
Tcl_AddErrorInfo(interp, ")");
return TCL_ERROR;
}
/*
* Use NRE to evaluate the bytecode from the trampoline.
|
| ︙ | ︙ | |||
839 840 841 842 843 844 845 |
CompileEnv compEnv; /* Compilation environment structure */
register 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 */
| | < | > > < | | 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 |
CompileEnv compEnv; /* Compilation environment structure */
register 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);
|
| ︙ | ︙ | |||
973 974 975 976 977 978 979 |
*/
if (TCL_ERROR == TclAssembleCode(envPtr, tokenPtr[1].start,
tokenPtr[1].size, TCL_EVAL_DIRECT)) {
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (\"%.*s\" body, line %d)",
| | | 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 |
*/
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;
|
| ︙ | ︙ | |||
1060 1061 1062 1063 1064 1065 1066 |
parsePtr->commandStart - envPtr->source);
/*
* Process the line of code.
*/
if (parsePtr->numWords > 0) {
| | | | | 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 |
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) {
|
| ︙ | ︙ | |||
1200 1201 1202 1203 1204 1205 1206 |
*/
for (thisBB = assemEnvPtr->head_bb; thisBB != NULL; thisBB = nextBB) {
if (thisBB->jumpTarget != NULL) {
Tcl_DecrRefCount(thisBB->jumpTarget);
}
if (thisBB->foreignExceptions != NULL) {
| | | | 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 |
*/
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);
|
| ︙ | ︙ | |||
1253 1254 1255 1256 1257 1258 1259 |
Tcl_Obj* instNameObj; /* Name of the instruction */
int tblIdx; /* Index in TalInstructionTable of the
* instruction */
enum TalInstType instType; /* Type of the instruction */
Tcl_Obj* operand1Obj = NULL;
/* First operand to the instruction */
const char* operand1; /* String rep of the operand */
| | | 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 |
Tcl_Obj* instNameObj; /* Name of the instruction */
int tblIdx; /* Index in TalInstructionTable of the
* instruction */
enum TalInstType instType; /* Type of the instruction */
Tcl_Obj* operand1Obj = NULL;
/* First operand to the instruction */
const char* operand1; /* String rep of the operand */
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 */
|
| ︙ | ︙ | |||
1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 |
|| CheckStrictlyPositive(interp, opnd) != TCL_OK) {
goto cleanup;
}
BBEmitInstInt1(assemEnvPtr, tblIdx, opnd, opnd);
break;
case ASSEM_DICT_GET:
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;
| > | 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 |
|| 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;
|
| ︙ | ︙ | |||
1525 1526 1527 1528 1529 1530 1531 |
Tcl_WrongNumArgs(interp, 1, &instNameObj, "table");
goto cleanup;
}
if (GetNextOperand(assemEnvPtr, &tokenPtr, &operand1Obj) != TCL_OK) {
goto cleanup;
}
| | | 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 |
Tcl_WrongNumArgs(interp, 1, &instNameObj, "table");
goto cleanup;
}
if (GetNextOperand(assemEnvPtr, &tokenPtr, &operand1Obj) != TCL_OK) {
goto cleanup;
}
jtPtr = 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);
|
| ︙ | ︙ | |||
1924 1925 1926 1927 1928 1929 1930 |
*/
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 =
| | | 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 |
*/
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 =
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;
|
| ︙ | ︙ | |||
1989 1990 1991 1992 1993 1994 1995 |
return TCL_ERROR;
}
/*
* Allocate the jumptable.
*/
| | | 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 |
return TCL_ERROR;
}
/*
* Allocate the jumptable.
*/
jtPtr = Tcl_Alloc(sizeof(JumptableInfo));
jtHashPtr = &jtPtr->hashTable;
Tcl_InitHashTable(jtHashPtr, TCL_STRING_KEYS);
/*
* Fill the keys and labels into the table.
*/
|
| ︙ | ︙ | |||
2054 2055 2056 2057 2058 2059 2060 |
entry != NULL;
entry = Tcl_NextHashEntry(&search)) {
label = Tcl_GetHashValue(entry);
Tcl_DecrRefCount(label);
Tcl_SetHashValue(entry, NULL);
}
Tcl_DeleteHashTable(jtHashPtr);
| | | 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 |
entry != NULL;
entry = Tcl_NextHashEntry(&search)) {
label = Tcl_GetHashValue(entry);
Tcl_DecrRefCount(label);
Tcl_SetHashValue(entry, NULL);
}
Tcl_DeleteHashTable(jtHashPtr);
Tcl_Free(jtPtr);
}
/*
*-----------------------------------------------------------------------------
*
* GetNextOperand --
*
|
| ︙ | ︙ | |||
2247 2248 2249 2250 2251 2252 2253 |
Tcl_Obj *value;
int status;
/* General operand validity check */
if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &value) != TCL_OK) {
return TCL_ERROR;
}
| | | | 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 |
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;
}
/*
|
| ︙ | ︙ | |||
2297 2298 2299 2300 2301 2302 2303 |
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;
| | | 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 |
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)) {
|
| ︙ | ︙ | |||
2637 2638 2639 2640 2641 2642 2643 |
*/
static BasicBlock *
AllocBB(
AssemblyEnv* assemEnvPtr) /* Assembly environment */
{
CompileEnv* envPtr = assemEnvPtr->envPtr;
| | | 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 |
*/
static BasicBlock *
AllocBB(
AssemblyEnv* assemEnvPtr) /* Assembly environment */
{
CompileEnv* envPtr = assemEnvPtr->envPtr;
BasicBlock *bb = 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;
|
| ︙ | ︙ | |||
3915 3916 3917 3918 3919 3920 3921 |
}
}
/*
* Allocate memory for a stack of active catches.
*/
| | | | 3925 3926 3927 3928 3929 3930 3931 3932 3933 3934 3935 3936 3937 3938 3939 3940 |
}
}
/*
* Allocate memory for a stack of active catches.
*/
catches = Tcl_Alloc(maxCatchDepth * sizeof(BasicBlock*));
catchIndices = 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.
|
| ︙ | ︙ | |||
3955 3956 3957 3958 3959 3960 3961 |
if (catchDepth != 0) {
Tcl_Panic("unclosed catch at end of code in "
"tclAssembly.c:BuildExceptionRanges, can't happen");
}
/* Free temp storage */
| | | | 3965 3966 3967 3968 3969 3970 3971 3972 3973 3974 3975 3976 3977 3978 3979 3980 |
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;
}
/*
*-----------------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
4256 4257 4258 4259 4260 4261 4262 |
CompileEnv* envPtr = assemEnvPtr->envPtr;
/* Compilation environment */
Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
/* Tcl interpreter */
Tcl_Obj* lineNo; /* Line number in the source */
Tcl_AddErrorInfo(interp, "\n in assembly code between lines ");
| | | 4266 4267 4268 4269 4270 4271 4272 4273 4274 4275 4276 4277 4278 4279 4280 |
CompileEnv* envPtr = assemEnvPtr->envPtr;
/* Compilation environment */
Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
/* Tcl interpreter */
Tcl_Obj* lineNo; /* Line number in the source */
Tcl_AddErrorInfo(interp, "\n in assembly code between lines ");
lineNo = Tcl_NewWideIntObj(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 {
|
| ︙ | ︙ | |||
4326 4327 4328 4329 4330 4331 4332 |
*-----------------------------------------------------------------------------
*/
static void
FreeAssembleCodeInternalRep(
Tcl_Obj *objPtr)
{
| | > > > | 4336 4337 4338 4339 4340 4341 4342 4343 4344 4345 4346 4347 4348 4349 4350 4351 4352 4353 4354 4355 4356 4357 |
*-----------------------------------------------------------------------------
*/
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:
*/
|
Changes to generic/tclAsync.c.
| ︙ | ︙ | |||
114 115 116 117 118 119 120 |
Tcl_AsyncProc *proc, /* Procedure to call when handler is
* invoked. */
ClientData clientData) /* Argument to pass to handler. */
{
AsyncHandler *asyncPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
| | | 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 |
Tcl_AsyncProc *proc, /* Procedure to call when handler is
* invoked. */
ClientData clientData) /* Argument to pass to handler. */
{
AsyncHandler *asyncPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
asyncPtr = Tcl_Alloc(sizeof(AsyncHandler));
asyncPtr->ready = 0;
asyncPtr->nextPtr = NULL;
asyncPtr->proc = proc;
asyncPtr->clientData = clientData;
asyncPtr->originTsd = tsdPtr;
asyncPtr->originThrdId = Tcl_GetCurrentThread();
|
| ︙ | ︙ | |||
306 307 308 309 310 311 312 |
prevPtr->nextPtr = asyncPtr->nextPtr;
}
if (asyncPtr == tsdPtr->lastHandler) {
tsdPtr->lastHandler = prevPtr;
}
}
Tcl_MutexUnlock(&tsdPtr->asyncMutex);
| | | 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 |
prevPtr->nextPtr = asyncPtr->nextPtr;
}
if (asyncPtr == tsdPtr->lastHandler) {
tsdPtr->lastHandler = prevPtr;
}
}
Tcl_MutexUnlock(&tsdPtr->asyncMutex);
Tcl_Free(asyncPtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_AsyncReady --
*
|
| ︙ | ︙ |
Changes to generic/tclBasic.c.
| ︙ | ︙ | |||
49 50 51 52 53 54 55 |
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. */
| | | > > > > > > > > > > > | 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 |
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; /* Ignored */
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) \
|
| ︙ | ︙ | |||
78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 |
iPtr->cmdFramePtr = (context).cmdFramePtr; \
iPtr->lineLABCPtr = (context).lineLABCPtr
/*
* Static functions in this file:
*/
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);
#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;
| > < | 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 |
iPtr->cmdFramePtr = (context).cmdFramePtr; \
iPtr->lineLABCPtr = (context).lineLABCPtr
/*
* Static functions in this file:
*/
static Tcl_ObjCmdProc BadEnsembleSubcommand;
static char * CallCommandTraces(Interp *iPtr, Command *cmdPtr,
const char *oldName, const char *newName,
int flags);
static int CancelEvalProc(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);
#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 ExprMaxFunc;
static Tcl_ObjCmdProc ExprMinFunc;
static Tcl_ObjCmdProc ExprRandFunc;
static Tcl_ObjCmdProc ExprRoundFunc;
|
| ︙ | ︙ | |||
140 141 142 143 144 145 146 | 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; | | > > > > > | 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 | 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]. */ |
| ︙ | ︙ | |||
175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 |
#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 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},
{"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},
{"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},
{"lrange", Tcl_LrangeObjCmd, TclCompileLrangeCmd, 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},
| > > > > > > > > > > > > > > > > > > > > > > | 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 |
#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},
{"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},
|
| ︙ | ︙ | |||
266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 |
{"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},
{"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}
};
/*
* Math functions. All are safe.
*/
typedef struct {
const char *name; /* Name of the function. The full name is
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 |
{"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}
};
/*
* Math functions. All are safe.
*/
typedef struct {
const char *name; /* Name of the function. The full name is
|
| ︙ | ︙ | |||
293 294 295 296 297 298 299 |
{ "atan", ExprUnaryFunc, (ClientData) atan },
{ "atan2", ExprBinaryFunc, (ClientData) atan2 },
{ "bool", ExprBoolFunc, NULL },
{ "ceil", ExprCeilFunc, NULL },
{ "cos", ExprUnaryFunc, (ClientData) cos },
{ "cosh", ExprUnaryFunc, (ClientData) cosh },
{ "double", ExprDoubleFunc, NULL },
| | | 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 |
{ "atan", ExprUnaryFunc, (ClientData) atan },
{ "atan2", ExprBinaryFunc, (ClientData) atan2 },
{ "bool", ExprBoolFunc, NULL },
{ "ceil", ExprCeilFunc, NULL },
{ "cos", ExprUnaryFunc, (ClientData) cos },
{ "cosh", ExprUnaryFunc, (ClientData) cosh },
{ "double", ExprDoubleFunc, NULL },
{ "entier", ExprIntFunc, NULL },
{ "exp", ExprUnaryFunc, (ClientData) exp },
{ "floor", ExprFloorFunc, NULL },
{ "fmod", ExprBinaryFunc, (ClientData) fmod },
{ "hypot", ExprBinaryFunc, (ClientData) hypot },
{ "int", ExprIntFunc, NULL },
{ "isqrt", ExprIsqrtFunc, NULL },
{ "log", ExprUnaryFunc, (ClientData) log },
|
| ︙ | ︙ | |||
408 409 410 411 412 413 414 415 416 417 418 419 420 421 |
{
Tcl_MutexLock(&cancelLock);
if (cancelTableInitialized == 1) {
Tcl_DeleteHashTable(&cancelTable);
cancelTableInitialized = 0;
}
Tcl_MutexUnlock(&cancelLock);
}
/*
*----------------------------------------------------------------------
*
* Tcl_CreateInterp --
*
| > > > > > > > | 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 |
{
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);
}
/*
*----------------------------------------------------------------------
*
* Tcl_CreateInterp --
*
|
| ︙ | ︙ | |||
437 438 439 440 441 442 443 |
{
Interp *iPtr;
Tcl_Interp *interp;
Command *cmdPtr;
const BuiltinFuncDef *builtinFuncPtr;
const OpCmdInfo *opcmdInfoPtr;
const CmdInfo *cmdInfoPtr;
| | | 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 |
{
Interp *iPtr;
Tcl_Interp *interp;
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;
|
| ︙ | ︙ | |||
468 469 470 471 472 473 474 |
}
#if defined(_WIN32) && !defined(_WIN64)
if (sizeof(time_t) != 4) {
/*NOTREACHED*/
Tcl_Panic("<time.h> is not compatible with MSVC");
}
| | | > > > > > > > > > > > > > > | | 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 |
}
#if defined(_WIN32) && !defined(_WIN64)
if (sizeof(time_t) != 4) {
/*NOTREACHED*/
Tcl_Panic("<time.h> is not compatible with MSVC");
}
if ((offsetof(Tcl_StatBuf,st_atime) != 32)
|| (offsetof(Tcl_StatBuf,st_ctime) != 40)) {
/*NOTREACHED*/
Tcl_Panic("<sys/stat.h> is not compatible with MSVC");
}
#endif
if (cancelTableInitialized == 0) {
Tcl_MutexLock(&cancelLock);
if (cancelTableInitialized == 0) {
Tcl_InitHashTable(&cancelTable, TCL_ONE_WORD_KEYS);
cancelTableInitialized = 1;
}
Tcl_MutexUnlock(&cancelLock);
}
if (commandTypeInit == 0) {
TclRegisterCommandTypeName(TclObjInterpProc, "proc");
TclRegisterCommandTypeName(TclEnsembleImplementationCmd, "ensemble");
TclRegisterCommandTypeName(TclAliasObjCmd, "alias");
TclRegisterCommandTypeName(TclLocalAliasObjCmd, "alias");
TclRegisterCommandTypeName(TclSlaveObjCmd, "slave");
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 = Tcl_Alloc(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->errorLine = 0;
|
| ︙ | ︙ | |||
519 520 521 522 523 524 525 |
/*
* TIP #280 - Initialize the arrays used to extend the ByteCode and Proc
* structures.
*/
iPtr->cmdFramePtr = NULL;
| | | | | | 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 |
/*
* TIP #280 - Initialize the arrays used to extend the ByteCode and Proc
* structures.
*/
iPtr->cmdFramePtr = NULL;
iPtr->linePBodyPtr = Tcl_Alloc(sizeof(Tcl_HashTable));
iPtr->lineBCPtr = Tcl_Alloc(sizeof(Tcl_HashTable));
iPtr->lineLAPtr = Tcl_Alloc(sizeof(Tcl_HashTable));
iPtr->lineLABCPtr = Tcl_Alloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(iPtr->linePBodyPtr, TCL_ONE_WORD_KEYS);
Tcl_InitHashTable(iPtr->lineBCPtr, TCL_ONE_WORD_KEYS);
Tcl_InitHashTable(iPtr->lineLAPtr, TCL_ONE_WORD_KEYS);
Tcl_InitHashTable(iPtr->lineLABCPtr, TCL_ONE_WORD_KEYS);
iPtr->scriptCLLocPtr = NULL;
iPtr->activeVarTracePtr = NULL;
|
| ︙ | ︙ | |||
615 616 617 618 619 620 621 |
/*
* 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 */
| | | 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 |
/*
* 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 = Tcl_Alloc(sizeof(CallFrame));
(void) Tcl_PushCallFrame(interp, (Tcl_CallFrame *) framePtr,
(Tcl_Namespace *) iPtr->globalNsPtr, /*isProcCallFrame*/ 0);
framePtr->objc = 0;
iPtr->framePtr = framePtr;
iPtr->varFramePtr = framePtr;
iPtr->rootFramePtr = framePtr;
|
| ︙ | ︙ | |||
645 646 647 648 649 650 651 |
/*
* TIP #285, Script cancellation support.
*/
iPtr->asyncCancelMsg = Tcl_NewObj();
| | | 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 |
/*
* TIP #285, Script cancellation support.
*/
iPtr->asyncCancelMsg = Tcl_NewObj();
cancelInfo = Tcl_Alloc(sizeof(CancelInfo));
cancelInfo->interp = interp;
iPtr->asyncCancel = Tcl_AsyncCreate(CancelEvalProc, cancelInfo);
cancelInfo->async = iPtr->asyncCancel;
cancelInfo->result = NULL;
cancelInfo->length = 0;
|
| ︙ | ︙ | |||
695 696 697 698 699 700 701 |
memset(statsPtr->literalCount, 0, sizeof(statsPtr->literalCount));
#endif /* TCL_COMPILE_STATS */
/*
* Initialize the ensemble error message rewriting support.
*/
| | < < | | 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 |
memset(statsPtr->literalCount, 0, sizeof(statsPtr->literalCount));
#endif /* TCL_COMPILE_STATS */
/*
* Initialize the ensemble error message rewriting support.
*/
TclResetRewriteEnsemble(interp, 1);
/*
* TIP#143: Initialise the resource limit support.
*/
TclInitLimitSupport(interp);
/*
* Initialise the thread-specific data ekeko. Note that the thread's alloc
* cache was already initialised by the call to alloc the interp struct.
*/
#if TCL_THREADS && defined(USE_THREAD_ALLOC)
iPtr->allocCache = TclpGetAllocCache();
#else
iPtr->allocCache = NULL;
#endif
iPtr->pendingObjDataPtr = NULL;
iPtr->asyncReadyPtr = TclGetAsyncReadyPtr();
iPtr->deferredCallbacks = NULL;
|
| ︙ | ︙ | |||
740 741 742 743 744 745 746 |
&& (cmdInfoPtr->nreProc == NULL)) {
Tcl_Panic("builtin command with NULL object command proc and a NULL compile proc");
}
hPtr = Tcl_CreateHashEntry(&iPtr->globalNsPtr->cmdTable,
cmdInfoPtr->name, &isNew);
if (isNew) {
| | | 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 |
&& (cmdInfoPtr->nreProc == NULL)) {
Tcl_Panic("builtin command with NULL object command proc and a NULL compile proc");
}
hPtr = Tcl_CreateHashEntry(&iPtr->globalNsPtr->cmdTable,
cmdInfoPtr->name, &isNew);
if (isNew) {
cmdPtr = Tcl_Alloc(sizeof(Command));
cmdPtr->hPtr = hPtr;
cmdPtr->nsPtr = iPtr->globalNsPtr;
cmdPtr->refCount = 1;
cmdPtr->cmdEpoch = 0;
cmdPtr->compileProc = cmdInfoPtr->compileProc;
cmdPtr->proc = TclInvokeObjectCommand;
cmdPtr->clientData = cmdPtr;
|
| ︙ | ︙ | |||
819 820 821 822 823 824 825 826 |
/* Adding the bytecode assembler command */
cmdPtr = (Command *) Tcl_NRCreateCommand(interp,
"::tcl::unsupported::assemble", Tcl_AssembleObjCmd,
TclNRAssembleObjCmd, NULL, NULL);
cmdPtr->compileProc = &TclCompileAssembleCmd;
Tcl_NRCreateCommand(interp, "::tcl::unsupported::inject", NULL,
| > | > > > > > > > > > | | | | | | | | 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 |
/* 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);
/* Export unsupported commands */
nsPtr = Tcl_FindNamespace(interp, "::tcl::unsupported", NULL, 0);
if (nsPtr) {
Tcl_Export(interp, nsPtr, "*", 1);
}
#ifdef USE_DTRACE
/*
* Register the tcl::dtrace command.
*/
Tcl_CreateObjCommand(interp, "::tcl::dtrace", DTraceObjCmd, NULL, NULL);
#endif /* USE_DTRACE */
/*
* Register the builtin math functions.
*/
nsPtr = Tcl_CreateNamespace(interp, "::tcl::mathfunc", NULL,NULL);
if (nsPtr == NULL) {
Tcl_Panic("Can't create math function namespace");
}
#define MATH_FUNC_PREFIX_LEN 17 /* == strlen("::tcl::mathfunc::") */
memcpy(mathFuncName, "::tcl::mathfunc::", MATH_FUNC_PREFIX_LEN);
for (builtinFuncPtr = BuiltinFuncTable; builtinFuncPtr->name != NULL;
builtinFuncPtr++) {
strcpy(mathFuncName+MATH_FUNC_PREFIX_LEN, builtinFuncPtr->name);
Tcl_CreateObjCommand(interp, mathFuncName,
builtinFuncPtr->objCmdProc, 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);
if (nsPtr == NULL) {
Tcl_Panic("can't create math operator namespace");
}
Tcl_Export(interp, nsPtr, "*", 1);
#define MATH_OP_PREFIX_LEN 15 /* == strlen("::tcl::mathop::") */
memcpy(mathFuncName, "::tcl::mathop::", MATH_OP_PREFIX_LEN);
for (opcmdInfoPtr=mathOpCmds ; opcmdInfoPtr->name!=NULL ; opcmdInfoPtr++){
TclOpCmdClientData *occdPtr = Tcl_Alloc(sizeof(TclOpCmdClientData));
occdPtr->op = opcmdInfoPtr->name;
occdPtr->i.numArgs = opcmdInfoPtr->i.numArgs;
occdPtr->expected = opcmdInfoPtr->expected;
strcpy(mathFuncName + MATH_OP_PREFIX_LEN, opcmdInfoPtr->name);
cmdPtr = (Command *) Tcl_CreateObjCommand(interp, mathFuncName,
opcmdInfoPtr->objProc, occdPtr, DeleteOpCmdClientData);
|
| ︙ | ︙ | |||
906 907 908 909 910 911 912 |
order.s = 1;
Tcl_SetVar2(interp, "tcl_platform", "byteOrder",
((order.c[0] == 1) ? "littleEndian" : "bigEndian"),
TCL_GLOBAL_ONLY);
Tcl_SetVar2Ex(interp, "tcl_platform", "wordSize",
| | | | | | | | | > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 |
order.s = 1;
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);
/* TIP #291 */
Tcl_SetVar2Ex(interp, "tcl_platform", "pointerSize",
Tcl_NewWideIntObj(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);
TclpSetVariables(interp);
#if TCL_THREADS
/*
* The existence of the "threaded" element of the tcl_platform array
* indicates that this particular Tcl shell has been compiled with threads
* turned on. Using "info exists tcl_platform(threaded)" a Tcl script can
* introspect on the interpreter level of thread safety.
*/
Tcl_SetVar2(interp, "tcl_platform", "threaded", "1", TCL_GLOBAL_ONLY);
#endif
/*
* Register Tcl's version number.
* TIP #268: Full patchlevel instead of just major.minor
*/
Tcl_PkgProvideEx(interp, "Tcl", TCL_PATCH_LEVEL, &tclStubs);
if (TclTommath_Init(interp) != TCL_OK) {
Tcl_Panic("%s", 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;
return interp;
}
static void
DeleteOpCmdClientData(
ClientData clientData)
{
TclOpCmdClientData *occdPtr = 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;
void *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;
}
/*
*----------------------------------------------------------------------
*
* TclHideUnsafeCommands --
*
|
| ︙ | ︙ | |||
991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 |
*/
int
TclHideUnsafeCommands(
Tcl_Interp *interp) /* Hide commands in this interpreter. */
{
register const CmdInfo *cmdInfoPtr;
if (interp == NULL) {
return TCL_ERROR;
}
for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL; cmdInfoPtr++) {
if (!(cmdInfoPtr->flags & CMD_IS_SAFE)) {
Tcl_HideCommand(interp, cmdInfoPtr->name, cmdInfoPtr->name);
}
}
| > | > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 |
*/
int
TclHideUnsafeCommands(
Tcl_Interp *interp) /* Hide commands in this interpreter. */
{
register const CmdInfo *cmdInfoPtr;
register const UnsafeEnsembleInfo *unsafePtr;
if (interp == NULL) {
return TCL_ERROR;
}
for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL; cmdInfoPtr++) {
if (!(cmdInfoPtr->flags & CMD_IS_SAFE)) {
Tcl_HideCommand(interp, cmdInfoPtr->name, cmdInfoPtr->name);
}
}
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, (ClientData) 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,
int objc,
Tcl_Obj *const objv[])
{
const UnsafeEnsembleInfo *infoPtr = 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 --
*
* Arrange for a function to be called before a given interpreter is
|
| ︙ | ︙ | |||
1039 1040 1041 1042 1043 1044 1045 |
{
Interp *iPtr = (Interp *) interp;
static Tcl_ThreadDataKey assocDataCounterKey;
int *assocDataCounterPtr =
Tcl_GetThreadData(&assocDataCounterKey, sizeof(int));
int isNew;
char buffer[32 + TCL_INTEGER_SPACE];
| | | | 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 |
{
Interp *iPtr = (Interp *) interp;
static Tcl_ThreadDataKey assocDataCounterKey;
int *assocDataCounterPtr =
Tcl_GetThreadData(&assocDataCounterKey, sizeof(int));
int isNew;
char buffer[32 + TCL_INTEGER_SPACE];
AssocData *dPtr = Tcl_Alloc(sizeof(AssocData));
Tcl_HashEntry *hPtr;
sprintf(buffer, "Assoc Data Key #%d", *assocDataCounterPtr);
(*assocDataCounterPtr)++;
if (iPtr->assocData == NULL) {
iPtr->assocData = Tcl_Alloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS);
}
hPtr = Tcl_CreateHashEntry(iPtr->assocData, buffer, &isNew);
dPtr->proc = proc;
dPtr->clientData = clientData;
Tcl_SetHashValue(hPtr, dPtr);
}
|
| ︙ | ︙ | |||
1095 1096 1097 1098 1099 1100 1101 |
if (hTablePtr == NULL) {
return;
}
for (hPtr = Tcl_FirstHashEntry(hTablePtr, &hSearch); hPtr != NULL;
hPtr = Tcl_NextHashEntry(&hSearch)) {
dPtr = Tcl_GetHashValue(hPtr);
if ((dPtr->proc == proc) && (dPtr->clientData == clientData)) {
| | | 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 |
if (hTablePtr == NULL) {
return;
}
for (hPtr = Tcl_FirstHashEntry(hTablePtr, &hSearch); hPtr != NULL;
hPtr = Tcl_NextHashEntry(&hSearch)) {
dPtr = Tcl_GetHashValue(hPtr);
if ((dPtr->proc == proc) && (dPtr->clientData == clientData)) {
Tcl_Free(dPtr);
Tcl_DeleteHashEntry(hPtr);
return;
}
}
}
/*
|
| ︙ | ︙ | |||
1135 1136 1137 1138 1139 1140 1141 |
{
Interp *iPtr = (Interp *) interp;
AssocData *dPtr;
Tcl_HashEntry *hPtr;
int isNew;
if (iPtr->assocData == NULL) {
| | | | 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 |
{
Interp *iPtr = (Interp *) interp;
AssocData *dPtr;
Tcl_HashEntry *hPtr;
int isNew;
if (iPtr->assocData == NULL) {
iPtr->assocData = Tcl_Alloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS);
}
hPtr = Tcl_CreateHashEntry(iPtr->assocData, name, &isNew);
if (isNew == 0) {
dPtr = Tcl_GetHashValue(hPtr);
} else {
dPtr = Tcl_Alloc(sizeof(AssocData));
}
dPtr->proc = proc;
dPtr->clientData = clientData;
Tcl_SetHashValue(hPtr, dPtr);
}
|
| ︙ | ︙ | |||
1187 1188 1189 1190 1191 1192 1193 |
if (hPtr == NULL) {
return;
}
dPtr = Tcl_GetHashValue(hPtr);
if (dPtr->proc != NULL) {
dPtr->proc(dPtr->clientData, interp);
}
| | | 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 |
if (hPtr == NULL) {
return;
}
dPtr = Tcl_GetHashValue(hPtr);
if (dPtr->proc != NULL) {
dPtr->proc(dPtr->clientData, interp);
}
Tcl_Free(dPtr);
Tcl_DeleteHashEntry(hPtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetAssocData --
|
| ︙ | ︙ | |||
1383 1384 1385 1386 1387 1388 1389 |
Tcl_MutexLock(&cancelLock);
hPtr = Tcl_FindHashEntry(&cancelTable, (char *) iPtr);
if (hPtr != NULL) {
CancelInfo *cancelInfo = Tcl_GetHashValue(hPtr);
if (cancelInfo != NULL) {
if (cancelInfo->result != NULL) {
| | | | 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 |
Tcl_MutexLock(&cancelLock);
hPtr = Tcl_FindHashEntry(&cancelTable, (char *) iPtr);
if (hPtr != NULL) {
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);
|
| ︙ | ︙ | |||
1440 1441 1442 1443 1444 1445 1446 |
*/
hPtr = Tcl_FirstHashEntry(hTablePtr, &search);
for (; hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
Tcl_DeleteCommandFromToken(interp, Tcl_GetHashValue(hPtr));
}
Tcl_DeleteHashTable(hTablePtr);
| | | | | | 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 |
*/
hPtr = Tcl_FirstHashEntry(hTablePtr, &search);
for (; hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
Tcl_DeleteCommandFromToken(interp, Tcl_GetHashValue(hPtr));
}
Tcl_DeleteHashTable(hTablePtr);
Tcl_Free(hTablePtr);
}
/*
* Invoke deletion callbacks; note that a callback can create new
* callbacks, so we iterate.
*/
while (iPtr->assocData != NULL) {
AssocData *dPtr;
hTablePtr = iPtr->assocData;
iPtr->assocData = NULL;
for (hPtr = Tcl_FirstHashEntry(hTablePtr, &search);
hPtr != NULL;
hPtr = Tcl_FirstHashEntry(hTablePtr, &search)) {
dPtr = Tcl_GetHashValue(hPtr);
Tcl_DeleteHashEntry(hPtr);
if (dPtr->proc != NULL) {
dPtr->proc(dPtr->clientData, interp);
}
Tcl_Free(dPtr);
}
Tcl_DeleteHashTable(hTablePtr);
Tcl_Free(hTablePtr);
}
/*
* Pop the root frame pointer and finish deleting the global
* namespace. The order is important [Bug 1658572].
*/
if ((iPtr->framePtr != iPtr->rootFramePtr) && !TclInExit()) {
Tcl_Panic("DeleteInterpProc: popping rootCallFrame with other frames on top");
}
Tcl_PopCallFrame(interp);
Tcl_Free(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.
*/
|
| ︙ | ︙ | |||
1524 1525 1526 1527 1528 1529 1530 |
}
Tcl_DecrRefCount(iPtr->emptyObjPtr);
iPtr->emptyObjPtr = NULL;
resPtr = iPtr->resolverPtr;
while (resPtr) {
nextResPtr = resPtr->nextPtr;
| | | | | | | | | | | | | | 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 |
}
Tcl_DecrRefCount(iPtr->emptyObjPtr);
iPtr->emptyObjPtr = NULL;
resPtr = iPtr->resolverPtr;
while (resPtr) {
nextResPtr = resPtr->nextPtr;
Tcl_Free(resPtr->name);
Tcl_Free(resPtr);
resPtr = nextResPtr;
}
/*
* 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 = 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 = 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_DeleteHashTable(&iPtr->varTraces);
Tcl_DeleteHashTable(&iPtr->varSearches);
Tcl_Free(iPtr);
}
/*
*---------------------------------------------------------------------------
*
* Tcl_HideCommand --
*
|
| ︙ | ︙ | |||
1725 1726 1727 1728 1729 1730 1731 |
/*
* Initialize the hidden command table if necessary.
*/
hiddenCmdTablePtr = iPtr->hiddenCmdTablePtr;
if (hiddenCmdTablePtr == NULL) {
| | | 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 |
/*
* Initialize the hidden command table if necessary.
*/
hiddenCmdTablePtr = iPtr->hiddenCmdTablePtr;
if (hiddenCmdTablePtr == NULL) {
hiddenCmdTablePtr = Tcl_Alloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(hiddenCmdTablePtr, TCL_STRING_KEYS);
iPtr->hiddenCmdTablePtr = hiddenCmdTablePtr;
}
/*
* It is an error to move an exposed command to a hidden command with
* hiddenCmdToken if a hidden command with the name hiddenCmdToken already
|
| ︙ | ︙ | |||
2057 2058 2059 2060 2061 2062 2063 | /* * isNew - No conflict with existing command. * deleted - We've already deleted a conflicting command */ break; } | > | > > | | | < | | | | < | 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 |
/*
* 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);
/*
* 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;
}
Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr);
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
|
| ︙ | ︙ | |||
2115 2116 2117 2118 2119 2120 2121 |
* However, we do not need to recompute this just yet; next time we
* need the info will be soon enough.
*/
TclInvalidateNsCmdLookup(nsPtr);
TclInvalidateNsPath(nsPtr);
}
| | | 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 |
* 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 = Tcl_Alloc(sizeof(Command));
Tcl_SetHashValue(hPtr, cmdPtr);
cmdPtr->hPtr = hPtr;
cmdPtr->nsPtr = nsPtr;
cmdPtr->refCount = 1;
cmdPtr->cmdEpoch = 0;
cmdPtr->compileProc = NULL;
cmdPtr->objProc = TclInvokeStringCommand;
|
| ︙ | ︙ | |||
2173 2174 2175 2176 2177 2178 2179 | * Results: * The return value is a token for the command, which can be used in * future calls to Tcl_GetCommandName. * * Side effects: * If a command named "cmdName" already exists for interp, it is * first deleted. Then the new command is created from the arguments. | < | 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 | * Results: * The return value is a token for the command, which can be used in * future calls to Tcl_GetCommandName. * * Side effects: * If a command named "cmdName" already exists for interp, it is * first deleted. Then the new command is created from the arguments. * * In the future, during bytecode evaluation when "cmdName" is seen as * the name of a command by Tcl_EvalObj or Tcl_Eval, the object-based * Tcl_ObjCmdProc proc will be called. When the command is deleted from * the table, deleteProc will be called. See the manual entry for details * on the calling sequence. * |
| ︙ | ︙ | |||
2237 2238 2239 2240 2241 2242 2243 |
}
return TclCreateObjCommandInNs(interp, tail, (Tcl_Namespace *) nsPtr,
proc, clientData, deleteProc);
}
Tcl_Command
| | | > | < > > | | | | > | | > > > | > > | | | | | | 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 |
}
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 *namespace, /* 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 *) namespace;
/*
* 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) {
/*
* 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);
/*
* Command already exists; delete it. Be careful to preserve any
* existing import links so we can restore them down below. That way,
* you can redefine a command and its import status will remain
* intact.
*/
cmdPtr->refCount++;
if (cmdPtr->importRefPtr) {
cmdPtr->flags |= CMD_REDEF_IN_PROGRESS;
}
/*
* Make sure namespace doesn't get deallocated.
*/
cmdPtr->nsPtr->refCount++;
Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr);
nsPtr = (Namespace *) TclEnsureNamespace(interp,
(Tcl_Namespace *) cmdPtr->nsPtr);
TclNsDecrRefCount(cmdPtr->nsPtr);
if (cmdPtr->flags & CMD_REDEF_IN_PROGRESS) {
oldRefPtr = cmdPtr->importRefPtr;
cmdPtr->importRefPtr = NULL;
}
TclCleanupCommandMacro(cmdPtr);
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
|
| ︙ | ︙ | |||
2335 2336 2337 2338 2339 2340 2341 |
* However, we do not need to recompute this just yet; next time we
* need the info will be soon enough.
*/
TclInvalidateNsCmdLookup(nsPtr);
TclInvalidateNsPath(nsPtr);
}
| | | 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 |
* 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 = Tcl_Alloc(sizeof(Command));
Tcl_SetHashValue(hPtr, cmdPtr);
cmdPtr->hPtr = hPtr;
cmdPtr->nsPtr = nsPtr;
cmdPtr->refCount = 1;
cmdPtr->cmdEpoch = 0;
cmdPtr->compileProc = NULL;
cmdPtr->objProc = proc;
|
| ︙ | ︙ | |||
2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 |
* all of these references to point to the new command.
*/
if (oldRefPtr != NULL) {
cmdPtr->importRefPtr = oldRefPtr;
while (oldRefPtr != NULL) {
Command *refCmdPtr = oldRefPtr->importedCmdPtr;
dataPtr = refCmdPtr->objClientData;
dataPtr->realCmdPtr = cmdPtr;
oldRefPtr = oldRefPtr->nextPtr;
}
}
/*
| > | 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 |
* all of these references to point to the new command.
*/
if (oldRefPtr != NULL) {
cmdPtr->importRefPtr = oldRefPtr;
while (oldRefPtr != NULL) {
Command *refCmdPtr = oldRefPtr->importedCmdPtr;
dataPtr = refCmdPtr->objClientData;
dataPtr->realCmdPtr = cmdPtr;
oldRefPtr = oldRefPtr->nextPtr;
}
}
/*
|
| ︙ | ︙ | |||
2410 2411 2412 2413 2414 2415 2416 |
Tcl_Interp *interp, /* Current interpreter. */
register int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Command *cmdPtr = clientData;
int i, result;
const char **argv =
| | | 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 |
Tcl_Interp *interp, /* Current interpreter. */
register int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Command *cmdPtr = clientData;
int i, result;
const char **argv =
TclStackAlloc(interp, (objc + 1) * sizeof(char *));
for (i = 0; i < objc; i++) {
argv[i] = TclGetString(objv[i]);
}
argv[objc] = 0;
/*
|
| ︙ | ︙ | |||
2459 2460 2461 2462 2463 2464 2465 |
int argc, /* Number of arguments. */
register const char **argv) /* Argument strings. */
{
Command *cmdPtr = clientData;
Tcl_Obj *objPtr;
int i, length, result;
Tcl_Obj **objv =
| | | 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 |
int argc, /* Number of arguments. */
register const char **argv) /* Argument strings. */
{
Command *cmdPtr = clientData;
Tcl_Obj *objPtr;
int i, length, result;
Tcl_Obj **objv =
TclStackAlloc(interp, (argc * sizeof(Tcl_Obj *)));
for (i = 0; i < argc; i++) {
length = strlen(argv[i]);
TclNewStringObj(objPtr, argv[i], length);
Tcl_IncrRefCount(objPtr);
objv[i] = objPtr;
}
|
| ︙ | ︙ | |||
3089 3090 3091 3092 3093 3094 3095 |
*/
tracePtr = cmdPtr->tracePtr;
while (tracePtr != NULL) {
CommandTrace *nextPtr = tracePtr->nextPtr;
if (tracePtr->refCount-- <= 1) {
| | | 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 |
*/
tracePtr = cmdPtr->tracePtr;
while (tracePtr != NULL) {
CommandTrace *nextPtr = tracePtr->nextPtr;
if (tracePtr->refCount-- <= 1) {
Tcl_Free(tracePtr);
}
tracePtr = nextPtr;
}
cmdPtr->tracePtr = NULL;
}
/*
|
| ︙ | ︙ | |||
3128 3129 3130 3131 3132 3133 3134 | * 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 | | | | | 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 |
* 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()
* 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().
*/
cmdPtr->deleteProc(cmdPtr->deleteData);
}
/*
* If this command was imported into other namespaces, then imported
|
| ︙ | ︙ | |||
3283 3284 3285 3286 3287 3288 3289 |
if (state == NULL) {
state = Tcl_SaveInterpState((Tcl_Interp *) iPtr, TCL_OK);
}
tracePtr->traceProc(tracePtr->clientData, (Tcl_Interp *) iPtr,
oldName, newName, flags);
cmdPtr->flags &= ~tracePtr->flags;
if (tracePtr->refCount-- <= 1) {
| | | 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 |
if (state == NULL) {
state = Tcl_SaveInterpState((Tcl_Interp *) iPtr, TCL_OK);
}
tracePtr->traceProc(tracePtr->clientData, (Tcl_Interp *) iPtr,
oldName, newName, flags);
cmdPtr->flags &= ~tracePtr->flags;
if (tracePtr->refCount-- <= 1) {
Tcl_Free(tracePtr);
}
}
if (state) {
Tcl_RestoreInterpState((Tcl_Interp *) iPtr, state);
}
|
| ︙ | ︙ | |||
3415 3416 3417 3418 3419 3420 3421 |
void
TclCleanupCommand(
register Command *cmdPtr) /* Points to the Command structure to
* be freed. */
{
if (cmdPtr->refCount-- <= 1) {
| | | 3695 3696 3697 3698 3699 3700 3701 3702 3703 3704 3705 3706 3707 3708 3709 |
void
TclCleanupCommand(
register Command *cmdPtr) /* Points to the Command structure to
* be freed. */
{
if (cmdPtr->refCount-- <= 1) {
Tcl_Free(cmdPtr);
}
}
/*
*----------------------------------------------------------------------
*
* TclInterpReady --
|
| ︙ | ︙ | |||
3594 3595 3596 3597 3598 3599 3600 |
/*
* 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;
| | | 3874 3875 3876 3877 3878 3879 3880 3881 3882 3883 3884 3885 3886 3887 3888 |
/*
* 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) {
|
| ︙ | ︙ | |||
3702 3703 3704 3705 3706 3707 3708 |
* 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);
| | | | 3982 3983 3984 3985 3986 3987 3988 3989 3990 3991 3992 3993 3994 3995 3996 3997 |
* 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 = 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;
|
| ︙ | ︙ | |||
3877 3878 3879 3880 3881 3882 3883 |
lookupNsPtr = iPtr->globalNsPtr;
} else {
/*
* TCL_EVAL_INVOKE was not set: clear rewrite rules
*/
| | > | > > > | > > | | > < < > < | | | | | | < | | | | 4157 4158 4159 4160 4161 4162 4163 4164 4165 4166 4167 4168 4169 4170 4171 4172 4173 4174 4175 4176 4177 4178 4179 4180 4181 4182 4183 4184 4185 4186 4187 4188 4189 4190 4191 4192 4193 4194 4195 4196 4197 4198 4199 4200 4201 4202 4203 4204 4205 4206 4207 4208 4209 4210 4211 4212 4213 4214 4215 4216 4217 4218 4219 4220 4221 4222 4223 4224 4225 4226 4227 4228 4229 4230 4231 4232 4233 4234 4235 4236 4237 4238 4239 4240 4241 4242 4243 4244 4245 4246 4247 4248 4249 4250 4251 4252 4253 4254 4255 4256 |
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_IS_DELETED)) {
/*
* 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);
}
|
| ︙ | ︙ | |||
4025 4026 4027 4028 4029 4030 4031 |
TclNRRunCallbacks(
Tcl_Interp *interp,
int result,
struct NRE_callback *rootPtr)
/* All callbacks down to rootPtr not inclusive
* are to be run. */
{
| > | | < < < | 4309 4310 4311 4312 4313 4314 4315 4316 4317 4318 4319 4320 4321 4322 4323 4324 4325 4326 |
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;
}
|
| ︙ | ︙ | |||
4186 4187 4188 4189 4190 4191 4192 |
ClientData data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
Tcl_Obj *listPtr;
const char *cmdString;
| | | | 4468 4469 4470 4471 4472 4473 4474 4475 4476 4477 4478 4479 4480 4481 4482 4483 4484 4485 4486 |
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 = 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);
|
| ︙ | ︙ | |||
4250 4251 4252 4253 4254 4255 4256 |
* to hold both the handler prefix and all words of the command invokation
* itself.
*/
Tcl_ListObjGetElements(NULL, currNsPtr->unknownHandlerPtr,
&handlerObjc, &handlerObjv);
newObjc = objc + handlerObjc;
| | | | 4532 4533 4534 4535 4536 4537 4538 4539 4540 4541 4542 4543 4544 4545 4546 4547 4548 4549 4550 4551 4552 4553 4554 4555 4556 4557 4558 |
* 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 = 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.
*
|
| ︙ | ︙ | |||
4342 4343 4344 4345 4346 4347 4348 |
Command **cmdPtrPtr,
Tcl_Obj *commandPtr,
int objc,
Tcl_Obj *const objv[])
{
Interp *iPtr = (Interp *) interp;
Command *cmdPtr = *cmdPtrPtr;
| | | | 4624 4625 4626 4627 4628 4629 4630 4631 4632 4633 4634 4635 4636 4637 4638 4639 |
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.
|
| ︙ | ︙ | |||
4395 4396 4397 4398 4399 4400 4401 |
{
Interp *iPtr = (Interp *) interp;
int traceCode = TCL_OK;
int objc = PTR2INT(data[0]);
Tcl_Obj *commandPtr = data[1];
Command *cmdPtr = data[2];
Tcl_Obj **objv = data[3];
| | | | 4677 4678 4679 4680 4681 4682 4683 4684 4685 4686 4687 4688 4689 4690 4691 4692 4693 4694 4695 |
{
Interp *iPtr = (Interp *) interp;
int traceCode = TCL_OK;
int objc = PTR2INT(data[0]);
Tcl_Obj *commandPtr = data[1];
Command *cmdPtr = data[2];
Tcl_Obj **objv = data[3];
size_t length;
const char *command = TclGetStringFromObj(commandPtr, &length);
if (!(cmdPtr->flags & CMD_IS_DELETED)) {
if (cmdPtr->flags & CMD_HAS_EXEC_TRACES) {
traceCode = TclCheckExecutionTraces(interp, command, length,
cmdPtr, result, TCL_TRACE_LEAVE_EXEC, objc, objv);
}
if (iPtr->tracePtr != NULL && traceCode == TCL_OK) {
traceCode = TclCheckInterpTraces(interp, command, length,
cmdPtr, result, TCL_TRACE_LEAVE_EXEC, objc, objv);
}
|
| ︙ | ︙ | |||
4478 4479 4480 4481 4482 4483 4484 |
int
Tcl_EvalTokensStandard(
Tcl_Interp *interp, /* Interpreter in which to lookup variables,
* execute nested commands, and report
* errors. */
Tcl_Token *tokenPtr, /* Pointer to first in an array of tokens to
* evaluate and concatenate. */
| | | 4760 4761 4762 4763 4764 4765 4766 4767 4768 4769 4770 4771 4772 4773 4774 |
int
Tcl_EvalTokensStandard(
Tcl_Interp *interp, /* Interpreter in which to lookup variables,
* execute nested commands, and report
* errors. */
Tcl_Token *tokenPtr, /* Pointer to first in an array of tokens to
* evaluate and concatenate. */
size_t count) /* Number of tokens to consider at tokenPtr.
* Must be at least 1. */
{
return TclSubstTokens(interp, tokenPtr, count, /* numLeftPtr */ NULL, 1,
NULL, NULL);
}
/*
|
| ︙ | ︙ | |||
4511 4512 4513 4514 4515 4516 4517 |
*/
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. */
| | | | 4793 4794 4795 4796 4797 4798 4799 4800 4801 4802 4803 4804 4805 4806 4807 4808 4809 4810 4811 4812 4813 4814 4815 4816 4817 4818 4819 4820 4821 4822 |
*/
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
* script consists of all bytes up to the
* first null character. */
int flags) /* Collection of OR-ed bits that control the
* evaluation of the script. Only
* TCL_EVAL_GLOBAL is currently supported. */
{
return TclEvalEx(interp, script, numBytes, flags, 1, NULL, script);
}
int
TclEvalEx(
Tcl_Interp *interp, /* Interpreter in which to evaluate the
* script. Also used for error reporting. */
const char *script, /* First character of script to evaluate. */
size_t numBytes, /* Number of bytes in script. If -1, the
* script consists of all bytes up to the
* first NUL character. */
int flags, /* Collection of OR-ed bits that control the
* evaluation of the script. Only
* TCL_EVAL_GLOBAL is currently supported. */
int line, /* The line the script starts on. */
int *clNextOuter, /* Information about an outer context for */
|
| ︙ | ︙ | |||
4557 4558 4559 4560 4561 4562 4563 |
{
Interp *iPtr = (Interp *) interp;
const char *p, *next;
const unsigned int minObjs = 20;
Tcl_Obj **objv, **objvSpace;
int *expand, *lines, *lineSpace;
Tcl_Token *tokenPtr;
| | > | 4839 4840 4841 4842 4843 4844 4845 4846 4847 4848 4849 4850 4851 4852 4853 4854 |
{
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;
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
|
| ︙ | ︙ | |||
4591 4592 4593 4594 4595 4596 4597 |
if (clNextOuter) {
clNext = clNextOuter;
} else {
clNext = &iPtr->scriptCLLocPtr->loc[0];
}
}
| | | 4874 4875 4876 4877 4878 4879 4880 4881 4882 4883 4884 4885 4886 4887 4888 |
if (clNextOuter) {
clNext = clNextOuter;
} else {
clNext = &iPtr->scriptCLLocPtr->loc[0];
}
}
if (numBytes == TCL_AUTO_LENGTH) {
numBytes = strlen(script);
}
Tcl_ResetResult(interp);
savedVarFramePtr = iPtr->varFramePtr;
if (flags & TCL_EVAL_GLOBAL) {
iPtr->varFramePtr = iPtr->rootFramePtr;
|
| ︙ | ︙ | |||
4708 4709 4710 4711 4712 4713 4714 |
unsigned int numWords = parsePtr->numWords;
/*
* Generate an array of objects for the words of the command.
*/
if (numWords > minObjs) {
| | | | | 4991 4992 4993 4994 4995 4996 4997 4998 4999 5000 5001 5002 5003 5004 5005 5006 5007 |
unsigned int numWords = parsePtr->numWords;
/*
* Generate an array of objects for the words of the command.
*/
if (numWords > minObjs) {
expand = Tcl_Alloc(numWords * sizeof(int));
objvSpace = Tcl_Alloc(numWords * sizeof(Tcl_Obj *));
lineSpace = Tcl_Alloc(numWords * sizeof(int));
}
expandRequested = 0;
objv = objvSpace;
lines = lineSpace;
iPtr->cmdFramePtr = eeFramePtr->nextPtr;
for (objectsUsed = 0, tokenPtr = parsePtr->tokenPtr;
|
| ︙ | ︙ | |||
4796 4797 4798 4799 4800 4801 4802 |
Tcl_Obj **copy = objvSpace;
int *lcopy = lineSpace;
int wordIdx = numWords;
int objIdx = objectsNeeded - 1;
if ((numWords > minObjs) || (objectsNeeded > minObjs)) {
objv = objvSpace =
| | | | 5079 5080 5081 5082 5083 5084 5085 5086 5087 5088 5089 5090 5091 5092 5093 5094 |
Tcl_Obj **copy = objvSpace;
int *lcopy = lineSpace;
int wordIdx = numWords;
int objIdx = objectsNeeded - 1;
if ((numWords > minObjs) || (objectsNeeded > minObjs)) {
objv = objvSpace =
Tcl_Alloc(objectsNeeded * sizeof(Tcl_Obj *));
lines = lineSpace = Tcl_Alloc(objectsNeeded * sizeof(int));
}
objectsUsed = 0;
while (wordIdx--) {
if (expand[wordIdx]) {
int numElements;
Tcl_Obj **elements, *temp = copy[wordIdx];
|
| ︙ | ︙ | |||
4824 4825 4826 4827 4828 4829 4830 |
objv[objIdx--] = copy[wordIdx];
objectsUsed++;
}
}
objv += objIdx+1;
if (copy != stackObjArray) {
| | | | 5107 5108 5109 5110 5111 5112 5113 5114 5115 5116 5117 5118 5119 5120 5121 5122 5123 5124 |
objv[objIdx--] = copy[wordIdx];
objectsUsed++;
}
}
objv += objIdx+1;
if (copy != stackObjArray) {
Tcl_Free(copy);
}
if (lcopy != linesStack) {
Tcl_Free(lcopy);
}
}
/*
* Execute the command and free the objects for its words.
*
* TIP #280: Remember the command itself for 'info frame'. We
|
| ︙ | ︙ | |||
4872 4873 4874 4875 4876 4877 4878 |
goto error;
}
for (i = 0; i < objectsUsed; i++) {
Tcl_DecrRefCount(objv[i]);
}
objectsUsed = 0;
if (objvSpace != stackObjArray) {
| | | | | 5155 5156 5157 5158 5159 5160 5161 5162 5163 5164 5165 5166 5167 5168 5169 5170 5171 5172 5173 5174 5175 5176 5177 5178 5179 5180 5181 |
goto error;
}
for (i = 0; i < objectsUsed; i++) {
Tcl_DecrRefCount(objv[i]);
}
objectsUsed = 0;
if (objvSpace != stackObjArray) {
Tcl_Free(objvSpace);
objvSpace = stackObjArray;
Tcl_Free(lineSpace);
lineSpace = linesStack;
}
/*
* Free expand separately since objvSpace could have been
* reallocated above.
*/
if (expand != expandStack) {
Tcl_Free(expand);
expand = expandStack;
}
}
/*
* Advance to the next command in the script.
*
|
| ︙ | ︙ | |||
4950 4951 4952 4953 4954 4955 4956 |
for (i = 0; i < objectsUsed; i++) {
Tcl_DecrRefCount(objv[i]);
}
if (gotParse) {
Tcl_FreeParse(parsePtr);
}
if (objvSpace != stackObjArray) {
| | | | | 5233 5234 5235 5236 5237 5238 5239 5240 5241 5242 5243 5244 5245 5246 5247 5248 5249 5250 5251 |
for (i = 0; i < objectsUsed; i++) {
Tcl_DecrRefCount(objv[i]);
}
if (gotParse) {
Tcl_FreeParse(parsePtr);
}
if (objvSpace != stackObjArray) {
Tcl_Free(objvSpace);
Tcl_Free(lineSpace);
}
if (expand != expandStack) {
Tcl_Free(expand);
}
iPtr->varFramePtr = savedVarFramePtr;
cleanup_return:
/*
* TIP #280. Release the local CmdFrame, and its contents.
*/
|
| ︙ | ︙ | |||
5118 5119 5120 5121 5122 5123 5124 |
hPtr = Tcl_CreateHashEntry(iPtr->lineLAPtr, objv[i], &new);
if (new) {
/*
* The word is not on the stack yet, remember the current location
* and initialize references.
*/
| | | 5401 5402 5403 5404 5405 5406 5407 5408 5409 5410 5411 5412 5413 5414 5415 |
hPtr = Tcl_CreateHashEntry(iPtr->lineLAPtr, objv[i], &new);
if (new) {
/*
* The word is not on the stack yet, remember the current location
* and initialize references.
*/
cfwPtr = Tcl_Alloc(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
|
| ︙ | ︙ | |||
5178 5179 5180 5181 5182 5183 5184 |
}
cfwPtr = Tcl_GetHashValue(hPtr);
if (cfwPtr->refCount-- > 1) {
continue;
}
| | | 5461 5462 5463 5464 5465 5466 5467 5468 5469 5470 5471 5472 5473 5474 5475 |
}
cfwPtr = Tcl_GetHashValue(hPtr);
if (cfwPtr->refCount-- > 1) {
continue;
}
Tcl_Free(cfwPtr);
Tcl_DeleteHashEntry(hPtr);
}
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
5211 5212 5213 5214 5215 5216 5217 |
TclArgumentBCEnter(
Tcl_Interp *interp,
Tcl_Obj *objv[],
int objc,
void *codePtr,
CmdFrame *cfPtr,
int cmd,
| | | 5494 5495 5496 5497 5498 5499 5500 5501 5502 5503 5504 5505 5506 5507 5508 |
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 =
|
| ︙ | ︙ | |||
5260 5261 5262 5263 5264 5265 5266 |
*/
for (word = 1; word < objc; word++) {
if (ePtr->line[word] >= 0) {
int isnew;
Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(iPtr->lineLABCPtr,
objv[word], &isnew);
| | | 5543 5544 5545 5546 5547 5548 5549 5550 5551 5552 5553 5554 5555 5556 5557 |
*/
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 = Tcl_Alloc(sizeof(CFWordBC));
cfwPtr->framePtr = cfPtr;
cfwPtr->obj = objv[word];
cfwPtr->pc = pc;
cfwPtr->word = word;
cfwPtr->nextPtr = lastPtr;
lastPtr = cfwPtr;
|
| ︙ | ︙ | |||
5338 5339 5340 5341 5342 5343 5344 |
if (cfwPtr->prevPtr) {
Tcl_SetHashValue(hPtr, cfwPtr->prevPtr);
} else {
Tcl_DeleteHashEntry(hPtr);
}
| | | 5621 5622 5623 5624 5625 5626 5627 5628 5629 5630 5631 5632 5633 5634 5635 |
if (cfwPtr->prevPtr) {
Tcl_SetHashValue(hPtr, cfwPtr->prevPtr);
} else {
Tcl_DeleteHashEntry(hPtr);
}
Tcl_Free(cfwPtr);
cfwPtr = nextPtr;
}
cfPtr->litarg = NULL;
}
/*
|
| ︙ | ︙ | |||
5381 5382 5383 5384 5385 5386 5387 |
/*
* 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.
*/
| | | 5664 5665 5666 5667 5668 5669 5670 5671 5672 5673 5674 5675 5676 5677 5678 |
/*
* 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)) {
return;
}
/*
* First look for location information recorded in the argument
* stack. That is nearest.
*/
|
| ︙ | ︙ | |||
5610 5611 5612 5613 5614 5615 5616 | /* * 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; | | | 5893 5894 5895 5896 5897 5898 5899 5900 5901 5902 5903 5904 5905 5906 5907 | /* * 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; /* * Now we check if we have data about invisible continuation lines for * the script, and make it available to the direct script parser and * evaluator we are about to call, if so. * * It may be possible that the script Tcl_Obj* can be free'd while the |
| ︙ | ︙ | |||
5664 5665 5666 5667 5668 5669 5670 |
if (iPtr->numLevels == 0) {
if (result == TCL_RETURN) {
result = TclUpdateReturnInfo(iPtr);
}
if ((result != TCL_OK) && (result != TCL_ERROR) && !allowExceptions) {
const char *script;
| | | 5947 5948 5949 5950 5951 5952 5953 5954 5955 5956 5957 5958 5959 5960 5961 |
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);
}
|
| ︙ | ︙ | |||
5911 5912 5913 5914 5915 5916 5917 |
Tcl_DecrRefCount(resultPtr);
if (Tcl_InitBignumFromDouble(interp, d, &big) != TCL_OK) {
return TCL_ERROR;
}
resultPtr = Tcl_NewBignumObj(&big);
/* FALLTHROUGH */
}
| | | 6194 6195 6196 6197 6198 6199 6200 6201 6202 6203 6204 6205 6206 6207 6208 |
Tcl_DecrRefCount(resultPtr);
if (Tcl_InitBignumFromDouble(interp, d, &big) != TCL_OK) {
return TCL_ERROR;
}
resultPtr = Tcl_NewBignumObj(&big);
/* FALLTHROUGH */
}
case TCL_NUMBER_INT:
case TCL_NUMBER_BIG:
result = TclGetLongFromObj(interp, resultPtr, ptr);
break;
case TCL_NUMBER_NAN:
Tcl_GetDoubleFromObj(interp, resultPtr, &d);
result = TCL_ERROR;
|
| ︙ | ︙ | |||
6097 6098 6099 6100 6101 6102 6103 |
"invalid hidden command name \"%s\"", cmdName));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "HIDDENTOKEN", cmdName,
NULL);
return TCL_ERROR;
}
cmdPtr = Tcl_GetHashValue(hPtr);
| > | > > | | | 6380 6381 6382 6383 6384 6385 6386 6387 6388 6389 6390 6391 6392 6393 6394 6395 6396 6397 6398 6399 6400 6401 6402 6403 6404 |
"invalid hidden command name \"%s\"", cmdName));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "HIDDENTOKEN", cmdName,
NULL);
return TCL_ERROR;
}
cmdPtr = 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(
|
| ︙ | ︙ | |||
6154 6155 6156 6157 6158 6159 6160 |
int code = TCL_OK;
if (expr[0] == '\0') {
/*
* An empty string. Just set the interpreter's result to 0.
*/
| | | 6440 6441 6442 6443 6444 6445 6446 6447 6448 6449 6450 6451 6452 6453 6454 |
int code = TCL_OK;
if (expr[0] == '\0') {
/*
* An empty string. Just set the interpreter's result to 0.
*/
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(0));
} else {
Tcl_Obj *resultPtr, *exprObj = Tcl_NewStringObj(expr, -1);
Tcl_IncrRefCount(exprObj);
code = Tcl_ExprObj(interp, exprObj, &resultPtr);
Tcl_DecrRefCount(exprObj);
if (code == TCL_OK) {
|
| ︙ | ︙ | |||
6194 6195 6196 6197 6198 6199 6200 |
void
Tcl_AppendObjToErrorInfo(
Tcl_Interp *interp, /* Interpreter to which error information
* pertains. */
Tcl_Obj *objPtr) /* Message to record. */
{
| | < > | 6480 6481 6482 6483 6484 6485 6486 6487 6488 6489 6490 6491 6492 6493 6494 6495 6496 |
void
Tcl_AppendObjToErrorInfo(
Tcl_Interp *interp, /* Interpreter to which error information
* pertains. */
Tcl_Obj *objPtr) /* Message to record. */
{
size_t length;
const char *message = TclGetStringFromObj(objPtr, &length);
register Interp *iPtr = (Interp *) interp;
Tcl_IncrRefCount(objPtr);
/*
* If we are just starting to log an error, errorInfo is initialized from
* the error message in the interpreter's result.
*/
|
| ︙ | ︙ | |||
6365 6366 6367 6368 6369 6370 6371 |
if (objc != 2) {
MathFuncWrongNumArgs(interp, 2, objc, objv);
return TCL_ERROR;
}
code = Tcl_GetDoubleFromObj(interp, objv[1], &d);
#ifdef ACCEPT_NAN
| | > > > | | > | 6651 6652 6653 6654 6655 6656 6657 6658 6659 6660 6661 6662 6663 6664 6665 6666 6667 6668 6669 6670 6671 |
if (objc != 2) {
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;
}
}
#endif
if (code != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetBignumFromObj(NULL, objv[1], &big) == TCL_OK) {
|
| ︙ | ︙ | |||
6401 6402 6403 6404 6405 6406 6407 |
if (objc != 2) {
MathFuncWrongNumArgs(interp, 2, objc, objv);
return TCL_ERROR;
}
code = Tcl_GetDoubleFromObj(interp, objv[1], &d);
#ifdef ACCEPT_NAN
| | > > > | | > | 6691 6692 6693 6694 6695 6696 6697 6698 6699 6700 6701 6702 6703 6704 6705 6706 6707 6708 6709 6710 6711 |
if (objc != 2) {
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;
}
}
#endif
if (code != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetBignumFromObj(NULL, objv[1], &big) == TCL_OK) {
|
| ︙ | ︙ | |||
6475 6476 6477 6478 6479 6480 6481 |
}
}
break;
case TCL_NUMBER_BIG:
if (Tcl_GetBignumFromObj(interp, objv[1], &big) != TCL_OK) {
return TCL_ERROR;
}
| | | 6769 6770 6771 6772 6773 6774 6775 6776 6777 6778 6779 6780 6781 6782 6783 |
}
}
break;
case TCL_NUMBER_BIG:
if (Tcl_GetBignumFromObj(interp, objv[1], &big) != TCL_OK) {
return TCL_ERROR;
}
if (big.sign != MP_ZPOS) {
mp_clear(&big);
goto negarg;
}
break;
default:
if (TclGetWideIntFromObj(interp, objv[1], &w) != TCL_OK) {
return TCL_ERROR;
|
| ︙ | ︙ | |||
6537 6538 6539 6540 6541 6542 6543 |
if (objc != 2) {
MathFuncWrongNumArgs(interp, 2, objc, objv);
return TCL_ERROR;
}
code = Tcl_GetDoubleFromObj(interp, objv[1], &d);
#ifdef ACCEPT_NAN
| | > > > | | > | 6831 6832 6833 6834 6835 6836 6837 6838 6839 6840 6841 6842 6843 6844 6845 6846 6847 6848 6849 6850 6851 |
if (objc != 2) {
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;
}
}
#endif
if (code != TCL_OK) {
return TCL_ERROR;
}
if ((d >= 0.0) && TclIsInfinite(d)
&& (Tcl_GetBignumFromObj(NULL, objv[1], &big) == TCL_OK)) {
|
| ︙ | ︙ | |||
6580 6581 6582 6583 6584 6585 6586 |
if (objc != 2) {
MathFuncWrongNumArgs(interp, 2, objc, objv);
return TCL_ERROR;
}
code = Tcl_GetDoubleFromObj(interp, objv[1], &d);
#ifdef ACCEPT_NAN
| | > > > | | | > | 6878 6879 6880 6881 6882 6883 6884 6885 6886 6887 6888 6889 6890 6891 6892 6893 6894 6895 6896 6897 6898 6899 |
if (objc != 2) {
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;
}
}
#endif
if (code != TCL_OK) {
return TCL_ERROR;
}
errno = 0;
return CheckDoubleResult(interp, func(d));
|
| ︙ | ︙ | |||
6640 6641 6642 6643 6644 6645 6646 |
if (objc != 3) {
MathFuncWrongNumArgs(interp, 3, objc, objv);
return TCL_ERROR;
}
code = Tcl_GetDoubleFromObj(interp, objv[1], &d1);
#ifdef ACCEPT_NAN
| | > > > | | | > | > > > | | | > | 6942 6943 6944 6945 6946 6947 6948 6949 6950 6951 6952 6953 6954 6955 6956 6957 6958 6959 6960 6961 6962 6963 6964 6965 6966 6967 6968 6969 6970 6971 6972 6973 6974 6975 6976 6977 6978 |
if (objc != 3) {
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;
}
}
#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;
}
}
#endif
if (code != TCL_OK) {
return TCL_ERROR;
}
errno = 0;
return CheckDoubleResult(interp, func(d1, d2));
|
| ︙ | ︙ | |||
6685 6686 6687 6688 6689 6690 6691 |
return TCL_ERROR;
}
if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) {
return TCL_ERROR;
}
| | | | > > | | | | | | | | 6995 6996 6997 6998 6999 7000 7001 7002 7003 7004 7005 7006 7007 7008 7009 7010 7011 7012 7013 7014 7015 7016 7017 7018 7019 7020 7021 7022 7023 7024 7025 7026 7027 7028 |
return TCL_ERROR;
}
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) {
TclInitBignumFromWideInt(&big, l);
goto tooLarge;
}
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(-l));
return TCL_OK;
}
|
| ︙ | ︙ | |||
6731 6732 6733 6734 6735 6736 6737 |
goto unChanged;
}
Tcl_SetObjResult(interp, Tcl_NewDoubleObj(-d));
return TCL_OK;
}
if (type == TCL_NUMBER_BIG) {
| | | 7043 7044 7045 7046 7047 7048 7049 7050 7051 7052 7053 7054 7055 7056 7057 |
goto unChanged;
}
Tcl_SetObjResult(interp, Tcl_NewDoubleObj(-d));
return TCL_OK;
}
if (type == TCL_NUMBER_BIG) {
if (((const mp_int *) ptr)->sign != MP_ZPOS) {
Tcl_GetBignumFromObj(NULL, objv[1], &big);
tooLarge:
mp_neg(&big, &big);
Tcl_SetObjResult(interp, Tcl_NewBignumObj(&big));
} else {
unChanged:
Tcl_SetObjResult(interp, objv[1]);
|
| ︙ | ︙ | |||
6794 6795 6796 6797 6798 6799 6800 |
if (objc != 2) {
MathFuncWrongNumArgs(interp, 2, objc, objv);
return TCL_ERROR;
}
if (Tcl_GetDoubleFromObj(interp, objv[1], &dResult) != TCL_OK) {
#ifdef ACCEPT_NAN
| | | | | | | 7106 7107 7108 7109 7110 7111 7112 7113 7114 7115 7116 7117 7118 7119 7120 7121 7122 7123 7124 7125 7126 7127 7128 7129 7130 7131 7132 7133 7134 7135 7136 7137 7138 7139 7140 7141 7142 7143 7144 7145 7146 7147 7148 7149 7150 7151 7152 7153 7154 7155 7156 7157 7158 7159 7160 7161 7162 7163 7164 7165 |
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)) {
Tcl_SetObjResult(interp, objv[1]);
return TCL_OK;
}
#endif
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewDoubleObj(dResult));
return TCL_OK;
}
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. */
{
double d;
int type;
ClientData ptr;
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_DOUBLE) {
d = *((const double *) ptr);
if ((d >= (double)WIDE_MAX) || (d <= (double)WIDE_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;
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(result));
return TCL_OK;
}
}
if (type != TCL_NUMBER_NAN) {
/*
* All integers are already of integer type.
|
| ︙ | ︙ | |||
6861 6862 6863 6864 6865 6866 6867 |
* Get the error message for NaN.
*/
Tcl_GetDoubleFromObj(interp, objv[1], &d);
return TCL_ERROR;
}
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | < < < < < < < < < < < < < < | 7173 7174 7175 7176 7177 7178 7179 7180 7181 7182 7183 7184 7185 7186 7187 7188 7189 7190 7191 7192 7193 7194 7195 7196 7197 7198 7199 7200 |
* Get the error message for NaN.
*/
Tcl_GetDoubleFromObj(interp, objv[1], &d);
return TCL_ERROR;
}
static int
ExprWideFunc(
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().
*/
|
| ︙ | ︙ | |||
7024 7025 7026 7027 7028 7029 7030 | iPtr->randSeed = TclpGetClicks() + (PTR2INT(Tcl_GetCurrentThread())<<12); /* * Make sure 1 <= randSeed <= (2^31) - 2. See below. */ | | | 7289 7290 7291 7292 7293 7294 7295 7296 7297 7298 7299 7300 7301 7302 7303 |
iPtr->randSeed = TclpGetClicks() + (PTR2INT(Tcl_GetCurrentThread())<<12);
/*
* Make sure 1 <= randSeed <= (2^31) - 2. See below.
*/
iPtr->randSeed &= 0x7fffffff;
if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7fffffff)) {
iPtr->randSeed ^= 123459876;
}
}
/*
* Generate the random number using the linear congruential generator
|
| ︙ | ︙ | |||
7107 7108 7109 7110 7111 7112 7113 |
if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) {
return TCL_ERROR;
}
if (type == TCL_NUMBER_DOUBLE) {
double fractPart, intPart;
| | | 7372 7373 7374 7375 7376 7377 7378 7379 7380 7381 7382 7383 7384 7385 7386 |
if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) {
return TCL_ERROR;
}
if (type == TCL_NUMBER_DOUBLE) {
double fractPart, intPart;
Tcl_WideInt max = WIDE_MAX, min = WIDE_MIN;
fractPart = modf(*((const double *) ptr), &intPart);
if (fractPart <= -0.5) {
min++;
} else if (fractPart >= 0.5) {
max--;
}
|
| ︙ | ︙ | |||
7130 7131 7132 7133 7134 7135 7136 |
mp_sub_d(&big, 1, &big);
} else if (fractPart >= 0.5) {
mp_add_d(&big, 1, &big);
}
Tcl_SetObjResult(interp, Tcl_NewBignumObj(&big));
return TCL_OK;
} else {
| | | | 7395 7396 7397 7398 7399 7400 7401 7402 7403 7404 7405 7406 7407 7408 7409 7410 7411 7412 7413 7414 7415 7416 |
mp_sub_d(&big, 1, &big);
} else if (fractPart >= 0.5) {
mp_add_d(&big, 1, &big);
}
Tcl_SetObjResult(interp, Tcl_NewBignumObj(&big));
return TCL_OK;
} else {
Tcl_WideInt result = (Tcl_WideInt)intPart;
if (fractPart <= -0.5) {
result--;
} else if (fractPart >= 0.5) {
result++;
}
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(result));
return TCL_OK;
}
}
if (type != TCL_NUMBER_NAN) {
/*
* All integers are already rounded
|
| ︙ | ︙ | |||
7168 7169 7170 7171 7172 7173 7174 |
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;
| | | < < < < < | < < < < < < < | < | 7433 7434 7435 7436 7437 7438 7439 7440 7441 7442 7443 7444 7445 7446 7447 7448 7449 7450 7451 7452 7453 7454 7455 7456 7457 7458 7459 7460 7461 7462 7463 7464 7465 7466 7467 7468 |
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. */
/*
* Convert argument and use it to reset the seed.
*/
if (objc != 2) {
MathFuncWrongNumArgs(interp, 2, objc, objv);
return TCL_ERROR;
}
if (TclGetWideBitsFromObj(NULL, objv[1], &w) != TCL_OK) {
return TCL_ERROR;
}
/*
* Reset the seed. Make sure 1 <= randSeed <= 2^31 - 2. See comments in
* ExprRandFunc for more details.
*/
iPtr->flags |= RAND_SEED_INITIALIZED;
iPtr->randSeed = (long) w & 0x7fffffff;
if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7fffffff)) {
iPtr->randSeed ^= 123459876;
}
/*
* To avoid duplicating the random number generation code we simply clean
* up our state and call the real random number function. That function
|
| ︙ | ︙ | |||
7330 7331 7332 7333 7334 7335 7336 |
kini("line"); kini("level");
#undef kini
}
for (i = 0; i < 6; i++) {
Tcl_DictObjGet(NULL, info, *k++, &val);
args[i] = val ? TclGetString(val) : NULL;
}
| > > | > > > > | > > | 7582 7583 7584 7585 7586 7587 7588 7589 7590 7591 7592 7593 7594 7595 7596 7597 7598 7599 7600 7601 7602 7603 7604 7605 7606 7607 7608 7609 7610 |
kini("line"); kini("level");
#undef kini
}
for (i = 0; i < 6; 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);
|
| ︙ | ︙ | |||
7474 7475 7476 7477 7478 7479 7480 |
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 *)
| | > | | > | > | 7734 7735 7736 7737 7738 7739 7740 7741 7742 7743 7744 7745 7746 7747 7748 7749 7750 7751 7752 7753 7754 7755 7756 7757 7758 7759 7760 7761 7762 7763 7764 7765 7766 7767 |
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
|
| ︙ | ︙ | |||
7594 7595 7596 7597 7598 7599 7600 |
void
TclPushTailcallPoint(
Tcl_Interp *interp)
{
TclNRAddCallback(interp, NRCommand, NULL, NULL, NULL, NULL);
((Interp *) interp)->numLevels++;
}
| < | 7857 7858 7859 7860 7861 7862 7863 7864 7865 7866 7867 7868 7869 7870 |
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
|
| ︙ | ︙ | |||
7630 7631 7632 7633 7634 7635 7636 |
}
}
if (!runPtr) {
Tcl_Panic("tailcall cannot find the right splicing spot: should not happen!");
}
runPtr->data[1] = listPtr;
}
| < | 7892 7893 7894 7895 7896 7897 7898 7899 7900 7901 7902 7903 7904 7905 |
}
}
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
|
| ︙ | ︙ | |||
7688 7689 7690 7691 7692 7693 7694 |
* 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;
| < > | | | < < | < < < | 7949 7950 7951 7952 7953 7954 7955 7956 7957 7958 7959 7960 7961 7962 7963 7964 7965 7966 7967 7968 7969 7970 7971 7972 7973 7974 7975 7976 |
* 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.
|
| ︙ | ︙ | |||
7774 7775 7776 7777 7778 7779 7780 |
} else {
break;
}
i++;
}
return result;
}
| < | 8030 8031 8032 8033 8034 8035 8036 8037 8038 8039 8040 8041 8042 8043 |
} else {
break;
}
i++;
}
return result;
}
void
Tcl_NRAddCallback(
Tcl_Interp *interp,
Tcl_NRPostProc *postProcPtr,
ClientData data0,
ClientData data1,
|
| ︙ | ︙ | |||
7963 7964 7965 7966 7967 7968 7969 | * 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); | | | 8218 8219 8220 8221 8222 8223 8224 8225 8226 8227 8228 8229 8230 8231 8232 |
* 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);
|
| ︙ | ︙ | |||
8022 8023 8024 8025 8026 8027 8028 |
/*
* #280.
* Drop the coroutine-owned copy of the lineLABCPtr hashtable for literal
* command arguments in bytecode.
*/
Tcl_DeleteHashTable(corPtr->lineLABCPtr);
| | | 8277 8278 8279 8280 8281 8282 8283 8284 8285 8286 8287 8288 8289 8290 8291 |
/*
* #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;
|
| ︙ | ︙ | |||
8149 8150 8151 8152 8153 8154 8155 |
TclListObjGetElements(NULL, listPtr, &objc, &objv);
return TclNREvalObjv(interp, objc, objv, 0, NULL);
}
/*
*----------------------------------------------------------------------
*
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | < | < < | < | < < | 8404 8405 8406 8407 8408 8409 8410 8411 8412 8413 8414 8415 8416 8417 8418 8419 8420 8421 8422 8423 8424 8425 8426 8427 8428 8429 8430 8431 8432 8433 8434 8435 8436 8437 8438 8439 8440 8441 8442 8443 8444 8445 8446 8447 8448 8449 8450 8451 8452 8453 8454 8455 8456 8457 8458 8459 8460 8461 8462 8463 8464 8465 8466 8467 8468 8469 8470 8471 8472 8473 8474 8475 8476 8477 8478 8479 8480 8481 8482 8483 8484 8485 8486 8487 8488 8489 8490 8491 8492 8493 8494 8495 8496 8497 8498 8499 8500 8501 8502 8503 8504 8505 8506 8507 8508 8509 8510 8511 8512 8513 8514 8515 8516 8517 8518 8519 8520 8521 8522 8523 8524 8525 8526 8527 8528 8529 8530 8531 8532 8533 8534 8535 8536 8537 8538 8539 8540 8541 8542 8543 8544 8545 8546 8547 8548 8549 8550 8551 8552 8553 8554 8555 8556 8557 8558 8559 8560 8561 8562 8563 8564 8565 8566 8567 8568 8569 8570 8571 8572 8573 8574 8575 8576 8577 8578 8579 8580 8581 8582 8583 8584 8585 8586 8587 8588 8589 8590 8591 8592 8593 8594 8595 8596 8597 8598 8599 8600 8601 8602 8603 8604 8605 8606 8607 8608 8609 8610 8611 8612 8613 8614 8615 8616 8617 8618 8619 8620 8621 8622 8623 8624 8625 8626 8627 8628 8629 8630 8631 8632 8633 8634 8635 8636 8637 8638 8639 8640 8641 8642 8643 8644 8645 8646 8647 8648 8649 8650 8651 8652 8653 8654 8655 8656 8657 8658 8659 8660 8661 8662 8663 8664 8665 8666 8667 8668 8669 8670 8671 8672 8673 8674 8675 8676 8677 8678 8679 8680 8681 8682 8683 8684 8685 8686 8687 8688 8689 8690 8691 8692 8693 8694 8695 8696 8697 8698 8699 8700 8701 8702 8703 8704 8705 8706 8707 8708 8709 8710 8711 8712 8713 8714 8715 8716 8717 8718 8719 8720 8721 8722 8723 8724 8725 8726 8727 8728 8729 8730 8731 8732 8733 8734 8735 8736 8737 8738 8739 8740 8741 8742 8743 8744 8745 8746 8747 8748 8749 8750 8751 8752 8753 8754 8755 8756 8757 8758 8759 8760 8761 8762 8763 8764 8765 8766 8767 8768 8769 8770 8771 8772 8773 8774 8775 8776 8777 |
TclListObjGetElements(NULL, listPtr, &objc, &objv);
return TclNREvalObjv(interp, objc, objv, 0, NULL);
}
/*
*----------------------------------------------------------------------
*
* CoroTypeObjCmd --
*
* Implementation of [::tcl::unsupported::corotype] command.
*
*----------------------------------------------------------------------
*/
static int
CoroTypeObjCmd(
ClientData clientData,
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 = 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 cmdPtr->objClientData;
}
static int
TclNRCoroInjectObjCmd(
ClientData clientData,
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(
ClientData clientData,
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,
int result)
{
CoroutineData *corPtr = data[0];
Tcl_Obj *listPtr = 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 = data[0];
Tcl_Obj *listPtr = 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(
ClientData clientData,
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;
}
|
| ︙ | ︙ | |||
8314 8315 8316 8317 8318 8319 8320 |
}
/*
* We ARE creating the coroutine command: allocate the corresponding
* struct and create the corresponding command.
*/
| | | 8891 8892 8893 8894 8895 8896 8897 8898 8899 8900 8901 8902 8903 8904 8905 |
}
/*
* We ARE creating the coroutine command: allocate the corresponding
* struct and create the corresponding command.
*/
corPtr = Tcl_Alloc(sizeof(CoroutineData));
cmdPtr = (Command *) TclNRCreateCommandInNs(interp, simpleName,
(Tcl_Namespace *)nsPtr, /*objProc*/ NULL, TclNRInterpCoroutine,
corPtr, DeleteCoroutine);
corPtr->cmdPtr = cmdPtr;
cmdPtr->refCount++;
|
| ︙ | ︙ | |||
8336 8337 8338 8339 8340 8341 8342 |
* tree. Like the chain -> tree conversion of the CmdFrame stack.
*/
{
Tcl_HashSearch hSearch;
Tcl_HashEntry *hePtr;
| | | 8913 8914 8915 8916 8917 8918 8919 8920 8921 8922 8923 8924 8925 8926 8927 |
* tree. Like the chain -> tree conversion of the CmdFrame stack.
*/
{
Tcl_HashSearch hSearch;
Tcl_HashEntry *hePtr;
corPtr->lineLABCPtr = 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,
|
| ︙ | ︙ | |||
8379 8380 8381 8382 8383 8384 8385 |
corPtr->callerEEPtr = iPtr->execEnvPtr;
RESTORE_CONTEXT(corPtr->running);
iPtr->execEnvPtr = corPtr->eePtr;
TclNRAddCallback(interp, NRCoroutineExitCallback, corPtr,
NULL, NULL, NULL);
| > | > > | | 8956 8957 8958 8959 8960 8961 8962 8963 8964 8965 8966 8967 8968 8969 8970 8971 8972 8973 8974 8975 |
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;
/*
|
| ︙ | ︙ |
Changes to generic/tclBinary.c.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 18 19 20 21 22 23 | * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #include "tommath.h" #include <math.h> /* * The following constants are used by GetFormatSpec to indicate various * special conditions in the parsing of a format specifier. */ | > | | | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 | * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #include "tommath.h" #include <math.h> #include <assert.h> /* * The following constants are used by GetFormatSpec to indicate various * special conditions in the parsing of a format specifier. */ #define BINARY_ALL ((size_t)-1) /* Use all elements in the argument. */ #define BINARY_NOCOUNT ((size_t)-2) /* No count was specified in format. */ /* * The following flags may be ORed together and returned by GetFormatSpec */ #define BINARY_SIGNED 0 /* Field to be read as signed data */ #define BINARY_UNSIGNED 1 /* Field to be read as unsigned data */ |
| ︙ | ︙ | |||
52 53 54 55 56 57 58 59 60 61 62 | /* * Prototypes for local procedures defined in this file: */ static void DupByteArrayInternalRep(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 int GetFormatSpec(const char **formatPtr, char *cmdPtr, | > > > | | | 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 | /* * 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 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[]); |
| ︙ | ︙ | |||
151 152 153 154 155 156 157 |
{ "hex", BinaryDecodeHex, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0 },
{ "uuencode", BinaryDecodeUu, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0 },
{ "base64", BinaryDecode64, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0 },
{ NULL, NULL, NULL, NULL, NULL, 0 }
};
/*
| | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | < | | | | | | | | < | | | | | | | | | | | < | | | | | | | | | | | | < | | | | | | | | | | | | | < | | | | | 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 |
{ "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 = {
"bytearray",
FreeByteArrayInternalRep,
DupByteArrayInternalRep,
NULL,
SetByteArrayFromAny
};
/*
* The following structure is the internal rep for a ByteArray object. Keeps
* track of how much memory has been used and how much has been allocated for
* the byte array to enable growing and shrinking of the ByteArray object with
* fewer mallocs.
*/
typedef struct {
size_t used; /* The number of bytes used in the byte
* array. */
size_t allocated; /* The amount of space actually allocated
* minus 1 byte. */
unsigned char bytes[1]; /* The array of bytes. The actual size of this
* field depends on the 'allocated' field
* above. */
} ByteArray;
#define BYTEARRAY_SIZE(len) \
(offsetof(ByteArray, bytes) + (len))
#define GET_BYTEARRAY(irPtr) ((ByteArray *) (irPtr)->twoPtrValue.ptr1)
#define SET_BYTEARRAY(irPtr, baPtr) \
(irPtr)->twoPtrValue.ptr1 = (baPtr)
int
TclIsPureByteArray(
Tcl_Obj * objPtr)
{
return TclHasIntRep(objPtr, &properByteArrayType);
}
/*
*----------------------------------------------------------------------
*
* Tcl_NewByteArrayObj --
*
|
| ︙ | ︙ | |||
311 312 313 314 315 316 317 |
#undef Tcl_NewByteArrayObj
Tcl_Obj *
Tcl_NewByteArrayObj(
const unsigned char *bytes, /* The array of bytes used to initialize the
* new object. */
| | < | 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 |
#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 */
{
#ifdef TCL_MEM_DEBUG
return Tcl_DbNewByteArrayObj(bytes, length, "unknown", 0);
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *objPtr;
TclNewObj(objPtr);
|
| ︙ | ︙ | |||
354 355 356 357 358 359 360 |
*----------------------------------------------------------------------
*/
Tcl_Obj *
Tcl_DbNewByteArrayObj(
const unsigned char *bytes, /* The array of bytes used to initialize the
* new object. */
| | < | 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 |
*----------------------------------------------------------------------
*/
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. */
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. */
{
#ifdef TCL_MEM_DEBUG
Tcl_Obj *objPtr;
|
| ︙ | ︙ | |||
393 394 395 396 397 398 399 |
*
*----------------------------------------------------------------------
*/
void
Tcl_SetByteArrayObj(
Tcl_Obj *objPtr, /* Object to initialize as a ByteArray. */
| | | | | > < < < < | | | | > | 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 |
*
*----------------------------------------------------------------------
*/
void
Tcl_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. */
{
ByteArray *byteArrayPtr;
Tcl_ObjIntRep ir;
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_SetByteArrayObj");
}
TclInvalidateStringRep(objPtr);
byteArrayPtr = Tcl_Alloc(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);
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetByteArrayFromObj --
*
|
| ︙ | ︙ | |||
445 446 447 448 449 450 451 452 |
unsigned char *
Tcl_GetByteArrayFromObj(
Tcl_Obj *objPtr, /* The ByteArray object. */
int *lengthPtr) /* If non-NULL, filled with length of the
* array of bytes in the ByteArray object. */
{
ByteArray *baPtr;
| > | | > | > > > | > > | | | 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 |
unsigned char *
Tcl_GetByteArrayFromObj(
Tcl_Obj *objPtr, /* The ByteArray object. */
int *lengthPtr) /* If non-NULL, filled with length of the
* array of bytes in the ByteArray object. */
{
ByteArray *baPtr;
const Tcl_ObjIntRep *irPtr = 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);
}
}
}
baPtr = GET_BYTEARRAY(irPtr);
if (lengthPtr != NULL) {
*lengthPtr = baPtr->used;
}
return baPtr->bytes;
}
/*
*----------------------------------------------------------------------
*
* Tcl_SetByteArrayLength --
*
|
| ︙ | ︙ | |||
483 484 485 486 487 488 489 |
*
*----------------------------------------------------------------------
*/
unsigned char *
Tcl_SetByteArrayLength(
Tcl_Obj *objPtr, /* The ByteArray object. */
| | > > | > | > | > > > | | > > | | | | 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 |
*
*----------------------------------------------------------------------
*/
unsigned char *
Tcl_SetByteArrayLength(
Tcl_Obj *objPtr, /* The ByteArray object. */
size_t 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);
}
}
}
byteArrayPtr = GET_BYTEARRAY(irPtr);
if (length > byteArrayPtr->allocated) {
byteArrayPtr = Tcl_Realloc(byteArrayPtr, BYTEARRAY_SIZE(length));
byteArrayPtr->allocated = length;
SET_BYTEARRAY(irPtr, byteArrayPtr);
}
TclInvalidateStringRep(objPtr);
byteArrayPtr->used = length;
return byteArrayPtr->bytes;
}
/*
|
| ︙ | ︙ | |||
531 532 533 534 535 536 537 538 |
Tcl_Interp *interp, /* Not used. */
Tcl_Obj *objPtr) /* The object to convert to type ByteArray. */
{
size_t length;
int improper = 0;
const char *src, *srcEnd;
unsigned char *dst;
ByteArray *byteArrayPtr;
| > | | | | < | > | | < | 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 |
Tcl_Interp *interp, /* Not used. */
Tcl_Obj *objPtr) /* The object to convert to type ByteArray. */
{
size_t length;
int improper = 0;
const char *src, *srcEnd;
unsigned char *dst;
Tcl_UniChar ch = 0;
ByteArray *byteArrayPtr;
Tcl_ObjIntRep ir;
if (TclHasIntRep(objPtr, &properByteArrayType)) {
return TCL_OK;
}
if (TclHasIntRep(objPtr, &tclByteArrayType)) {
return TCL_OK;
}
src = TclGetStringFromObj(objPtr, &length);
srcEnd = src + length;
byteArrayPtr = Tcl_Alloc(BYTEARRAY_SIZE(length));
for (dst = byteArrayPtr->bytes; src < srcEnd; ) {
src += TclUtfToUniChar(src, &ch);
improper = improper || (ch > 255);
*dst++ = UCHAR(ch);
}
byteArrayPtr->used = dst - byteArrayPtr->bytes;
byteArrayPtr->allocated = length;
SET_BYTEARRAY(&ir, byteArrayPtr);
Tcl_StoreIntRep(objPtr,
improper ? &tclByteArrayType : &properByteArrayType, &ir);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* FreeByteArrayInternalRep --
|
| ︙ | ︙ | |||
582 583 584 585 586 587 588 |
*----------------------------------------------------------------------
*/
static void
FreeByteArrayInternalRep(
Tcl_Obj *objPtr) /* Object with internal rep to free. */
{
| | > | > > > > > | 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 |
*----------------------------------------------------------------------
*/
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)));
}
/*
*----------------------------------------------------------------------
*
* DupByteArrayInternalRep --
*
|
| ︙ | ︙ | |||
608 609 610 611 612 613 614 |
*/
static void
DupByteArrayInternalRep(
Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
Tcl_Obj *copyPtr) /* Object with internal rep to set. */
{
| | > | | | > | > | | > > > > > > > > > > > > > > > > > > > | < < < < < < < < < | | | | > < | < < | | | < < < | < > > > | | 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 |
*/
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 = Tcl_Alloc(BYTEARRAY_SIZE(length));
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 = Tcl_Alloc(BYTEARRAY_SIZE(length));
copyArrayPtr->used = length;
copyArrayPtr->allocated = length;
memcpy(copyArrayPtr->bytes, srcArrayPtr->bytes, length);
SET_BYTEARRAY(&ir, copyArrayPtr);
Tcl_StoreIntRep(copyPtr, &properByteArrayType, &ir);
}
/*
*----------------------------------------------------------------------
*
* UpdateStringOfByteArray --
*
* Update the string representation for a ByteArray data object.
*
* Results:
* None.
*
* Side effects:
* The object's string is set to a valid string that results from the
* ByteArray-to-string conversion.
*
*----------------------------------------------------------------------
*/
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;
/*
* How much space will string rep need?
*/
for (i = 0; i < length; i++) {
if ((src[i] == 0) || (src[i] > 127)) {
size++;
}
}
if (size == length) {
char *dst = Tcl_InitStringRep(objPtr, (char *)src, size);
TclOOM(dst, size);
} 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);
}
}
/*
*----------------------------------------------------------------------
*
* TclAppendBytesToByteArray --
|
| ︙ | ︙ | |||
711 712 713 714 715 716 717 |
*----------------------------------------------------------------------
*/
void
TclAppendBytesToByteArray(
Tcl_Obj *objPtr,
const unsigned char *bytes,
| | | > | > | > > > | > | > | > > > | > > | | | | > | > > | > | > > | | | | > | > > | | | 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 |
*----------------------------------------------------------------------
*/
void
TclAppendBytesToByteArray(
Tcl_Obj *objPtr,
const unsigned char *bytes,
size_t len)
{
ByteArray *byteArrayPtr;
size_t needed;
Tcl_ObjIntRep *irPtr;
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object","TclAppendBytesToByteArray");
}
if (len == TCL_AUTO_LENGTH) {
Tcl_Panic("%s must be called with definite number of bytes to append",
"TclAppendBytesToByteArray");
}
if (len == 0) {
/*
* Append zero bytes is a no-op.
*/
return;
}
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);
}
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;
if (needed <= INT_MAX/2) {
/*
* Try to allocate double the total space that is needed.
*/
attempt = 2 * needed;
ptr = Tcl_AttemptRealloc(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;
attempt = needed + growth;
ptr = Tcl_AttemptRealloc(byteArrayPtr, BYTEARRAY_SIZE(attempt));
}
if (ptr == NULL) {
/*
* Last chance: Try to allocate exactly what is needed.
*/
attempt = needed;
ptr = Tcl_Realloc(byteArrayPtr, BYTEARRAY_SIZE(attempt));
}
byteArrayPtr = ptr;
byteArrayPtr->allocated = attempt;
SET_BYTEARRAY(irPtr, byteArrayPtr);
}
if (bytes) {
memcpy(byteArrayPtr->bytes + byteArrayPtr->used, bytes, len);
}
byteArrayPtr->used += len;
TclInvalidateStringRep(objPtr);
|
| ︙ | ︙ | |||
833 834 835 836 837 838 839 |
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. */
| | | | > | 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 |
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;
}
/*
|
| ︙ | ︙ | |||
884 885 886 887 888 889 890 |
* of bytes in a single argument.
*/
if (arg >= objc) {
goto badIndex;
}
if (count == BINARY_ALL) {
| | | 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 |
* 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') {
|
| ︙ | ︙ | |||
956 957 958 959 960 961 962 |
&listv) != TCL_OK) {
return TCL_ERROR;
}
arg++;
if (count == BINARY_ALL) {
count = listc;
| | | 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 |
&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;
|
| ︙ | ︙ | |||
980 981 982 983 984 985 986 |
}
offset += count;
break;
case 'X':
if (count == BINARY_NOCOUNT) {
count = 1;
}
| | | | | | | | | | 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 |
}
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.
*/
resultPtr = Tcl_NewObj();
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) {
|
| ︙ | ︙ | |||
1048 1049 1050 1051 1052 1053 1054 |
}
switch (cmd) {
case 'a':
case 'A': {
char pad = (char) (cmd == 'a' ? '\0' : ' ');
unsigned char *bytes;
| | | | | | | 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 |
}
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;
|
| ︙ | ︙ | |||
1082 1083 1084 1085 1086 1087 1088 |
last = cursor + ((count + 7) / 8);
if (count > length) {
count = length;
}
value = 0;
errorString = "binary";
if (cmd == 'B') {
| | | | 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 |
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;
|
| ︙ | ︙ | |||
1144 1145 1146 1147 1148 1149 1150 |
last = cursor + ((count + 1) / 2);
if (count > length) {
count = length;
}
value = 0;
errorString = "hexadecimal";
if (cmd == 'H') {
| | | | 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 |
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;
}
|
| ︙ | ︙ | |||
1236 1237 1238 1239 1240 1241 1242 |
} else {
TclListObjGetElements(interp, objv[arg], &listc, &listv);
if (count == BINARY_ALL) {
count = listc;
}
}
arg++;
| | | | | | 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 |
} 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) {
|
| ︙ | ︙ | |||
1297 1298 1299 1300 1301 1302 1303 |
badIndex:
errorString = "not enough arguments for all format specifiers";
goto error;
badField:
{
Tcl_UniChar ch = 0;
| | | 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 |
badIndex:
errorString = "not enough arguments for all format specifiers";
goto error;
badField:
{
Tcl_UniChar ch = 0;
char buf[TCL_UTF_MAX + 1] = "";
TclUtfToUniChar(errorString, &ch);
buf[Tcl_UniCharToUtf(ch, buf)] = '\0';
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad field specifier \"%s\"", buf));
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
1338 1339 1340 1341 1342 1343 1344 |
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. */
| | | | > | | 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 |
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. */
const char *errorString;
const char *str;
int offset, size;
size_t length = 0;
int i;
Tcl_Obj *valuePtr, *elementPtr;
Tcl_HashTable numberCacheHash;
Tcl_HashTable *numberCachePtr;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv,
"value formatString ?varName ...?");
return TCL_ERROR;
}
numberCachePtr = &numberCacheHash;
Tcl_InitHashTable(numberCachePtr, TCL_ONE_WORD_KEYS);
buffer = 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)) {
|
| ︙ | ︙ | |||
1386 1387 1388 1389 1390 1391 1392 |
}
if (count == BINARY_ALL) {
count = length - offset;
} else {
if (count == BINARY_NOCOUNT) {
count = 1;
}
| | | | 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 |
}
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--;
}
}
/*
|
| ︙ | ︙ | |||
1445 1446 1447 1448 1449 1450 1451 |
}
if (count == BINARY_ALL) {
count = (length - offset) * 8;
} else {
if (count == BINARY_NOCOUNT) {
count = 1;
}
| | | | | 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 |
}
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;
valuePtr = Tcl_NewObj();
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');
}
|
| ︙ | ︙ | |||
1510 1511 1512 1513 1514 1515 1516 |
}
src = buffer + offset;
valuePtr = Tcl_NewObj();
Tcl_SetObjLength(valuePtr, count);
dest = TclGetString(valuePtr);
if (cmd == 'h') {
| | | | 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 |
}
src = buffer + offset;
valuePtr = Tcl_NewObj();
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];
}
|
| ︙ | ︙ | |||
1576 1577 1578 1579 1580 1581 1582 |
scanNumber:
if (arg >= objc) {
DeleteScanNumberCache(numberCachePtr);
goto badIndex;
}
if (count == BINARY_NOCOUNT) {
| | | | | | 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 |
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;
}
valuePtr = Tcl_NewObj();
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) {
|
| ︙ | ︙ | |||
1651 1652 1653 1654 1655 1656 1657 |
}
/*
* Set the result to the last position of the cursor.
*/
done:
| | | | 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 |
}
/*
* 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[TCL_UTF_MAX + 1] = "";
TclUtfToUniChar(errorString, &ch);
buf[Tcl_UniCharToUtf(ch, buf)] = '\0';
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad field specifier \"%s\"", buf));
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
1706 1707 1708 1709 1710 1711 1712 |
*----------------------------------------------------------------------
*/
static int
GetFormatSpec(
const char **formatPtr, /* Pointer to format string. */
char *cmdPtr, /* Pointer to location of command char. */
| | | 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 |
*----------------------------------------------------------------------
*/
static int
GetFormatSpec(
const char **formatPtr, /* Pointer to format string. */
char *cmdPtr, /* Pointer to location of command char. */
size_t *countPtr, /* Pointer to repeat count value. */
int *flagsPtr) /* Pointer to field flags */
{
/*
* Skip any leading blanks.
*/
while (**formatPtr == ' ') {
|
| ︙ | ︙ | |||
1872 1873 1874 1875 1876 1877 1878 |
*----------------------------------------------------------------------
*/
static void
CopyNumber(
const void *from, /* source */
void *to, /* destination */
| | | 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 |
*----------------------------------------------------------------------
*/
static void
CopyNumber(
const void *from, /* source */
void *to, /* destination */
size_t length, /* Number of bytes to copy */
int type) /* What type of thing are we copying? */
{
switch (NeedReversing(type)) {
case 0:
memcpy(to, from, length);
break;
case 1: {
|
| ︙ | ︙ | |||
1959 1960 1961 1962 1963 1964 1965 |
FormatNumber(
Tcl_Interp *interp, /* Current interpreter, used to report
* errors. */
int type, /* Type of number to format. */
Tcl_Obj *src, /* Number to format. */
unsigned char **cursorPtr) /* Pointer to index into destination buffer. */
{
| < | > | > | > | | | | 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 |
FormatNumber(
Tcl_Interp *interp, /* Current interpreter, used to report
* errors. */
int type, /* Type of number to format. */
Tcl_Obj *src, /* Number to format. */
unsigned char **cursorPtr) /* Pointer to index into destination buffer. */
{
double dvalue;
Tcl_WideInt wvalue;
float fvalue;
switch (type) {
case 'd':
case 'q':
case 'Q':
/*
* Double-precision floating point values. Tcl_GetDoubleFromObj
* 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) {
return TCL_ERROR;
}
dvalue = irPtr->doubleValue;
}
CopyNumber(&dvalue, *cursorPtr, sizeof(double), type);
*cursorPtr += sizeof(double);
return TCL_OK;
case 'f':
case 'r':
case 'R':
/*
* Single-precision floating point values. Tcl_GetDoubleFromObj
* 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) {
return TCL_ERROR;
}
dvalue = irPtr->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) {
fvalue = (dvalue >= 0.0) ? FLT_MAX : -FLT_MAX;
} else {
fvalue = (float) dvalue;
}
CopyNumber(&fvalue, *cursorPtr, sizeof(float), type);
*cursorPtr += sizeof(float);
return TCL_OK;
/*
* 64-bit integer values.
*/
case 'w':
case 'W':
case 'm':
if (TclGetWideBitsFromObj(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);
|
| ︙ | ︙ | |||
2051 2052 2053 2054 2055 2056 2057 |
/*
* 32-bit integer values.
*/
case 'i':
case 'I':
case 'n':
| | | | | | | | | | | | | | | | | | 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 |
/*
* 32-bit integer values.
*/
case 'i':
case 'I':
case 'n':
if (TclGetWideBitsFromObj(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);
} else {
*(*cursorPtr)++ = UCHAR(wvalue >> 24);
*(*cursorPtr)++ = UCHAR(wvalue >> 16);
*(*cursorPtr)++ = UCHAR(wvalue >> 8);
*(*cursorPtr)++ = UCHAR(wvalue);
}
return TCL_OK;
/*
* 16-bit integer values.
*/
case 's':
case 'S':
case 't':
if (TclGetWideBitsFromObj(interp, src, &wvalue) != TCL_OK) {
return TCL_ERROR;
}
if (NeedReversing(type)) {
*(*cursorPtr)++ = UCHAR(wvalue);
*(*cursorPtr)++ = UCHAR(wvalue >> 8);
} else {
*(*cursorPtr)++ = UCHAR(wvalue >> 8);
*(*cursorPtr)++ = UCHAR(wvalue);
}
return TCL_OK;
/*
* 8-bit integer values.
*/
case 'c':
if (TclGetWideBitsFromObj(interp, src, &wvalue) != TCL_OK) {
return TCL_ERROR;
}
*(*cursorPtr)++ = UCHAR(wvalue);
return TCL_OK;
default:
Tcl_Panic("unexpected fallthrough");
return TCL_ERROR;
}
}
|
| ︙ | ︙ | |||
2127 2128 2129 2130 2131 2132 2133 |
static Tcl_Obj *
ScanNumber(
unsigned char *buffer, /* Buffer to scan number from. */
int type, /* Format character from "binary scan" */
int flags, /* Format field flags */
Tcl_HashTable **numberCachePtrPtr)
| | | | | 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 |
static Tcl_Obj *
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. */
{
long value;
float fvalue;
double dvalue;
Tcl_WideUInt uwvalue;
/*
|
| ︙ | ︙ | |||
2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 |
+ (buffer[1] << 16)
+ (((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);
}
| > | | | | | | | 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 |
+ (buffer[1] << 16)
+ (((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);
}
returnNumericObject:
if (*numberCachePtrPtr == NULL) {
return Tcl_NewWideIntObj(value);
} else {
register Tcl_HashTable *tablePtr = *numberCachePtrPtr;
register Tcl_HashEntry *hPtr;
int isNew;
hPtr = Tcl_CreateHashEntry(tablePtr, INT2PTR(value), &isNew);
if (!isNew) {
return Tcl_GetHashValue(hPtr);
}
if (tablePtr->numEntries <= BINARY_SCAN_MAX_CACHE) {
register Tcl_Obj *objPtr = Tcl_NewWideIntObj(value);
Tcl_IncrRefCount(objPtr);
Tcl_SetHashValue(hPtr, objPtr);
return objPtr;
}
/*
* We've overflowed the cache! Someone's parsing a LOT of varied
* binary data in a single call! Bail out by switching back to the
* old behaviour for the rest of the scan.
*
* Note that anyone just using the 'c' conversion (for bytes)
* cannot trigger this.
*/
DeleteScanNumberCache(tablePtr);
*numberCachePtrPtr = NULL;
return Tcl_NewWideIntObj(value);
}
/*
* Do not cache wide (64-bit) values; they are already too large to
* use as keys.
*/
|
| ︙ | ︙ | |||
2401 2402 2403 2404 2405 2406 2407 |
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *resultObj = NULL;
unsigned char *data = NULL;
unsigned char *cursor = NULL;
| | | | | | 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 |
Tcl_Interp *interp,
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;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
2445 2446 2447 2448 2449 2450 2451 |
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *resultObj = NULL;
unsigned char *data, *datastart, *dataend;
unsigned char *begin, *cursor, c;
| | > | | | | | | | | | 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 |
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *resultObj = NULL;
unsigned char *data, *datastart, *dataend;
unsigned char *begin, *cursor, c;
int i, index, value, size, cut = 0, strict = 0;
size_t count = 0;
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);
datastart = data = (unsigned char *)
TclGetStringFromObj(objv[objc - 1], &count);
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:
TclDecrRefCount(resultObj);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"invalid hexadecimal digit \"%c\" at position %" TCL_Z_MODIFIER "u",
c, data - datastart - 1));
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* BinaryEncode64 --
|
| ︙ | ︙ | |||
2565 2566 2567 2568 2569 2570 2571 |
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *resultObj;
unsigned char *data, *cursor, *limit;
int maxlen = 0;
const char *wrapchar = "\n";
| | | > | | | | | | | | | | | 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 |
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *resultObj;
unsigned char *data, *cursor, *limit;
int maxlen = 0;
const char *wrapchar = "\n";
size_t wrapcharlen = 1;
int i, index, size, outindex = 0;
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 = TclGetStringFromObj(objv[i + 1], &wrapcharlen);
if (wrapcharlen == 0) {
maxlen = 0;
}
break;
}
}
resultObj = Tcl_NewObj();
data = TclGetByteArrayFromObj(objv[objc - 1], &count);
if (count > 0) {
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;
}
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 {
|
| ︙ | ︙ | |||
2669 2670 2671 2672 2673 2674 2675 |
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *resultObj;
unsigned char *data, *start, *cursor;
| | | | | | > | | | | | | | 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 |
ClientData 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[] = { (unsigned char) '\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 < 3 || 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;
}
break;
case OPT_WRAPCHAR:
wrapchar = TclGetByteArrayFromObj(objv[i + 1], &wrapcharlen);
break;
}
}
/*
* Allocate the buffer. This is a little bit too long, but is "good
* enough".
*/
resultObj = Tcl_NewObj();
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;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
2786 2787 2788 2789 2790 2791 2792 |
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *resultObj = NULL;
unsigned char *data, *datastart, *dataend;
unsigned char *begin, *cursor;
| | > | | | | | | | 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 |
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *resultObj = NULL;
unsigned char *data, *datastart, *dataend;
unsigned char *begin, *cursor;
int i, index, size, strict = 0, lineLen;
size_t count = 0;
unsigned char c;
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);
datastart = data = (unsigned char *)
TclGetStringFromObj(objv[objc - 1], &count);
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;
|
| ︙ | ︙ | |||
2890 2891 2892 2893 2894 2895 2896 |
do {
c = *data++;
if (c == '\n') {
break;
} else if (c >= 32 && c <= 96) {
data--;
break;
| | | 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 |
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);
}
}
/*
|
| ︙ | ︙ | |||
2916 2917 2918 2919 2920 2921 2922 |
Tcl_SetObjResult(interp, Tcl_ObjPrintf("short uuencode data"));
Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "SHORT", NULL);
TclDecrRefCount(resultObj);
return TCL_ERROR;
badUu:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
| | | | 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 |
Tcl_SetObjResult(interp, Tcl_ObjPrintf("short uuencode data"));
Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "SHORT", NULL);
TclDecrRefCount(resultObj);
return TCL_ERROR;
badUu:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"invalid uuencode character \"%c\" at position %" TCL_Z_MODIFIER "u",
c, data - datastart - 1));
Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "INVALID", NULL);
TclDecrRefCount(resultObj);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
2951 2952 2953 2954 2955 2956 2957 |
Tcl_Obj *const objv[])
{
Tcl_Obj *resultObj = NULL;
unsigned char *data, *datastart, *dataend, c = '\0';
unsigned char *begin = NULL;
unsigned char *cursor = NULL;
int strict = 0;
| | > | | | 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 |
Tcl_Obj *const objv[])
{
Tcl_Obj *resultObj = NULL;
unsigned char *data, *datastart, *dataend, c = '\0';
unsigned char *begin = NULL;
unsigned char *cursor = NULL;
int strict = 0;
int i, index, size, cut = 0;
size_t count = 0;
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);
datastart = data = (unsigned char *)
TclGetStringFromObj(objv[objc - 1], &count);
dataend = data + count;
size = ((count + 3) & ~3) * 3 / 4;
begin = cursor = Tcl_SetByteArrayLength(resultObj, size);
while (data < dataend) {
unsigned long value = 0;
/*
|
| ︙ | ︙ | |||
3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 |
*/
if (data < dataend) {
c = *data++;
} else if (i > 1) {
c = '=';
} else {
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) {
| > > > > > > > > | | | | | > > > > > | > | | | | < | 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 |
*/
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 && TclIsSpaceProc(c)) {
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 || !TclIsSpaceProc(c)) {
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;
}
for (; data < dataend; data++) {
if (!TclIsSpaceProc(*data)) {
goto bad64;
}
}
}
}
Tcl_SetByteArrayLength(resultObj, cursor - begin - cut);
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
bad64:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"invalid base64 character \"%c\" at position %" TCL_Z_MODIFIER "u",
(char) c, data - datastart - 1));
TclDecrRefCount(resultObj);
return TCL_ERROR;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclCkalloc.c.
| ︙ | ︙ | |||
16 17 18 19 20 21 22 | */ #include "tclInt.h" #define FALSE 0 #define TRUE 1 | < < | | 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 |
*/
#include "tclInt.h"
#define FALSE 0
#define TRUE 1
#undef Tcl_Free
#undef Tcl_AttemptAlloc
#undef Tcl_AttemptRealloc
#ifdef TCL_MEM_DEBUG
/*
* One of the following structures is allocated each time the
* "memory tag" command is invoked, to hold the current tag.
*/
typedef struct {
size_t refCount; /* Number of mem_headers referencing this
* tag. */
char string[1]; /* Actual size of string will be as large as
* needed for actual tag. This must be the
* last field in the structure. */
} MemTag;
#define TAG_SIZE(bytesInString) ((offsetof(MemTag, string) + 1) + bytesInString)
static MemTag *curTagPtr = NULL;/* Tag to use in all future mem_headers (set
* by "memory tag" command). */
/*
* One of the following structures is allocated just before each dynamically
* allocated chunk of memory, both to record information about the chunk and
|
| ︙ | ︙ | |||
117 118 119 120 121 122 123 | static char *onExitMemDumpFileName = NULL; static char dumpFile[100]; /* Records where to dump memory allocation * information. */ /* * Mutex to serialize allocations. This is a low-level mutex that must be * explicitly initialized. This is necessary because the self initializing | | | 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 | static char *onExitMemDumpFileName = NULL; static char dumpFile[100]; /* Records where to dump memory allocation * information. */ /* * Mutex to serialize allocations. This is a low-level mutex that must be * explicitly initialized. This is necessary because the self initializing * mutexes use Tcl_Alloc... */ static Tcl_Mutex *ckallocMutexPtr; static int ckallocInit = 0; /* * Prototypes for procedures defined in this file: |
| ︙ | ︙ | |||
152 153 154 155 156 157 158 |
void
TclInitDbCkalloc(void)
{
if (!ckallocInit) {
ckallocInit = 1;
ckallocMutexPtr = Tcl_GetAllocMutex();
| | | 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 |
void
TclInitDbCkalloc(void)
{
if (!ckallocInit) {
ckallocInit = 1;
ckallocMutexPtr = Tcl_GetAllocMutex();
#if !TCL_THREADS
/* Silence compiler warning */
(void)ckallocMutexPtr;
#endif
}
}
/*
|
| ︙ | ︙ | |||
241 242 243 244 245 246 247 |
for (idx = 0; idx < LOW_GUARD_SIZE; idx++) {
byte = *(memHeaderP->low_guard + idx);
if (byte != GUARD_VALUE) {
guard_failed = TRUE;
fflush(stdout);
byte &= 0xff;
| | | | | | 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 |
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,
(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);
fflush(stderr); /* In case name pointer is bad. */
fprintf(stderr, "%" TCL_Z_MODIFIER "u bytes allocated at (%s %d)\n", memHeaderP->length,
memHeaderP->file, memHeaderP->line);
Tcl_Panic("Memory validation failure");
}
hiPtr = (unsigned char *)memHeaderP->body + memHeaderP->length;
for (idx = 0; idx < HIGH_GUARD_SIZE; idx++) {
byte = *(hiPtr + idx);
if (byte != GUARD_VALUE) {
guard_failed = TRUE;
fflush(stdout);
byte &= 0xff;
fprintf(stderr, "hi guard byte %" TCL_Z_MODIFIER "u is 0x%x \t%c\n", 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);
fflush(stderr); /* In case name pointer is bad. */
fprintf(stderr, "%" TCL_Z_MODIFIER "u bytes allocated at (%s %d)\n",
memHeaderP->length, memHeaderP->file,
memHeaderP->line);
Tcl_Panic("Memory validation failure");
|
| ︙ | ︙ | |||
372 373 374 375 376 377 378 |
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
| | | | | | | | | 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 |
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_DbCkalloc - debugging Tcl_Alloc
*
* 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__
* and __LINE__.
*
*----------------------------------------------------------------------
*/
void *
Tcl_DbCkalloc(
size_t size,
const char *file,
int line)
{
struct mem_header *result = NULL;
if (validate_memory) {
Tcl_ValidateAllMemory(file, line);
}
/* Don't let size argument to TclpAlloc overflow */
if (size <= UINT_MAX - HIGH_GUARD_SIZE -sizeof(struct mem_header)) {
result = (struct mem_header *) TclpAlloc(size +
sizeof(struct mem_header) + HIGH_GUARD_SIZE);
}
if (result == NULL) {
fflush(stdout);
TclDumpMemoryInfo(stderr, 0);
Tcl_Panic("unable to alloc %" TCL_Z_MODIFIER "u bytes, %s line %d", size, file, line);
}
/*
* Fill in guard zones and size. Also initialize the contents of the block
* with bogus bytes to detect uses of initialized data. Link into
* allocated list.
*/
|
| ︙ | ︙ | |||
453 454 455 456 457 458 459 |
total_mallocs);
fflush(stderr);
alloc_tracing = TRUE;
trace_on_at_malloc = 0;
}
if (alloc_tracing) {
| | | 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 |
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);
}
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);
|
| ︙ | ︙ | |||
477 478 479 480 481 482 483 |
}
Tcl_MutexUnlock(ckallocMutexPtr);
return result->body;
}
| | | | | | 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 |
}
Tcl_MutexUnlock(ckallocMutexPtr);
return result->body;
}
void *
Tcl_AttemptDbCkalloc(
size_t size,
const char *file,
int line)
{
struct mem_header *result = NULL;
if (validate_memory) {
Tcl_ValidateAllMemory(file, line);
}
/* Don't let size argument to TclpAlloc overflow */
if (size <= UINT_MAX - HIGH_GUARD_SIZE - sizeof(struct mem_header)) {
result = (struct mem_header *) TclpAlloc(size +
sizeof(struct mem_header) + HIGH_GUARD_SIZE);
}
if (result == NULL) {
fflush(stdout);
TclDumpMemoryInfo(stderr, 0);
return NULL;
}
/*
* Fill in guard zones and size. Also initialize the contents of the block
* with bogus bytes to detect uses of initialized data. Link into
* allocated list.
|
| ︙ | ︙ | |||
542 543 544 545 546 547 548 |
total_mallocs);
fflush(stderr);
alloc_tracing = TRUE;
trace_on_at_malloc = 0;
}
if (alloc_tracing) {
| | | 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 |
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);
}
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);
|
| ︙ | ︙ | |||
569 570 571 572 573 574 575 |
return result->body;
}
/*
*----------------------------------------------------------------------
*
| | | | | | 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 |
return result->body;
}
/*
*----------------------------------------------------------------------
*
* Tcl_DbCkfree - debugging Tcl_Free
*
* 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
* __LINE__.
*
*----------------------------------------------------------------------
*/
void
Tcl_DbCkfree(
void *ptr,
const char *file,
int line)
{
struct mem_header *memp;
if (ptr == NULL) {
return;
}
/*
* The following cast is *very* tricky. Must convert the pointer to an
* integer before doing arithmetic on it, because otherwise the arithmetic
* will be done differently (and incorrectly) on word-addressed machines
* such as Crays (will subtract only bytes, even though BODY_OFFSET is in
* words on these machines).
*/
memp = (struct mem_header *) (((size_t) ptr) - BODY_OFFSET);
if (alloc_tracing) {
fprintf(stderr, "Tcl_Free %p %" TCL_Z_MODIFIER "u %s %d\n",
memp->body, memp->length, file, line);
}
if (validate_memory) {
Tcl_ValidateAllMemory(file, line);
}
|
| ︙ | ︙ | |||
651 652 653 654 655 656 657 |
TclpFree((char *) memp);
Tcl_MutexUnlock(ckallocMutexPtr);
}
/*
*--------------------------------------------------------------------
*
| | | | | | 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 |
TclpFree((char *) memp);
Tcl_MutexUnlock(ckallocMutexPtr);
}
/*
*--------------------------------------------------------------------
*
* Tcl_DbCkrealloc - debugging Tcl_Realloc
*
* 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 *
Tcl_DbCkrealloc(
void *ptr,
size_t size,
const char *file,
int line)
{
char *newPtr;
size_t copySize;
struct mem_header *memp;
|
| ︙ | ︙ | |||
687 688 689 690 691 692 693 |
memp = (struct mem_header *) (((size_t) ptr) - BODY_OFFSET);
copySize = size;
if (copySize > memp->length) {
copySize = memp->length;
}
newPtr = Tcl_DbCkalloc(size, file, line);
| | | | | | 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 |
memp = (struct mem_header *) (((size_t) ptr) - BODY_OFFSET);
copySize = size;
if (copySize > memp->length) {
copySize = memp->length;
}
newPtr = Tcl_DbCkalloc(size, file, line);
memcpy(newPtr, ptr, copySize);
Tcl_DbCkfree(ptr, file, line);
return newPtr;
}
void *
Tcl_AttemptDbCkrealloc(
void *ptr,
size_t size,
const char *file,
int line)
{
char *newPtr;
size_t copySize;
struct mem_header *memp;
|
| ︙ | ︙ | |||
721 722 723 724 725 726 727 |
if (copySize > memp->length) {
copySize = memp->length;
}
newPtr = Tcl_AttemptDbCkalloc(size, file, line);
if (newPtr == NULL) {
return NULL;
}
| | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 |
if (copySize > memp->length) {
copySize = memp->length;
}
newPtr = Tcl_AttemptDbCkalloc(size, file, line);
if (newPtr == NULL) {
return NULL;
}
memcpy(newPtr, ptr, copySize);
Tcl_DbCkfree(ptr, file, line);
return newPtr;
}
/*
*----------------------------------------------------------------------
*
* MemoryCmd --
*
* Implements the Tcl "memory" command, which provides Tcl-level control
|
| ︙ | ︙ | |||
1048 1049 1050 1051 1052 1053 1054 | * * Interface to TclpAlloc when TCL_MEM_DEBUG is disabled. It does check * that memory was actually allocated. * *---------------------------------------------------------------------- */ | > | | | | | | | | | > | | | | | | | > | | | | | | | | | | > | | | | | | | | | > | | | 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 |
*
* Interface to TclpAlloc when TCL_MEM_DEBUG is disabled. It does check
* that memory was actually allocated.
*
*----------------------------------------------------------------------
*/
#undef Tcl_Alloc
void *
Tcl_Alloc(
size_t size)
{
void *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
* alloc(0).
*
* The ANSI spec actually says that systems either return NULL *or* a
* special pointer on failure, but we only check for NULL
*/
if ((result == NULL) && size) {
Tcl_Panic("unable to alloc %" TCL_Z_MODIFIER "u bytes", size);
}
return result;
}
void *
Tcl_DbCkalloc(
size_t size,
const char *file,
int line)
{
void *result;
result = TclpAlloc(size);
if ((result == NULL) && size) {
fflush(stdout);
Tcl_Panic("unable to alloc %" TCL_Z_MODIFIER "u bytes, %s line %d",
size, file, line);
}
return result;
}
/*
*----------------------------------------------------------------------
*
* Tcl_AttemptAlloc --
*
* Interface to TclpAlloc when TCL_MEM_DEBUG is disabled. It does not
* check that memory was actually allocated.
*
*----------------------------------------------------------------------
*/
void *
Tcl_AttemptAlloc(
size_t size)
{
void *result;
result = TclpAlloc(size);
return result;
}
void *
Tcl_AttemptDbCkalloc(
size_t size,
const char *file,
int line)
{
void *result;
result = TclpAlloc(size);
return result;
}
/*
*----------------------------------------------------------------------
*
* Tcl_Realloc --
*
* Interface to TclpRealloc when TCL_MEM_DEBUG is disabled. It does check
* that memory was actually allocated.
*
*----------------------------------------------------------------------
*/
#undef Tcl_Realloc
void *
Tcl_Realloc(
void *ptr,
size_t size)
{
char *result;
result = TclpRealloc(ptr, size);
if ((result == NULL) && size) {
Tcl_Panic("unable to realloc %" TCL_Z_MODIFIER "u bytes", size);
}
return result;
}
void *
Tcl_DbCkrealloc(
void *ptr,
size_t size,
const char *file,
int line)
{
void *result;
result = 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);
}
return result;
}
/*
*----------------------------------------------------------------------
*
* Tcl_AttemptRealloc --
*
* Interface to TclpRealloc when TCL_MEM_DEBUG is disabled. It does not
* check that memory was actually allocated.
*
*----------------------------------------------------------------------
*/
void *
Tcl_AttemptRealloc(
void *ptr,
size_t size)
{
void *result;
result = TclpRealloc(ptr, size);
return result;
}
void *
Tcl_AttemptDbCkrealloc(
void *ptr,
size_t size,
const char *file,
int line)
{
void *result;
result = TclpRealloc(ptr, size);
return result;
}
/*
*----------------------------------------------------------------------
*
* Tcl_Free --
*
* Interface to TclpFree when TCL_MEM_DEBUG is disabled. Done here rather
* in the macro to keep some modules from being compiled with
* TCL_MEM_DEBUG enabled and some with it disabled.
*
*----------------------------------------------------------------------
*/
#undef Tcl_Free
void
Tcl_Free(
void *ptr)
{
TclpFree(ptr);
}
void
Tcl_DbCkfree(
void *ptr,
const char *file,
int line)
{
TclpFree(ptr);
}
/*
|
| ︙ | ︙ |
Changes to generic/tclClock.c.
| ︙ | ︙ | |||
271 272 273 274 275 276 277 |
return;
}
/*
* Create the client data, which is a refcounted literal pool.
*/
| | | | 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 |
return;
}
/*
* Create the client data, which is a refcounted literal pool.
*/
data = Tcl_Alloc(sizeof(ClockClientData));
data->refCount = 0;
data->literals = Tcl_Alloc(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.
|
| ︙ | ︙ | |||
448 449 450 451 452 453 454 |
}
/*
* fields.seconds could be an unsigned number that overflowed. Make sure
* that it isn't.
*/
| | | 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 |
}
/*
* fields.seconds could be an unsigned number that overflowed. Make sure
* that it isn't.
*/
if (TclHasIntRep(objv[1], &tclBignumType)) {
Tcl_SetObjResult(interp, literals[LIT_INTEGER_VALUE_TOO_LARGE]);
return TCL_ERROR;
}
/*
* Convert UTC time to local.
*/
|
| ︙ | ︙ | |||
484 485 486 487 488 489 490 |
Tcl_DictObjPut(NULL, dict, literals[LIT_LOCALSECONDS],
Tcl_NewWideIntObj(fields.localSeconds));
Tcl_DictObjPut(NULL, dict, literals[LIT_SECONDS],
Tcl_NewWideIntObj(fields.seconds));
Tcl_DictObjPut(NULL, dict, literals[LIT_TZNAME], fields.tzName);
Tcl_DecrRefCount(fields.tzName);
Tcl_DictObjPut(NULL, dict, literals[LIT_TZOFFSET],
| | | | | | | | | | | | 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 |
Tcl_DictObjPut(NULL, dict, literals[LIT_LOCALSECONDS],
Tcl_NewWideIntObj(fields.localSeconds));
Tcl_DictObjPut(NULL, dict, literals[LIT_SECONDS],
Tcl_NewWideIntObj(fields.seconds));
Tcl_DictObjPut(NULL, dict, literals[LIT_TZNAME], fields.tzName);
Tcl_DecrRefCount(fields.tzName);
Tcl_DictObjPut(NULL, dict, literals[LIT_TZOFFSET],
Tcl_NewWideIntObj(fields.tzOffset));
Tcl_DictObjPut(NULL, dict, literals[LIT_JULIANDAY],
Tcl_NewWideIntObj(fields.julianDay));
Tcl_DictObjPut(NULL, dict, literals[LIT_GREGORIAN],
Tcl_NewWideIntObj(fields.gregorian));
Tcl_DictObjPut(NULL, dict, literals[LIT_ERA],
literals[fields.era ? LIT_BCE : LIT_CE]);
Tcl_DictObjPut(NULL, dict, literals[LIT_YEAR],
Tcl_NewWideIntObj(fields.year));
Tcl_DictObjPut(NULL, dict, literals[LIT_DAYOFYEAR],
Tcl_NewWideIntObj(fields.dayOfYear));
Tcl_DictObjPut(NULL, dict, literals[LIT_MONTH],
Tcl_NewWideIntObj(fields.month));
Tcl_DictObjPut(NULL, dict, literals[LIT_DAYOFMONTH],
Tcl_NewWideIntObj(fields.dayOfMonth));
Tcl_DictObjPut(NULL, dict, literals[LIT_ISO8601YEAR],
Tcl_NewWideIntObj(fields.iso8601Year));
Tcl_DictObjPut(NULL, dict, literals[LIT_ISO8601WEEK],
Tcl_NewWideIntObj(fields.iso8601Week));
Tcl_DictObjPut(NULL, dict, literals[LIT_DAYOFWEEK],
Tcl_NewWideIntObj(fields.dayOfWeek));
Tcl_SetObjResult(interp, dict);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
624 625 626 627 628 629 630 |
if (Tcl_IsShared(dict)) {
dict = Tcl_DuplicateObj(dict);
Tcl_IncrRefCount(dict);
copied = 1;
}
status = Tcl_DictObjPut(interp, dict, literals[LIT_JULIANDAY],
| | | 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 |
if (Tcl_IsShared(dict)) {
dict = Tcl_DuplicateObj(dict);
Tcl_IncrRefCount(dict);
copied = 1;
}
status = Tcl_DictObjPut(interp, dict, literals[LIT_JULIANDAY],
Tcl_NewWideIntObj(fields.julianDay));
if (status == TCL_OK) {
Tcl_SetObjResult(interp, dict);
}
if (copied) {
Tcl_DecrRefCount(dict);
}
return status;
|
| ︙ | ︙ | |||
708 709 710 711 712 713 714 |
if (Tcl_IsShared(dict)) {
dict = Tcl_DuplicateObj(dict);
Tcl_IncrRefCount(dict);
copied = 1;
}
status = Tcl_DictObjPut(interp, dict, literals[LIT_JULIANDAY],
| | | 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 |
if (Tcl_IsShared(dict)) {
dict = Tcl_DuplicateObj(dict);
Tcl_IncrRefCount(dict);
copied = 1;
}
status = Tcl_DictObjPut(interp, dict, literals[LIT_JULIANDAY],
Tcl_NewWideIntObj(fields.julianDay));
if (status == TCL_OK) {
Tcl_SetObjResult(interp, dict);
}
if (copied) {
Tcl_DecrRefCount(dict);
}
return status;
|
| ︙ | ︙ | |||
1768 1769 1770 1771 1772 1773 1774 |
#ifdef TCL_WIDE_CLICKS
clicks = TclpGetWideClicks();
#else
clicks = (Tcl_WideInt) TclpGetClicks();
#endif
break;
case CLICKS_MICROS:
| < | | 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 |
#ifdef TCL_WIDE_CLICKS
clicks = TclpGetWideClicks();
#else
clicks = (Tcl_WideInt) TclpGetClicks();
#endif
break;
case CLICKS_MICROS:
clicks = TclpGetMicroseconds();
break;
}
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(clicks));
return TCL_OK;
}
|
| ︙ | ︙ | |||
1839 1840 1841 1842 1843 1844 1845 |
int
ClockMicrosecondsObjCmd(
ClientData clientData, /* Client data is unused */
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const *objv) /* Parameter values */
{
| < < < | < | 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 |
int
ClockMicrosecondsObjCmd(
ClientData clientData, /* Client data is unused */
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const *objv) /* Parameter values */
{
if (objc != 1) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(TclpGetMicroseconds()));
return TCL_OK;
}
/*
*-----------------------------------------------------------------------------
*
* ClockParseformatargsObjCmd --
|
| ︙ | ︙ | |||
1918 1919 1920 1921 1922 1923 1924 |
formatObj = litPtr[LIT__DEFAULT_FORMAT];
localeObj = litPtr[LIT_C];
timezoneObj = litPtr[LIT__NIL];
for (i = 2; i < objc; i+=2) {
if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0,
&optionIndex) != TCL_OK) {
Tcl_SetErrorCode(interp, "CLOCK", "badOption",
| | | 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 |
formatObj = litPtr[LIT__DEFAULT_FORMAT];
localeObj = litPtr[LIT_C];
timezoneObj = litPtr[LIT__NIL];
for (i = 2; i < objc; i+=2) {
if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0,
&optionIndex) != TCL_OK) {
Tcl_SetErrorCode(interp, "CLOCK", "badOption",
TclGetString(objv[i]), NULL);
return TCL_ERROR;
}
switch (optionIndex) {
case CLOCK_FORMAT_FORMAT:
formatObj = objv[i+1];
break;
case CLOCK_FORMAT_GMT:
|
| ︙ | ︙ | |||
2035 2036 2037 2038 2039 2040 2041 |
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)) {
| | | | | 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 |
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);
}
tzWas = Tcl_Alloc(strlen(tzIsNow) + 1);
strcpy(tzWas, tzIsNow);
} else if (tzIsNow == NULL && tzWas != NULL) {
tzset();
if (tzWas != INT2PTR(-1)) Tcl_Free(tzWas);
tzWas = NULL;
}
Tcl_MutexUnlock(&clockMutex);
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
2072 2073 2074 2075 2076 2077 2078 |
ClockClientData *data = clientData;
int i;
if (data->refCount-- <= 1) {
for (i = 0; i < LIT__END; ++i) {
Tcl_DecrRefCount(data->literals[i]);
}
| | | | 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 |
ClockClientData *data = clientData;
int i;
if (data->refCount-- <= 1) {
for (i = 0; i < LIT__END; ++i) {
Tcl_DecrRefCount(data->literals[i]);
}
Tcl_Free(data->literals);
Tcl_Free(data);
}
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclCmdAH.c.
| ︙ | ︙ | |||
42 43 44 45 46 47 48 | /* * Prototypes for local procedures defined in this file: */ static int CheckAccess(Tcl_Interp *interp, Tcl_Obj *pathPtr, int mode); | < < < | 42 43 44 45 46 47 48 49 50 51 52 53 54 55 | /* * Prototypes for local procedures defined in this file: */ static int CheckAccess(Tcl_Interp *interp, Tcl_Obj *pathPtr, int mode); static int EncodingConvertfromObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int EncodingConverttoObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int EncodingDirsObjCmd(ClientData dummy, |
| ︙ | ︙ | |||
80 81 82 83 84 85 86 | static Tcl_NRPostProc ForSetupCallback; static Tcl_NRPostProc ForCondCallback; static Tcl_NRPostProc ForNextCallback; static Tcl_NRPostProc ForPostNextCallback; static Tcl_NRPostProc ForeachLoopStep; static Tcl_NRPostProc EvalCmdErrMsg; | < | 77 78 79 80 81 82 83 84 85 86 87 88 89 90 | 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; |
| ︙ | ︙ | |||
245 246 247 248 249 250 251 |
/* Do not decrRefCount 'options', it was already done by
* Tcl_ObjSetVar2 */
return TCL_ERROR;
}
}
Tcl_ResetResult(interp);
| | | 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 |
/* Do not decrRefCount 'options', it was already done by
* Tcl_ObjSetVar2 */
return TCL_ERROR;
}
}
Tcl_ResetResult(interp);
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(result));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_CdObjCmd --
|
| ︙ | ︙ | |||
371 372 373 374 375 376 377 |
{
if (objc != 1) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return TCL_ERROR;
}
return TCL_CONTINUE;
}
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 367 368 369 370 371 372 373 374 375 376 377 378 379 380 |
{
if (objc != 1) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return TCL_ERROR;
}
return TCL_CONTINUE;
}
/*
*-----------------------------------------------------------------------------
*
* TclInitEncodingCmd --
*
* This function creates the 'encoding' ensemble.
|
| ︙ | ︙ | |||
452 453 454 455 456 457 458 |
Tcl_Command
TclInitEncodingCmd(
Tcl_Interp* interp) /* Tcl interpreter */
{
static const EnsembleImplMap encodingImplMap[] = {
{"convertfrom", EncodingConvertfromObjCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
{"convertto", EncodingConverttoObjCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
| | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 |
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
|
| ︙ | ︙ | |||
592 593 594 595 596 597 598 |
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 */
| | | | 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 |
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.
*/
|
| ︙ | ︙ | |||
654 655 656 657 658 659 660 |
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 */
| | | 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 |
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];
|
| ︙ | ︙ | |||
959 960 961 962 963 964 965 |
int
Tcl_ExitObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
| | | | | 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 |
int
Tcl_ExitObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_WideInt value;
if ((objc != 1) && (objc != 2)) {
Tcl_WrongNumArgs(interp, 1, objv, "?returnCode?");
return TCL_ERROR;
}
if (objc == 1) {
value = 0;
} else if (TclGetWideBitsFromObj(interp, objv[1], &value) != TCL_OK) {
return TCL_ERROR;
}
Tcl_Exit((int)value);
/*NOTREACHED*/
return TCL_OK; /* Better not ever reach this! */
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1090 1091 1092 1093 1094 1095 1096 |
/*
* 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[] = {
| | | | | | | | | | | | | | | | | | | | | | | | | > | | | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 |
/*
* 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
|
| ︙ | ︙ | |||
1314 1315 1316 1317 1318 1319 1320 |
if (objc == 3) {
/*
* Need separate variable for reading longs from an object on 64-bit
* platforms. [Bug 698146]
*/
| | | | 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 |
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 = buf.st_mtime;
if (Tcl_FSUtime(objv[1], &tval) != 0) {
|
| ︙ | ︙ | |||
1341 1342 1343 1344 1345 1346 1347 |
*/
if (GetStatBuf(interp, objv[1], Tcl_FSStat, &buf) != TCL_OK) {
return TCL_ERROR;
}
}
| | | 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 |
*/
if (GetStatBuf(interp, objv[1], Tcl_FSStat, &buf) != TCL_OK) {
return TCL_ERROR;
}
}
Tcl_SetObjResult(interp, Tcl_NewWideIntObj((long) buf.st_atime));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* FileAttrModifyTimeCmd --
|
| ︙ | ︙ | |||
1395 1396 1397 1398 1399 1400 1401 |
#endif
if (objc == 3) {
/*
* Need separate variable for reading longs from an object on 64-bit
* platforms. [Bug 698146]
*/
| | | | 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 |
#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 = buf.st_atime;
tval.modtime = newTime;
if (Tcl_FSUtime(objv[1], &tval) != 0) {
|
| ︙ | ︙ | |||
1421 1422 1423 1424 1425 1426 1427 |
*/
if (GetStatBuf(interp, objv[1], Tcl_FSStat, &buf) != TCL_OK) {
return TCL_ERROR;
}
}
| | | 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 |
*/
if (GetStatBuf(interp, objv[1], Tcl_FSStat, &buf) != TCL_OK) {
return TCL_ERROR;
}
}
Tcl_SetObjResult(interp, Tcl_NewWideIntObj((long) buf.st_mtime));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* FileAttrLinkStatCmd --
|
| ︙ | ︙ | |||
2009 2010 2011 2012 2013 2014 2015 |
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",
| | | 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 |
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;
}
/*
|
| ︙ | ︙ | |||
2044 2045 2046 2047 2048 2049 2050 |
int objc,
Tcl_Obj *const objv[])
{
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "name ?name ...?");
return TCL_ERROR;
}
| | | 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 |
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 --
|
| ︙ | ︙ | |||
2261 2262 2263 2264 2265 2266 2267 |
} 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",
| | | 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 |
} 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;
}
|
| ︙ | ︙ | |||
2440 2441 2442 2443 2444 2445 2446 |
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...
*/
| | | | | | | | | | | 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 |
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...
*/
STORE_ARY("dev", Tcl_NewWideIntObj((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("size", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_size));
#ifdef HAVE_STRUCT_STAT_ST_BLOCKS
STORE_ARY("blocks", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_blocks));
#endif
#ifdef HAVE_STRUCT_STAT_ST_BLKSIZE
STORE_ARY("blksize", Tcl_NewWideIntObj((long)statPtr->st_blksize));
#endif
STORE_ARY("atime", Tcl_NewWideIntObj((long)statPtr->st_atime));
STORE_ARY("mtime", Tcl_NewWideIntObj((long)statPtr->st_mtime));
STORE_ARY("ctime", Tcl_NewWideIntObj((long)statPtr->st_ctime));
mode = (unsigned short) statPtr->st_mode;
STORE_ARY("mode", Tcl_NewWideIntObj(mode));
STORE_ARY("type", Tcl_NewStringObj(GetTypeFromMode(mode), -1));
#undef STORE_ARY
return TCL_OK;
}
/*
|
| ︙ | ︙ |
Changes to generic/tclCmdIL.c.
| ︙ | ︙ | |||
31 32 33 34 35 36 37 |
const char *strValuePtr;
Tcl_WideInt wideValue;
double doubleValue;
Tcl_Obj *objValuePtr;
} collationKey;
union { /* Object being sorted, or its index. */
Tcl_Obj *objPtr;
| | | 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 |
const char *strValuePtr;
Tcl_WideInt wideValue;
double doubleValue;
Tcl_Obj *objValuePtr;
} collationKey;
union { /* Object being sorted, or its index. */
Tcl_Obj *objPtr;
size_t index;
} payload;
struct SortElement *nextPtr;/* Next element in the list, or NULL for end
* of list. */
} SortElement;
/*
* These function pointer types are used with the "lsearch" and "lsort"
|
| ︙ | ︙ | |||
133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 |
static int InfoPatchLevelCmd(ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
static int InfoProcsCmd(ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
static int InfoScriptCmd(ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
static int InfoSharedlibCmd(ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
static int InfoTclVersionCmd(ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
static SortElement * MergeLists(SortElement *leftPtr, SortElement *rightPtr,
SortInfo *infoPtr);
static int SortCompare(SortElement *firstPtr, SortElement *second,
SortInfo *infoPtr);
static Tcl_Obj * SelectObjFromSublist(Tcl_Obj *firstPtr,
SortInfo *infoPtr);
/*
* Array of values describing how to implement each standard subcommand of the
* "info" command.
*/
static const EnsembleImplMap defaultInfoMap[] = {
{"args", InfoArgsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"body", InfoBodyCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"cmdcount", InfoCmdCountCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0},
{"commands", InfoCommandsCmd, TclCompileInfoCommandsCmd, NULL, NULL, 0},
{"complete", InfoCompleteCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"coroutine", TclInfoCoroutineCmd, TclCompileInfoCoroutineCmd, NULL, NULL, 0},
{"default", InfoDefaultCmd, TclCompileBasic3ArgCmd, NULL, NULL, 0},
{"errorstack", InfoErrorStackCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
{"exists", TclInfoExistsCmd, TclCompileInfoExistsCmd, NULL, NULL, 0},
{"frame", InfoFrameCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
{"functions", InfoFunctionsCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
{"globals", TclInfoGlobalsCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
{"hostname", InfoHostnameCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0},
{"level", InfoLevelCmd, TclCompileInfoLevelCmd, NULL, NULL, 0},
{"library", InfoLibraryCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0},
{"loaded", InfoLoadedCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
{"locals", TclInfoLocalsCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
| > > > | | 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 |
static int InfoPatchLevelCmd(ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
static int InfoProcsCmd(ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
static int InfoScriptCmd(ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
static int InfoSharedlibCmd(ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
static int InfoCmdTypeCmd(ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
static int InfoTclVersionCmd(ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
static SortElement * MergeLists(SortElement *leftPtr, SortElement *rightPtr,
SortInfo *infoPtr);
static int SortCompare(SortElement *firstPtr, SortElement *second,
SortInfo *infoPtr);
static Tcl_Obj * SelectObjFromSublist(Tcl_Obj *firstPtr,
SortInfo *infoPtr);
/*
* Array of values describing how to implement each standard subcommand of the
* "info" command.
*/
static const EnsembleImplMap defaultInfoMap[] = {
{"args", InfoArgsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"body", InfoBodyCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"cmdcount", InfoCmdCountCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0},
{"cmdtype", InfoCmdTypeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
{"commands", InfoCommandsCmd, TclCompileInfoCommandsCmd, NULL, NULL, 0},
{"complete", InfoCompleteCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"coroutine", TclInfoCoroutineCmd, TclCompileInfoCoroutineCmd, NULL, NULL, 0},
{"default", InfoDefaultCmd, TclCompileBasic3ArgCmd, NULL, NULL, 0},
{"errorstack", InfoErrorStackCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
{"exists", TclInfoExistsCmd, TclCompileInfoExistsCmd, NULL, NULL, 0},
{"frame", InfoFrameCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
{"functions", InfoFunctionsCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
{"globals", TclInfoGlobalsCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
{"hostname", InfoHostnameCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0},
{"level", InfoLevelCmd, TclCompileInfoLevelCmd, NULL, NULL, 0},
{"library", InfoLibraryCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0},
{"loaded", InfoLoadedCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
{"locals", TclInfoLocalsCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
{"nameofexecutable", InfoNameOfExecutableCmd, TclCompileBasic0ArgCmd, NULL, NULL, 1},
{"patchlevel", InfoPatchLevelCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0},
{"procs", InfoProcsCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
{"script", InfoScriptCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
{"sharedlibextension", InfoSharedlibCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0},
{"tclversion", InfoTclVersionCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0},
{"vars", TclInfoVarsCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
{NULL, NULL, NULL, NULL, NULL, 0}
|
| ︙ | ︙ | |||
397 398 399 400 401 402 403 |
Tcl_WrongNumArgs(interp, 1, objv, "varName ?increment?");
return TCL_ERROR;
}
if (objc == 3) {
incrPtr = objv[2];
} else {
| | | 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 |
Tcl_WrongNumArgs(interp, 1, objv, "varName ?increment?");
return TCL_ERROR;
}
if (objc == 3) {
incrPtr = objv[2];
} else {
incrPtr = Tcl_NewWideIntObj(1);
}
Tcl_IncrRefCount(incrPtr);
newValuePtr = TclIncrObjVar2(interp, objv[1], NULL,
incrPtr, TCL_LEAVE_ERR_MSG);
Tcl_DecrRefCount(incrPtr);
if (newValuePtr == NULL) {
|
| ︙ | ︙ | |||
532 533 534 535 536 537 538 |
InfoBodyCmd(
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;
| | | | 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 |
InfoBodyCmd(
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;
const char *name, *bytes;
Proc *procPtr;
size_t numBytes;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "procname");
return TCL_ERROR;
}
name = TclGetString(objv[1]);
|
| ︙ | ︙ | |||
559 560 561 562 563 564 565 |
* bytecompiled - in that case, the return was a copy of the body's string
* rep. In order to better isolate the implementation details of the
* compiler/engine subsystem, we now always return a copy of the string
* rep. It is important to return a copy so that later manipulations of
* the object do not invalidate the internal rep.
*/
| | < < < < < < < < < < | | 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 |
* bytecompiled - in that case, the return was a copy of the body's string
* rep. In order to better isolate the implementation details of the
* compiler/engine subsystem, we now always return a copy of the string
* rep. It is important to return a copy so that later manipulations of
* the object do not invalidate the internal rep.
*/
bytes = TclGetStringFromObj(procPtr->bodyPtr, &numBytes);
Tcl_SetObjResult(interp, Tcl_NewStringObj(bytes, numBytes));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* InfoCmdCountCmd --
|
| ︙ | ︙ | |||
609 610 611 612 613 614 615 |
Interp *iPtr = (Interp *) interp;
if (objc != 1) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return TCL_ERROR;
}
| | | 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 |
Interp *iPtr = (Interp *) interp;
if (objc != 1) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(iPtr->cmdCount));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* InfoCommandsCmd --
|
| ︙ | ︙ | |||
654 655 656 657 658 659 660 |
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;
| | | 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 |
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;
/*
* Get the pattern and find the "effective namespace" in which to list
* commands.
*/
if (objc == 1) {
|
| ︙ | ︙ | |||
991 992 993 994 995 996 997 |
&& (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;
}
| | | | 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 |
&& (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\"",
|
| ︙ | ︙ | |||
1050 1051 1052 1053 1054 1055 1056 |
if ((objc != 1) && (objc != 2)) {
Tcl_WrongNumArgs(interp, 1, objv, "?interp?");
return TCL_ERROR;
}
target = interp;
if (objc == 2) {
| | | 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 |
if ((objc != 1) && (objc != 2)) {
Tcl_WrongNumArgs(interp, 1, objv, "?interp?");
return TCL_ERROR;
}
target = interp;
if (objc == 2) {
target = Tcl_GetSlave(interp, TclGetString(objv[1]));
if (target == NULL) {
return TCL_ERROR;
}
}
iPtr = (Interp *) target;
Tcl_SetObjResult(interp, iPtr->errorStack);
|
| ︙ | ︙ | |||
1174 1175 1176 1177 1178 1179 1180 |
}
if (objc == 1) {
/*
* Just "info frame".
*/
| | | 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 |
}
if (objc == 1) {
/*
* Just "info frame".
*/
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(topLevel));
goto done;
}
/*
* We've got "info frame level" and must parse the level first.
*/
|
| ︙ | ︙ | |||
1296 1297 1298 1299 1300 1301 1302 |
/*
* Evaluation, dynamic script. Type, line, cmd, the latter through
* str.
*/
ADD_PAIR("type", Tcl_NewStringObj(typeString[framePtr->type], -1));
if (framePtr->line) {
| | | | 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 |
/*
* 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));
break;
case TCL_LOCATION_PREBC:
/*
* Precompiled. Result contains the type as signal, nothing else.
|
| ︙ | ︙ | |||
1335 1336 1337 1338 1339 1340 1341 |
/*
* Now filled: cmd.str.(cmd,len), line
* Possibly modified: type, path!
*/
ADD_PAIR("type", Tcl_NewStringObj(typeString[fPtr->type], -1));
if (fPtr->line) {
| | | 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 |
/*
* Now filled: cmd.str.(cmd,len), line
* Possibly modified: type, path!
*/
ADD_PAIR("type", Tcl_NewStringObj(typeString[fPtr->type], -1));
if (fPtr->line) {
ADD_PAIR("line", Tcl_NewWideIntObj(fPtr->line[0]));
}
if (fPtr->type == TCL_LOCATION_SOURCE) {
ADD_PAIR("file", fPtr->data.eval.path);
/*
* Death of reference by TclGetSrcInfoForPc.
|
| ︙ | ︙ | |||
1362 1363 1364 1365 1366 1367 1368 |
case TCL_LOCATION_SOURCE:
/*
* Evaluation of a script file.
*/
ADD_PAIR("type", Tcl_NewStringObj(typeString[framePtr->type], -1));
| | | 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 |
case TCL_LOCATION_SOURCE:
/*
* Evaluation of a script file.
*/
ADD_PAIR("type", Tcl_NewStringObj(typeString[framePtr->type], -1));
ADD_PAIR("line", Tcl_NewWideIntObj(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.
*/
|
| ︙ | ︙ | |||
1399 1400 1401 1402 1403 1404 1405 |
TclNewObj(procNameObj);
Tcl_GetCommandFullName(interp, (Tcl_Command) procPtr->cmdPtr,
procNameObj);
ADD_PAIR("proc", procNameObj);
} else if (procPtr->cmdPtr->clientData) {
ExtraFrameInfo *efiPtr = procPtr->cmdPtr->clientData;
| | | 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 |
TclNewObj(procNameObj);
Tcl_GetCommandFullName(interp, (Tcl_Command) procPtr->cmdPtr,
procNameObj);
ADD_PAIR("proc", procNameObj);
} else if (procPtr->cmdPtr->clientData) {
ExtraFrameInfo *efiPtr = procPtr->cmdPtr->clientData;
size_t i;
/*
* This is a non-standard command. Luckily, it's told us how to
* render extra information about its frame.
*/
for (i=0 ; i<efiPtr->length ; i++) {
|
| ︙ | ︙ | |||
1433 1434 1435 1436 1437 1438 1439 |
CallFrame *idx;
for (idx=top ; idx!=NULL ; idx=idx->callerVarPtr) {
if (idx == current) {
int c = framePtr->framePtr->level;
int t = iPtr->varFramePtr->level;
| | | 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 |
CallFrame *idx;
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));
break;
}
}
}
tmpObj = Tcl_NewListObj(lc, lv);
if (needsFree >= 0) {
|
| ︙ | ︙ | |||
1588 1589 1590 1591 1592 1593 1594 |
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" */
| | | 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 |
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));
return TCL_OK;
}
if (objc == 2) {
int level;
CallFrame *framePtr, *rootFramePtr = iPtr->rootFramePtr;
|
| ︙ | ︙ | |||
2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 |
}
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* Tcl_JoinObjCmd --
*
* This procedure is invoked to process the "join" Tcl command. See the
* user documentation for details on what it does.
*
* Results:
* A standard Tcl object result.
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 |
}
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* 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(
ClientData dummy, /* Not used. */
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 slave 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.
*
* Results:
* A standard Tcl object result.
|
| ︙ | ︙ | |||
2149 2150 2151 2152 2153 2154 2155 |
int
Tcl_JoinObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
| > | | 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 |
int
Tcl_JoinObjCmd(
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;
if ((objc < 2) || (objc > 3)) {
Tcl_WrongNumArgs(interp, 1, objv, "list ?joinString?");
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
2180 2181 2182 2183 2184 2185 2186 |
Tcl_SetObjResult(interp, elemPtrs[0]);
return TCL_OK;
}
joinObjPtr = (objc == 2) ? Tcl_NewStringObj(" ", 1) : objv[2];
Tcl_IncrRefCount(joinObjPtr);
| | | 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 |
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++) {
|
| ︙ | ︙ | |||
2368 2369 2370 2371 2372 2373 2374 |
Tcl_LinsertObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
register int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *listPtr;
| > | | 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 |
Tcl_LinsertObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
register int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *listPtr;
size_t index;
int len, result;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv, "list index ?element ...?");
return TCL_ERROR;
}
result = TclListObjLength(interp, objv[1], &len);
|
| ︙ | ︙ | |||
2390 2391 2392 2393 2394 2395 2396 |
* appended to the list.
*/
result = TclGetIntForIndexM(interp, objv[2], /*end*/ len, &index);
if (result != TCL_OK) {
return result;
}
| | | | 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 |
* appended to the list.
*/
result = TclGetIntForIndexM(interp, objv[2], /*end*/ len, &index);
if (result != TCL_OK) {
return result;
}
if (index + 1 > (size_t)len + 1) {
index = len;
}
/*
* If the list object is unshared we can modify it directly. Otherwise we
* create a copy to modify: this is "copy on write".
*/
listPtr = objv[1];
if (Tcl_IsShared(listPtr)) {
listPtr = TclListObjCopy(NULL, listPtr);
}
if ((objc == 4) && (index == (size_t)len)) {
/*
* Special case: insert one element at the end of the list.
*/
Tcl_ListObjAppendElement(NULL, listPtr, objv[3]);
} else {
if (TCL_OK != Tcl_ListObjReplace(interp, listPtr, index, 0,
|
| ︙ | ︙ | |||
2503 2504 2505 2506 2507 2508 2509 |
}
/*
* Set the interpreter's object result to an integer object holding the
* length.
*/
| | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 |
}
/*
* 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(
ClientData notUsed, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
register 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) {
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;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_LrangeObjCmd --
|
| ︙ | ︙ | |||
2532 2533 2534 2535 2536 2537 2538 |
Tcl_LrangeObjCmd(
ClientData notUsed, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
register Tcl_Obj *const objv[])
/* Argument objects. */
{
| < | > < < | < | > > > | > > > > > > > > > > > > > > > > | > > > > | > > | | > > | > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > | > | > > > > | < > > > > > > | < | > > | > > | < > > > > | > | < < > > > | < > > > > > > > > > > | | < > > > | | > > > > > | 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 |
Tcl_LrangeObjCmd(
ClientData notUsed, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
register Tcl_Obj *const objv[])
/* Argument objects. */
{
int listLen, result;
size_t first, last;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 1, objv, "list first last");
return TCL_ERROR;
}
result = TclListObjLength(interp, objv[1], &listLen);
if (result != TCL_OK) {
return result;
}
result = TclGetIntForIndexM(interp, objv[2], /*endValue*/ listLen - 1,
&first);
if (result != TCL_OK) {
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(
ClientData notUsed, /* Not used. */
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 = 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;
}
/*
*----------------------------------------------------------------------
*
* Tcl_LrepeatObjCmd --
|
| ︙ | ︙ | |||
2736 2737 2738 2739 2740 2741 2742 |
Tcl_LreplaceObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
register Tcl_Obj *listPtr;
| > | | 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 |
Tcl_LreplaceObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
register Tcl_Obj *listPtr;
size_t first, last;
int listLen, numToDelete, result;
if (objc < 4) {
Tcl_WrongNumArgs(interp, 1, objv,
"list first last ?element ...?");
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
2765 2766 2767 2768 2769 2770 2771 |
}
result = TclGetIntForIndexM(interp, objv[3], /*end*/ listLen-1, &last);
if (result != TCL_OK) {
return result;
}
| | < | < < < | < < | < < < < < < | | | | 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 |
}
result = TclGetIntForIndexM(interp, objv[3], /*end*/ listLen-1, &last);
if (result != TCL_OK) {
return result;
}
if (first == TCL_INDEX_NONE) {
first = 0;
} else if (first > (size_t)listLen) {
first = listLen;
}
if (last + 1 > (size_t)listLen) {
last = listLen - 1;
}
if (first + 1 <= last + 1) {
numToDelete = last - first + 1;
} else {
numToDelete = 0;
}
/*
* If the list object is unshared we can modify it directly, otherwise we
|
| ︙ | ︙ | |||
2927 2928 2929 2930 2931 2932 2933 |
Tcl_LsearchObjCmd(
ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument values. */
{
const char *bytes, *patternBytes;
| | > | | | 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 |
Tcl_LsearchObjCmd(
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;
int allMatches, inlineReturn, negatedMatch, returnSubindices, noCase;
double patDouble, objDouble;
SortInfo sortInfo;
Tcl_Obj *patObj, **listv, *listPtr, *startPtr, *itemPtr;
SortStrCmpFn_t strCmpFn = TclUtfCmp;
Tcl_RegExp regexp = NULL;
static const char *const options[] = {
|
| ︙ | ︙ | |||
3086 3087 3088 3089 3090 3091 3092 | 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; } | | | > | 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 |
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", "LSORT",
"BADSTRIDE", NULL);
result = TCL_ERROR;
goto done;
}
groupSize = wide;
i++;
break;
case LSEARCH_INDEX: { /* -index */
Tcl_Obj **indices;
int j;
if (allocatedIndexVector) {
|
| ︙ | ︙ | |||
3151 3152 3153 3154 3155 3156 3157 |
* Fill the array by parsing each index. We don't know whether
* their scale is sensible yet, but we at least perform the
* syntactic check here.
*/
for (j=0 ; j<sortInfo.indexc ; j++) {
int encoded = 0;
| | | < | | | 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 |
* Fill the array by parsing each index. We don't know whether
* their scale is sensible yet, but we at least perform the
* syntactic check here.
*/
for (j=0 ; j<sortInfo.indexc ; j++) {
int encoded = 0;
if (TclIndexEncode(interp, indices[j], TCL_INDEX_NONE,
TCL_INDEX_NONE, &encoded) != TCL_OK) {
result = TCL_ERROR;
}
if (encoded == (int)TCL_INDEX_NONE) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"index \"%s\" cannot select an element "
"from any list", TclGetString(indices[j])));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX"
"OUTOFRANGE", NULL);
result = TCL_ERROR;
}
if (result == TCL_ERROR) {
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (-index option item number %d)", j));
|
| ︙ | ︙ | |||
3258 3259 3260 3261 3262 3263 3264 |
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);
| | | 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 |
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;
|
| ︙ | ︙ | |||
3289 3290 3291 3292 3293 3294 3295 |
*/
if (startPtr) {
result = TclGetIntForIndexM(interp, startPtr, listc-1, &start);
if (result != TCL_OK) {
goto done;
}
| | | | | | 3514 3515 3516 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 |
*/
if (startPtr) {
result = TclGetIntForIndexM(interp, startPtr, listc-1, &start);
if (result != TCL_OK) {
goto done;
}
if (start == TCL_INDEX_NONE) {
start = TCL_INDEX_START;
}
/*
* 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 (allMatches || inlineReturn) {
Tcl_ResetResult(interp);
} else {
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(-1));
}
goto done;
}
/*
* If start points within a group, it points to the start of the group.
*/
|
| ︙ | ︙ | |||
3371 3372 3373 3374 3375 3376 3377 | /* * 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. */ | | | 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 |
/*
* 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;
upper = listc;
while (lower + groupSize != upper && sortInfo.resultCode == TCL_OK) {
i = (lower + upper)/2;
|
| ︙ | ︙ | |||
3506 3507 3508 3509 3510 3511 3512 |
* This split allows for more optimal compilation of
* memcmp/strcasecmp.
*/
if (noCase) {
match = (TclUtfCasecmp(bytes, patternBytes) == 0);
} else {
| | < | 3731 3732 3733 3734 3735 3736 3737 3738 3739 3740 3741 3742 3743 3744 3745 |
* This split allows for more optimal compilation of
* memcmp/strcasecmp.
*/
if (noCase) {
match = (TclUtfCasecmp(bytes, patternBytes) == 0);
} else {
match = (memcmp(bytes, patternBytes, length) == 0);
}
}
break;
case DICTIONARY:
bytes = TclGetString(itemPtr);
match = (DictionaryCompare(bytes, patternBytes) == 0);
|
| ︙ | ︙ | |||
3591 3592 3593 3594 3595 3596 3597 |
} else {
itemPtr = listv[i];
Tcl_ListObjAppendElement(interp, listPtr, itemPtr);
}
} else if (returnSubindices) {
int j;
| | | | | | | | 3815 3816 3817 3818 3819 3820 3821 3822 3823 3824 3825 3826 3827 3828 3829 3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 3846 3847 3848 3849 3850 3851 3852 3853 3854 3855 3856 3857 3858 |
} else {
itemPtr = listv[i];
Tcl_ListObjAppendElement(interp, listPtr, itemPtr);
}
} else if (returnSubindices) {
int j;
itemPtr = TclNewWideIntObjFromSize(i+groupOffset);
for (j=0 ; j<sortInfo.indexc ; j++) {
Tcl_ListObjAppendElement(interp, itemPtr, TclNewWideIntObjFromSize(
TclIndexDecode(sortInfo.indexv[j], listc)));
}
Tcl_ListObjAppendElement(interp, listPtr, itemPtr);
} else {
Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewWideIntObj(i));
}
}
}
/*
* Return everything or a single value.
*/
if (allMatches) {
Tcl_SetObjResult(interp, listPtr);
} else if (!inlineReturn) {
if (returnSubindices) {
int j;
itemPtr = TclNewWideIntObjFromSize(index+groupOffset);
for (j=0 ; j<sortInfo.indexc ; j++) {
Tcl_ListObjAppendElement(interp, itemPtr, TclNewWideIntObjFromSize(
TclIndexDecode(sortInfo.indexv[j], listc)));
}
Tcl_SetObjResult(interp, itemPtr);
} else {
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(index));
}
} else if (index < 0) {
/*
* Is this superfluous? The result should be a blank object by
* default...
*/
|
| ︙ | ︙ | |||
3764 3765 3766 3767 3768 3769 3770 |
int
Tcl_LsortObjCmd(
ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument values. */
{
| | | > > | 3988 3989 3990 3991 3992 3993 3994 3995 3996 3997 3998 3999 4000 4001 4002 4003 4004 4005 4006 |
int
Tcl_LsortObjCmd(
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 sortMode = SORTMODE_ASCII;
int group, allocatedIndexVector = 0;
size_t j, idx, groupSize, groupOffset;
Tcl_WideInt wide;
Tcl_Obj *resultPtr, *cmdPtr, **listObjPtrs, *listObj, *indexPtr;
SortElement *elementArray = NULL, *elementPtr;
SortInfo sortInfo; /* Information about this sort that needs to
* be passed to the comparison function. */
# define NUM_LISTS 30
SortElement *subList[NUM_LISTS+1];
/* This array holds pointers to temporary
|
| ︙ | ︙ | |||
3868 3869 3870 3871 3872 3873 3874 | * 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. */ | | | | < | | | 4094 4095 4096 4097 4098 4099 4100 4101 4102 4103 4104 4105 4106 4107 4108 4109 4110 4111 4112 4113 4114 4115 4116 4117 4118 4119 4120 4121 4122 4123 |
* Check each of the indices for syntactic correctness. Note that
* we do not store the converted values here because we do not
* know if this is the only -index option yet and so we can't
* allocate any space; that happens after the scan through all the
* options is done.
*/
for (j=0 ; j<(size_t)indexc ; 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\" cannot select an element "
"from any list", 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];
i++;
break;
|
| ︙ | ︙ | |||
3917 3918 3919 3920 3921 3922 3923 | 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; } | | | > | 4142 4143 4144 4145 4146 4147 4148 4149 4150 4151 4152 4153 4154 4155 4156 4157 4158 4159 4160 4161 4162 4163 4164 4165 4166 4167 4168 |
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;
|
| ︙ | ︙ | |||
3961 3962 3963 3964 3965 3966 3967 | break; default: sortInfo.indexv = TclStackAlloc(interp, sizeof(int) * sortInfo.indexc); allocatedIndexVector = 1; /* Cannot use indexc field, as it * might be decreased by 1 later. */ } | | | > | 4187 4188 4189 4190 4191 4192 4193 4194 4195 4196 4197 4198 4199 4200 4201 4202 4203 4204 |
break;
default:
sortInfo.indexv =
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) {
Tcl_Obj *newCommandPtr, *newObjPtr;
|
| ︙ | ︙ | |||
4035 4036 4037 4038 4039 4040 4041 |
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);
| | | | 4262 4263 4264 4265 4266 4267 4268 4269 4270 4271 4272 4273 4274 4275 4276 4277 4278 4279 4280 4281 4282 4283 4284 4285 4286 4287 4288 4289 4290 4291 4292 4293 4294 |
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];
}
|
| ︙ | ︙ | |||
4093 4094 4095 4096 4097 4098 4099 |
}
/*
* The following loop creates a SortElement for each list element and
* begins sorting it into the sublists as it appears.
*/
| | | | 4320 4321 4322 4323 4324 4325 4326 4327 4328 4329 4330 4331 4332 4333 4334 4335 4336 |
}
/*
* The following loop creates a SortElement for each list element and
* begins sorting it into the sublists as it appears.
*/
elementArray = Tcl_Alloc(length * sizeof(SortElement));
for (i=0; i < length; i++) {
idx = groupSize * i + groupOffset;
if (indexc) {
/*
* If this is an indexed sort, retrieve the corresponding element
*/
indexPtr = SelectObjFromSublist(listObjPtrs[idx], &sortInfo);
if (sortInfo.resultCode != TCL_OK) {
|
| ︙ | ︙ | |||
4189 4190 4191 4192 4193 4194 4195 |
listRepPtr = ListRepPtr(resultPtr);
newArray = &listRepPtr->elements;
if (group) {
for (i=0; elementPtr!=NULL ; elementPtr=elementPtr->nextPtr) {
idx = elementPtr->payload.index;
for (j = 0; j < groupSize; j++) {
if (indices) {
| | | | 4416 4417 4418 4419 4420 4421 4422 4423 4424 4425 4426 4427 4428 4429 4430 4431 4432 4433 4434 4435 4436 4437 4438 4439 4440 4441 4442 |
listRepPtr = ListRepPtr(resultPtr);
newArray = &listRepPtr->elements;
if (group) {
for (i=0; elementPtr!=NULL ; elementPtr=elementPtr->nextPtr) {
idx = elementPtr->payload.index;
for (j = 0; j < groupSize; j++) {
if (indices) {
objPtr = TclNewWideIntObjFromSize(idx + j - groupOffset);
newArray[i++] = objPtr;
Tcl_IncrRefCount(objPtr);
} else {
objPtr = listObjPtrs[idx + j - groupOffset];
newArray[i++] = objPtr;
Tcl_IncrRefCount(objPtr);
}
}
}
} else if (indices) {
for (i=0; elementPtr != NULL ; elementPtr = elementPtr->nextPtr) {
objPtr = TclNewWideIntObjFromSize(elementPtr->payload.index);
newArray[i++] = objPtr;
Tcl_IncrRefCount(objPtr);
}
} else {
for (i=0; elementPtr != NULL ; elementPtr = elementPtr->nextPtr) {
objPtr = elementPtr->payload.objPtr;
newArray[i++] = objPtr;
|
| ︙ | ︙ | |||
4226 4227 4228 4229 4230 4231 4232 |
TclDecrRefCount(listObj);
sortInfo.compareCmdPtr = NULL;
}
if (allocatedIndexVector) {
TclStackFree(interp, sortInfo.indexv);
}
if (elementArray) {
| | | 4453 4454 4455 4456 4457 4458 4459 4460 4461 4462 4463 4464 4465 4466 4467 |
TclDecrRefCount(listObj);
sortInfo.compareCmdPtr = NULL;
}
if (allocatedIndexVector) {
TclStackFree(interp, sortInfo.indexv);
}
if (elementArray) {
Tcl_Free(elementArray);
}
return sortInfo.resultCode;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
4633 4634 4635 4636 4637 4638 4639 |
if (Tcl_ListObjIndex(infoPtr->interp, objPtr, index,
¤tObj) != TCL_OK) {
infoPtr->resultCode = TCL_ERROR;
return NULL;
}
if (currentObj == NULL) {
| > > | > > > > | | > | 4860 4861 4862 4863 4864 4865 4866 4867 4868 4869 4870 4871 4872 4873 4874 4875 4876 4877 4878 4879 4880 4881 4882 4883 |
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);
infoPtr->resultCode = TCL_ERROR;
return NULL;
}
objPtr = currentObj;
}
|
| ︙ | ︙ |
Changes to generic/tclCmdMZ.c.
| ︙ | ︙ | |||
13 14 15 16 17 18 19 20 21 22 23 24 25 26 | * Copyright (c) 2003-2009 Donal K. Fellows. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #include "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; | > | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 | * Copyright (c) 2003-2009 Donal K. Fellows. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #include "tclCompile.h" #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; |
| ︙ | ︙ | |||
122 123 124 125 126 127 128 |
int
Tcl_RegexpObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
| < | > | | 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 |
int
Tcl_RegexpObjCmd(
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;
Tcl_RegExp regExpr;
Tcl_Obj *objPtr, *startIndex = NULL, *resultPtr = NULL;
Tcl_RegExpInfo info;
static const char *const options[] = {
"-all", "-about", "-indices", "-inline",
"-expanded", "-line", "-linestop", "-lineanchor",
"-nocase", "-start", "--", NULL
};
enum options {
REGEXP_ALL, REGEXP_ABOUT, REGEXP_INDICES, REGEXP_INLINE,
REGEXP_EXPANDED,REGEXP_LINE, REGEXP_LINESTOP,REGEXP_LINEANCHOR,
REGEXP_NOCASE, REGEXP_START, REGEXP_LAST
};
indices = 0;
about = 0;
cflags = TCL_REG_ADVANCED;
offset = TCL_INDEX_START;
all = 0;
doinline = 0;
for (i = 1; i < objc; i++) {
const char *name;
int index;
|
| ︙ | ︙ | |||
186 187 188 189 190 191 192 |
case REGEXP_LINESTOP:
cflags |= TCL_REG_NLSTOP;
break;
case REGEXP_LINEANCHOR:
cflags |= TCL_REG_NLANCH;
break;
case REGEXP_START: {
| | | | 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 |
case REGEXP_LINESTOP:
cflags |= TCL_REG_NLSTOP;
break;
case REGEXP_LINEANCHOR:
cflags |= TCL_REG_NLANCH;
break;
case REGEXP_START: {
size_t temp;
if (++i >= objc) {
goto endOfForLoop;
}
if (TclGetIntForIndexM(interp, objv[i], TCL_INDEX_START, &temp) != TCL_OK) {
goto optionError;
}
if (startIndex) {
Tcl_DecrRefCount(startIndex);
}
startIndex = objv[i];
Tcl_IncrRefCount(startIndex);
|
| ︙ | ︙ | |||
254 255 256 257 258 259 260 |
* regexp to avoid shimmering problems.
*/
objPtr = objv[1];
stringLength = Tcl_GetCharLength(objPtr);
if (startIndex) {
| | | | | 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 |
* regexp to avoid shimmering problems.
*/
objPtr = objv[1];
stringLength = Tcl_GetCharLength(objPtr);
if (startIndex) {
TclGetIntForIndexM(interp, startIndex, stringLength, &offset);
Tcl_DecrRefCount(startIndex);
if (offset == TCL_INDEX_NONE) {
offset = TCL_INDEX_START;
}
}
regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags);
if (regExpr == NULL) {
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
301 302 303 304 305 306 307 |
* Pass either 0 or TCL_REG_NOTBOL in the eflags. Passing
* TCL_REG_NOTBOL indicates that the character at offset should not be
* considered the start of the line. If for example the pattern {^} is
* passed and -start is positive, then the pattern will not match the
* start of the string unless the previous character is a newline.
*/
| | | | 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 |
* Pass either 0 or TCL_REG_NOTBOL in the eflags. Passing
* TCL_REG_NOTBOL indicates that the character at offset should not be
* considered the start of the line. If for example the pattern {^} is
* passed and -start is positive, then the pattern will not match the
* start of the string unless the previous character is a newline.
*/
if (offset == TCL_INDEX_START) {
eflags = 0;
} else if (offset + 1 > stringLength + 1) {
eflags = TCL_REG_NOTBOL;
} else if (Tcl_GetUniChar(objPtr, offset-1) == '\n') {
eflags = 0;
} else {
eflags = TCL_REG_NOTBOL;
}
|
| ︙ | ︙ | |||
331 332 333 334 335 336 337 |
/*
* If inlining, the interpreter's object result remains an
* empty list, otherwise set it to an integer object w/ value
* 0.
*/
if (!doinline) {
| | | 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 |
/*
* If inlining, the interpreter's object result remains an
* empty list, otherwise set it to an integer object w/ value
* 0.
*/
if (!doinline) {
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(0));
}
return TCL_OK;
}
break;
}
/*
|
| ︙ | ︙ | |||
359 360 361 362 363 364 365 |
resultPtr = Tcl_NewObj();
}
}
for (i = 0; i < objc; i++) {
Tcl_Obj *newPtr;
if (indices) {
| | | | | | | | | | 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 |
resultPtr = Tcl_NewObj();
}
}
for (i = 0; i < objc; i++) {
Tcl_Obj *newPtr;
if (indices) {
size_t 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) {
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) {
end--;
}
} else {
start = TCL_INDEX_NONE;
end = TCL_INDEX_NONE;
}
objs[0] = TclNewWideIntObjFromSize(start);
objs[1] = TclNewWideIntObjFromSize(end);
newPtr = Tcl_NewListObj(2, objs);
} else {
if (i <= (int)info.nsubs) {
newPtr = Tcl_GetRange(objPtr,
offset + info.matches[i].start,
offset + info.matches[i].end - 1);
} else {
newPtr = Tcl_NewObj();
}
}
|
| ︙ | ︙ | |||
439 440 441 442 443 444 445 |
* these cases we always want to bump the index up one.
*/
if (matchLength == 0) {
offset++;
}
all++;
| | | | 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 |
* these cases we always want to bump the index up one.
*/
if (matchLength == 0) {
offset++;
}
all++;
if (offset + 1 >= stringLength + 1) {
break;
}
}
/*
* Set the interpreter's object result to an integer object with value 1
* if -all wasn't specified, otherwise it's all-1 (the number of times
* through the while - 1).
*/
if (doinline) {
Tcl_SetObjResult(interp, resultPtr);
} else {
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(all ? all-1 : 1));
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
482 483 484 485 486 487 488 |
int
Tcl_RegsubObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
| | > | | | | | 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 |
int
Tcl_RegsubObjCmd(
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;
Tcl_RegExp regExpr;
Tcl_RegExpInfo info;
Tcl_Obj *resultPtr, *subPtr, *objPtr, *startIndex = NULL;
Tcl_UniChar ch, *wsrc, *wfirstChar, *wstring, *wsubspec = 0, *wend;
static const char *const options[] = {
"-all", "-command", "-expanded", "-line",
"-linestop", "-lineanchor", "-nocase", "-start",
"--", NULL
};
enum options {
REGSUB_ALL, REGSUB_COMMAND, REGSUB_EXPANDED, REGSUB_LINE,
REGSUB_LINESTOP, REGSUB_LINEANCHOR, REGSUB_NOCASE, REGSUB_START,
REGSUB_LAST
};
cflags = TCL_REG_ADVANCED;
all = 0;
offset = TCL_INDEX_START;
command = 0;
resultPtr = NULL;
for (idx = 1; idx < (size_t)objc; idx++) {
const char *name;
int index;
name = TclGetString(objv[idx]);
if (name[0] != '-') {
break;
}
|
| ︙ | ︙ | |||
541 542 543 544 545 546 547 |
case REGSUB_LINESTOP:
cflags |= TCL_REG_NLSTOP;
break;
case REGSUB_LINEANCHOR:
cflags |= TCL_REG_NLANCH;
break;
case REGSUB_START: {
| | | | | | | | | | | > | | | | | | 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 |
case REGSUB_LINESTOP:
cflags |= TCL_REG_NLSTOP;
break;
case REGSUB_LINEANCHOR:
cflags |= TCL_REG_NLANCH;
break;
case REGSUB_START: {
size_t temp;
if (++idx >= (size_t)objc) {
goto endOfForLoop;
}
if (TclGetIntForIndexM(interp, objv[idx], TCL_INDEX_START, &temp) != TCL_OK) {
goto optionError;
}
if (startIndex) {
Tcl_DecrRefCount(startIndex);
}
startIndex = objv[idx];
Tcl_IncrRefCount(startIndex);
break;
}
case REGSUB_LAST:
idx++;
goto endOfForLoop;
}
}
endOfForLoop:
if ((size_t)objc < idx + 3 || (size_t)objc > idx + 4) {
Tcl_WrongNumArgs(interp, 1, objv,
"?-option ...? exp string subSpec ?varName?");
optionError:
if (startIndex) {
Tcl_DecrRefCount(startIndex);
}
return TCL_ERROR;
}
objc -= idx;
objv += idx;
if (startIndex) {
size_t stringLength = Tcl_GetCharLength(objv[1]);
TclGetIntForIndexM(interp, startIndex, stringLength, &offset);
Tcl_DecrRefCount(startIndex);
if (offset == TCL_INDEX_NONE) {
offset = TCL_INDEX_START;
}
}
if (all && (offset == TCL_INDEX_START) && (command == 0)
&& (strpbrk(TclGetString(objv[2]), "&\\") == NULL)
&& (strpbrk(TclGetString(objv[0]), "*+?{}()[].\\|^$") == NULL)) {
/*
* This is a simple one pair string map situation. We make use of a
* slightly modified version of the one pair STR_MAP code.
*/
size_t slen;
int nocase, wsrclc;
int (*strCmpFn)(const Tcl_UniChar*,const Tcl_UniChar*,size_t);
Tcl_UniChar *p;
numMatches = 0;
nocase = (cflags & TCL_REG_NOCASE);
strCmpFn = nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp;
wsrc = TclGetUnicodeFromObj(objv[0], &slen);
wstring = TclGetUnicodeFromObj(objv[1], &wlen);
wsubspec = TclGetUnicodeFromObj(objv[2], &wsublen);
wend = wstring + wlen - (slen ? slen - 1 : 0);
result = TCL_OK;
if (slen == 0) {
/*
* regsub behavior for "" matches between each character. 'string
* map' skips the "" case.
|
| ︙ | ︙ | |||
628 629 630 631 632 633 634 |
wlen = 0;
}
} else {
wsrclc = Tcl_UniCharToLower(*wsrc);
for (p = wfirstChar = wstring; wstring < wend; wstring++) {
if ((*wstring == *wsrc ||
(nocase && Tcl_UniCharToLower(*wstring)==wsrclc)) &&
| | < | 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 |
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))) {
if (numMatches == 0) {
resultPtr = Tcl_NewUnicodeObj(wstring, 0);
Tcl_IncrRefCount(resultPtr);
}
if (p != wstring) {
Tcl_AppendUnicodeToObj(resultPtr, p, wstring - p);
p = wstring + slen;
|
| ︙ | ︙ | |||
694 695 696 697 698 699 700 |
*/
if (objv[1] == objv[0]) {
objPtr = Tcl_DuplicateObj(objv[1]);
} else {
objPtr = objv[1];
}
| | | | 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 |
*/
if (objv[1] == objv[0]) {
objPtr = Tcl_DuplicateObj(objv[1]);
} else {
objPtr = objv[1];
}
wstring = TclGetUnicodeFromObj(objPtr, &wlen);
if (objv[2] == objv[0]) {
subPtr = Tcl_DuplicateObj(objv[2]);
} else {
subPtr = objv[2];
}
if (!command) {
wsubspec = TclGetUnicodeFromObj(subPtr, &wsublen);
}
result = TCL_OK;
/*
* The following loop is to handle multiple matches within the same source
* string; each iteration handles one match and its corresponding
|
| ︙ | ︙ | |||
739 740 741 742 743 744 745 |
}
if (match == 0) {
break;
}
if (numMatches == 0) {
resultPtr = Tcl_NewUnicodeObj(wstring, 0);
Tcl_IncrRefCount(resultPtr);
| | | 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 |
}
if (match == 0) {
break;
}
if (numMatches == 0) {
resultPtr = Tcl_NewUnicodeObj(wstring, 0);
Tcl_IncrRefCount(resultPtr);
if (offset > TCL_INDEX_START) {
/*
* Copy the initial portion of the string in if an offset was
* specified.
*/
Tcl_AppendUnicodeToObj(resultPtr, wstring, offset);
}
|
| ︙ | ︙ | |||
773 774 775 776 777 778 779 |
if (command) {
Tcl_Obj **args = NULL, **parts;
int numArgs;
Tcl_ListObjGetElements(interp, subPtr, &numParts, &parts);
numArgs = numParts + info.nsubs + 1;
| | | 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 |
if (command) {
Tcl_Obj **args = NULL, **parts;
int numArgs;
Tcl_ListObjGetElements(interp, subPtr, &numParts, &parts);
numArgs = numParts + info.nsubs + 1;
args = 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 >= 0) && (subEnd >= 0)) {
args[idx + numParts] = Tcl_NewUnicodeObj(
|
| ︙ | ︙ | |||
803 804 805 806 807 808 809 |
* 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]);
}
| | | | 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 |
* 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
|
| ︙ | ︙ | |||
955 956 957 958 959 960 961 |
result = TCL_ERROR;
} else {
/*
* Set the interpreter's object result to an integer object
* holding the number of matches.
*/
| | | 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 |
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));
}
} else {
/*
* No varname supplied, so just return the modified string.
*/
Tcl_SetObjResult(interp, resultPtr);
|
| ︙ | ︙ | |||
1174 1175 1176 1177 1178 1179 1180 |
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_UniChar ch = 0;
int len;
const char *splitChars;
const char *stringPtr;
const char *end;
| | | 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 |
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_UniChar ch = 0;
int len;
const char *splitChars;
const char *stringPtr;
const char *end;
size_t splitCharLen, stringLen;
Tcl_Obj *listPtr, *objPtr;
if (objc == 2) {
splitChars = " \n\t\r";
splitCharLen = 4;
} else if (objc == 3) {
splitChars = TclGetStringFromObj(objv[2], &splitCharLen);
|
| ︙ | ︙ | |||
1212 1213 1214 1215 1216 1217 1218 |
* is a *major* win when splitting on a long string (especially in the
* megabyte range!) - DKF
*/
Tcl_InitHashTable(&charReuseTable, TCL_ONE_WORD_KEYS);
for ( ; stringPtr < end; stringPtr += len) {
| | | | | | 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 |
* is a *major* win when splitting on a long string (especially in the
* megabyte range!) - DKF
*/
Tcl_InitHashTable(&charReuseTable, TCL_ONE_WORD_KEYS);
for ( ; stringPtr < end; stringPtr += len) {
int fullchar;
len = TclUtfToUniChar(stringPtr, &ch);
fullchar = ch;
#if TCL_UTF_MAX <= 4
if ((ch >= 0xD800) && (len < 3)) {
len += TclUtfToUniChar(stringPtr + len, &ch);
fullchar = (((fullchar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000;
}
#endif
/*
* Assume Tcl_UniChar is an integral type...
*/
|
| ︙ | ︙ | |||
1253 1254 1255 1256 1257 1258 1259 | /* * 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. */ | | | | 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 |
/*
* 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) {
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;
Tcl_UniChar splitChar = 0;
/*
* Normal case: split on any of a given set of characters. Discard
* instances of the split characters.
*/
|
| ︙ | ︙ | |||
1317 1318 1319 1320 1321 1322 1323 |
static int
StringFirstCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
| | | | | | 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 |
static int
StringFirstCmd(
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;
if (objc < 3 || objc > 4) {
Tcl_WrongNumArgs(interp, 1, objv,
"needleString haystackString ?startIndex?");
return TCL_ERROR;
}
if (objc == 4) {
size_t end = Tcl_GetCharLength(objv[2]) - 1;
if (TCL_OK != TclGetIntForIndexM(interp, objv[3], end, &start)) {
return TCL_ERROR;
}
}
Tcl_SetObjResult(interp, TclNewWideIntObjFromSize(TclStringFirst(objv[1],
objv[2], start)));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1362 1363 1364 1365 1366 1367 1368 |
static int
StringLastCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
| | | | | | 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 |
static int
StringLastCmd(
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;
if (objc < 3 || objc > 4) {
Tcl_WrongNumArgs(interp, 1, objv,
"needleString haystackString ?lastIndex?");
return TCL_ERROR;
}
if (objc == 4) {
size_t end = Tcl_GetCharLength(objv[2]) - 1;
if (TCL_OK != TclGetIntForIndexM(interp, objv[3], end, &last)) {
return TCL_ERROR;
}
}
Tcl_SetObjResult(interp, TclNewWideIntObjFromSize(TclStringLast(objv[1],
objv[2], last)));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1407 1408 1409 1410 1411 1412 1413 |
static int
StringIndexCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
| | | | | | | > > > > | | > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 |
static int
StringIndexCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
size_t index, end;
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 = (unsigned char) 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(
ClientData dummy, /* Not used */
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;
}
/*
*----------------------------------------------------------------------
*
* StringIsCmd --
*
* This procedure is invoked to process the "string is" Tcl command. See
|
| ︙ | ︙ | |||
1473 1474 1475 1476 1477 1478 1479 |
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *string1, *end, *stop;
Tcl_UniChar ch = 0;
int (*chcomp)(int) = NULL; /* The UniChar comparison function. */
| | > > | | | | | | | | | | | 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 |
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *string1, *end, *stop;
Tcl_UniChar ch = 0;
int (*chcomp)(int) = NULL; /* The UniChar comparison function. */
int i, result = 1, strict = 0, index, length3;
size_t failat = 0;
size_t length1, length2;
Tcl_Obj *objPtr, *failVarObj = NULL;
Tcl_WideInt w;
static const char *const isClasses[] = {
"alnum", "alpha", "ascii", "control",
"boolean", "dict", "digit", "double",
"entier", "false", "graph", "integer",
"list", "lower", "print", "punct",
"space", "true", "upper", "wideinteger",
"wordchar", "xdigit", NULL
};
enum isClasses {
STR_IS_ALNUM, STR_IS_ALPHA, STR_IS_ASCII, STR_IS_CONTROL,
STR_IS_BOOL, STR_IS_DICT, STR_IS_DIGIT, STR_IS_DOUBLE,
STR_IS_ENTIER, STR_IS_FALSE, STR_IS_GRAPH, STR_IS_INT,
STR_IS_LIST, STR_IS_LOWER, STR_IS_PRINT, STR_IS_PUNCT,
STR_IS_SPACE, STR_IS_TRUE, STR_IS_UPPER, STR_IS_WIDE,
STR_IS_WORD, STR_IS_XDIGIT
};
static const char *const isOptions[] = {
"-strict", "-failindex", NULL
};
enum isOptions {
OPT_STRICT, OPT_FAILIDX
};
|
| ︙ | ︙ | |||
1560 1561 1562 1563 1564 1565 1566 |
break;
case STR_IS_ASCII:
chcomp = UniCharIsAscii;
break;
case STR_IS_BOOL:
case STR_IS_TRUE:
case STR_IS_FALSE:
| | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > < | | | | 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 |
break;
case STR_IS_ASCII:
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 (strict) {
result = 0;
} else {
string1 = TclGetStringFromObj(objPtr, &length1);
result = length1 == 0;
}
} else if ((objPtr->internalRep.wideValue != 0)
? (index == STR_IS_FALSE) : (index == STR_IS_TRUE)) {
result = 0;
}
break;
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;
register 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)) {
break;
}
string1 = TclGetStringFromObj(objPtr, &length1);
if (length1 == 0) {
if (strict) {
result = 0;
}
|
| ︙ | ︙ | |||
1611 1612 1613 1614 1615 1616 1617 |
}
break;
}
case STR_IS_GRAPH:
chcomp = Tcl_UniCharIsGraph;
break;
case STR_IS_INT:
| < < < < | | | 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 |
}
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;
}
|
| ︙ | ︙ | |||
1662 1663 1664 1665 1666 1667 1668 |
}
break;
case STR_IS_WIDE:
if (TCL_OK == TclGetWideIntFromObj(NULL, objPtr, &w)) {
break;
}
| < | 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 |
}
break;
case STR_IS_WIDE:
if (TCL_OK == TclGetWideIntFromObj(NULL, objPtr, &w)) {
break;
}
string1 = TclGetStringFromObj(objPtr, &length1);
if (length1 == 0) {
if (strict) {
result = 0;
}
goto str_is_done;
}
|
| ︙ | ︙ | |||
1716 1717 1718 1719 1720 1721 1722 |
break;
case STR_IS_LIST:
/*
* We ignore the strictness here, since empty strings are always
* well-formed lists.
*/
| | | > | 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 |
break;
case STR_IS_LIST:
/*
* We ignore the strictness here, since empty strings are always
* well-formed lists.
*/
if (TCL_OK == TclListObjLength(NULL, objPtr, &length3)) {
break;
}
if (failVarObj != NULL) {
/*
* Need to figure out where the list parsing failed, which is
* fairly expensive. This is adapted from the core of
* SetListFromAny().
*/
const char *elemStart, *nextElem;
size_t lenRemain;
size_t elemSize;
register const char *p;
string1 = TclGetStringFromObj(objPtr, &length1);
end = string1 + length1;
failat = -1;
for (p=string1, lenRemain=length1; lenRemain > 0;
p=nextElem, lenRemain=end-nextElem) {
|
| ︙ | ︙ | |||
1798 1799 1800 1801 1802 1803 1804 |
goto str_is_done;
}
end = string1 + length1;
for (; string1 < end; string1 += length2, failat++) {
int fullchar;
length2 = TclUtfToUniChar(string1, &ch);
fullchar = ch;
| | | | | | | 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 |
goto str_is_done;
}
end = string1 + length1;
for (; string1 < end; string1 += length2, failat++) {
int fullchar;
length2 = TclUtfToUniChar(string1, &ch);
fullchar = ch;
#if TCL_UTF_MAX <= 4
if ((ch >= 0xD800) && (length2 < 3)) {
length2 += TclUtfToUniChar(string1 + length2, &ch);
fullchar = (((fullchar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000;
}
#endif
if (!chcomp(fullchar)) {
result = 0;
break;
}
}
}
/*
* Only set the failVarObj when we will return 0 and we have indicated a
* valid fail index (>= 0).
*/
str_is_done:
if ((result == 0) && (failVarObj != NULL) &&
Tcl_ObjSetVar2(interp, failVarObj, NULL, TclNewWideIntObjFromSize(failat),
TCL_LEAVE_ERR_MSG) == NULL) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result));
return TCL_OK;
}
static int
UniCharIsAscii(
int character)
{
return (character >= 0) && (character < 0x80);
}
static int
UniCharIsHexDigit(
int character)
{
return (character >= 0) && (character < 0x80) && isxdigit(UCHAR(character));
}
/*
*----------------------------------------------------------------------
*
* StringMapCmd --
*
|
| ︙ | ︙ | |||
1865 1866 1867 1868 1869 1870 1871 |
static int
StringMapCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
| | | | | > | | | | | > | > | 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 |
static int
StringMapCmd(
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 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);
if (objc < 3 || objc > 4) {
Tcl_WrongNumArgs(interp, 1, objv, "?-nocase? charMap string");
return TCL_ERROR;
}
if (objc == 4) {
const char *string = TclGetStringFromObj(objv[1], &length2);
if ((length2 > 1) &&
strncmp(string, "-nocase", length2) == 0) {
nocase = 1;
} else {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad option \"%s\": must be -nocase", string));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option",
string, 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!)
*/
if (!TclHasStringRep(objv[objc-2])
&& TclHasIntRep(objv[objc-2], &tclDictType)) {
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) {
/*
* Empty charMap, just return whatever string was given.
*/
Tcl_SetObjResult(interp, objv[objc-1]);
return TCL_OK;
}
mapElemc = 2 * i;
mapWithDict = 1;
/*
* Copy the dictionary out into an array; that's the easiest way to
* adapt this code...
*/
mapElemv = TclStackAlloc(interp, sizeof(Tcl_Obj *) * mapElemc);
Tcl_DictObjFirst(interp, objv[objc-2], &search, mapElemv+0,
mapElemv+1, &done);
for (index=2 ; index<mapElemc ; index+=2) {
Tcl_DictObjNext(&search, mapElemv+index, mapElemv+index+1, &done);
}
Tcl_DictObjDone(&search);
} else {
int i;
if (TclListObjGetElements(interp, objv[objc-2], &i,
&mapElemv) != TCL_OK) {
return TCL_ERROR;
}
mapElemc = i;
if (mapElemc == 0) {
/*
* empty charMap, just return whatever string was given.
*/
Tcl_SetObjResult(interp, objv[objc-1]);
return TCL_OK;
|
| ︙ | ︙ | |||
1966 1967 1968 1969 1970 1971 1972 |
if (objv[objc-2] == objv[objc-1]) {
sourceObj = Tcl_DuplicateObj(objv[objc-1]);
copySource = 1;
} else {
sourceObj = objv[objc-1];
}
| | | 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 |
if (objv[objc-2] == objv[objc-1]) {
sourceObj = Tcl_DuplicateObj(objv[objc-1]);
copySource = 1;
} else {
sourceObj = objv[objc-1];
}
ustring1 = TclGetUnicodeFromObj(sourceObj, &length1);
if (length1 == 0) {
/*
* Empty input string, just stop now.
*/
goto done;
}
|
| ︙ | ︙ | |||
1992 1993 1994 1995 1996 1997 1998 | /* * Special case for one map pair which avoids the extra for loop and * extra calls to get Unicode data. The algorithm is otherwise * identical to the multi-pair case. This will be >30% faster on * larger strings. */ | | > | | | | | | > | | | | | | | 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 |
/*
* Special case for one map pair which avoids the extra for loop and
* extra calls to get Unicode data. The algorithm is otherwise
* identical to the multi-pair case. This will be >30% faster on
* larger strings.
*/
size_t mapLen;
int u2lc;
Tcl_UniChar *mapString;
ustring2 = TclGetUnicodeFromObj(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);
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)) {
if (p != ustring1) {
Tcl_AppendUnicodeToObj(resultPtr, p, ustring1-p);
p = ustring1 + length2;
} else {
p += length2;
}
ustring1 = p - 1;
Tcl_AppendUnicodeToObj(resultPtr, mapString, mapLen);
}
}
}
} else {
Tcl_UniChar **mapStrings;
size_t *mapLens;
int *u2lc = 0;
/*
* 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 = TclStackAlloc(interp, mapElemc*sizeof(Tcl_UniChar *)*2);
mapLens = TclStackAlloc(interp, mapElemc * sizeof(size_t) * 2);
if (nocase) {
u2lc = TclStackAlloc(interp, mapElemc * sizeof(int));
}
for (index = 0; index < mapElemc; index++) {
mapStrings[index] = TclGetUnicodeFromObj(mapElemv[index],
mapLens+index);
if (nocase && ((index % 2) == 0)) {
u2lc[index/2] = Tcl_UniCharToLower(*mapStrings[index]);
}
}
for (p = ustring1; ustring1 < end; ustring1++) {
for (index = 0; index < mapElemc; index += 2) {
/*
* Get the key string to match on.
*/
ustring2 = mapStrings[index];
length2 = mapLens[index];
if ((length2 > 0) && ((*ustring1 == *ustring2) || (nocase &&
(Tcl_UniCharToLower(*ustring1) == u2lc[index/2]))) &&
/* Restrict max compare length. */
((size_t)(end-ustring1) >= length2) && ((length2 == 1) ||
!strCmpFn(ustring2, ustring1, length2))) {
if (p != ustring1) {
/*
* Put the skipped chars onto the result first.
*/
Tcl_AppendUnicodeToObj(resultPtr, p, ustring1-p);
p = ustring1 + length2;
|
| ︙ | ︙ | |||
2143 2144 2145 2146 2147 2148 2149 |
if (objc < 3 || objc > 4) {
Tcl_WrongNumArgs(interp, 1, objv, "?-nocase? pattern string");
return TCL_ERROR;
}
if (objc == 4) {
| | | | 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 |
if (objc < 3 || objc > 4) {
Tcl_WrongNumArgs(interp, 1, objv, "?-nocase? pattern string");
return TCL_ERROR;
}
if (objc == 4) {
size_t length;
const char *string = TclGetStringFromObj(objv[1], &length);
if ((length > 1) &&
strncmp(string, "-nocase", length) == 0) {
nocase = TCL_MATCH_NOCASE;
} else {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad option \"%s\": must be -nocase", string));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option",
string, NULL);
return TCL_ERROR;
|
| ︙ | ︙ | |||
2187 2188 2189 2190 2191 2192 2193 |
static int
StringRangeCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
| | | | | | | | | | | 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 |
static int
StringRangeCmd(
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;
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.
*/
end = Tcl_GetCharLength(objv[1]) - 1;
if (TclGetIntForIndexM(interp, objv[2], end, &first) != TCL_OK ||
TclGetIntForIndexM(interp, objv[3], end, &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));
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
2299 2300 2301 2302 2303 2304 2305 |
static int
StringRplcCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
| | | < | | | | > | | | < > | | | | 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 |
static int
StringRplcCmd(
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;
if (objc < 4 || objc > 5) {
Tcl_WrongNumArgs(interp, 1, objv, "string first last ?string?");
return TCL_ERROR;
}
end = Tcl_GetCharLength(objv[1]) - 1;
if (TclGetIntForIndexM(interp, objv[2], end, &first) != TCL_OK ||
TclGetIntForIndexM(interp, objv[3], end, &last) != TCL_OK) {
return TCL_ERROR;
}
/*
* The following test screens out most empty substrings as candidates for
* replacement. When they are detected, no replacement is done, and the
* result is the original string.
*/
if ((last == 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;
}
resultPtr = TclStringReplace(interp, objv[1], first,
last + 1 - first, (objc == 5) ? objv[4] : NULL,
TCL_STRING_IN_PLACE);
|
| ︙ | ︙ | |||
2410 2411 2412 2413 2414 2415 2416 |
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_UniChar ch = 0;
const char *p, *string;
| | | | | | | | | | | 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 |
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_UniChar ch = 0;
const char *p, *string;
size_t numChars, length, cur, index;
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) {
return TCL_ERROR;
}
string = TclGetString(objv[1]);
if (index + 1 > numChars + 1) {
index = numChars;
}
cur = 0;
if (index + 1 > 1) {
p = Tcl_UtfAtIndex(string, index);
for (cur = index; cur != TCL_INDEX_NONE; cur--) {
TclUtfToUniChar(p, &ch);
if (!Tcl_UniCharIsWordChar(ch)) {
break;
}
p = Tcl_UtfPrev(p, string);
}
if (cur != index) {
cur += 1;
}
}
Tcl_SetObjResult(interp, TclNewWideIntObjFromSize(cur));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* StringEndCmd --
|
| ︙ | ︙ | |||
2471 2472 2473 2474 2475 2476 2477 |
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_UniChar ch = 0;
const char *p, *end, *string;
| | | | | | | | | | 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 |
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_UniChar ch = 0;
const char *p, *end, *string;
size_t length, numChars, cur, index;
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) {
return TCL_ERROR;
}
string = TclGetStringFromObj(objv[1], &length);
if (index == TCL_INDEX_NONE) {
index = TCL_INDEX_START;
}
if (index + 1 <= numChars + 1) {
p = Tcl_UtfAtIndex(string, index);
end = string+length;
for (cur = index; p < end; cur++) {
p += TclUtfToUniChar(p, &ch);
if (!Tcl_UniCharIsWordChar(ch)) {
break;
}
}
if (cur == index) {
cur++;
}
} else {
cur = numChars + 1;
}
Tcl_SetObjResult(interp, TclNewWideIntObjFromSize(cur));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* StringEqualCmd --
|
| ︙ | ︙ | |||
2537 2538 2539 2540 2541 2542 2543 |
{
/*
* 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/...).
*/
| | | < | | | | | | 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 |
{
/*
* 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;
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)) {
nocase = 1;
} else if ((length > 1)
&& !strncmp(string2, "-length", length)) {
if (i+1 >= objc-2) {
goto str_cmp_args;
}
i++;
if (TclGetIntFromObj(interp, objv[i], &reqlength) != TCL_OK) {
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
2578 2579 2580 2581 2582 2583 2584 |
/*
* From now on, we only access the two objects at the end of the argument
* array.
*/
objv += objc-2;
| | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 |
/*
* 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);
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(match ? 0 : 1));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
2687 2688 2689 2690 2691 2692 2693 |
{
/*
* 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/...).
*/
| > | > > > > | > > > > > | > > > > > > > > > | > > > | | | | | | | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 |
{
/*
* 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;
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)) {
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 --
|
| ︙ | ︙ | |||
2873 2874 2875 2876 2877 2878 2879 |
static int
StringBytesCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
| | | | 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 |
static int
StringBytesCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
size_t length;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "string");
return TCL_ERROR;
}
(void) TclGetStringFromObj(objv[1], &length);
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(length));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* StringLenCmd --
|
| ︙ | ︙ | |||
2915 2916 2917 2918 2919 2920 2921 |
Tcl_Obj *const objv[]) /* Argument objects. */
{
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "string");
return TCL_ERROR;
}
| | | 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 |
Tcl_Obj *const objv[]) /* Argument objects. */
{
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "string");
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(Tcl_GetCharLength(objv[1])));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* StringLowerCmd --
|
| ︙ | ︙ | |||
2944 2945 2946 2947 2948 2949 2950 |
static int
StringLowerCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
| | | | | | | 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 |
static int
StringLowerCmd(
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;
if (objc < 2 || objc > 4) {
Tcl_WrongNumArgs(interp, 1, objv, "string ?first? ?last?");
return TCL_ERROR;
}
string1 = TclGetStringFromObj(objv[1], &length1);
if (objc == 2) {
Tcl_Obj *resultPtr = Tcl_NewStringObj(string1, length1);
length1 = Tcl_UtfToLower(TclGetString(resultPtr));
Tcl_SetObjLength(resultPtr, length1);
Tcl_SetObjResult(interp, resultPtr);
} else {
size_t 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 = 0;
}
last = first;
if ((objc == 4) && (TclGetIntForIndexM(interp, objv[3], length1,
&last) != TCL_OK)) {
return TCL_ERROR;
}
if (last + 1 >= length1 + 1) {
last = length1;
}
if (last + 1 < first + 1) {
Tcl_SetObjResult(interp, objv[1]);
return TCL_OK;
}
string1 = TclGetStringFromObj(objv[1], &length1);
start = Tcl_UtfAtIndex(string1, first);
end = Tcl_UtfAtIndex(start, last - first + 1);
|
| ︙ | ︙ | |||
3029 3030 3031 3032 3033 3034 3035 |
static int
StringUpperCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
| | | | | | | | 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 |
static int
StringUpperCmd(
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;
if (objc < 2 || objc > 4) {
Tcl_WrongNumArgs(interp, 1, objv, "string ?first? ?last?");
return TCL_ERROR;
}
string1 = TclGetStringFromObj(objv[1], &length1);
if (objc == 2) {
Tcl_Obj *resultPtr = Tcl_NewStringObj(string1, length1);
length1 = Tcl_UtfToUpper(TclGetString(resultPtr));
Tcl_SetObjLength(resultPtr, length1);
Tcl_SetObjResult(interp, resultPtr);
} else {
size_t 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;
}
last = first;
if ((objc == 4) && (TclGetIntForIndexM(interp, objv[3], length1,
&last) != TCL_OK)) {
return TCL_ERROR;
}
if (last + 1 >= length1 + 1) {
last = length1;
}
if (last + 1 < first + 1) {
Tcl_SetObjResult(interp, objv[1]);
return TCL_OK;
}
string1 = TclGetStringFromObj(objv[1], &length1);
start = Tcl_UtfAtIndex(string1, first);
end = Tcl_UtfAtIndex(start, last - first + 1);
|
| ︙ | ︙ | |||
3114 3115 3116 3117 3118 3119 3120 |
static int
StringTitleCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
| | | | | | | | 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 |
static int
StringTitleCmd(
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;
if (objc < 2 || objc > 4) {
Tcl_WrongNumArgs(interp, 1, objv, "string ?first? ?last?");
return TCL_ERROR;
}
string1 = TclGetStringFromObj(objv[1], &length1);
if (objc == 2) {
Tcl_Obj *resultPtr = Tcl_NewStringObj(string1, length1);
length1 = Tcl_UtfToTitle(TclGetString(resultPtr));
Tcl_SetObjLength(resultPtr, length1);
Tcl_SetObjResult(interp, resultPtr);
} else {
size_t 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;
}
last = first;
if ((objc == 4) && (TclGetIntForIndexM(interp, objv[3], length1,
&last) != TCL_OK)) {
return TCL_ERROR;
}
if (last + 1 >= length1 + 1) {
last = length1;
}
if (last + 1 < first + 1) {
Tcl_SetObjResult(interp, objv[1]);
return TCL_OK;
}
string1 = TclGetStringFromObj(objv[1], &length1);
start = Tcl_UtfAtIndex(string1, first);
end = Tcl_UtfAtIndex(start, last - first + 1);
|
| ︙ | ︙ | |||
3200 3201 3202 3203 3204 3205 3206 |
StringTrimCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *string1, *string2;
| | | 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 |
StringTrimCmd(
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;
if (objc == 3) {
string2 = TclGetStringFromObj(objv[2], &length2);
} else if (objc == 2) {
string2 = tclDefaultTrimSet;
length2 = strlen(tclDefaultTrimSet);
} else {
|
| ︙ | ︙ | |||
3247 3248 3249 3250 3251 3252 3253 |
StringTrimLCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *string1, *string2;
| > | | 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 |
StringTrimLCmd(
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;
if (objc == 3) {
string2 = TclGetStringFromObj(objv[2], &length2);
} else if (objc == 2) {
string2 = tclDefaultTrimSet;
length2 = strlen(tclDefaultTrimSet);
} else {
|
| ︙ | ︙ | |||
3293 3294 3295 3296 3297 3298 3299 |
StringTrimRCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *string1, *string2;
| > | | 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 |
StringTrimRCmd(
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;
if (objc == 3) {
string2 = TclGetStringFromObj(objv[2], &length2);
} else if (objc == 2) {
string2 = tclDefaultTrimSet;
length2 = strlen(tclDefaultTrimSet);
} else {
|
| ︙ | ︙ | |||
3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 |
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},
{"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},
| > | 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 |
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},
|
| ︙ | ︙ | |||
3491 3492 3493 3494 3495 3496 3497 |
int
TclNRSwitchObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
| | | > | 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 |
int
TclNRSwitchObjCmd(
ClientData dummy, /* Not used. */
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;
Tcl_Obj *stringObj, *indexVarObj, *matchVarObj;
Tcl_Obj *const *savedObjv = objv;
Tcl_RegExp regExpr = NULL;
Interp *iPtr = (Interp *) interp;
int pc = 0;
int bidx = 0; /* Index of body argument. */
|
| ︙ | ︙ | |||
3642 3643 3644 3645 3646 3647 3648 |
*/
splitObjs = 0;
if (objc == 1) {
Tcl_Obj **listv;
blist = objv[0];
| | | 3632 3633 3634 3635 3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 |
*/
splitObjs = 0;
if (objc == 1) {
Tcl_Obj **listv;
blist = objv[0];
if (TclListObjGetElements(interp, objv[0], &objc, &listv) != TCL_OK) {
return TCL_ERROR;
}
/*
* Ensure that the list is non-empty.
*/
|
| ︙ | ︙ | |||
3803 3804 3805 3806 3807 3808 3809 |
TclNewObj(indicesObj);
}
for (j=0 ; j<=info.nsubs ; j++) {
if (indexVarObj != NULL) {
Tcl_Obj *rangeObjAry[2];
| | | | | | 3793 3794 3795 3796 3797 3798 3799 3800 3801 3802 3803 3804 3805 3806 3807 3808 3809 3810 3811 |
TclNewObj(indicesObj);
}
for (j=0 ; j<=info.nsubs ; j++) {
if (indexVarObj != NULL) {
Tcl_Obj *rangeObjAry[2];
if (info.matches[j].end + 1 > 1) {
rangeObjAry[0] = TclNewWideIntObjFromSize(info.matches[j].start);
rangeObjAry[1] = TclNewWideIntObjFromSize(info.matches[j].end-1);
} else {
rangeObjAry[0] = rangeObjAry[1] = Tcl_NewWideIntObj(-1);
}
/*
* Never fails; the object is always clean at this point.
*/
Tcl_ListObjAppendElement(NULL, indicesObj,
|
| ︙ | ︙ | |||
3899 3900 3901 3902 3903 3904 3905 |
* own.
*/
}
if (ctxPtr->type == TCL_LOCATION_SOURCE && ctxPtr->line[bidx] >= 0) {
int bline = ctxPtr->line[bidx];
| | | | | 3889 3890 3891 3892 3893 3894 3895 3896 3897 3898 3899 3900 3901 3902 3903 3904 3905 3906 3907 3908 3909 3910 3911 3912 3913 3914 3915 3916 3917 3918 3919 3920 3921 3922 3923 3924 3925 3926 |
* own.
*/
}
if (ctxPtr->type == TCL_LOCATION_SOURCE && ctxPtr->line[bidx] >= 0) {
int bline = ctxPtr->line[bidx];
ctxPtr->line = Tcl_Alloc(objc * sizeof(int));
ctxPtr->nline = objc;
TclListLines(blist, bline, objc, ctxPtr->line, objv);
} else {
/*
* This is either a dynamic code word, when all elements are
* relative to themselves, or something else less expected and
* where we have no information. The result is the same in both
* cases; tell the code to come that it doesn't know where it is,
* which triggers reversion to the old behavior.
*/
int k;
ctxPtr->line = Tcl_Alloc(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) {
/*
* This shouldn't happen since we've checked that the last body is
* not a continuation...
*/
Tcl_Panic("fall-out when searching for body to match pattern");
}
|
| ︙ | ︙ | |||
3956 3957 3958 3959 3960 3961 3962 |
{
/* Unpack the preserved data */
int splitObjs = PTR2INT(data[0]);
CmdFrame *ctxPtr = data[1];
int pc = PTR2INT(data[2]);
const char *pattern = data[3];
| | | | | | 3946 3947 3948 3949 3950 3951 3952 3953 3954 3955 3956 3957 3958 3959 3960 3961 3962 3963 3964 3965 3966 3967 3968 3969 3970 3971 3972 3973 3974 3975 3976 3977 3978 3979 3980 3981 3982 3983 3984 3985 3986 3987 |
{
/* Unpack the preserved data */
int splitObjs = PTR2INT(data[0]);
CmdFrame *ctxPtr = data[1];
int pc = PTR2INT(data[2]);
const char *pattern = data[3];
size_t patternLength = strlen(pattern);
/*
* Clean up TIP 280 context information
*/
if (splitObjs) {
Tcl_Free(ctxPtr->line);
if (pc && (ctxPtr->type == TCL_LOCATION_SOURCE)) {
/*
* Death of SrcInfo reference.
*/
Tcl_DecrRefCount(ctxPtr->data.eval.path);
}
}
/*
* Generate an error message if necessary.
*/
if (result == TCL_ERROR) {
unsigned 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)));
}
TclStackFree(interp, ctxPtr);
return result;
}
/*
|
| ︙ | ︙ | |||
4108 4109 4110 4111 4112 4113 4114 |
i = count;
#ifndef TCL_WIDE_CLICKS
Tcl_GetTime(&start);
#else
start = TclpGetWideClicks();
#endif
while (i-- > 0) {
| | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 4098 4099 4100 4101 4102 4103 4104 4105 4106 4107 4108 4109 4110 4111 4112 4113 4114 4115 4116 4117 4118 4119 4120 4121 4122 4123 4124 4125 4126 4127 4128 4129 4130 4131 4132 4133 4134 4135 4136 4137 4138 4139 4140 4141 4142 4143 4144 4145 4146 4147 4148 4149 4150 4151 4152 4153 4154 4155 4156 4157 4158 4159 4160 4161 4162 4163 4164 4165 4166 4167 4168 4169 4170 4171 4172 4173 4174 4175 4176 4177 4178 4179 4180 4181 4182 4183 4184 4185 4186 4187 4188 4189 4190 4191 4192 4193 4194 4195 4196 4197 4198 4199 4200 4201 4202 4203 4204 4205 4206 4207 4208 4209 4210 4211 4212 4213 4214 4215 4216 4217 4218 4219 4220 4221 4222 4223 4224 4225 4226 4227 4228 4229 4230 4231 4232 4233 4234 4235 4236 4237 4238 4239 4240 4241 4242 4243 4244 4245 4246 4247 4248 4249 4250 4251 4252 4253 4254 4255 4256 4257 4258 4259 4260 4261 4262 4263 4264 4265 4266 4267 4268 4269 4270 4271 4272 4273 4274 4275 4276 4277 4278 4279 4280 4281 4282 4283 4284 4285 4286 4287 4288 4289 4290 4291 4292 4293 4294 4295 4296 4297 4298 4299 4300 4301 4302 4303 4304 4305 4306 4307 4308 4309 4310 4311 4312 4313 4314 4315 4316 4317 4318 4319 4320 4321 4322 4323 4324 4325 4326 4327 4328 4329 4330 4331 4332 4333 4334 4335 4336 4337 4338 4339 4340 4341 4342 4343 4344 4345 4346 4347 4348 4349 4350 4351 4352 4353 4354 4355 4356 4357 4358 4359 4360 4361 4362 4363 4364 4365 4366 4367 4368 4369 4370 4371 4372 4373 4374 4375 4376 4377 4378 4379 4380 4381 4382 4383 4384 4385 4386 4387 4388 4389 4390 4391 4392 4393 4394 4395 4396 4397 4398 4399 4400 4401 4402 4403 4404 4405 4406 4407 4408 4409 4410 4411 4412 4413 4414 4415 4416 4417 4418 4419 4420 4421 4422 4423 4424 4425 4426 4427 4428 4429 4430 4431 4432 4433 4434 4435 4436 4437 4438 4439 4440 4441 4442 4443 4444 4445 4446 4447 4448 4449 4450 4451 4452 4453 4454 4455 4456 4457 4458 4459 4460 4461 4462 4463 4464 4465 4466 4467 4468 4469 4470 4471 4472 4473 4474 4475 4476 4477 4478 4479 4480 4481 4482 4483 4484 4485 4486 4487 4488 4489 4490 4491 4492 4493 4494 4495 4496 4497 4498 4499 4500 4501 4502 4503 4504 4505 4506 4507 4508 4509 4510 4511 4512 4513 4514 4515 4516 4517 4518 4519 4520 4521 4522 4523 4524 4525 4526 4527 4528 4529 4530 4531 4532 4533 4534 4535 4536 4537 4538 4539 4540 4541 4542 4543 4544 4545 4546 4547 4548 4549 4550 4551 4552 4553 4554 4555 4556 4557 4558 4559 4560 4561 4562 4563 4564 4565 4566 4567 4568 4569 4570 4571 4572 4573 4574 4575 4576 4577 4578 4579 4580 4581 4582 4583 4584 4585 4586 4587 4588 4589 4590 4591 4592 4593 4594 4595 4596 4597 4598 4599 4600 4601 4602 4603 4604 4605 4606 4607 4608 4609 4610 4611 4612 4613 4614 4615 4616 4617 4618 4619 4620 4621 4622 4623 4624 4625 4626 4627 4628 4629 4630 4631 4632 4633 4634 4635 4636 4637 4638 4639 4640 4641 4642 4643 4644 4645 4646 4647 4648 4649 4650 4651 4652 4653 4654 4655 4656 4657 4658 4659 4660 4661 4662 4663 4664 4665 4666 4667 4668 4669 4670 4671 4672 4673 4674 4675 4676 4677 4678 4679 4680 4681 4682 4683 4684 4685 4686 4687 4688 4689 4690 4691 4692 4693 4694 4695 4696 4697 4698 4699 4700 4701 4702 4703 4704 |
i = count;
#ifndef TCL_WIDE_CLICKS
Tcl_GetTime(&start);
#else
start = TclpGetWideClicks();
#endif
while (i-- > 0) {
result = TclEvalObjEx(interp, objPtr, 0, NULL, 0);
if (result != TCL_OK) {
return result;
}
}
#ifndef TCL_WIDE_CLICKS
Tcl_GetTime(&stop);
totalMicroSec = ((double) (stop.sec - start.sec)) * 1.0e6
+ (stop.usec - start.usec);
#else
stop = TclpGetWideClicks();
totalMicroSec = ((double) TclpWideClicksToNanoseconds(stop - start))/1.0e3;
#endif
if (count <= 1) {
/*
* Use int obj since we know time is not fractional. [Bug 1202178]
*/
objs[0] = Tcl_NewWideIntObj((count <= 0) ? 0 : (Tcl_WideInt)totalMicroSec);
} else {
objs[0] = Tcl_NewDoubleObj(totalMicroSec/count);
}
/*
* Construct the result as a list because many programs have always parsed
* as such (extracting the first element, typically).
*/
TclNewLiteralStringObj(objs[1], "microseconds");
TclNewLiteralStringObj(objs[2], "per");
TclNewLiteralStringObj(objs[3], "iteration");
Tcl_SetObjResult(interp, Tcl_NewListObj(4, objs));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_TimeRateObjCmd --
*
* This object-based procedure is invoked to process the "timerate" Tcl
* command.
*
* This is similar to command "time", except the execution limited by
* given time (in milliseconds) instead of repetition count.
*
* Example:
* timerate {after 5} 1000; # equivalent to: time {after 5} [expr 1000/5]
*
* Results:
* A standard Tcl object result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_TimeRateObjCmd(
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 */
register Tcl_Obj *objPtr;
register int result, i;
Tcl_Obj *calibrate = NULL, *direct = NULL;
Tcl_WideUInt count = 0; /* Holds repetition count */
Tcl_WideInt maxms = WIDE_MIN;
/* Maximal running time (in milliseconds) */
Tcl_WideUInt maxcnt = WIDE_MAX;
/* Maximal count of iterations. */
Tcl_WideUInt threshold = 1; /* Current threshold for check time (faster
* repeat count without time check) */
Tcl_WideUInt 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. */
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 options {
TMRT_EV_DIRECT, TMRT_OVERHEAD, TMRT_CALIBRATE, TMRT_LAST
};
NRE_callback *rootPtr;
ByteCode *codePtr = NULL;
int codeOptimized = 0;
for (i = 1; i < objc - 1; i++) {
int index;
if (Tcl_GetIndexFromObj(NULL, objv[i], options, "option", TCL_EXACT,
&index) != TCL_OK) {
break;
}
if (index == TMRT_LAST) {
i++;
break;
}
switch (index) {
case TMRT_EV_DIRECT:
direct = objv[i];
break;
case TMRT_OVERHEAD:
if (++i >= objc - 1) {
goto usage;
}
if (Tcl_GetDoubleFromObj(interp, objv[i], &overhead) != TCL_OK) {
return TCL_ERROR;
}
break;
case TMRT_CALIBRATE:
calibrate = objv[i];
break;
}
}
if (i >= objc || i < objc - 3) {
usage:
Tcl_WrongNumArgs(interp, 1, objv,
"?-direct? ?-calibrate? ?-overhead double? "
"command ?time ?max-count??");
return TCL_ERROR;
}
objPtr = objv[i++];
if (i < objc) { /* max-time */
result = Tcl_GetWideIntFromObj(interp, objv[i++], &maxms);
if (result != TCL_OK) {
return result;
}
if (i < objc) { /* max-count*/
Tcl_WideInt v;
result = Tcl_GetWideIntFromObj(interp, objv[i], &v);
if (result != TCL_OK) {
return result;
}
maxcnt = (v > 0) ? v : 0;
}
}
/*
* If we are doing calibration.
*/
if (calibrate) {
/*
* If no time specified for the calibration.
*/
if (maxms == WIDE_MIN) {
Tcl_Obj *clobjv[6];
Tcl_WideInt maxCalTime = 5000;
double lastMeasureOverhead = measureOverhead;
clobjv[0] = objv[0];
i = 1;
if (direct) {
clobjv[i++] = direct;
}
clobjv[i++] = objPtr;
/*
* Reset last measurement overhead.
*/
measureOverhead = (double) 0;
/*
* Self-call with 100 milliseconds to warm-up, before entering the
* calibration cycle.
*/
TclNewIntObj(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;
}
i--;
clobjv[i++] = calibrate;
clobjv[i++] = objPtr;
/*
* Set last measurement overhead to max.
*/
measureOverhead = (double) UWIDE_MAX;
/*
* Run the calibration cycle until it is more precise.
*/
maxms = -1000;
do {
lastMeasureOverhead = measureOverhead;
TclNewIntObj(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;
}
maxCalTime += maxms;
/*
* Increase maxms for more precise calibration.
*/
maxms -= -maxms / 4;
/*
* As long as new value more as 0.05% better
*/
} while ((measureOverhead >= lastMeasureOverhead
|| measureOverhead / lastMeasureOverhead <= 0.9995)
&& maxCalTime > 0);
return result;
}
if (maxms == 0) {
/*
* Reset last measurement overhead
*/
measureOverhead = 0;
Tcl_SetObjResult(interp, Tcl_NewLongObj(0));
return TCL_OK;
}
/*
* If time is negative, make current overhead more precise.
*/
if (maxms > 0) {
/*
* Set last measurement overhead to max.
*/
measureOverhead = (double) UWIDE_MAX;
} else {
maxms = -maxms;
}
}
if (maxms == WIDE_MIN) {
maxms = 1000;
}
if (overhead == -1) {
overhead = measureOverhead;
}
/*
* Ensure that resetting of result will not smudge the further
* measurement.
*/
Tcl_ResetResult(interp);
/*
* Compile object if needed.
*/
if (!direct) {
if (TclInterpReady(interp) != TCL_OK) {
return TCL_ERROR;
}
codePtr = TclCompileObj(interp, objPtr, NULL, 0);
TclPreserveByteCode(codePtr);
/*
* Replace last compiled done instruction with continue: 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.)
*/
if (codePtr->codeStart[codePtr->numCodeBytes-1] == INST_DONE) {
codePtr->codeStart[codePtr->numCodeBytes-1] = INST_CONTINUE;
codeOptimized = 1;
}
}
/*
* Get start and stop time.
*/
#ifdef TCL_WIDE_CLICKS
start = middle = TclpGetWideClicks();
/*
* Time to stop execution (in wide clicks).
*/
stop = start + (maxms * 1000 / TclpWideClickInMicrosec());
#else
Tcl_GetTime(&now);
start = now.sec;
start *= 1000000;
start += now.usec;
middle = start;
/*
* Time to stop execution (in microsecs).
*/
stop = start + maxms * 1000;
#endif /* TCL_WIDE_CLICKS */
/*
* Start measurement.
*/
if (maxcnt > 0) {
while (1) {
/*
* Evaluate a single iteration.
*/
count++;
if (!direct) { /* precompiled */
rootPtr = TOP_CB(interp);
result = TclNRExecuteByteCode(interp, codePtr);
result = TclNRRunCallbacks(interp, result, rootPtr);
} else { /* eval */
result = TclEvalObjEx(interp, objPtr, 0, NULL, 0);
}
/*
* Allow break and continue from measurement cycle (used for
* conditional stop and flow control of iterations).
*/
switch (result) {
case TCL_OK:
break;
case TCL_BREAK:
/*
* Force stop immediately.
*/
threshold = 1;
maxcnt = 0;
case TCL_CONTINUE:
result = TCL_OK;
break;
default:
goto done;
}
/*
* Don't check time up to threshold.
*/
if (--threshold > 0) {
continue;
}
/*
* Check stop time reached, estimate new threshold.
*/
#ifdef TCL_WIDE_CLICKS
middle = TclpGetWideClicks();
#else
Tcl_GetTime(&now);
middle = now.sec;
middle *= 1000000;
middle += now.usec;
#endif /* TCL_WIDE_CLICKS */
if (middle >= stop || count >= maxcnt) {
break;
}
/*
* Don't calculate threshold by few iterations, because sometimes
* first iteration(s) can be too fast or slow (cached, delayed
* clean up, etc).
*/
if (count < 10) {
threshold = 1;
continue;
}
/*
* Average iteration time in microsecs.
*/
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;
}
} else {
if (factor < 50) {
factor++;
}
}
} else if (factor > 4) {
/*
* Iterations seem to be shorter.
*/
if (threshold < (maxIterTm / 2)) {
factor /= 2;
if (factor < 4) {
factor = 4;
}
} else {
factor--;
}
}
/*
* As relation between remaining time and time since last check,
* maximal some % of time (by factor), so avoid growing of the
* execution time if iterations are not consistent, e.g. was
* continuously on time).
*/
threshold = ((stop - middle) / maxIterTm) / factor + 1;
if (threshold > 100000) { /* fix for too large threshold */
threshold = 100000;
}
/*
* Consider max-count
*/
if (threshold > maxcnt - count) {
threshold = maxcnt - count;
}
}
}
{
Tcl_Obj *objarr[8], **objs = objarr;
Tcl_WideUInt usec, val;
int digits;
/*
* Absolute execution time in microseconds or in wide clicks.
*/
usec = (Tcl_WideUInt)(middle - start);
#ifdef TCL_WIDE_CLICKS
/*
* convert execution time (in wide clicks) to microsecs.
*/
usec *= TclpWideClickInMicrosec();
#endif /* TCL_WIDE_CLICKS */
if (!count) { /* no iterations - avoid divide by zero */
objs[0] = objs[2] = objs[4] = Tcl_NewWideIntObj(0);
goto retRes;
}
/*
* If not calibrating...
*/
if (!calibrate) {
/*
* Minimize influence of measurement overhead.
*/
if (overhead > 0) {
/*
* Estimate the time of overhead (microsecs).
*/
Tcl_WideUInt curOverhead = overhead * count;
if (usec > curOverhead) {
usec -= curOverhead;
} else {
usec = 0;
}
}
} else {
/*
* Calibration: obtaining new measurement overhead.
*/
if (measureOverhead > ((double) usec) / count) {
measureOverhead = ((double) usec) / count;
}
objs[0] = Tcl_NewDoubleObj(measureOverhead);
TclNewLiteralStringObj(objs[1], "\xC2\xB5s/#-overhead"); /* mics */
objs += 2;
}
val = usec / count; /* microsecs per iteration */
if (val >= 1000000) {
objs[0] = Tcl_NewWideIntObj(val);
} else {
if (val < 10) {
digits = 6;
} else if (val < 100) {
digits = 4;
} else if (val < 1000) {
digits = 3;
} else if (val < 10000) {
digits = 2;
} else {
digits = 1;
}
objs[0] = Tcl_ObjPrintf("%.*f", digits, ((double) usec)/count);
}
objs[2] = Tcl_NewWideIntObj(count); /* iterations */
/*
* Calculate speed as rate (count) per sec
*/
if (!usec) {
usec++; /* Avoid divide by zero. */
}
if (count < (WIDE_MAX / 1000000)) {
val = (count * 1000000) / usec;
if (val < 100000) {
if (val < 100) {
digits = 3;
} else if (val < 1000) {
digits = 2;
} else {
digits = 1;
}
objs[4] = Tcl_ObjPrintf("%.*f",
digits, ((double) (count * 1000000)) / usec);
} else {
objs[4] = Tcl_NewWideIntObj(val);
}
} else {
objs[4] = Tcl_NewWideIntObj((count / usec) * 1000000);
}
retRes:
/*
* Estimated net execution time (in millisecs).
*/
if (!calibrate) {
if (usec >= 1) {
objs[6] = Tcl_ObjPrintf("%.3f", (double)usec / 1000);
} else {
objs[6] = Tcl_NewWideIntObj(0);
}
TclNewLiteralStringObj(objs[7], "net-ms");
}
/*
* Construct the result as a list because many programs have always
* parsed as such (extracting the first element, typically).
*/
TclNewLiteralStringObj(objs[1], "\xC2\xB5s/#"); /* mics/# */
TclNewLiteralStringObj(objs[3], "#");
TclNewLiteralStringObj(objs[5], "#/sec");
Tcl_SetObjResult(interp, Tcl_NewListObj(8, objarr));
}
done:
if (codePtr != NULL) {
if ( codeOptimized
&& codePtr->codeStart[codePtr->numCodeBytes-1] == INST_CONTINUE
) {
codePtr->codeStart[codePtr->numCodeBytes-1] = INST_DONE;
}
TclReleaseByteCode(codePtr);
}
return result;
}
/*
*----------------------------------------------------------------------
*
* Tcl_TryObjCmd, TclNRTryObjCmd --
*
* This procedure is invoked to process the "try" Tcl command. See the
|
| ︙ | ︙ | |||
4266 4267 4268 4269 4270 4271 4272 |
"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",
| | | 4813 4814 4815 4816 4817 4818 4819 4820 4821 4822 4823 4824 4825 4826 4827 |
"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];
|
| ︙ | ︙ | |||
4805 4806 4807 4808 4809 4810 4811 |
* contain n elements. */
int line, /* Line the list as a whole starts on. */
int n, /* #elements in lines */
int *lines, /* Array of line numbers, to fill. */
Tcl_Obj *const *elems) /* The list elems as Tcl_Obj*, in need of
* derived continuation data */
{
| | | 5352 5353 5354 5355 5356 5357 5358 5359 5360 5361 5362 5363 5364 5365 5366 |
* contain n elements. */
int line, /* Line the list as a whole starts on. */
int n, /* #elements in lines */
int *lines, /* Array of line numbers, to fill. */
Tcl_Obj *const *elems) /* The list elems as Tcl_Obj*, in need of
* derived continuation data */
{
const char *listStr = TclGetString(listObj);
const char *listHead = listStr;
int i, length = strlen(listStr);
const char *element = NULL, *next = NULL;
ContLineLoc *clLocPtr = TclContinuationsGet(listObj);
int *clNext = (clLocPtr ? &clLocPtr->loc[0] : NULL);
for (i = 0; i < n; i++) {
|
| ︙ | ︙ |
Changes to generic/tclCompCmds.c.
| ︙ | ︙ | |||
318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 |
isDataEven = (isDataValid && (len & 1) == 0);
/*
* Special case: literal odd-length argument is always an error.
*/
if (isDataValid && !isDataEven) {
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.
*/
| > > > > > > > > > > > | 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 |
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.
*/
|
| ︙ | ︙ | |||
388 389 390 391 392 393 394 |
/*
* Prepare for the internal foreach.
*/
keyVar = AnonymousLocal(envPtr);
valVar = AnonymousLocal(envPtr);
| | | > > > > | 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 |
/*
* Prepare for the internal foreach.
*/
keyVar = AnonymousLocal(envPtr);
valVar = AnonymousLocal(envPtr);
infoPtr = Tcl_Alloc(sizeof(ForeachInfo));
infoPtr->numLists = 1;
infoPtr->varLists[0] = Tcl_Alloc(sizeof(ForeachVarList) + sizeof(int));
infoPtr->varLists[0]->numVars = 2;
infoPtr->varLists[0]->varIndexes[0] = keyVar;
infoPtr->varLists[0]->varIndexes[1] = valVar;
infoIndex = TclCreateAuxData(infoPtr, &newForeachInfoType, envPtr);
/*
* Start issuing instructions to write to the array.
*/
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
|
| ︙ | ︙ | |||
424 425 426 427 428 429 430 |
TclEmitInstInt4(INST_RETURN_IMM, TCL_ERROR, envPtr);
TclEmitInt4( 0, envPtr);
TclAdjustStackDepth(-1, envPtr);
fwd = CurrentOffset(envPtr) - offsetFwd;
TclStoreInt1AtPtr(fwd, envPtr->codeStart+offsetFwd+1);
}
| < < < | 439 440 441 442 443 444 445 446 447 448 449 450 451 452 |
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 */
|
| ︙ | ︙ | |||
685 686 687 688 689 690 691 |
/* Stack at this point is empty */
TclEmitOpcode( INST_PUSH_RESULT, envPtr);
TclEmitOpcode( INST_PUSH_RETURN_CODE, envPtr);
/* Stack at this point on both branches: result returnCode */
if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) {
| | | | 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 |
/* Stack at this point is empty */
TclEmitOpcode( INST_PUSH_RESULT, envPtr);
TclEmitOpcode( INST_PUSH_RETURN_CODE, envPtr);
/* Stack at this point on both branches: result returnCode */
if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) {
Tcl_Panic("TclCompileCatchCmd: bad jump distance %" TCL_Z_MODIFIER "d",
(CurrentOffset(envPtr) - jumpFixup.codeOffset));
}
/*
* Push the return options if the caller wants them. This needs to happen
* before INST_END_CATCH
*/
|
| ︙ | ︙ | |||
892 893 894 895 896 897 898 899 900 901 902 |
}
(void) Tcl_ListObjAppendElement(NULL, listObj, objPtr);
}
if (listObj != NULL) {
Tcl_Obj **objs;
const char *bytes;
int len;
Tcl_ListObjGetElements(NULL, listObj, &len, &objs);
objPtr = Tcl_ConcatObj(len, objs);
Tcl_DecrRefCount(listObj);
| > | | | 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 |
}
(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.
*/
|
| ︙ | ︙ | |||
1080 1081 1082 1083 1084 1085 1086 |
/*
* Parse the increment amount, if present.
*/
if (parsePtr->numWords == 4) {
const char *word;
| | > | 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 |
/*
* 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);
}
|
| ︙ | ︙ | |||
1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 |
CompileWord(envPtr, tokenPtr, interp, i);
tokenPtr = TokenAfter(tokenPtr);
}
TclEmitInstInt4(INST_DICT_GET, parsePtr->numWords-2, envPtr);
TclAdjustStackDepth(-1, 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. */
Command *cmdPtr, /* Points to defintion of command being
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 |
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. */
Command *cmdPtr, /* Points to defintion of command being
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *tokenPtr;
int i;
DefineLineInformation; /* TIP #280 */
/*
* 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 ; i<parsePtr->numWords ; 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. */
Command *cmdPtr, /* Points to defintion of command being
|
| ︙ | ︙ | |||
1264 1265 1266 1267 1268 1269 1270 |
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;
| | > | 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 |
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...
|
| ︙ | ︙ | |||
1547 1548 1549 1550 1551 1552 1553 |
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) {
| | | | 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 |
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);
}
/*
* Allocate a temporary variable to store the iterator reference. The
|
| ︙ | ︙ | |||
1763 1764 1765 1766 1767 1768 1769 |
/*
* 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.
*/
| | | 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 |
/*
* 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 = Tcl_Alloc(sizeof(DictUpdateInfo) + sizeof(int) * (numVars - 1));
duiPtr->length = numVars;
keyTokenPtrs = TclStackAlloc(interp, sizeof(Tcl_Token *) * numVars);
tokenPtr = TokenAfter(dictVarTokenPtr);
for (i=0 ; i<numVars ; i++) {
/*
* Put keys to one side for later compilation to bytecode.
|
| ︙ | ︙ | |||
1846 1847 1848 1849 1850 1851 1852 |
TclEmitInstInt4( INST_REVERSE, 3, envPtr);
TclEmitInstInt4( INST_DICT_UPDATE_END, dictIndex, envPtr);
TclEmitInt4( infoIndex, envPtr);
TclEmitInvoke(envPtr,INST_RETURN_STK);
if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) {
| | | | | 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 |
TclEmitInstInt4( INST_REVERSE, 3, envPtr);
TclEmitInstInt4( INST_DICT_UPDATE_END, dictIndex, envPtr);
TclEmitInt4( infoIndex, envPtr);
TclEmitInvoke(envPtr,INST_RETURN_STK);
if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) {
Tcl_Panic("TclCompileDictCmd(update): bad jump distance %" TCL_Z_MODIFIER "d",
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(
|
| ︙ | ︙ | |||
2208 2209 2210 2211 2212 2213 2214 |
TclEmitInvoke(envPtr, INST_RETURN_STK);
/*
* Prepare for the start of the next command.
*/
if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) {
| | | | 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 |
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);
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
2246 2247 2248 2249 2250 2251 2252 |
ClientData clientData)
{
DictUpdateInfo *dui1Ptr, *dui2Ptr;
unsigned len;
dui1Ptr = clientData;
len = sizeof(DictUpdateInfo) + sizeof(int) * (dui1Ptr->length - 1);
| | | | | | 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 |
ClientData clientData)
{
DictUpdateInfo *dui1Ptr, *dui2Ptr;
unsigned len;
dui1Ptr = clientData;
len = sizeof(DictUpdateInfo) + sizeof(int) * (dui1Ptr->length - 1);
dui2Ptr = Tcl_Alloc(len);
memcpy(dui2Ptr, dui1Ptr, len);
return dui2Ptr;
}
static void
FreeDictUpdateInfo(
ClientData clientData)
{
Tcl_Free(clientData);
}
static void
PrintDictUpdateInfo(
ClientData clientData,
Tcl_Obj *appendObj,
ByteCode *codePtr,
unsigned int pcOffset)
{
DictUpdateInfo *duiPtr = clientData;
size_t i;
for (i=0 ; i<duiPtr->length ; i++) {
if (i) {
Tcl_AppendToObj(appendObj, ", ", -1);
}
Tcl_AppendPrintfToObj(appendObj, "%%v%u", duiPtr->varIndices[i]);
}
}
static void
DisassembleDictUpdateInfo(
ClientData clientData,
Tcl_Obj *dictObj,
ByteCode *codePtr,
unsigned int pcOffset)
{
DictUpdateInfo *duiPtr = clientData;
size_t i;
Tcl_Obj *variables = Tcl_NewObj();
for (i=0 ; i<duiPtr->length ; i++) {
Tcl_ListObjAppendElement(NULL, variables,
Tcl_NewIntObj(duiPtr->varIndices[i]));
}
Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("variables", -1),
|
| ︙ | ︙ | |||
2699 2700 2701 2702 2703 2704 2705 |
/*
* Create and initialize the ForeachInfo and ForeachVarList data
* structures describing this command. Then create a AuxData record
* pointing to the ForeachInfo structure.
*/
numLists = (numWords - 2)/2;
| | | 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 |
/*
* Create and initialize the ForeachInfo and ForeachVarList data
* structures describing this command. Then create a AuxData record
* pointing to the ForeachInfo structure.
*/
numLists = (numWords - 2)/2;
infoPtr = Tcl_Alloc(sizeof(ForeachInfo)
+ (numLists - 1) * sizeof(ForeachVarList *));
infoPtr->numLists = 0; /* Count this up as we go */
/*
* Parse each var list into sequence of var names. Don't
* compile the foreach inline if any var name needs substitutions or isn't
* a scalar, or if any var list needs substitutions.
|
| ︙ | ︙ | |||
2733 2734 2735 2736 2737 2738 2739 |
if (!TclWordKnownAtCompileTime(tokenPtr, varListObj) ||
TCL_OK != Tcl_ListObjLength(NULL, varListObj, &numVars) ||
numVars == 0) {
code = TCL_ERROR;
goto done;
}
| | | > > | | | 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 |
if (!TclWordKnownAtCompileTime(tokenPtr, varListObj) ||
TCL_OK != Tcl_ListObjLength(NULL, varListObj, &numVars) ||
numVars == 0) {
code = TCL_ERROR;
goto done;
}
varListPtr = Tcl_Alloc(sizeof(ForeachVarList)
+ (numVars - 1) * sizeof(int));
varListPtr->numVars = numVars;
infoPtr->varLists[i/2] = varListPtr;
infoPtr->numLists++;
for (j = 0; j < numVars; j++) {
Tcl_Obj *varNameObj;
const char *bytes;
int varIndex;
size_t length;
Tcl_ListObjIndex(NULL, varListObj, j, &varNameObj);
bytes = TclGetStringFromObj(varNameObj, &length);
varIndex = LocalScalar(bytes, length, envPtr);
if (varIndex < 0) {
code = TCL_ERROR;
goto done;
}
varListPtr->varIndexes[j] = varIndex;
}
Tcl_SetObjLength(varListObj, 0);
|
| ︙ | ︙ | |||
2869 2870 2871 2872 2873 2874 2875 |
* data to duplicate. */
{
register ForeachInfo *srcPtr = clientData;
ForeachInfo *dupPtr;
register ForeachVarList *srcListPtr, *dupListPtr;
int numVars, i, j, numLists = srcPtr->numLists;
| | | | 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 |
* data to duplicate. */
{
register ForeachInfo *srcPtr = clientData;
ForeachInfo *dupPtr;
register ForeachVarList *srcListPtr, *dupListPtr;
int numVars, i, j, numLists = srcPtr->numLists;
dupPtr = Tcl_Alloc(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 = Tcl_Alloc(sizeof(ForeachVarList)
+ numVars * sizeof(int));
dupListPtr->numVars = numVars;
for (j = 0; j < numVars; j++) {
dupListPtr->varIndexes[j] = srcListPtr->varIndexes[j];
}
dupPtr->varLists[i] = dupListPtr;
}
|
| ︙ | ︙ | |||
2920 2921 2922 2923 2924 2925 2926 |
register ForeachInfo *infoPtr = clientData;
register ForeachVarList *listPtr;
int numLists = infoPtr->numLists;
register int i;
for (i = 0; i < numLists; i++) {
listPtr = infoPtr->varLists[i];
| | | | 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 |
register ForeachInfo *infoPtr = clientData;
register ForeachVarList *listPtr;
int numLists = infoPtr->numLists;
register int i;
for (i = 0; i < numLists; i++) {
listPtr = infoPtr->varLists[i];
Tcl_Free(listPtr);
}
Tcl_Free(infoPtr);
}
/*
*----------------------------------------------------------------------
*
* PrintForeachInfo, DisassembleForeachInfo --
*
|
| ︙ | ︙ | |||
3127 3128 3129 3130 3131 3132 3133 |
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr = parsePtr->tokenPtr;
Tcl_Obj **objv, *formatObj, *tmpObj;
char *bytes, *start;
| | > | 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 |
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr = parsePtr->tokenPtr;
Tcl_Obj **objv, *formatObj, *tmpObj;
char *bytes, *start;
int i, j;
size_t len;
/*
* Don't handle any guaranteed-error cases.
*/
if (parsePtr->numWords < 2) {
return TCL_ERROR;
|
| ︙ | ︙ | |||
3150 3151 3152 3153 3154 3155 3156 |
Tcl_IncrRefCount(formatObj);
tokenPtr = TokenAfter(tokenPtr);
if (!TclWordKnownAtCompileTime(tokenPtr, formatObj)) {
Tcl_DecrRefCount(formatObj);
return TCL_ERROR;
}
| | | | | 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 |
Tcl_IncrRefCount(formatObj);
tokenPtr = TokenAfter(tokenPtr);
if (!TclWordKnownAtCompileTime(tokenPtr, formatObj)) {
Tcl_DecrRefCount(formatObj);
return TCL_ERROR;
}
objv = Tcl_Alloc((parsePtr->numWords-2) * sizeof(Tcl_Obj *));
for (i=0 ; i+2 < parsePtr->numWords ; i++) {
tokenPtr = TokenAfter(tokenPtr);
objv[i] = Tcl_NewObj();
Tcl_IncrRefCount(objv[i]);
if (!TclWordKnownAtCompileTime(tokenPtr, objv[i])) {
goto checkForStringConcatCase;
}
}
/*
* Everything is a literal, so the result is constant too (or an error if
* the format is broken). Do the format now.
*/
tmpObj = Tcl_Format(interp, 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;
}
/*
|
| ︙ | ︙ | |||
3200 3201 3202 3203 3204 3205 3206 |
* 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]);
}
| | | | 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 |
* 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;
|
| ︙ | ︙ | |||
3242 3243 3244 3245 3246 3247 3248 |
* 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. */
| | | 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 |
* 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. */
tmpObj = Tcl_NewObj(); /* The buffer used to accumulate the literal
* being built. */
for (bytes = start ; *bytes ; bytes++) {
if (*bytes == '%') {
Tcl_AppendToObj(tmpObj, start, bytes - start);
|
| ︙ | ︙ | |||
3342 3343 3344 3345 3346 3347 3348 |
}
return index;
}
int
TclLocalScalar(
const char *bytes,
| | | 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 |
}
return index;
}
int
TclLocalScalar(
const char *bytes,
size_t numBytes,
CompileEnv *envPtr)
{
Tcl_Token token[2] = {{TCL_TOKEN_SIMPLE_WORD, NULL, 0, 1},
{TCL_TOKEN_TEXT, NULL, 0, 0}};
token[1].start = bytes;
token[1].size = numBytes;
|
| ︙ | ︙ | |||
3392 3393 3394 3395 3396 3397 3398 |
Tcl_Token *varTokenPtr, /* Points to a variable token. */
CompileEnv *envPtr, /* Holds resulting instructions. */
int flags, /* TCL_NO_LARGE_INDEX | TCL_NO_ELEMENT. */
int *localIndexPtr, /* Must not be NULL. */
int *isScalarPtr) /* Must not be NULL. */
{
register const char *p;
| | | > | | | | > > | | | | | | > | | > | | | | | | | | | | 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 3505 3506 3507 3508 3509 3510 3511 3512 3513 3514 3515 3516 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 3549 3550 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 |
Tcl_Token *varTokenPtr, /* Points to a variable token. */
CompileEnv *envPtr, /* Holds resulting instructions. */
int flags, /* TCL_NO_LARGE_INDEX | TCL_NO_ELEMENT. */
int *localIndexPtr, /* Must not be NULL. */
int *isScalarPtr) /* Must not be NULL. */
{
register const char *p;
const char *last, *name, *elName;
register size_t n;
Tcl_Token *elemTokenPtr = NULL;
size_t nameLen, elNameLen;
int simpleVarName, localIndex;
int elemTokenCount = 0, allocedTokens = 0, removedParen = 0;
/*
* Decide if we can use a frame slot for the var/array name or if we need
* to emit code to compute and push the name at runtime. We use a frame
* slot (entry in the array of local vars) if we are compiling a procedure
* body and if the name is simple text that does not include namespace
* qualifiers.
*/
simpleVarName = 0;
name = elName = NULL;
nameLen = elNameLen = 0;
localIndex = -1;
if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
/*
* A simple variable name. Divide it up into "name" and "elName"
* strings. If it is not a local variable, look it up at runtime.
*/
simpleVarName = 1;
name = varTokenPtr[1].start;
nameLen = varTokenPtr[1].size;
if (name[nameLen-1] == ')') {
/*
* last char is ')' => potential array reference.
*/
last = Tcl_UtfPrev(name + nameLen, name);
if (*last == ')') {
for (p = name; p < last; p = Tcl_UtfNext(p)) {
if (*p == '(') {
elName = p + 1;
elNameLen = last - elName;
nameLen = p - name;
break;
}
}
}
if (!(flags & TCL_NO_ELEMENT) && elNameLen) {
/*
* An array element, the element name is a simple string:
* assemble the corresponding token.
*/
elemTokenPtr = TclStackAlloc(interp, sizeof(Tcl_Token));
allocedTokens = 1;
elemTokenPtr->type = TCL_TOKEN_TEXT;
elemTokenPtr->start = elName;
elemTokenPtr->size = elNameLen;
elemTokenPtr->numComponents = 0;
elemTokenCount = 1;
}
}
} else if (interp && ((n = varTokenPtr->numComponents) > 1)
&& (varTokenPtr[1].type == TCL_TOKEN_TEXT)
&& (varTokenPtr[n].type == TCL_TOKEN_TEXT)
&& (*((p = varTokenPtr[n].start + varTokenPtr[n].size)-1) == ')')
&& (*Tcl_UtfPrev(p, varTokenPtr[n].start) == ')')) {
/*
* Check for parentheses inside first token.
*/
simpleVarName = 0;
for (p = varTokenPtr[1].start,
last = p + varTokenPtr[1].size; p < last; p = Tcl_UtfNext(p)) {
if (*p == '(') {
simpleVarName = 1;
break;
}
}
if (simpleVarName) {
size_t remainingLen;
/*
* Check the last token: if it is just ')', do not count it.
* Otherwise, remove the ')' and flag so that it is restored at
* the end.
*/
if (varTokenPtr[n].size == 1) {
n--;
} else {
varTokenPtr[n].size--;
removedParen = n;
}
name = varTokenPtr[1].start;
nameLen = p - varTokenPtr[1].start;
elName = p + 1;
remainingLen = (varTokenPtr[2].start - p) - 1;
elNameLen = (varTokenPtr[n].start-p) + varTokenPtr[n].size - 1;
if (!(flags & TCL_NO_ELEMENT)) {
if (remainingLen) {
/*
* Make a first token with the extra characters in the first
* token.
*/
elemTokenPtr = TclStackAlloc(interp, n * sizeof(Tcl_Token));
allocedTokens = 1;
elemTokenPtr->type = TCL_TOKEN_TEXT;
elemTokenPtr->start = elName;
elemTokenPtr->size = remainingLen;
elemTokenPtr->numComponents = 0;
elemTokenCount = n;
/*
* Copy the remaining tokens.
*/
|
| ︙ | ︙ | |||
3528 3529 3530 3531 3532 3533 3534 |
if (simpleVarName) {
/*
* See whether name has any namespace separators (::'s).
*/
int hasNsQualifiers = 0;
| | | | | | | 3583 3584 3585 3586 3587 3588 3589 3590 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 3629 3630 |
if (simpleVarName) {
/*
* See whether name has any namespace separators (::'s).
*/
int hasNsQualifiers = 0;
for (p = name, last = p + nameLen-1; p < last; p = Tcl_UtfNext(p)) {
if ((*p == ':') && (*(p+1) == ':')) {
hasNsQualifiers = 1;
break;
}
}
/*
* 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 ((flags & TCL_NO_LARGE_INDEX) && (localIndex > 255)) {
/*
* We'll push the name.
*/
localIndex = -1;
}
}
if (interp && localIndex < 0) {
PushLiteral(envPtr, name, nameLen);
}
/*
* Compile the element script, if any, and only if not inhibited. [Bug
* 3600328]
*/
if (elName != NULL && !(flags & TCL_NO_ELEMENT)) {
if (elNameLen) {
TclCompileTokens(interp, elemTokenPtr, elemTokenCount,
envPtr);
} else {
PushStringLiteral(envPtr, "");
}
}
} else if (interp) {
|
| ︙ | ︙ |
Changes to generic/tclCompCmdsGR.c.
| ︙ | ︙ | |||
23 24 25 26 27 28 29 | */ 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); | < | | | | 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 |
*/
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 = Tcl_NewObj();
int result = TCL_ERROR;
if (TclWordKnownAtCompileTime(tokenPtr, tmpObj)) {
result = TclIndexEncode(NULL, tmpObj, before, after, indexPtr);
|
| ︙ | ︙ | |||
123 124 125 126 127 128 129 |
for (i=1; i<numWords; varTokenPtr = TokenAfter(varTokenPtr),i++) {
localIndex = IndexTailVarIfKnown(interp, varTokenPtr, envPtr);
if (localIndex < 0) {
return TCL_ERROR;
}
| > | | | > > | 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 |
for (i=1; i<numWords; varTokenPtr = TokenAfter(varTokenPtr),i++) {
localIndex = IndexTailVarIfKnown(interp, varTokenPtr, envPtr);
if (localIndex < 0) {
return TCL_ERROR;
}
/*
* TODO: Consider what value can pass through the
* IndexTailVarIfKnown() screen. Full CompileWord() likely does not
* apply here. Push known value instead.
*/
CompileWord(envPtr, varTokenPtr, interp, i);
TclEmitInstInt4( INST_NSUPVAR, localIndex, envPtr);
}
/*
* Pop the namespace, and set the result to empty
*/
|
| ︙ | ︙ | |||
175 176 177 178 179 180 181 |
* 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. */
| > | | 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 |
* 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. */
size_t numBytes;
int jumpFalseDist, numWords, wordIdx, j, code;
const char *word;
int realCond = 1; /* Set to 0 for static conditions:
* "if 0 {..}" */
int boolVal; /* Value of static condition. */
int compileScripts = 1;
DefineLineInformation; /* TIP #280 */
|
| ︙ | ︙ | |||
266 267 268 269 270 271 272 |
TclCompileExprWords(interp, testTokenPtr, 1, envPtr);
if (jumpFalseFixupArray.next >= jumpFalseFixupArray.end) {
TclExpandJumpFixupArray(&jumpFalseFixupArray);
}
jumpIndex = jumpFalseFixupArray.next;
jumpFalseFixupArray.next++;
TclEmitForwardJump(envPtr, TCL_FALSE_JUMP,
| | | 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 |
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.
*/
|
| ︙ | ︙ | |||
313 314 315 316 317 318 319 |
*/
if (jumpEndFixupArray.next >= jumpEndFixupArray.end) {
TclExpandJumpFixupArray(&jumpEndFixupArray);
}
jumpEndFixupArray.next++;
TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP,
| | | | 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 |
*/
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;
}
|
| ︙ | ︙ | |||
408 409 410 411 412 413 414 |
/*
* 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,
| | | | 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 |
/*
* 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.
*/
|
| ︙ | ︙ | |||
493 494 495 496 497 498 499 |
haveImmValue = 0;
immValue = 1;
if (parsePtr->numWords == 3) {
incrTokenPtr = TokenAfter(varTokenPtr);
if (incrTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
const char *word = incrTokenPtr[1].start;
| | | 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 |
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)) {
|
| ︙ | ︙ | |||
600 601 602 603 604 605 606 |
}
tokenPtr = TokenAfter(parsePtr->tokenPtr);
objPtr = Tcl_NewObj();
Tcl_IncrRefCount(objPtr);
if (!TclWordKnownAtCompileTime(tokenPtr, objPtr)) {
goto notCompilable;
}
| | | 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 |
}
tokenPtr = TokenAfter(parsePtr->tokenPtr);
objPtr = Tcl_NewObj();
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.)
*/
|
| ︙ | ︙ | |||
916 917 918 919 920 921 922 |
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);
}
| | | 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 |
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 {
|
| ︙ | ︙ | |||
993 994 995 996 997 998 999 | tokenPtr = TokenAfter(tokenPtr); /* * Generate the next variable name. */ PushVarNameWord(interp, tokenPtr, envPtr, 0, &localIndex, | | | 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 |
tokenPtr = TokenAfter(tokenPtr);
/*
* Generate the next variable name.
*/
PushVarNameWord(interp, tokenPtr, envPtr, 0, &localIndex,
&isScalar, idx + 2);
/*
* Emit instructions to get the idx'th item out of the list value on
* the stack and assign it to the variable.
*/
if (isScalar) {
|
| ︙ | ︙ | |||
1032 1033 1034 1035 1036 1037 1038 |
}
/*
* Generate code to leave the rest of the list on the stack.
*/
TclEmitInstInt4( INST_LIST_RANGE_IMM, idx, envPtr);
| | | 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 |
}
/*
* 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;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1083 1084 1085 1086 1087 1088 1089 |
valTokenPtr = TokenAfter(parsePtr->tokenPtr);
if (numWords != 3) {
goto emitComplexLindex;
}
idxTokenPtr = TokenAfter(valTokenPtr);
| | | | 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 |
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.
*/
|
| ︙ | ︙ | |||
1237 1238 1239 1240 1241 1242 1243 |
* 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);
| | | 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 |
* 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;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1312 1313 1314 1315 1316 1317 1318 |
if (parsePtr->numWords != 4) {
return TCL_ERROR;
}
listTokenPtr = TokenAfter(parsePtr->tokenPtr);
tokenPtr = TokenAfter(listTokenPtr);
| | | | | 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 |
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.
*/
|
| ︙ | ︙ | |||
1402 1403 1404 1405 1406 1407 1408 |
* 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);
| | | | | | | | | 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 |
* 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 ; i<parsePtr->numWords ; 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;
}
|
| ︙ | ︙ | |||
1468 1469 1470 1471 1472 1473 1474 |
* command. */
Command *cmdPtr, /* Points to defintion of command being
* compiled. */
CompileEnv *envPtr) /* Holds the resulting instructions. */
{
Tcl_Token *tokenPtr, *listTokenPtr;
DefineLineInformation; /* TIP #280 */
| | | | < < < < < < < < < < < < < < < < < | | | | > > | | | 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 |
* command. */
Command *cmdPtr, /* Points to defintion of command being
* compiled. */
CompileEnv *envPtr) /* Holds the resulting instructions. */
{
Tcl_Token *tokenPtr, *listTokenPtr;
DefineLineInformation; /* TIP #280 */
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);
|
| ︙ | ︙ | |||
1547 1548 1549 1550 1551 1552 1553 |
}
/* Make a list of them... */
TclEmitInstInt4( INST_LIST, i - 4, envPtr);
emptyPrefix = 0;
}
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | | | 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 |
}
/* 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;
}
|
| ︙ | ︙ | |||
2125 2126 2127 2128 2129 2130 2131 |
* 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. */
| > | | 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 |
* 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. */
size_t len;
int i, nocase, exact, sawLast, simple;
const char *str;
DefineLineInformation; /* TIP #280 */
/*
* We are only interested in compiling simple regexp cases. Currently
* supported compile cases are:
* regexp ?-nocase? ?--? staticString $var
|
| ︙ | ︙ | |||
2166 2167 2168 2169 2170 2171 2172 |
}
str = varTokenPtr[1].start;
len = varTokenPtr[1].size;
if ((len == 2) && (str[0] == '-') && (str[1] == '-')) {
sawLast++;
i++;
break;
| | | 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 |
}
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;
|
| ︙ | ︙ | |||
2230 2231 2232 2233 2234 2235 2236 |
simple = 1;
PushLiteral(envPtr, Tcl_DStringValue(&ds),Tcl_DStringLength(&ds));
Tcl_DStringFree(&ds);
}
}
if (!simple) {
| | | | 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 |
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);
}
|
| ︙ | ︙ | |||
2313 2314 2315 2316 2317 2318 2319 |
*/
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr, *stringTokenPtr;
Tcl_Obj *patternObj = NULL, *replacementObj = NULL;
Tcl_DString pattern;
const char *bytes;
| | > | 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 |
*/
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
|
| ︙ | ︙ | |||
2340 2341 2342 2343 2344 2345 2346 |
Tcl_DStringInit(&pattern);
tokenPtr = TokenAfter(tokenPtr);
patternObj = Tcl_NewObj();
if (!TclWordKnownAtCompileTime(tokenPtr, patternObj)) {
goto done;
}
| | | | 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 |
Tcl_DStringInit(&pattern);
tokenPtr = TokenAfter(tokenPtr);
patternObj = Tcl_NewObj();
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);
patternObj = Tcl_NewObj();
if (!TclWordKnownAtCompileTime(tokenPtr, patternObj)) {
|
| ︙ | ︙ | |||
2391 2392 2393 2394 2395 2396 2397 |
if (bytes[1] == '\0') {
/*
* OK, we've proved there are no metacharacters except for the
* '*' at each end.
*/
len = Tcl_DStringLength(&pattern) - 2;
| | | | | 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 |
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);
}
|
| ︙ | ︙ | |||
2551 2552 2553 2554 2555 2556 2557 |
/*
* All options are known at compile time, so we're going to bytecompile.
* Emit instructions to push the result on the stack.
*/
if (explicitResult) {
| | | 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 |
/*
* 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, "");
}
|
| ︙ | ︙ | |||
2629 2630 2631 2632 2633 2634 2635 |
TclEmitInstInt4(INST_LIST, numOptionWords, envPtr);
/*
* Push the result.
*/
if (explicitResult) {
| | | 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 |
TclEmitInstInt4(INST_LIST, numOptionWords, envPtr);
/*
* Push the result.
*/
if (explicitResult) {
CompileWord(envPtr, wordTokenPtr, interp, numWords - 1);
} else {
PushStringLiteral(envPtr, "");
}
/*
* Issue the RETURN itself.
*/
|
| ︙ | ︙ | |||
2678 2679 2680 2681 2682 2683 2684 |
void
TclCompileSyntaxError(
Tcl_Interp *interp,
CompileEnv *envPtr)
{
Tcl_Obj *msg = Tcl_GetObjResult(interp);
| | | 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 |
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);
|
| ︙ | ︙ | |||
2860 2861 2862 2863 2864 2865 2866 | /* TODO: Consider what value can pass through the * IndexTailVarIfKnown() screen. Full CompileWord() * likely does not apply here. Push known value instead. */ CompileWord(envPtr, varTokenPtr, interp, i); TclEmitInstInt4( INST_VARIABLE, localIndex, envPtr); | | | | 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 |
/* TODO: Consider what value can pass through the
* IndexTailVarIfKnown() screen. Full CompileWord()
* likely does not apply here. Push known value instead. */
CompileWord(envPtr, varTokenPtr, interp, i);
TclEmitInstInt4( INST_VARIABLE, localIndex, envPtr);
if (i + 1 < numWords) {
/*
* A value has been given: set the variable, pop the value
*/
CompileWord(envPtr, valueTokenPtr, interp, i + 1);
Emit14Inst( INST_STORE_SCALAR, localIndex, envPtr);
TclEmitOpcode( INST_POP, envPtr);
}
}
/*
* Set the result to empty
|
| ︙ | ︙ | |||
2906 2907 2908 2909 2910 2911 2912 |
IndexTailVarIfKnown(
Tcl_Interp *interp,
Tcl_Token *varTokenPtr, /* Token representing the variable name */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Obj *tailPtr;
const char *tailName, *p;
| | > | 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 |
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 n = varTokenPtr->numComponents;
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.
|
| ︙ | ︙ | |||
2941 2942 2943 2944 2945 2946 2947 |
}
Tcl_SetStringObj(tailPtr, lastTokenPtr->start, lastTokenPtr->size);
}
tailName = TclGetStringFromObj(tailPtr, &len);
if (len) {
| | | | 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 |
}
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.
|
| ︙ | ︙ |
Changes to generic/tclCompCmdsSZ.c.
| ︙ | ︙ | |||
255 256 257 258 259 260 261 |
Tcl_DecrRefCount(obj);
} else {
folded = obj;
}
} else {
Tcl_DecrRefCount(obj);
if (folded) {
| | | | 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 |
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 ++;
}
|
| ︙ | ︙ | |||
443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 |
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
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",
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 |
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. */
Command *cmdPtr, /* Points to defintion of command being
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *tokenPtr;
DefineLineInformation; /* TIP #280 */
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_OK;
}
/* 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 isClasses {
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;
|
| ︙ | ︙ | |||
687 688 689 690 691 692 693 |
} else {
OP( NUM_TYPE);
OP( DUP);
JUMP1( JUMP_FALSE, end);
}
switch (t) {
| < < < < > | > > > > > > > > > > > > | 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 |
} 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);
|
| ︙ | ︙ | |||
733 734 735 736 737 738 739 |
* created by Tcl_ParseCommand. */
Command *cmdPtr, /* Points to defintion of command being
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr;
| > | | | 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 |
* 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;
|
| ︙ | ︙ | |||
830 831 832 833 834 835 836 | /* * 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]; | | | | 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 |
/*
* 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);
|
| ︙ | ︙ | |||
857 858 859 860 861 862 863 864 865 866 867 868 869 870 |
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *mapTokenPtr, *stringTokenPtr;
Tcl_Obj *mapObj, **objv;
char *bytes;
int len;
/*
* We only handle the case:
*
* string map {foo bar} $thing
*
* That is, a literal two-element list (doesn't need to be brace-quoted,
| > | 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 |
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *mapTokenPtr, *stringTokenPtr;
Tcl_Obj *mapObj, **objv;
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,
|
| ︙ | ︙ | |||
892 893 894 895 896 897 898 |
/*
* 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.
*/
| | | | | | | 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 |
/*
* 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;
}
|
| ︙ | ︙ | |||
933 934 935 936 937 938 939 |
/* Every path must push the string argument */
CompileWord(envPtr, stringTokenPtr, interp, 1);
/*
* Parse the two indices.
*/
| | | | | | 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 |
/* 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;
}
/*
|
| ︙ | ︙ | |||
998 999 1000 1001 1002 1003 1004 |
Tcl_Token *tokenPtr, *valueTokenPtr;
DefineLineInformation; /* TIP #280 */
int first, last;
if (parsePtr->numWords < 4 || parsePtr->numWords > 5) {
return TCL_ERROR;
}
| | | | | | | | | < | | < < | | 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 |
Tcl_Token *tokenPtr, *valueTokenPtr;
DefineLineInformation; /* TIP #280 */
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 */
|
| ︙ | ︙ | |||
1090 1091 1092 1093 1094 1095 1096 |
* 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
| | | | | | | | | | | | | | | | | | | | | 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 |
* 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);
|
| ︙ | ︙ | |||
1349 1350 1351 1352 1353 1354 1355 |
return (character >= 0) && (character < 0x80);
}
static int
UniCharIsHexDigit(
int character)
{
| | | 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 |
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},
|
| ︙ | ︙ | |||
1460 1461 1462 1463 1464 1465 1466 |
return TCL_OK;
}
void
TclSubstCompile(
Tcl_Interp *interp,
const char *bytes,
| | | 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 |
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;
|
| ︙ | ︙ | |||
1491 1492 1493 1494 1495 1496 1497 |
if (tokenPtr->type != TCL_TOKEN_TEXT && tokenPtr->type != TCL_TOKEN_BS) {
PUSH("");
count++;
}
for (endTokenPtr = tokenPtr + parse.numTokens;
tokenPtr < endTokenPtr; tokenPtr = TokenAfter(tokenPtr)) {
| > | | | 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 |
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);
|
| ︙ | ︙ | |||
1522 1523 1524 1525 1526 1527 1528 |
* 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) {
| > | | 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 |
* 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;
}
}
|
| ︙ | ︙ | |||
1561 1562 1563 1564 1565 1566 1567 |
/* Jump to the end (all BREAKs land here) */
breakOffset = CurrentOffset(envPtr);
TclEmitInstInt4(INST_JUMP4, 0, envPtr);
/* Start */
if (TclFixupForwardJumpToHere(envPtr, &startFixup, 127)) {
| | | | 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 |
/* 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);
|
| ︙ | ︙ | |||
1620 1621 1622 1623 1624 1625 1626 |
/* OTHER */
TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &otherFixup);
TclAdjustStackDepth(1, envPtr);
/* BREAK destination */
if (TclFixupForwardJumpToHere(envPtr, &breakFixup, 127)) {
| | | | | | | | | | | | | | 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 |
/* 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;
|
| ︙ | ︙ | |||
1795 1796 1797 1798 1799 1800 1801 |
* 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--) {
| | | 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 |
* 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 size_t 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).
|
| ︙ | ︙ | |||
1886 1887 1888 1889 1890 1891 1892 |
* 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;
| | | | | | | 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 |
* 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_Alloc(sizeof(Tcl_Token) * maxLen);
bodyToken = Tcl_Alloc(sizeof(Tcl_Token *) * maxLen);
bodyLines = Tcl_Alloc(sizeof(int) * maxLen);
bodyContLines = Tcl_Alloc(sizeof(int*) * maxLen);
bline = mapPtr->loc[eclIndex].line[valueIndex+1];
numWords = 0;
while (numBytes > 0) {
const char *prevBytes = bytes;
int literal;
|
| ︙ | ︙ | |||
1944 1945 1946 1947 1948 1949 1950 |
TclAdvanceContinuations(&bline, &clNext, bytes - envPtr->source);
numBytes -= (bytes - prevBytes);
numWords++;
}
if (numWords % 2) {
abort:
| | | | | | | | | 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 |
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_Alloc(sizeof(Tcl_Token *) * numWords);
bodyLines = Tcl_Alloc(sizeof(int) * numWords);
bodyContLines = Tcl_Alloc(sizeof(int*) * numWords);
bodyTokenArray = NULL;
for (i=0 ; i<numWords ; i++) {
/*
* We only handle the very simplest case. Anything more complex is
* a good reason to go to the interpreted case anyway due to
* traces, etc.
*/
|
| ︙ | ︙ | |||
2026 2027 2028 2029 2030 2031 2032 |
result = TCL_OK;
/*
* Clean up all our temporary space and return.
*/
freeTemporaries:
| | | | | | 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 |
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;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
2331 2332 2333 2334 2335 2336 2337 |
* (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.
*/
| | | 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 |
* (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 = Tcl_Alloc(sizeof(JumptableInfo));
Tcl_InitHashTable(&jtPtr->hashTable, TCL_STRING_KEYS);
infoIndex = TclCreateAuxData(jtPtr, &tclJumptableInfoType, envPtr);
finalFixups = TclStackAlloc(interp, sizeof(int) * (numBodyTokens/2));
foundDefault = 0;
mustGenerate = 1;
/*
|
| ︙ | ︙ | |||
2503 2504 2505 2506 2507 2508 2509 |
*/
static ClientData
DupJumptableInfo(
ClientData clientData)
{
JumptableInfo *jtPtr = clientData;
| | | 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 |
*/
static ClientData
DupJumptableInfo(
ClientData clientData)
{
JumptableInfo *jtPtr = clientData;
JumptableInfo *newJtPtr = 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) {
|
| ︙ | ︙ | |||
2525 2526 2527 2528 2529 2530 2531 |
static void
FreeJumptableInfo(
ClientData clientData)
{
JumptableInfo *jtPtr = clientData;
Tcl_DeleteHashTable(&jtPtr->hashTable);
| | | 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 |
static void
FreeJumptableInfo(
ClientData clientData)
{
JumptableInfo *jtPtr = clientData;
Tcl_DeleteHashTable(&jtPtr->hashTable);
Tcl_Free(jtPtr);
}
static void
PrintJumptableInfo(
ClientData clientData,
Tcl_Obj *appendObj,
ByteCode *codePtr,
|
| ︙ | ︙ | |||
2866 2867 2868 2869 2870 2871 2872 |
}
if (Tcl_ListObjGetElements(NULL, tmpObj, &objc, &objv) != TCL_OK
|| (objc > 2)) {
TclDecrRefCount(tmpObj);
goto failedToCompile;
}
if (objc > 0) {
| | | | 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 |
}
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;
}
|
| ︙ | ︙ | |||
2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 |
int *resultVars,
int *optionVars,
Tcl_Token **handlerTokens)
{
DefineLineInformation; /* TIP #280 */
int range, resultVar, optionsVar;
int i, j, len, forwardsNeedFixing = 0, trapZero = 0, afterBody = 0;
int *addrsToFix, *forwardsToFix, notCodeJumpSource, notECJumpSource;
int *noError;
char buf[TCL_INTEGER_SPACE];
resultVar = AnonymousLocal(envPtr);
optionsVar = AnonymousLocal(envPtr);
if (resultVar < 0 || optionsVar < 0) {
| > | 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 |
int *resultVars,
int *optionVars,
Tcl_Token **handlerTokens)
{
DefineLineInformation; /* TIP #280 */
int range, resultVar, optionsVar;
int i, j, len, forwardsNeedFixing = 0, trapZero = 0, afterBody = 0;
size_t slen;
int *addrsToFix, *forwardsToFix, notCodeJumpSource, notECJumpSource;
int *noError;
char buf[TCL_INTEGER_SPACE];
resultVar = AnonymousLocal(envPtr);
optionsVar = AnonymousLocal(envPtr);
if (resultVar < 0 || optionsVar < 0) {
|
| ︙ | ︙ | |||
3082 3083 3084 3085 3086 3087 3088 | */ LOAD( optionsVar); PUSH( "-errorcode"); OP4( DICT_GET, 1); TclAdjustStackDepth(-1, envPtr); OP44( LIST_RANGE_IMM, 0, len-1); | | | | 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 |
*/
LOAD( optionsVar);
PUSH( "-errorcode");
OP4( DICT_GET, 1);
TclAdjustStackDepth(-1, envPtr);
OP44( LIST_RANGE_IMM, 0, len-1);
p = TclGetStringFromObj(matchClauses[i], &slen);
PushLiteral(envPtr, p, slen);
OP( STR_EQ);
JUMP4( JUMP_FALSE, notECJumpSource);
} else {
notECJumpSource = -1; /* LINT */
}
OP( POP);
|
| ︙ | ︙ | |||
3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 |
Tcl_Token *finallyToken) /* Not NULL */
{
DefineLineInformation; /* TIP #280 */
int range, resultVar, optionsVar, i, j, len, forwardsNeedFixing = 0;
int trapZero = 0, afterBody = 0, finalOK, finalError, noFinalError;
int *addrsToFix, *forwardsToFix, notCodeJumpSource, notECJumpSource;
char buf[TCL_INTEGER_SPACE];
resultVar = AnonymousLocal(envPtr);
optionsVar = AnonymousLocal(envPtr);
if (resultVar < 0 || optionsVar < 0) {
return TCL_ERROR;
}
| > | 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 |
Tcl_Token *finallyToken) /* Not NULL */
{
DefineLineInformation; /* TIP #280 */
int range, resultVar, optionsVar, i, j, len, forwardsNeedFixing = 0;
int trapZero = 0, afterBody = 0, finalOK, finalError, noFinalError;
int *addrsToFix, *forwardsToFix, notCodeJumpSource, notECJumpSource;
char buf[TCL_INTEGER_SPACE];
size_t slen;
resultVar = AnonymousLocal(envPtr);
optionsVar = AnonymousLocal(envPtr);
if (resultVar < 0 || optionsVar < 0) {
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
3293 3294 3295 3296 3297 3298 3299 | */ LOAD( optionsVar); PUSH( "-errorcode"); OP4( DICT_GET, 1); TclAdjustStackDepth(-1, envPtr); OP44( LIST_RANGE_IMM, 0, len-1); | | | | 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 |
*/
LOAD( optionsVar);
PUSH( "-errorcode");
OP4( DICT_GET, 1);
TclAdjustStackDepth(-1, envPtr);
OP44( LIST_RANGE_IMM, 0, len-1);
p = TclGetStringFromObj(matchClauses[i], &slen);
PushLiteral(envPtr, p, slen);
OP( STR_EQ);
JUMP4( JUMP_FALSE, notECJumpSource);
} else {
notECJumpSource = -1; /* LINT */
}
OP( POP);
|
| ︙ | ︙ | |||
3619 3620 3621 3622 3623 3624 3625 |
continue;
}
}
return TCL_ERROR;
}
if (varCount == 0) {
const char *bytes;
| | | 3688 3689 3690 3691 3692 3693 3694 3695 3696 3697 3698 3699 3700 3701 3702 |
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++;
|
| ︙ | ︙ |
Changes to generic/tclCompExpr.c.
| ︙ | ︙ | |||
497 498 499 500 501 502 503 | * Declarations for local functions to this file: */ static void CompileExprTree(Tcl_Interp *interp, OpNode *nodes, int index, Tcl_Obj *const **litObjvPtr, Tcl_Obj *const *funcObjv, Tcl_Token *tokenPtr, CompileEnv *envPtr, int optimize); | | | | | 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 | * Declarations for local functions to this file: */ static void CompileExprTree(Tcl_Interp *interp, OpNode *nodes, int index, Tcl_Obj *const **litObjvPtr, Tcl_Obj *const *funcObjv, Tcl_Token *tokenPtr, CompileEnv *envPtr, int optimize); static void ConvertTreeToTokens(const char *start, size_t 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, Tcl_Obj *litList, Tcl_Obj *funcList, Tcl_Parse *parsePtr, int parseOnly); static size_t ParseLexeme(const char *start, size_t numBytes, unsigned char *lexemePtr, Tcl_Obj **literalPtr); /* *---------------------------------------------------------------------- * * ParseExpr -- * |
| ︙ | ︙ | |||
532 533 534 535 536 537 538 | * 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 | | | | 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 |
* 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.
*
*----------------------------------------------------------------------
*/
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. */
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. */
|
| ︙ | ︙ | |||
567 568 569 570 571 572 573 |
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. */
| | | 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 |
unsigned int nodesAvailable = 64; /* Initial size of the storage array. This
* value establishes a minimum tree memory
* cost of only about 1 kibyte, and is large
* enough for most expressions to parse with
* no need for array growth and
* reallocation. */
unsigned int nodesUsed = 0; /* Number of OpNodes filled. */
size_t scanned = 0; /* Capture number of byte scanned by parsing
* routines. */
int lastParsed; /* Stores info about what the lexeme parsed
* the previous pass through the parsing loop
* was. If it was an operator, lastParsed is
* the index of the OpNode for that operator.
* If it was not an operator, lastParsed holds
* an OperandTypes value encoding what we need
|
| ︙ | ︙ | |||
611 612 613 614 615 616 617 |
* 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. */
| | | | 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 |
* 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
* constructed out of substrings of the
* original expression. In order to keep the
* error message readable, we impose this
* limit on the substring size we extract. */
TclParseInit(interp, start, numBytes, parsePtr);
nodes = Tcl_AttemptAlloc(nodesAvailable * sizeof(OpNode));
if (nodes == NULL) {
TclNewLiteralStringObj(msg, "not enough memory to parse expression");
errCode = "NOMEM";
goto error;
}
/*
|
| ︙ | ︙ | |||
663 664 665 666 667 668 669 |
if (nodesUsed >= nodesAvailable) {
unsigned int size = nodesUsed * 2;
OpNode *newPtr = NULL;
do {
if (size <= UINT_MAX/sizeof(OpNode)) {
| | | 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 |
if (nodesUsed >= nodesAvailable) {
unsigned int size = nodesUsed * 2;
OpNode *newPtr = NULL;
do {
if (size <= UINT_MAX/sizeof(OpNode)) {
newPtr = Tcl_AttemptRealloc(nodes, size * sizeof(OpNode));
}
} while ((newPtr == NULL)
&& ((size -= (size - nodesUsed) / 2) > nodesUsed));
if (newPtr == NULL) {
TclNewLiteralStringObj(msg,
"not enough memory to parse expression");
errCode = "NOMEM";
|
| ︙ | ︙ | |||
698 699 700 701 702 703 704 |
if ((NODE_TYPE & lexeme) == 0) {
int b;
switch (lexeme) {
case INVALID:
msg = Tcl_ObjPrintf("invalid character \"%.*s\"",
| | | | 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 |
if ((NODE_TYPE & lexeme) == 0) {
int b;
switch (lexeme) {
case INVALID:
msg = Tcl_ObjPrintf("invalid character \"%.*s\"",
(int)scanned, start);
errCode = "BADCHAR";
goto error;
case INCOMPLETE:
msg = Tcl_ObjPrintf("incomplete operator \"%.*s\"",
(int)scanned, start);
errCode = "PARTOP";
goto error;
case BAREWORD:
/*
* Most barewords in an expression are a syntax error. The
* exceptions are that when a bareword is followed by an open
|
| ︙ | ︙ | |||
732 733 734 735 736 737 738 |
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\"",
| | | | | | 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 |
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);
|
| ︙ | ︙ | |||
1373 1374 1375 1376 1377 1378 1379 |
}
/*
* Free any partial parse tree we've built.
*/
if (nodes != NULL) {
| | | 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 |
}
/*
* Free any partial parse tree we've built.
*/
if (nodes != NULL) {
Tcl_Free(nodes);
}
if (interp == NULL) {
/*
* Nowhere to report an error message, so just free it.
*/
|
| ︙ | ︙ | |||
1402 1403 1404 1405 1406 1407 1408 | * Add a detailed quote from the bad expression, displaying and * sometimes marking the precise location of the syntax error. */ Tcl_AppendPrintfToObj(msg, "\nin expression \"%s%.*s%.*s%s%s%.*s%s\"", ((start - limit) < parsePtr->string) ? "" : "...", ((start - limit) < parsePtr->string) | | | | | 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 | * Add a detailed quote from the bad expression, displaying and * sometimes marking the precise location of the syntax error. */ Tcl_AppendPrintfToObj(msg, "\nin expression \"%s%.*s%.*s%s%s%.*s%s\"", ((start - limit) < parsePtr->string) ? "" : "...", ((start - limit) < parsePtr->string) ? (int) (start - parsePtr->string) : (int)limit - 3, ((start - limit) < parsePtr->string) ? parsePtr->string : start - limit + 3, (scanned < limit) ? (int)scanned : (int)limit - 3, start, (scanned < limit) ? "" : "...", insertMark ? mark : "", (start + scanned + limit > parsePtr->end) ? (int) (parsePtr->end - start) - (int)scanned : (int)limit-3, start + scanned, (start + scanned + limit > parsePtr->end) ? "" : "..."); /* * Next, append any postscript message. */ |
| ︙ | ︙ | |||
1430 1431 1432 1433 1434 1435 1436 | /* * Finally, place context information in the errorInfo. */ numBytes = parsePtr->end - parsePtr->string; Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (parsing expression \"%.*s%s\")", | | | 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 |
/*
* Finally, place context information in the errorInfo.
*/
numBytes = parsePtr->end - parsePtr->string;
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (parsing expression \"%.*s%s\")",
(numBytes < limit) ? (int)numBytes : (int)limit - 3,
parsePtr->string, (numBytes < limit) ? "" : "..."));
if (errCode) {
Tcl_SetErrorCode(interp, "TCL", "PARSE", "EXPR", errCode,
subErrCode, NULL);
}
}
|
| ︙ | ︙ | |||
1467 1468 1469 1470 1471 1472 1473 |
*
*----------------------------------------------------------------------
*/
static void
ConvertTreeToTokens(
const char *start,
| | | 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 |
*
*----------------------------------------------------------------------
*/
static void
ConvertTreeToTokens(
const char *start,
size_t numBytes,
OpNode *nodes,
Tcl_Token *tokenPtr,
Tcl_Parse *parsePtr)
{
int subExprTokenIdx = 0;
OpNode *nodePtr = nodes;
int next = nodePtr->right;
|
| ︙ | ︙ | |||
1556 1557 1558 1559 1560 1561 1562 | * 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, | | | | 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 |
* 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));
subExprTokenPtr->type = TCL_TOKEN_SUB_EXPR;
parsePtr->numTokens += toCopy;
} else {
/*
* Multiple element word. Create a TCL_TOKEN_SUB_EXPR token to
* lead, with fields initialized from the leading token, then
* copy entire set of word tokens.
*/
TclGrowParseTokenArray(parsePtr, toCopy+1);
subExprTokenPtr = parsePtr->tokenPtr + parsePtr->numTokens;
*subExprTokenPtr = *tokenPtr;
subExprTokenPtr->type = TCL_TOKEN_SUB_EXPR;
subExprTokenPtr->numComponents++;
subExprTokenPtr++;
memcpy(subExprTokenPtr, tokenPtr,
toCopy * sizeof(Tcl_Token));
parsePtr->numTokens += toCopy + 1;
}
scanned = tokenPtr->start + tokenPtr->size - start;
start += scanned;
numBytes -= scanned;
tokenPtr += toCopy;
|
| ︙ | ︙ | |||
1755 1756 1757 1758 1759 1760 1761 | */ subExprTokenPtr = parsePtr->tokenPtr + subExprTokenIdx; subExprTokenPtr->size = start - subExprTokenPtr->start; /* * All the Tcl_Tokens allocated and filled belong to | | | 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 | */ 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 * TCL_TOKEN_SUB_EXPR token, and all the rest (one fewer) * are its components. */ subExprTokenPtr->numComponents = (parsePtr->numTokens - subExprTokenIdx) - 1; |
| ︙ | ︙ | |||
1815 1816 1817 1818 1819 1820 1821 |
*----------------------------------------------------------------------
*/
int
Tcl_ParseExpr(
Tcl_Interp *interp, /* Used for error reporting. */
const char *start, /* Start of source string to parse. */
| | | | | | < | 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 |
*----------------------------------------------------------------------
*/
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
* string consists of all bytes up to the
* first null character. */
Tcl_Parse *parsePtr) /* Structure to fill with information about
* the parsed expression; any previous
* information in the structure is ignored. */
{
int code;
OpNode *opTree = NULL; /* Will point to the tree of operators. */
Tcl_Obj *litList = Tcl_NewObj(); /* List to hold the literals. */
Tcl_Obj *funcList = Tcl_NewObj(); /* List to hold the functon names. */
Tcl_Parse *exprParsePtr = TclStackAlloc(interp, sizeof(Tcl_Parse));
/* Holds the Tcl_Tokens of substitutions. */
if (numBytes == TCL_AUTO_LENGTH) {
numBytes = (start ? strlen(start) : 0);
}
code = ParseExpr(interp, start, numBytes, &opTree, litList, funcList,
exprParsePtr, 1 /* parseOnly */);
Tcl_DecrRefCount(funcList);
Tcl_DecrRefCount(litList);
TclParseInit(interp, start, numBytes, parsePtr);
if (code == TCL_OK) {
ConvertTreeToTokens(start, numBytes,
opTree, exprParsePtr->tokenPtr, parsePtr);
} else {
parsePtr->term = exprParsePtr->term;
parsePtr->errorType = exprParsePtr->errorType;
}
Tcl_FreeParse(exprParsePtr);
TclStackFree(interp, exprParsePtr);
Tcl_Free(opTree);
return code;
}
/*
*----------------------------------------------------------------------
*
* ParseLexeme --
*
* Parse a single lexeme from the start of a string, scanning no more
* than numBytes bytes.
*
* Results:
* Returns the number of bytes scanned to produce the lexeme.
*
* Side effects:
* Code identifying lexeme parsed is writen to *lexemePtr.
*
*----------------------------------------------------------------------
*/
static size_t
ParseLexeme(
const char *start, /* Start of lexeme to parse. */
size_t 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;
Tcl_Obj *literal = NULL;
unsigned char byte;
if (numBytes == 0) {
*lexemePtr = END;
return 0;
|
| ︙ | ︙ | |||
2023 2024 2025 2026 2027 2028 2029 | /* * We have a number followed directly by bareword characters * (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] */ | | | 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 |
/*
* We have a number followed directly by bareword characters
* (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)) {
const char *p = start;
while (p < end) {
if (!TclIsBareword(*p++)) {
/*
* The number has non-bareword characters, so we
* must treat it as a number.
|
| ︙ | ︙ | |||
2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 |
/*
* We reject leading underscores in bareword. No sensible reason why.
* Might be inspired by reserved identifier rules in C, which of course
* have no direct relevance here.
*/
if (!TclIsBareword(*start) || *start == '_') {
if (Tcl_UtfCharComplete(start, numBytes)) {
scanned = TclUtfToUniChar(start, &ch);
} else {
| > | | | 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 |
/*
* 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);
} else {
char utfBytes[4];
memcpy(utfBytes, start, numBytes);
utfBytes[numBytes] = '\0';
scanned = TclUtfToUniChar(utfBytes, &ch);
}
*lexemePtr = INVALID;
Tcl_DecrRefCount(literal);
return scanned;
}
|
| ︙ | ︙ | |||
2108 2109 2110 2111 2112 2113 2114 |
*----------------------------------------------------------------------
*/
void
TclCompileExpr(
Tcl_Interp *interp, /* Used for error reporting. */
const char *script, /* The source script to compile. */
| | | 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 |
*----------------------------------------------------------------------
*/
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. */
CompileEnv *envPtr, /* Holds resulting instructions. */
int optimize) /* 0 for one-off expressions. */
{
OpNode *opTree = NULL; /* Will point to the tree of operators */
Tcl_Obj *litList = Tcl_NewObj(); /* List to hold the literals */
Tcl_Obj *funcList = Tcl_NewObj(); /* List to hold the functon names*/
Tcl_Parse *parsePtr = TclStackAlloc(interp, sizeof(Tcl_Parse));
|
| ︙ | ︙ | |||
2146 2147 2148 2149 2150 2151 2152 |
TclCompileSyntaxError(interp, envPtr);
}
Tcl_FreeParse(parsePtr);
TclStackFree(interp, parsePtr);
Tcl_DecrRefCount(funcList);
Tcl_DecrRefCount(litList);
| | | 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 |
TclCompileSyntaxError(interp, envPtr);
}
Tcl_FreeParse(parsePtr);
TclStackFree(interp, parsePtr);
Tcl_DecrRefCount(funcList);
Tcl_DecrRefCount(litList);
Tcl_Free(opTree);
}
/*
*----------------------------------------------------------------------
*
* ExecConstantExprTree --
* Compiles and executes bytecode for the subexpression tree at index
|
| ︙ | ︙ | |||
2256 2257 2258 2259 2260 2261 2262 |
} else if (nodePtr->mark == MARK_RIGHT) {
next = nodePtr->right;
switch (nodePtr->lexeme) {
case FUNCTION: {
Tcl_DString cmdName;
const char *p;
| | | 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 |
} else if (nodePtr->mark == MARK_RIGHT) {
next = nodePtr->right;
switch (nodePtr->lexeme) {
case FUNCTION: {
Tcl_DString cmdName;
const char *p;
size_t length;
Tcl_DStringInit(&cmdName);
TclDStringAppendLiteral(&cmdName, "tcl::mathfunc::");
p = TclGetStringFromObj(*funcObjv, &length);
funcObjv++;
Tcl_DStringAppend(&cmdName, p, length);
TclEmitPush(TclRegisterLiteral(envPtr,
|
| ︙ | ︙ | |||
2415 2416 2417 2418 2419 2420 2421 |
numWords = 1; /* No arguments, so just the command */
break;
case OT_LITERAL: {
Tcl_Obj *const *litObjv = *litObjvPtr;
Tcl_Obj *literal = *litObjv;
if (optimize) {
| | | 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 |
numWords = 1; /* No arguments, so just the command */
break;
case OT_LITERAL: {
Tcl_Obj *const *litObjv = *litObjvPtr;
Tcl_Obj *literal = *litObjv;
if (optimize) {
size_t length;
const char *bytes = TclGetStringFromObj(literal, &length);
int index = TclRegisterLiteral(envPtr, bytes, length, 0);
Tcl_Obj *objPtr = TclFetchLiteral(envPtr, index);
if ((objPtr->typePtr == NULL) && (literal->typePtr != NULL)) {
/*
* Would like to do this:
|
| ︙ | ︙ | |||
2472 2473 2474 2475 2476 2477 2478 | 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. */ | | > > > | < | 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 |
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);
index = TclRegisterLiteral(envPtr, bytes, numBytes, 0);
tableValue = TclFetchLiteral(envPtr, index);
if ((tableValue->typePtr == NULL) &&
(objPtr->typePtr != NULL)) {
/*
* Same intrep surgery as for OT_LITERAL.
*/
|
| ︙ | ︙ |
Changes to generic/tclCompile.c.
| ︙ | ︙ | |||
637 638 639 640 641 642 643 644 645 646 647 648 649 650 |
* 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 */
{NULL, 0, 0, 0, {OPERAND_NONE}}
};
/*
* Prototypes for procedures defined later in this file:
*/
| > > > > > > > > | 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 |
* 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 */
{NULL, 0, 0, 0, {OPERAND_NONE}}
};
/*
* Prototypes for procedures defined later in this file:
*/
|
| ︙ | ︙ | |||
673 674 675 676 677 678 679 | static void StartExpanding(CompileEnv *envPtr); /* * TIP #280: Helper for building the per-word line information of all compiled * commands. */ static void EnterCmdWordData(ExtCmdLoc *eclPtr, int srcOffset, | | | 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 | static void StartExpanding(CompileEnv *envPtr); /* * TIP #280: Helper for building the per-word line information of all compiled * commands. */ static void EnterCmdWordData(ExtCmdLoc *eclPtr, int srcOffset, Tcl_Token *tokenPtr, const char *cmd, int numWords, int line, int *clNext, int **lines, CompileEnv *envPtr); static void ReleaseCmdWordData(ExtCmdLoc *eclPtr); /* * The structure below defines the bytecode Tcl object type by means of * procedures that can be invoked by generic object code. |
| ︙ | ︙ | |||
703 704 705 706 707 708 709 710 711 712 713 714 715 |
static const Tcl_ObjType substCodeType = {
"substcode", /* name */
FreeSubstCodeInternalRep, /* freeIntRepProc */
DupByteCodeInternalRep, /* dupIntRepProc - shared with bytecode */
NULL, /* updateStringProc */
NULL, /* setFromAnyProc */
};
/*
* Helper macros.
*/
#define TclIncrUInt4AtPtr(ptr, delta) \
| > | | 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 |
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 --
*
* Part of the bytecode Tcl object type implementation. Attempts to
|
| ︙ | ︙ | |||
764 765 766 767 768 769 770 |
(char *) &tclTraceCompile, TCL_LINK_INT) != TCL_OK) {
Tcl_Panic("SetByteCodeFromAny: unable to create link for tcl_traceCompile variable");
}
traceInitialized = 1;
}
#endif
| | < | 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 |
(char *) &tclTraceCompile, TCL_LINK_INT) != TCL_OK) {
Tcl_Panic("SetByteCodeFromAny: unable to create link for tcl_traceCompile variable");
}
traceInitialized = 1;
}
#endif
stringPtr = TclGetStringFromObj(objPtr, &length);
/*
* TIP #280: Pick up the CmdFrame in which the BC compiler was invoked and
* use to initialize the tracking in the compiler. This information was
* stored by TclCompEvalObj and ProcCompileProc.
*/
|
| ︙ | ︙ | |||
952 953 954 955 956 957 958 |
*----------------------------------------------------------------------
*/
static void
FreeByteCodeInternalRep(
register Tcl_Obj *objPtr) /* Object whose internal rep to free. */
{
| | > > > | 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 |
*----------------------------------------------------------------------
*/
static void
FreeByteCodeInternalRep(
register Tcl_Obj *objPtr) /* Object whose internal rep to free. */
{
ByteCode *codePtr;
ByteCodeGetIntRep(objPtr, &tclByteCodeType, codePtr);
assert(codePtr != NULL);
TclReleaseByteCode(codePtr);
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1115 1116 1117 1118 1119 1120 1121 |
}
if (codePtr->localCachePtr && (codePtr->localCachePtr->refCount-- <= 1)) {
TclFreeLocalCache(interp, codePtr->localCachePtr);
}
TclHandleRelease(codePtr->interpHandle);
| | | 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 |
}
if (codePtr->localCachePtr && (codePtr->localCachePtr->refCount-- <= 1)) {
TclFreeLocalCache(interp, codePtr->localCachePtr);
}
TclHandleRelease(codePtr->interpHandle);
Tcl_Free(codePtr);
}
/*
* ---------------------------------------------------------------------
*
* IsCompactibleCompileEnv --
*
|
| ︙ | ︙ | |||
1282 1283 1284 1285 1286 1287 1288 |
Tcl_Interp *interp,
Tcl_Obj *objPtr,
int flags)
{
Interp *iPtr = (Interp *) interp;
ByteCode *codePtr = NULL;
| | > > < | | > | | < | | 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 |
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);
|
| ︙ | ︙ | |||
1350 1351 1352 1353 1354 1355 1356 |
*----------------------------------------------------------------------
*/
static void
FreeSubstCodeInternalRep(
register Tcl_Obj *objPtr) /* Object whose internal rep to free. */
{
| | > > > | | | | 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 |
*----------------------------------------------------------------------
*/
static void
FreeSubstCodeInternalRep(
register Tcl_Obj *objPtr) /* Object whose internal rep to free. */
{
register ByteCode *codePtr;
ByteCodeGetIntRep(objPtr, &substCodeType, codePtr);
assert(codePtr != NULL);
TclReleaseByteCode(codePtr);
}
static void
ReleaseCmdWordData(
ExtCmdLoc *eclPtr)
{
int i;
if (eclPtr->type == TCL_LOCATION_SOURCE) {
Tcl_DecrRefCount(eclPtr->path);
}
for (i=0 ; i<eclPtr->nuloc ; i++) {
Tcl_Free(eclPtr->loc[i].line);
}
if (eclPtr->loc != NULL) {
Tcl_Free(eclPtr->loc);
}
Tcl_Free(eclPtr);
}
/*
*----------------------------------------------------------------------
*
* TclInitCompileEnv --
*
|
| ︙ | ︙ | |||
1399 1400 1401 1402 1403 1404 1405 |
void
TclInitCompileEnv(
Tcl_Interp *interp, /* The interpreter for which a CompileEnv
* structure is initialized. */
register CompileEnv *envPtr,/* Points to the CompileEnv structure to
* initialize. */
const char *stringPtr, /* The source string to be compiled. */
| | | 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 |
void
TclInitCompileEnv(
Tcl_Interp *interp, /* The interpreter for which a CompileEnv
* structure is initialized. */
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. */
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);
|
| ︙ | ︙ | |||
1451 1452 1453 1454 1455 1456 1457 |
* the context invoking the byte code compiler. This structure is used to
* keep the per-word line information for all compiled commands.
*
* See also tclBasic.c, TclEvalObjEx, for the equivalent code in the
* non-compiling evaluator
*/
| | | 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 |
* the context invoking the byte code compiler. This structure is used to
* keep the per-word line information for all compiled commands.
*
* See also tclBasic.c, TclEvalObjEx, for the equivalent code in the
* non-compiling evaluator
*/
envPtr->extCmdMapPtr = Tcl_Alloc(sizeof(ExtCmdLoc));
envPtr->extCmdMapPtr->loc = NULL;
envPtr->extCmdMapPtr->nloc = 0;
envPtr->extCmdMapPtr->nuloc = 0;
envPtr->extCmdMapPtr->path = NULL;
if (invoker == NULL) {
/*
|
| ︙ | ︙ | |||
1606 1607 1608 1609 1610 1611 1612 |
*/
void
TclFreeCompileEnv(
register CompileEnv *envPtr)/* Points to the CompileEnv structure. */
{
if (envPtr->localLitTable.buckets != envPtr->localLitTable.staticBuckets){
| | | 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 |
*/
void
TclFreeCompileEnv(
register CompileEnv *envPtr)/* Points to the CompileEnv structure. */
{
if (envPtr->localLitTable.buckets != envPtr->localLitTable.staticBuckets){
Tcl_Free(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.
*/
|
| ︙ | ︙ | |||
1636 1637 1638 1639 1640 1641 1642 |
if (auxDataPtr->type->freeProc != NULL) {
auxDataPtr->type->freeProc(auxDataPtr->clientData);
}
auxDataPtr++;
}
}
if (envPtr->mallocedCodeArray) {
| | | | | | | | 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 |
if (auxDataPtr->type->freeProc != NULL) {
auxDataPtr->type->freeProc(auxDataPtr->clientData);
}
auxDataPtr++;
}
}
if (envPtr->mallocedCodeArray) {
Tcl_Free(envPtr->codeStart);
}
if (envPtr->mallocedLiteralArray) {
Tcl_Free(envPtr->literalArrayPtr);
}
if (envPtr->mallocedExceptArray) {
Tcl_Free(envPtr->exceptArrayPtr);
Tcl_Free(envPtr->exceptAuxArrayPtr);
}
if (envPtr->mallocedCmdMap) {
Tcl_Free(envPtr->cmdMapPtr);
}
if (envPtr->mallocedAuxDataArray) {
Tcl_Free(envPtr->auxDataArrayPtr);
}
if (envPtr->extCmdMapPtr) {
ReleaseCmdWordData(envPtr->extCmdMapPtr);
envPtr->extCmdMapPtr = NULL;
}
}
|
| ︙ | ︙ | |||
1714 1715 1716 1717 1718 1719 1720 |
if (tempPtr != NULL) {
Tcl_AppendToObj(tempPtr, tokenPtr->start, tokenPtr->size);
}
break;
case TCL_TOKEN_BS:
if (tempPtr != NULL) {
| | | | 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 |
if (tempPtr != NULL) {
Tcl_AppendToObj(tempPtr, tokenPtr->start, tokenPtr->size);
}
break;
case TCL_TOKEN_BS:
if (tempPtr != NULL) {
char utfBuf[4] = "";
size_t length = TclParseBackslash(tokenPtr->start,
tokenPtr->size, NULL, utfBuf);
Tcl_AppendToObj(tempPtr, utfBuf, length);
}
break;
default:
|
| ︙ | ︙ | |||
1758 1759 1760 1761 1762 1763 1764 |
*
*----------------------------------------------------------------------
*/
static int
ExpandRequested(
Tcl_Token *tokenPtr,
| | < > | | | > | | 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 |
*
*----------------------------------------------------------------------
*/
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) {
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)
{
size_t wordIdx = 0;
int depth = TclGetStackDepth(envPtr);
DefineLineInformation;
if (cmdObj) {
CompileCmdLiteral(interp, cmdObj, envPtr);
wordIdx = 1;
tokenPtr = TokenAfter(tokenPtr);
}
|
| ︙ | ︙ | |||
1968 1969 1970 1971 1972 1973 1974 |
/*
* Throw out any line information generated by the failed compile attempt.
*/
while (mapPtr->nuloc - 1 > eclIndex) {
mapPtr->nuloc--;
| | | 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 |
/*
* 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.
*/
|
| ︙ | ︙ | |||
2018 2019 2020 2021 2022 2023 2024 |
* 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,
| | | 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 |
* 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? */
|
| ︙ | ︙ | |||
2086 2087 2088 2089 2090 2091 2092 |
/*
* TIP #280: Free full form of per-word line data and insert the reduced
* form now
*/
envPtr->line = cmdLine;
envPtr->clNext = clNext;
| | | | | | 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 |
/*
* 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
* 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);
if (envPtr->iPtr == NULL) {
Tcl_Panic("TclCompileScript() called on uninitialized CompileEnv");
}
/* Each iteration compiles one command from the script. */
while (numBytes + 1 > 1) {
Tcl_Parse parse;
const char *next;
if (TCL_OK != Tcl_ParseCommand(interp, p, numBytes, 0, &parse)) {
/*
* Compile bytecodes to report the parse error at runtime.
*/
|
| ︙ | ︙ | |||
2254 2255 2256 2257 2258 2259 2260 |
void
TclCompileVarSubst(
Tcl_Interp *interp,
Tcl_Token *tokenPtr,
CompileEnv *envPtr)
{
const char *p, *name = tokenPtr[1].start;
| | | | 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 |
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).
|
| ︙ | ︙ | |||
2328 2329 2330 2331 2332 2333 2334 |
* compile. */
int count, /* Number of tokens to consider at tokenPtr.
* Must be at least 1. */
CompileEnv *envPtr) /* Holds the resulting instructions. */
{
Tcl_DString textBuffer; /* Holds concatenated chars from adjacent
* TCL_TOKEN_TEXT, TCL_TOKEN_BS tokens. */
| | | > | 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 |
* compile. */
int count, /* Number of tokens to consider at tokenPtr.
* Must be at least 1. */
CompileEnv *envPtr) /* Holds the resulting instructions. */
{
Tcl_DString textBuffer; /* Holds concatenated chars from adjacent
* TCL_TOKEN_TEXT, TCL_TOKEN_BS tokens. */
char buffer[4] = "";
int i, numObjsToConcat, adjust;
size_t length;
unsigned char *entryCodeNext = envPtr->codeNext;
#define NUM_STATIC_POS 20
int isLiteral, maxNumCL, numCL;
int *clPosition = NULL;
int depth = TclGetStackDepth(envPtr);
/*
|
| ︙ | ︙ | |||
2364 2365 2366 2367 2368 2369 2370 |
isLiteral = 0;
break;
}
}
if (isLiteral) {
maxNumCL = NUM_STATIC_POS;
| | | 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 |
isLiteral = 0;
break;
}
}
if (isLiteral) {
maxNumCL = NUM_STATIC_POS;
clPosition = Tcl_Alloc(maxNumCL * sizeof(int));
}
adjust = 0;
Tcl_DStringInit(&textBuffer);
numObjsToConcat = 0;
for ( ; count > 0; count--, tokenPtr++) {
switch (tokenPtr->type) {
|
| ︙ | ︙ | |||
2405 2406 2407 2408 2409 2410 2411 |
if ((length == 1) && (buffer[0] == ' ') &&
(tokenPtr->start[1] == '\n')) {
if (isLiteral) {
int clPos = Tcl_DStringLength(&textBuffer);
if (numCL >= maxNumCL) {
maxNumCL *= 2;
| | | 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 |
if ((length == 1) && (buffer[0] == ' ') &&
(tokenPtr->start[1] == '\n')) {
if (isLiteral) {
int clPos = Tcl_DStringLength(&textBuffer);
if (numCL >= maxNumCL) {
maxNumCL *= 2;
clPosition = Tcl_Realloc(clPosition,
maxNumCL * sizeof(int));
}
clPosition[numCL] = clPos;
numCL ++;
}
adjust++;
}
|
| ︙ | ︙ | |||
2463 2464 2465 2466 2467 2468 2469 |
numObjsToConcat++;
count -= tokenPtr->numComponents;
tokenPtr += tokenPtr->numComponents;
break;
default:
Tcl_Panic("Unexpected token type in TclCompileTokens: %d; %.*s",
| | | 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 |
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);
}
}
/*
* Push any accumulated characters appearing at the end.
*/
|
| ︙ | ︙ | |||
2510 2511 2512 2513 2514 2515 2516 |
/*
* Release the temp table we used to collect the locations of continuation
* lines, if any.
*/
if (maxNumCL) {
| | | 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 |
/*
* Release the temp table we used to collect the locations of continuation
* lines, if any.
*/
if (maxNumCL) {
Tcl_Free(clPosition);
}
TclCheckStackDepth(depth+1, envPtr);
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
2721 2722 2723 2724 2725 2726 2727 |
* 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.
*/
| | | 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 |
* 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;
|
| ︙ | ︙ | |||
2779 2780 2781 2782 2783 2784 2785 |
if (envPtr->iPtr->varFramePtr != NULL) {
namespacePtr = envPtr->iPtr->varFramePtr->nsPtr;
} else {
namespacePtr = envPtr->iPtr->globalNsPtr;
}
| | | 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 |
if (envPtr->iPtr->varFramePtr != NULL) {
namespacePtr = envPtr->iPtr->varFramePtr->nsPtr;
} else {
namespacePtr = envPtr->iPtr->globalNsPtr;
}
p = Tcl_Alloc(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);
|
| ︙ | ︙ | |||
2807 2808 2809 2810 2811 2812 2813 |
codePtr->numAuxDataItems = envPtr->auxDataArrayNext;
codePtr->numCmdLocBytes = cmdLocBytes;
codePtr->maxExceptDepth = envPtr->maxExceptDepth;
codePtr->maxStackDepth = envPtr->maxStackDepth;
p += sizeof(ByteCode);
codePtr->codeStart = p;
| | | | | 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 |
codePtr->numAuxDataItems = envPtr->auxDataArrayNext;
codePtr->numCmdLocBytes = cmdLocBytes;
codePtr->maxExceptDepth = envPtr->maxExceptDepth;
codePtr->maxStackDepth = envPtr->maxStackDepth;
p += sizeof(ByteCode);
codePtr->codeStart = p;
memcpy(p, envPtr->codeStart, 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);
}
p += TCL_ALIGN(objArrayBytes); /* align exception range array */
if (exceptArrayBytes > 0) {
codePtr->exceptArrayPtr = (ExceptionRange *) p;
memcpy(p, envPtr->exceptArrayPtr, exceptArrayBytes);
} else {
codePtr->exceptArrayPtr = NULL;
}
p += TCL_ALIGN(exceptArrayBytes); /* align AuxData array */
if (auxDataArrayBytes > 0) {
codePtr->auxDataArrayPtr = (AuxData *) p;
memcpy(p, envPtr->auxDataArrayPtr, auxDataArrayBytes);
} else {
codePtr->auxDataArrayPtr = NULL;
}
p += auxDataArrayBytes;
#ifndef TCL_COMPILE_DEBUG
EncodeCmdLocMap(envPtr, codePtr, (unsigned char *) p);
|
| ︙ | ︙ | |||
2890 2891 2892 2893 2894 2895 2896 |
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.
*/
| | < < | 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 |
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;
}
/*
*----------------------------------------------------------------------
*
* TclFindCompiledLocal --
|
| ︙ | ︙ | |||
2926 2927 2928 2929 2930 2931 2932 |
*/
int
TclFindCompiledLocal(
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. */
| | | 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 |
*/
int
TclFindCompiledLocal(
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*/
{
register CompiledLocal *localPtr;
int localVar = -1;
register int i;
|
| ︙ | ︙ | |||
2952 2953 2954 2955 2956 2957 2958 | * 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; | | | < | | | | 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 |
* 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)) {
return i;
}
}
localPtr = localPtr->nextPtr;
}
}
/*
* Create a new variable if appropriate.
*/
if (create || (name == NULL)) {
localVar = procPtr->numCompiledLocals;
localPtr = Tcl_Alloc(offsetof(CompiledLocal, name) + nameBytes + 1);
if (procPtr->firstLocalPtr == NULL) {
procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr;
} else {
procPtr->lastLocalPtr->nextPtr = localPtr;
procPtr->lastLocalPtr = localPtr;
}
localPtr->nextPtr = NULL;
localPtr->nameLength = nameBytes;
localPtr->frameIndex = localVar;
localPtr->flags = 0;
if (name == NULL) {
localPtr->flags |= VAR_TEMPORARY;
}
localPtr->defValuePtr = NULL;
localPtr->resolveInfo = NULL;
if (name != NULL) {
memcpy(localPtr->name, name, nameBytes);
}
localPtr->name[nameBytes] = '\0';
procPtr->numCompiledLocals++;
}
return localVar;
}
|
| ︙ | ︙ | |||
3058 3059 3060 3061 3062 3063 3064 |
* [inclusive].
*/
size_t currBytes = envPtr->codeNext - envPtr->codeStart;
size_t newBytes = 2 * (envPtr->codeEnd - envPtr->codeStart);
if (envPtr->mallocedCodeArray) {
| | | | | | 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 |
* [inclusive].
*/
size_t currBytes = envPtr->codeNext - envPtr->codeStart;
size_t newBytes = 2 * (envPtr->codeEnd - envPtr->codeStart);
if (envPtr->mallocedCodeArray) {
envPtr->codeStart = Tcl_Realloc(envPtr->codeStart, newBytes);
} else {
/*
* envPtr->codeStart isn't a Tcl_Alloc'd pointer, so we must code a
* Tcl_Realloc equivalent for ourselves.
*/
unsigned char *newPtr = Tcl_Alloc(newBytes);
memcpy(newPtr, envPtr->codeStart, currBytes);
envPtr->codeStart = newPtr;
envPtr->mallocedCodeArray = 1;
}
envPtr->codeNext = envPtr->codeStart + currBytes;
|
| ︙ | ︙ | |||
3125 3126 3127 3128 3129 3130 3131 |
size_t currElems = envPtr->cmdMapEnd;
size_t newElems = 2 * currElems;
size_t currBytes = currElems * sizeof(CmdLocation);
size_t newBytes = newElems * sizeof(CmdLocation);
if (envPtr->mallocedCmdMap) {
| | | | | | 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 |
size_t currElems = envPtr->cmdMapEnd;
size_t newElems = 2 * currElems;
size_t currBytes = currElems * sizeof(CmdLocation);
size_t newBytes = newElems * sizeof(CmdLocation);
if (envPtr->mallocedCmdMap) {
envPtr->cmdMapPtr = Tcl_Realloc(envPtr->cmdMapPtr, newBytes);
} else {
/*
* envPtr->cmdMapPtr isn't a Tcl_Alloc'd pointer, so we must code a
* Tcl_Realloc equivalent for ourselves.
*/
CmdLocation *newPtr = Tcl_Alloc(newBytes);
memcpy(newPtr, envPtr->cmdMapPtr, currBytes);
envPtr->cmdMapPtr = newPtr;
envPtr->mallocedCmdMap = 1;
}
envPtr->cmdMapEnd = newElems;
}
|
| ︙ | ︙ | |||
3229 3230 3231 3232 3233 3234 3235 |
EnterCmdWordData(
ExtCmdLoc *eclPtr, /* Points to the map environment structure in
* which to enter command location
* information. */
int srcOffset, /* Offset of first char of the command. */
Tcl_Token *tokenPtr,
const char *cmd,
| < | 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 |
EnterCmdWordData(
ExtCmdLoc *eclPtr, /* Points to the map environment structure in
* which to enter command location
* information. */
int srcOffset, /* Offset of first char of the command. */
Tcl_Token *tokenPtr,
const char *cmd,
int numWords,
int line,
int *clNext,
int **wlines,
CompileEnv *envPtr)
{
ECL *ePtr;
|
| ︙ | ︙ | |||
3251 3252 3253 3254 3255 3256 3257 | * to eclPtr->loc[eclPtr->nuloc-1] (inclusive). */ size_t currElems = eclPtr->nloc; size_t newElems = (currElems ? 2*currElems : 1); size_t newBytes = newElems * sizeof(ECL); | | | | | | 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 |
* to eclPtr->loc[eclPtr->nuloc-1] (inclusive).
*/
size_t currElems = eclPtr->nloc;
size_t newElems = (currElems ? 2*currElems : 1);
size_t newBytes = newElems * sizeof(ECL);
eclPtr->loc = Tcl_Realloc(eclPtr->loc, newBytes);
eclPtr->nloc = newElems;
}
ePtr = &eclPtr->loc[eclPtr->nuloc];
ePtr->srcOffset = srcOffset;
ePtr->line = Tcl_Alloc(numWords * sizeof(int));
ePtr->next = Tcl_Alloc(numWords * sizeof(int *));
ePtr->nline = numWords;
wwlines = Tcl_Alloc(numWords * sizeof(int));
last = cmd;
wordLine = line;
wordNext = clNext;
for (wordIdx=0 ; wordIdx<numWords;
wordIdx++, tokenPtr += tokenPtr->numComponents + 1) {
TclAdvanceLines(&wordLine, last, tokenPtr->start);
|
| ︙ | ︙ | |||
3329 3330 3331 3332 3333 3334 3335 |
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 =
| | | | | | | | 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 |
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 =
Tcl_Realloc(envPtr->exceptArrayPtr, newBytes);
envPtr->exceptAuxArrayPtr =
Tcl_Realloc(envPtr->exceptAuxArrayPtr, newBytes2);
} else {
/*
* envPtr->exceptArrayPtr isn't a Tcl_Alloc'd pointer, so we must
* code a Tcl_Realloc equivalent for ourselves.
*/
ExceptionRange *newPtr = Tcl_Alloc(newBytes);
ExceptionAux *newPtr2 = Tcl_Alloc(newBytes2);
memcpy(newPtr, envPtr->exceptArrayPtr, currBytes);
memcpy(newPtr2, envPtr->exceptAuxArrayPtr, currBytes2);
envPtr->exceptArrayPtr = newPtr;
envPtr->exceptAuxArrayPtr = newPtr2;
envPtr->mallocedExceptArray = 1;
}
|
| ︙ | ︙ | |||
3442 3443 3444 3445 3446 3447 3448 |
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) {
| | | | 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 |
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 = Tcl_Realloc(auxPtr->breakTargets,
sizeof(int) * auxPtr->allocBreakTargets);
} else {
auxPtr->breakTargets =
Tcl_Alloc(sizeof(int) * auxPtr->allocBreakTargets);
}
}
auxPtr->breakTargets[auxPtr->numBreakTargets - 1] = CurrentOffset(envPtr);
TclEmitInstInt4(INST_JUMP4, 0, envPtr);
}
void
|
| ︙ | ︙ | |||
3468 3469 3470 3471 3472 3473 3474 |
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) {
| | | | 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 |
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 = Tcl_Realloc(auxPtr->continueTargets,
sizeof(int) * auxPtr->allocContinueTargets);
} else {
auxPtr->continueTargets =
Tcl_Alloc(sizeof(int) * auxPtr->allocContinueTargets);
}
}
auxPtr->continueTargets[auxPtr->numContinueTargets - 1] =
CurrentOffset(envPtr);
TclEmitInstInt4(INST_JUMP4, 0, envPtr);
}
|
| ︙ | ︙ | |||
3634 3635 3636 3637 3638 3639 3640 |
}
/*
* Drop the arrays we were holding the only reference to.
*/
if (auxPtr->breakTargets) {
| | | | 3647 3648 3649 3650 3651 3652 3653 3654 3655 3656 3657 3658 3659 3660 3661 3662 3663 3664 3665 3666 |
}
/*
* 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;
}
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
3695 3696 3697 3698 3699 3700 3701 |
size_t currBytes = envPtr->auxDataArrayNext * sizeof(AuxData);
int newElems = 2*envPtr->auxDataArrayEnd;
size_t newBytes = newElems * sizeof(AuxData);
if (envPtr->mallocedAuxDataArray) {
envPtr->auxDataArrayPtr =
| | | | | | 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 3729 |
size_t currBytes = envPtr->auxDataArrayNext * sizeof(AuxData);
int newElems = 2*envPtr->auxDataArrayEnd;
size_t newBytes = newElems * sizeof(AuxData);
if (envPtr->mallocedAuxDataArray) {
envPtr->auxDataArrayPtr =
Tcl_Realloc(envPtr->auxDataArrayPtr, newBytes);
} else {
/*
* envPtr->auxDataArrayPtr isn't a Tcl_Alloc'd pointer, so we must
* code a Tcl_Realloc equivalent for ourselves.
*/
AuxData *newPtr = Tcl_Alloc(newBytes);
memcpy(newPtr, envPtr->auxDataArrayPtr, currBytes);
envPtr->auxDataArrayPtr = newPtr;
envPtr->mallocedAuxDataArray = 1;
}
envPtr->auxDataArrayEnd = newElems;
}
|
| ︙ | ︙ | |||
3784 3785 3786 3787 3788 3789 3790 |
*/
size_t currBytes = fixupArrayPtr->next * sizeof(JumpFixup);
int newElems = 2*(fixupArrayPtr->end + 1);
size_t newBytes = newElems * sizeof(JumpFixup);
if (fixupArrayPtr->mallocedArray) {
| | | | | | 3797 3798 3799 3800 3801 3802 3803 3804 3805 3806 3807 3808 3809 3810 3811 3812 3813 3814 3815 3816 3817 3818 |
*/
size_t currBytes = fixupArrayPtr->next * sizeof(JumpFixup);
int newElems = 2*(fixupArrayPtr->end + 1);
size_t newBytes = newElems * sizeof(JumpFixup);
if (fixupArrayPtr->mallocedArray) {
fixupArrayPtr->fixup = Tcl_Realloc(fixupArrayPtr->fixup, newBytes);
} else {
/*
* fixupArrayPtr->fixup isn't a Tcl_Alloc'd pointer, so we must code a
* Tcl_Realloc equivalent for ourselves.
*/
JumpFixup *newPtr = Tcl_Alloc(newBytes);
memcpy(newPtr, fixupArrayPtr->fixup, currBytes);
fixupArrayPtr->fixup = newPtr;
fixupArrayPtr->mallocedArray = 1;
}
fixupArrayPtr->end = newElems;
}
|
| ︙ | ︙ | |||
3823 3824 3825 3826 3827 3828 3829 |
void
TclFreeJumpFixupArray(
register JumpFixupArray *fixupArrayPtr)
/* Points to the JumpFixupArray structure to
* free. */
{
if (fixupArrayPtr->mallocedArray) {
| | | 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 3846 3847 3848 3849 3850 |
void
TclFreeJumpFixupArray(
register JumpFixupArray *fixupArrayPtr)
/* Points to the JumpFixupArray structure to
* free. */
{
if (fixupArrayPtr->mallocedArray) {
Tcl_Free(fixupArrayPtr->fixup);
}
}
/*
*----------------------------------------------------------------------
*
* TclEmitForwardJump --
|
| ︙ | ︙ | |||
3923 3924 3925 3926 3927 3928 3929 |
* describes the forward jump. */
int jumpDist, /* Jump distance to set in jump instr. */
int distThreshold) /* Maximum distance before the two byte jump
* is grown to five bytes. */
{
unsigned char *jumpPc, *p;
int firstCmd, lastCmd, firstRange, lastRange, k;
| | | 3936 3937 3938 3939 3940 3941 3942 3943 3944 3945 3946 3947 3948 3949 3950 |
* describes the forward jump. */
int jumpDist, /* Jump distance to set in jump instr. */
int distThreshold) /* Maximum distance before the two byte jump
* is grown to five bytes. */
{
unsigned char *jumpPc, *p;
int firstCmd, lastCmd, firstRange, lastRange, k;
size_t numBytes;
if (jumpDist <= distThreshold) {
jumpPc = envPtr->codeStart + jumpFixupPtr->codeOffset;
switch (jumpFixupPtr->jumpType) {
case TCL_UNCONDITIONAL_JUMP:
TclUpdateInstInt1AtPc(INST_JUMP1, jumpDist, jumpPc);
break;
|
| ︙ | ︙ |
Changes to generic/tclCompile.h.
| ︙ | ︙ | |||
177 178 179 180 181 182 183 |
* in the byte code. The association with a ByteCode structure BC is done
* through the 'lineBCPtr' HashTable in Interp, keyed by the address of BC.
* Also recorded is information coming from the context, i.e. type of the
* frame and associated information, like the path of a sourced file.
*/
typedef struct {
| | | 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 |
* in the byte code. The association with a ByteCode structure BC is done
* through the 'lineBCPtr' HashTable in Interp, keyed by the address of BC.
* Also recorded is information coming from the context, i.e. type of the
* frame and associated information, like the path of a sourced file.
*/
typedef struct {
size_t srcOffset; /* Command location to find the entry. */
int nline; /* Number of words in the command */
int *line; /* Line information for all words in the
* command. */
int **next; /* Transient information used by the compiler
* for tracking of hidden continuation
* lines. */
} ECL;
|
| ︙ | ︙ | |||
213 214 215 216 217 218 219 | * * The following definitions declare the types of procedures that are called * to duplicate or free this auxiliary data when the containing ByteCode * objects are duplicated and freed. Pointers to these procedures are kept in * the AuxData structure. */ | | | | | 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 | * * The following definitions declare the types of procedures that are called * to duplicate or free this auxiliary data when the containing ByteCode * objects are duplicated and freed. Pointers to these procedures are kept in * the AuxData structure. */ typedef void *(AuxDataDupProc) (void *clientData); typedef void (AuxDataFreeProc) (void *clientData); typedef void (AuxDataPrintProc)(void *clientData, Tcl_Obj *appendObj, struct ByteCode *codePtr, unsigned int pcOffset); /* * We define a separate AuxDataType struct to hold type-related information * for the AuxData structure. This separation makes it possible for clients * outside of the TCL core to manipulate (in a limited fashion!) AuxData; for |
| ︙ | ︙ | |||
262 263 264 265 266 267 268 |
* during compilation by CompileProcs and used by instructions during
* execution.
*/
typedef struct AuxData {
const AuxDataType *type; /* Pointer to the AuxData type associated with
* this ClientData. */
| | | 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 |
* during compilation by CompileProcs and used by instructions during
* execution.
*/
typedef struct AuxData {
const AuxDataType *type; /* Pointer to the AuxData type associated with
* this ClientData. */
void *clientData; /* The compilation data itself. */
} AuxData;
/*
* Structure defining the compilation environment. After compilation, fields
* describing bytecode instructions are copied out into the more compact
* ByteCode structure defined below.
*/
|
| ︙ | ︙ | |||
510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 |
* 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;
/*
* 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
* tclExecute.c.
*/
enum TclInstruction {
| > > > > > > > > > > > > > > > > > < | 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 |
* 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 ? 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
* tclExecute.c.
*/
enum TclInstruction {
/* Opcodes 0 to 9 */
INST_DONE = 0,
INST_PUSH1,
INST_PUSH4,
INST_POP,
INST_DUP,
INST_STR_CONCAT1,
|
| ︙ | ︙ | |||
796 797 798 799 800 801 802 803 804 805 806 |
INST_LAPPEND_LIST,
INST_LAPPEND_LIST_ARRAY,
INST_LAPPEND_LIST_ARRAY_STK,
INST_LAPPEND_LIST_STK,
INST_CLOCK_READ,
/* The last opcode */
LAST_INST_OPCODE
};
| > > < | 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 |
INST_LAPPEND_LIST,
INST_LAPPEND_LIST_ARRAY,
INST_LAPPEND_LIST_ARRAY_STK,
INST_LAPPEND_LIST_STK,
INST_CLOCK_READ,
INST_DICT_GET_DEF,
/* The last opcode */
LAST_INST_OPCODE
};
/*
* Table describing the Tcl bytecode instructions: their name (for displaying
* code), total number of code bytes required (including operand bytes), and a
* description of the type of each operand. These operand types include signed
* and unsigned integers of length one and four bytes. The unsigned integers
* are used for indexes or for, e.g., the count of objects to push in a "push"
|
| ︙ | ︙ | |||
838 839 840 841 842 843 844 |
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. */
| | | 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 |
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. */
int stackEffect; /* The worst-case balance stack effect of the
* instruction, used for stack requirements
* computations. The value INT_MIN signals
* that the instruction's worst case effect is
* (1-opnd1). */
int numOperands; /* Number of operands. */
InstOperandType opTypes[MAX_INSTRUCTION_OPERANDS];
|
| ︙ | ︙ | |||
996 997 998 999 1000 1001 1002 |
/*
* 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 {
| | | 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 |
/*
* 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[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;
|
| ︙ | ︙ | |||
1051 1052 1053 1054 1055 1056 1057 | CompileEnv *envPtr); MODULE_SCOPE void TclCleanupStackForBreakContinue(CompileEnv *envPtr, ExceptionAux *auxPtr); MODULE_SCOPE void TclCompileCmdWord(Tcl_Interp *interp, Tcl_Token *tokenPtr, int count, CompileEnv *envPtr); MODULE_SCOPE void TclCompileExpr(Tcl_Interp *interp, const char *script, | | | | | | | | | | | | | | | | | | | | 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 |
CompileEnv *envPtr);
MODULE_SCOPE void TclCleanupStackForBreakContinue(CompileEnv *envPtr,
ExceptionAux *auxPtr);
MODULE_SCOPE void TclCompileCmdWord(Tcl_Interp *interp,
Tcl_Token *tokenPtr, int count,
CompileEnv *envPtr);
MODULE_SCOPE void TclCompileExpr(Tcl_Interp *interp, const char *script,
size_t 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,
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 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 void TclDeleteExecEnv(ExecEnv *eePtr);
MODULE_SCOPE void TclDeleteLiteralTable(Tcl_Interp *interp,
LiteralTable *tablePtr);
MODULE_SCOPE void TclEmitForwardJump(CompileEnv *envPtr,
TclJumpType jumpType, JumpFixup *jumpFixupPtr);
MODULE_SCOPE void TclEmitInvoke(CompileEnv *envPtr, int opcode, ...);
MODULE_SCOPE ExceptionRange * TclGetExceptionRangeForPc(unsigned char *pc,
int catchOnly, ByteCode *codePtr);
MODULE_SCOPE void TclExpandJumpFixupArray(JumpFixupArray *fixupArrayPtr);
MODULE_SCOPE int TclNRExecuteByteCode(Tcl_Interp *interp,
ByteCode *codePtr);
MODULE_SCOPE Tcl_Obj * TclFetchLiteral(CompileEnv *envPtr, size_t index);
MODULE_SCOPE int TclFindCompiledLocal(const char *name, size_t nameChars,
int create, CompileEnv *envPtr);
MODULE_SCOPE int TclFixupForwardJump(CompileEnv *envPtr,
JumpFixup *jumpFixupPtr, int jumpDist,
int distThreshold);
MODULE_SCOPE void TclFreeCompileEnv(CompileEnv *envPtr);
MODULE_SCOPE void TclFreeJumpFixupArray(JumpFixupArray *fixupArrayPtr);
MODULE_SCOPE int TclGetIndexFromToken(Tcl_Token *tokenPtr,
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 TclInitCompileEnv(Tcl_Interp *interp,
CompileEnv *envPtr, const char *string,
size_t 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 void TclPrintObject(FILE *outFile,
Tcl_Obj *objPtr, size_t 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);
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[]);
#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,
register Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[], int isLambda);
/*
*----------------------------------------------------------------
* Macros and flag values used by Tcl bytecode compilation and execution
* modules inside the Tcl core but not used outside.
*----------------------------------------------------------------
*/
/*
* Simplified form to access AuxData.
*
* void *TclFetchAuxData(CompileEng *envPtr, int index);
*/
#define TclFetchAuxData(envPtr, index) \
(envPtr)->auxDataArrayPtr[(index)].clientData
#define LITERAL_ON_HEAP 0x01
#define LITERAL_CMD_NAME 0x02
|
| ︙ | ︙ | |||
1449 1450 1451 1452 1453 1454 1455 |
# define TclGetInt1AtPtr(p) ((int) *((signed char *) p))
#else
# define TclGetInt1AtPtr(p) \
(((int) *((char *) p)) | ((*(p) & 0200) ? (-256) : 0))
#endif
#define TclGetInt4AtPtr(p) \
| | | 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 |
# define TclGetInt1AtPtr(p) ((int) *((signed char *) p))
#else
# define TclGetInt1AtPtr(p) \
(((int) *((char *) p)) | ((*(p) & 0200) ? (-256) : 0))
#endif
#define TclGetInt4AtPtr(p) \
(((int) (TclGetUInt1AtPtr(p) << 24)) | \
(*((p)+1) << 16) | \
(*((p)+2) << 8) | \
(*((p)+3)))
#define TclGetUInt1AtPtr(p) \
((unsigned int) *(p))
#define TclGetUInt4AtPtr(p) \
|
| ︙ | ︙ | |||
1501 1502 1503 1504 1505 1506 1507 |
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,
| | | | | 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 |
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
|
| ︙ | ︙ | |||
1777 1778 1779 1780 1781 1782 1783 |
#define TCL_DTRACE_DEBUG_LOG() \
int tclDTraceDebugEnabled = TCL_DTRACE_DEBUG_LOG_ENABLED; \
int tclDTraceDebugIndent = 0; \
FILE *tclDTraceDebugLog = NULL; \
void TclDTraceOpenDebugLog(void) { \
char n[35]; \
| | | | 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 |
#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; \
|
| ︙ | ︙ |
Changes to generic/tclConfig.c.
| ︙ | ︙ | |||
75 76 77 78 79 80 81 |
const Tcl_Config *configuration, /* Embedded configuration. */
const char *valEncoding) /* Name of the encoding used to store the
* configuration values, ASCII, thus UTF-8. */
{
Tcl_Obj *pDB, *pkgDict;
Tcl_DString cmdName;
const Tcl_Config *cfg;
| | | | 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 |
const Tcl_Config *configuration, /* Embedded configuration. */
const char *valEncoding) /* Name of the encoding used to store the
* configuration values, ASCII, thus UTF-8. */
{
Tcl_Obj *pDB, *pkgDict;
Tcl_DString cmdName;
const Tcl_Config *cfg;
QCCD *cdPtr = Tcl_Alloc(sizeof(QCCD));
cdPtr->interp = interp;
if (valEncoding) {
cdPtr->encoding = Tcl_Alloc(strlen(valEncoding)+1);
strcpy(cdPtr->encoding, valEncoding);
} else {
cdPtr->encoding = NULL;
}
cdPtr->pkg = Tcl_NewStringObj(pkgName, -1);
/*
|
| ︙ | ︙ | |||
198 199 200 201 202 203 204 |
Tcl_Interp *interp,
int objc,
struct Tcl_Obj *const *objv)
{
QCCD *cdPtr = clientData;
Tcl_Obj *pkgName = cdPtr->pkg;
Tcl_Obj *pDB, *pkgDict, *val, *listPtr;
| > | | 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 |
Tcl_Interp *interp,
int objc,
struct Tcl_Obj *const *objv)
{
QCCD *cdPtr = clientData;
Tcl_Obj *pkgName = cdPtr->pkg;
Tcl_Obj *pDB, *pkgDict, *val, *listPtr;
size_t n = 0;
int index, m;
static const char *const subcmdStrings[] = {
"get", "list", NULL
};
enum subcmds {
CFG_GET, CFG_LIST
};
Tcl_DString conv;
|
| ︙ | ︙ | |||
257 258 259 260 261 262 263 | return TCL_ERROR; } } /* * Value is stored as-is in a byte array, see Bug [9b2e636361], * so we have to decode it first. */ | | | | | | 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 |
return TCL_ERROR;
}
}
/*
* Value is stored as-is in a byte array, see Bug [9b2e636361],
* so we have to decode it first.
*/
value = (const char *) TclGetByteArrayFromObj(val, &n);
value = Tcl_ExternalToUtfDString(venc, value, n, &conv);
Tcl_SetObjResult(interp, Tcl_NewStringObj(value,
Tcl_DStringLength(&conv)));
Tcl_DStringFree(&conv);
return TCL_OK;
case CFG_LIST:
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
Tcl_DictObjSize(interp, pkgDict, &m);
listPtr = Tcl_NewListObj(m, NULL);
if (!listPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"insufficient memory to create list", -1));
Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
return TCL_ERROR;
}
if (m) {
Tcl_DictSearch s;
Tcl_Obj *key;
int done;
for (Tcl_DictObjFirst(interp, pkgDict, &s, &key, NULL, &done);
!done; Tcl_DictObjNext(&s, &key, NULL, &done)) {
Tcl_ListObjAppendElement(NULL, listPtr, key);
|
| ︙ | ︙ | |||
329 330 331 332 333 334 335 |
QCCD *cdPtr = clientData;
Tcl_Obj *pkgName = cdPtr->pkg;
Tcl_Obj *pDB = GetConfigDict(cdPtr->interp);
Tcl_DictObjRemove(NULL, pDB, pkgName);
Tcl_DecrRefCount(pkgName);
if (cdPtr->encoding) {
| | | | 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 |
QCCD *cdPtr = 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);
}
Tcl_Free(cdPtr);
}
/*
*-------------------------------------------------------------------------
*
* GetConfigDict --
*
|
| ︙ | ︙ |
Changes to generic/tclDTrace.d.
| ︙ | ︙ | |||
178 179 180 181 182 183 184 |
void *freeIntRepProc;
void *dupIntRepProc;
void *updateStringProc;
void *setFromAnyProc;
} Tcl_ObjType;
struct Tcl_Obj {
| | | | 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 |
void *freeIntRepProc;
void *dupIntRepProc;
void *updateStringProc;
void *setFromAnyProc;
} Tcl_ObjType;
struct Tcl_Obj {
size_t refCount;
char *bytes;
size_t length;
Tcl_ObjType *typePtr;
union {
long longValue;
double doubleValue;
void *otherValuePtr;
int64_t wideValue;
struct {
|
| ︙ | ︙ |
Changes to generic/tclDate.c.
|
| | | < | | | | | < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 | /* A Bison parser, made by GNU Bison 3.1. */ /* Bison implementation for Yacc-like parsers in C Copyright (C) 1984, 1989-1990, 2000-2015, 2018 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see <http://www.gnu.org/licenses/>. */ /* As a special exception, you may create a larger work that contains part or all of the Bison parser skeleton and distribute that work under terms of your choice, so long as that work isn't itself a parser generator using the skeleton or a modified version thereof as a parser skeleton. Alternatively, if you modify or redistribute the parser skeleton itself, you may (at your option) remove this |
| ︙ | ︙ | |||
43 44 45 46 47 48 49 | define necessary library symbols; they are noted "INFRINGES ON USER NAME SPACE" below. */ /* Identify Bison output. */ #define YYBISON 1 /* Bison version. */ | | > > | > | > | | | < < | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < > | 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 | define necessary library symbols; they are noted "INFRINGES ON USER NAME SPACE" below. */ /* Identify Bison output. */ #define YYBISON 1 /* Bison version. */ #define YYBISON_VERSION "3.1" /* Skeleton name. */ #define YYSKELETON_NAME "yacc.c" /* Pure parsers. */ #define YYPURE 1 /* Push parsers. */ #define YYPUSH 0 /* Pull parsers. */ #define YYPULL 1 /* Substitute the variable and function names. */ #define yyparse TclDateparse #define yylex TclDatelex #define yyerror TclDateerror #define yydebug TclDatedebug #define yynerrs TclDatenerrs /* Copy the first part of user declarations. */ /* * tclDate.c -- * * This file is generated from a yacc grammar defined in the file * tclGetDate.y. It should not be edited directly. * * Copyright (c) 1992-1995 Karl Lehenbauer 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++ * doesn't like that, and complains. Tell it to shut up. */ |
| ︙ | ︙ | |||
181 182 183 184 185 186 187 |
const char *dateStart;
const char *dateInput;
time_t *dateRelPointer;
int dateDigitCount;
} DateInfo;
| | | | 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 |
const char *dateStart;
const char *dateInput;
time_t *dateRelPointer;
int dateDigitCount;
} DateInfo;
#define YYMALLOC Tcl_Alloc
#define YYFREE(x) (Tcl_Free((void*) (x)))
#define yyDSTmode (info->dateDSTmode)
#define yyDayOrdinal (info->dateDayOrdinal)
#define yyDayNumber (info->dateDayNumber)
#define yyMonthOrdinal (info->dateMonthOrdinal)
#define yyHaveDate (info->dateHaveDate)
#define yyHaveDay (info->dateHaveDay)
|
| ︙ | ︙ | |||
252 253 254 255 256 257 258 |
typedef enum _MERIDIAN {
MERam, MERpm, MER24
} MERIDIAN;
| | | > > > | > | | > > > > > > > > > | | > > > > > > > > > > > > > > > > > > > > > > | | | > | | > | < | | > | > | < > > > > > | 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 |
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 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. */
#if ! defined YYSTYPE && ! defined YYSTYPE_IS_DECLARED
union YYSTYPE
{
time_t Number;
enum _MERIDIAN Meridian;
};
typedef union YYSTYPE YYSTYPE;
# define YYSTYPE_IS_TRIVIAL 1
# define YYSTYPE_IS_DECLARED 1
#endif
/* Location type. */
#if ! defined YYLTYPE && ! defined YYLTYPE_IS_DECLARED
typedef struct YYLTYPE YYLTYPE;
struct YYLTYPE
{
int first_line;
int first_column;
int last_line;
int last_column;
};
# define YYLTYPE_IS_DECLARED 1
# define YYLTYPE_IS_TRIVIAL 1
#endif
int TclDateparse (DateInfo* info);
/* Copy the second part of user declarations. */
/*
|
| ︙ | ︙ | |||
318 319 320 321 322 323 324 | DateInfo* info); static time_t ToSeconds(time_t Hours, time_t Minutes, time_t Seconds, MERIDIAN Meridian); MODULE_SCOPE int yyparse(DateInfo*); | < < < < < | | | > > > > > | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > | | > | | > > > | > | > > | < < > | < | < > | < < < | < > | | | | | | | | | < | < | | | | | < < < < | < < < < < < < < < < < < | | | | | | | | | | > > > > > > > > > > > > > > > > > > > > | | > | | | > | 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 |
DateInfo* info);
static time_t ToSeconds(time_t Hours, time_t Minutes,
time_t Seconds, MERIDIAN Meridian);
MODULE_SCOPE int yyparse(DateInfo*);
#ifdef short
# undef short
#endif
#ifdef YYTYPE_UINT8
typedef YYTYPE_UINT8 yytype_uint8;
#else
typedef unsigned char yytype_uint8;
#endif
#ifdef YYTYPE_INT8
typedef YYTYPE_INT8 yytype_int8;
#else
typedef signed char yytype_int8;
#endif
#ifdef YYTYPE_UINT16
typedef YYTYPE_UINT16 yytype_uint16;
#else
typedef unsigned short yytype_uint16;
#endif
#ifdef YYTYPE_INT16
typedef YYTYPE_INT16 yytype_int16;
#else
typedef short 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 <stddef.h> /* INFRINGES ON USER NAME SPACE */
# define YYSIZE_T size_t
# else
# define YYSIZE_T unsigned
# endif
#endif
#define YYSIZE_MAXIMUM ((YYSIZE_T) -1)
#ifndef YY_
# if defined YYENABLE_NLS && YYENABLE_NLS
# if ENABLE_NLS
# include <libintl.h> /* INFRINGES ON USER NAME SPACE */
# define YY_(Msgid) dgettext ("bison-runtime", Msgid)
# endif
# endif
# ifndef YY_
# define YY_(Msgid) Msgid
# endif
#endif
#ifndef YY_ATTRIBUTE
# 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__))
# 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
#if ! defined yyoverflow || YYERROR_VERBOSE
/* The parser invokes alloca or malloc; define the necessary symbols. */
# ifdef YYSTACK_USE_ALLOCA
# if YYSTACK_USE_ALLOCA
# ifdef __GNUC__
# define YYSTACK_ALLOC __builtin_alloca
# elif defined __BUILTIN_VA_ARG_INCR
# include <alloca.h> /* INFRINGES ON USER NAME SPACE */
# elif defined _AIX
# define YYSTACK_ALLOC __alloca
# elif defined _MSC_VER
# include <malloc.h> /* INFRINGES ON USER NAME SPACE */
# define alloca _alloca
# else
# define YYSTACK_ALLOC alloca
# if ! defined _ALLOCA_H && ! defined EXIT_SUCCESS
# include <stdlib.h> /* INFRINGES ON USER NAME SPACE */
/* Use EXIT_SUCCESS as a witness for stdlib.h. */
# ifndef EXIT_SUCCESS
# define EXIT_SUCCESS 0
# endif
# endif
# endif
# endif
# endif
# ifdef YYSTACK_ALLOC
/* Pacify GCC's 'empty if-body' warning. */
# define YYSTACK_FREE(Ptr) do { /* empty */; } while (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. */
# define YYSTACK_ALLOC_MAXIMUM 4032 /* reasonable circa 2006 */
# endif
# else
# 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 \
&& ! ((defined YYMALLOC || defined malloc) \
&& (defined YYFREE || defined free)))
# include <stdlib.h> /* INFRINGES ON USER NAME SPACE */
# ifndef EXIT_SUCCESS
# define EXIT_SUCCESS 0
# endif
# endif
# ifndef YYMALLOC
# define YYMALLOC malloc
# if ! defined malloc && ! defined EXIT_SUCCESS
void *malloc (YYSIZE_T); /* INFRINGES ON USER NAME SPACE */
# endif
# endif
# ifndef YYFREE
# define YYFREE free
# if ! defined free && ! defined EXIT_SUCCESS
void free (void *); /* INFRINGES ON USER NAME SPACE */
# endif
# endif
# endif
#endif /* ! defined yyoverflow || YYERROR_VERBOSE */
#if (! defined yyoverflow \
&& (! defined __cplusplus \
|| (defined YYLTYPE_IS_TRIVIAL && YYLTYPE_IS_TRIVIAL \
&& defined YYSTYPE_IS_TRIVIAL && YYSTYPE_IS_TRIVIAL)))
/* A type that is properly aligned for any stack member. */
union yyalloc
{
yytype_int16 yyss_alloc;
YYSTYPE yyvs_alloc;
YYLTYPE yyls_alloc;
};
/* The size of the maximum gap between one aligned stack and the next. */
# define YYSTACK_GAP_MAXIMUM (sizeof (union yyalloc) - 1)
/* The size of an array large to enough to hold all stacks, each with
N elements. */
# define YYSTACK_BYTES(N) \
((N) * (sizeof (yytype_int16) + sizeof (YYSTYPE) + sizeof (YYLTYPE)) \
+ 2 * YYSTACK_GAP_MAXIMUM)
# define YYCOPY_NEEDED 1
/* Relocate STACK from its old location to the new one. The
local variables YYSIZE and YYSTACKSIZE give the old and new number of
elements in the stack, and YYPTR gives the new location of the
stack. Advance YYPTR to a properly aligned location for the next
stack. */
# define YYSTACK_RELOCATE(Stack_alloc, Stack) \
do \
{ \
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)
#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 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 83
/* YYTRANSLATE[YYX] -- Symbol number corresponding to YYX as returned
by yylex, with out-of-bounds checking. */
#define YYUNDEFTOK 2
#define YYMAXUTOK 274
#define YYTRANSLATE(YYX) \
((unsigned) (YYX) <= YYMAXUTOK ? yytranslate[YYX] : YYUNDEFTOK)
/* YYTRANSLATE[TOKEN-NUM] -- Symbol number corresponding to TOKEN-NUM
as returned by yylex, without out-of-bounds checking. */
static const yytype_uint8 yytranslate[] =
{
0, 2, 2, 2, 2, 2, 2, 2, 2, 2,
2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
2, 2, 2, 25, 22, 21, 24, 23, 2, 2,
|
| ︙ | ︙ | |||
582 583 584 585 586 587 588 |
2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
2, 2, 2, 2, 2, 2, 1, 2, 3, 4,
5, 6, 7, 8, 9, 10, 11, 12, 13, 14,
15, 16, 17, 18, 19
};
#if YYDEBUG
| | < | > | | < < < < < | < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < | | | | | > | > | | < < | | | < < | | > > | | | | | | > > > | | | | > > > > > > > | < < < < < < < < < < < < < < < < < < < < < < < | | < | < | 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 |
2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
2, 2, 2, 2, 2, 2, 1, 2, 3, 4,
5, 6, 7, 8, 9, 10, 11, 12, 13, 14,
15, 16, 17, 18, 19
};
#if YYDEBUG
/* YYRLINE[YYN] -- Source line where rule number YYN was defined. */
static const yytype_uint16 yyrline[] =
{
0, 223, 223, 224, 227, 230, 233, 236, 239, 242,
245, 249, 254, 257, 263, 269, 277, 283, 294, 298,
302, 308, 312, 316, 320, 324, 330, 334, 339, 344,
349, 354, 358, 363, 367, 372, 379, 383, 389, 398,
407, 417, 431, 436, 439, 442, 445, 448, 451, 456,
459, 464, 468, 472, 478, 496, 499
};
#endif
#if YYDEBUG || YYERROR_VERBOSE || 0
/* YYTNAME[SYMBOL-NUM] -- String name of the symbol SYMBOL-NUM.
First, the terminals, then, starting at YYNTOKENS, nonterminals. */
static const char *const yytname[] =
{
"$end", "error", "$undefined", "tAGO", "tDAY", "tDAYZONE", "tID",
"tMERIDIAN", "tMONTH", "tMONTH_UNIT", "tSTARDATE", "tSEC_UNIT",
"tSNUMBER", "tUNUMBER", "tZONE", "tEPOCH", "tDST", "tISOBASE",
"tDAY_UNIT", "tNEXT", "':'", "'-'", "','", "'/'", "'.'", "'+'",
"$accept", "spec", "item", "time", "zone", "day", "date", "ordMonth",
"iso", "trek", "relspec", "relunits", "sign", "unit", "number",
"o_merid", YY_NULLPTR
};
#endif
# ifdef YYPRINT
/* YYTOKNUM[NUM] -- (External) token number corresponding to the
(internal) symbol number NUM (which must be that of a token). */
static const yytype_uint16 yytoknum[] =
{
0, 256, 257, 258, 259, 260, 261, 262, 263, 264,
265, 266, 267, 268, 269, 270, 271, 272, 273, 274,
58, 45, 44, 47, 46, 43
};
# endif
#define YYPACT_NINF -22
#define yypact_value_is_default(Yystate) \
(!!((Yystate) == (-22)))
#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[] =
{
-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
};
/* YYDEFACT[STATE-NUM] -- Default reduction number in state STATE-NUM.
Performed when YYTABLE does not specify something else to do. Zero
means the default is an error. */
static const yytype_uint8 yydefact[] =
{
2, 0, 1, 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,
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
};
/* YYPGOTO[NTERM-NUM]. */
static const yytype_int8 yypgoto[] =
{
-22, -22, -22, -22, -22, -22, -22, -22, -22, -22,
-22, -22, -22, -9, -22, 6
};
/* YYDEFGOTO[NTERM-NUM]. */
static const yytype_int8 yydefgoto[] =
{
-1, 1, 17, 18, 19, 20, 21, 22, 23, 24,
25, 26, 27, 28, 29, 67
};
/* YYTABLE[YYPACT[STATE-NUM]] -- What to do in state STATE-NUM. If
positive, shift that token. If negative, reduce the rule whose
number is the opposite. If YYTABLE_NINF, syntax error. */
static const yytype_uint8 yytable[] =
{
39, 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,
|
| ︙ | ︙ | |||
752 753 754 755 756 757 758 |
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
};
| | | > > > > > > > > > > > > > > > > > > > > > > > | | | | | | | < < < < < < | | | | | | < | > | | | | | | | | | | < | < > | < > | | | | < > | < > | | | | < > | | < < < < < < < < < < < < < < < < < < < < < < | | | | | | | | > | | > | > | > > > > > > > > | < > > > | > > > > > > | > > | > > > > > > > > > > > > > > > > > > > > > > > > | | | < < < < < < > | | < | | < < < < < < | < < < < < < < < < < < < < < < < | < | < < | < < < < < < | > > | > | | | | | < < | < < < < < < < < > < | | | > | | | | | | | | | < < < < < < < < < < < < < < < < | 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 |
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. */
static const yytype_uint8 yystos[] =
{
0, 27, 0, 4, 5, 8, 9, 10, 11, 13,
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
};
/* 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 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, 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
};
#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
#define YYRECOVERING() (!!yyerrstatus)
#define YYBACKUP(Token, Value) \
do \
if (yychar == YYEMPTY) \
{ \
yychar = (Token); \
yylval = (Value); \
YYPOPSTACK (yylen); \
yystate = *yyssp; \
goto yybackup; \
} \
else \
{ \
yyerror (&yylloc, info, YY_("syntax error: cannot back up")); \
YYERROR; \
} \
while (0)
/* Error token number */
#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). */
#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)
#endif
#define YYRHSLOC(Rhs, K) ((Rhs)[K])
/* Enable debugging if requested. */
#if YYDEBUG
# ifndef YYFPRINTF
# include <stdio.h> /* 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. |
`----------------------------------------*/
static void
yy_symbol_value_print (FILE *yyoutput, int yytype, YYSTYPE const * const yyvaluep, YYLTYPE const * const yylocationp, DateInfo* info)
{
FILE *yyo = yyoutput;
YYUSE (yyo);
YYUSE (yylocationp);
YYUSE (info);
if (!yyvaluep)
return;
# ifdef YYPRINT
if (yytype < YYNTOKENS)
YYPRINT (yyoutput, yytoknum[yytype], *yyvaluep);
# endif
YYUSE (yytype);
}
/*--------------------------------.
| Print this symbol on YYOUTPUT. |
`--------------------------------*/
static void
yy_symbol_print (FILE *yyoutput, int yytype, YYSTYPE const * const yyvaluep, YYLTYPE const * const yylocationp, DateInfo* info)
{
YYFPRINTF (yyoutput, "%s %s (",
yytype < YYNTOKENS ? "token" : "nterm", yytname[yytype]);
YY_LOCATION_PRINT (yyoutput, *yylocationp);
YYFPRINTF (yyoutput, ": ");
yy_symbol_value_print (yyoutput, yytype, yyvaluep, yylocationp, info);
YYFPRINTF (yyoutput, ")");
}
/*------------------------------------------------------------------.
| yy_stack_print -- Print the state stack from its BOTTOM up to its |
| TOP (included). |
`------------------------------------------------------------------*/
static void
yy_stack_print (yytype_int16 *yybottom, yytype_int16 *yytop)
{
YYFPRINTF (stderr, "Stack now");
for (; yybottom <= yytop; yybottom++)
{
int yybot = *yybottom;
YYFPRINTF (stderr, " %d", yybot);
}
YYFPRINTF (stderr, "\n");
}
# define YY_STACK_PRINT(Bottom, Top) \
do { \
if (yydebug) \
yy_stack_print ((Bottom), (Top)); \
} while (0)
/*------------------------------------------------.
| Report that the YYRULE is going to be reduced. |
`------------------------------------------------*/
static void
yy_reduce_print (yytype_int16 *yyssp, YYSTYPE *yyvsp, YYLTYPE *yylsp, int yyrule, DateInfo* info)
{
unsigned long yylno = yyrline[yyrule];
int yynrhs = yyr2[yyrule];
int yyi;
YYFPRINTF (stderr, "Reducing stack by rule %d (line %lu):\n",
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");
}
}
# define YY_REDUCE_PRINT(Rule) \
do { \
if (yydebug) \
yy_reduce_print (yyssp, yyvsp, yylsp, Rule, info); \
} while (0)
/* Nonzero means print parse trace. It is left uninitialized so that
multiple parsers can coexist. */
int yydebug;
#else /* !YYDEBUG */
# define YYDPRINTF(Args)
# define YY_SYMBOL_PRINT(Title, Type, Value, Location)
# define YY_STACK_PRINT(Bottom, Top)
# define YY_REDUCE_PRINT(Rule)
#endif /* !YYDEBUG */
/* YYINITDEPTH -- initial size of the parser's stacks. */
#ifndef YYINITDEPTH
# define YYINITDEPTH 200
#endif
/* YYMAXDEPTH -- maximum size the stacks can grow to (effective only
if the built-in stack extension method is used).
Do not make this value too large; the results are undefined if
YYSTACK_ALLOC_MAXIMUM < YYSTACK_BYTES (YYMAXDEPTH)
evaluated with infinite-precision integer arithmetic. */
#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. */
static YYSIZE_T
yystrlen (const char *yystr)
{
YYSIZE_T yylen;
for (yylen = 0; yystr[yylen]; yylen++)
continue;
return yylen;
}
# endif
# endif
# ifndef yystpcpy
# 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. */
static char *
yystpcpy (char *yydest, const char *yysrc)
{
char *yyd = yydest;
const char *yys = yysrc;
while ((*yyd++ = *yys++) != '\0')
continue;
|
| ︙ | ︙ | |||
1116 1117 1118 1119 1120 1121 1122 |
{
if (*yystr == '"')
{
YYSIZE_T yyn = 0;
char const *yyp = yystr;
for (;;)
| | | | | | | | | | | | | | | | | | | | > | < | | | > | | | | < < | < < < | < | | < < | > > > | > > | > > | | > > > > | | | | | | | | | | | | | | > | > | | > | | | > | < | | | | < < < | | > | | | | | < | | | > | > | > | < < | | > > | | < > > > | > > > > > > > > > | | > | > > > | | > | > > > > > > > | | | > | | | < | | | | | | | | | | | < | < < < < < < < < < < < < < < < < < | < < < < | | < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | > | > > > | > > > > > > > > | | | > > > > > > > > > > > > > > > > > > > > > > > > | > > > > | > < < | > > > > > < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < > > > > > | < < < < < < < < | < < < < < < | | | | | | | | | | | | | | | > | | | | | | | | | | | | | | | | | > > > | | | | | | | 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 |
{
if (*yystr == '"')
{
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;
}
do_not_strip_quotes: ;
}
if (! yyres)
return yystrlen (yystr);
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;
}
#endif /* YYERROR_VERBOSE */
/*-----------------------------------------------.
| Release the memory associated to this symbol. |
`-----------------------------------------------*/
static void
yydestruct (const char *yymsg, int yytype, YYSTYPE *yyvaluep, YYLTYPE *yylocationp, DateInfo* info)
{
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
}
/*----------.
| yyparse. |
`----------*/
int
yyparse (DateInfo* info)
{
/* The lookahead 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;
int yyn;
int yyresult;
/* Lookahead 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
#define YYPOPSTACK(N) (yyvsp -= (N), yyssp -= (N), yylsp -= (N))
/* The number of symbols on the RHS of the reduced rule.
Keep to zero when no symbol should be popped. */
int yylen = 0;
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;
goto yysetstate;
/*------------------------------------------------------------.
| yynewstate -- Push a new state, which is found in yystate. |
`------------------------------------------------------------*/
yynewstate:
/* In all cases, when you get here, the value and location stacks
have just been pushed. So pushing a state here evens the stacks. */
yyssp++;
yysetstate:
*yyssp = yystate;
if (yyss + yystacksize - 1 <= yyssp)
{
/* 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;
}
#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);
}
# 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));
if (yyss + yystacksize - 1 <= yyssp)
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. */
/* First try to decide what to do without reference to lookahead token. */
yyn = yypact[yystate];
if (yypact_value_is_default (yyn))
goto yydefault;
/* Not known => get a lookahead token if don't already have one. */
/* YYCHAR is either YYEMPTY or YYEOF or a valid lookahead symbol. */
if (yychar == YYEMPTY)
{
YYDPRINTF ((stderr, "Reading a token: "));
yychar = yylex (&yylval, &yylloc, info);
}
if (yychar <= YYEOF)
{
yychar = yytoken = YYEOF;
YYDPRINTF ((stderr, "Now at end of input.\n"));
}
|
| ︙ | ︙ | |||
1547 1548 1549 1550 1551 1552 1553 |
detect an error, take that action. */
yyn += yytoken;
if (yyn < 0 || YYLAST < yyn || yycheck[yyn] != yytoken)
goto yydefault;
yyn = yytable[yyn];
if (yyn <= 0)
{
| | | < < < | | < | > > | 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 |
detect an error, take that action. */
yyn += yytoken;
if (yyn < 0 || YYLAST < yyn || yycheck[yyn] != yytoken)
goto yydefault;
yyn = yytable[yyn];
if (yyn <= 0)
{
if (yytable_value_is_error (yyn))
goto yyerrlab;
yyn = -yyn;
goto yyreduce;
}
/* Count tokens shifted since error; after three, turn off error
status. */
if (yyerrstatus)
yyerrstatus--;
/* Shift the lookahead token. */
YY_SYMBOL_PRINT ("Shifting", yytoken, &yylval, &yylloc);
/* Discard the shifted token. */
yychar = YYEMPTY;
yystate = yyn;
YY_IGNORE_MAYBE_UNINITIALIZED_BEGIN
*++yyvsp = yylval;
YY_IGNORE_MAYBE_UNINITIALIZED_END
*++yylsp = yylloc;
goto yynewstate;
/*-----------------------------------------------------------.
| yydefault -- do the default action for the current state. |
`-----------------------------------------------------------*/
|
| ︙ | ︙ | |||
1592 1593 1594 1595 1596 1597 1598 | | yyreduce -- Do a reduction. | `-----------------------------*/ yyreduce: /* yyn is the number of a rule to reduce with. */ yylen = yyr2[yyn]; /* If YYLEN is nonzero, implement the default value of the action: | | | > > | > | > | > | > | > | > | > | | | > | | | | > | | | | > | | | | | > | | | | | > | | > | | > | | > | | > | | > | | | > | | | > | | > | | | > | | | | > | | | | > | | | | > | | | | > | | | > | | | | > | | | > | > | | | | > | | > | | | > | | | | | | | | > | | | | | | | | > | | | | | | | > | | | | > | > | | > | | > | | > | | > | | > | > | > | | > | | > | | > | | | | | > | > | | > | < > > > > > > > > > > > | | | | > > > > > > > | > | > > | < < < | | | | < < | | | > | < | < | | | | < < > | | | | < > | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | < < | > | | | | 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 |
| yyreduce -- Do a reduction. |
`-----------------------------*/
yyreduce:
/* yyn is the number of a rule to reduce with. */
yylen = yyr2[yyn];
/* If YYLEN is nonzero, implement the default value of the action:
'$$ = $1'.
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. */
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);
yyMinutes = 0;
yySeconds = 0;
yyMeridian = (yyvsp[0].Meridian);
}
break;
case 14:
{
yyHour = (yyvsp[-3].Number);
yyMinutes = (yyvsp[-1].Number);
yySeconds = 0;
yyMeridian = (yyvsp[0].Meridian);
}
break;
case 15:
{
yyHour = (yyvsp[-4].Number);
yyMinutes = (yyvsp[-2].Number);
yyMeridian = MER24;
yyDSTmode = DSToff;
yyTimezone = ((yyvsp[0].Number) % 100 + ((yyvsp[0].Number) / 100) * 60);
++yyHaveZone;
}
break;
case 16:
{
yyHour = (yyvsp[-5].Number);
yyMinutes = (yyvsp[-3].Number);
yySeconds = (yyvsp[-1].Number);
yyMeridian = (yyvsp[0].Meridian);
}
break;
case 17:
{
yyHour = (yyvsp[-6].Number);
yyMinutes = (yyvsp[-4].Number);
yySeconds = (yyvsp[-2].Number);
yyMeridian = MER24;
yyDSTmode = DSToff;
yyTimezone = ((yyvsp[0].Number) % 100 + ((yyvsp[0].Number) / 100) * 60);
++yyHaveZone;
}
break;
case 18:
{
yyTimezone = (yyvsp[-1].Number);
yyDSTmode = DSTon;
}
break;
case 19:
{
yyTimezone = (yyvsp[0].Number);
yyDSTmode = DSToff;
}
break;
case 20:
{
yyTimezone = (yyvsp[0].Number);
yyDSTmode = DSTon;
}
break;
case 21:
{
yyDayOrdinal = 1;
yyDayNumber = (yyvsp[0].Number);
}
break;
case 22:
{
yyDayOrdinal = 1;
yyDayNumber = (yyvsp[-1].Number);
}
break;
case 23:
{
yyDayOrdinal = (yyvsp[-1].Number);
yyDayNumber = (yyvsp[0].Number);
}
break;
case 24:
{
yyDayOrdinal = (yyvsp[-2].Number) * (yyvsp[-1].Number);
yyDayNumber = (yyvsp[0].Number);
}
break;
case 25:
{
yyDayOrdinal = 2;
yyDayNumber = (yyvsp[0].Number);
}
break;
case 26:
{
yyMonth = (yyvsp[-2].Number);
yyDay = (yyvsp[0].Number);
}
break;
case 27:
{
yyMonth = (yyvsp[-4].Number);
yyDay = (yyvsp[-2].Number);
yyYear = (yyvsp[0].Number);
}
break;
case 28:
{
yyYear = (yyvsp[0].Number) / 10000;
yyMonth = ((yyvsp[0].Number) % 10000)/100;
yyDay = (yyvsp[0].Number) % 100;
}
break;
case 29:
{
yyDay = (yyvsp[-4].Number);
yyMonth = (yyvsp[-2].Number);
yyYear = (yyvsp[0].Number);
}
break;
case 30:
{
yyMonth = (yyvsp[-2].Number);
yyDay = (yyvsp[0].Number);
yyYear = (yyvsp[-4].Number);
}
break;
case 31:
{
yyMonth = (yyvsp[-1].Number);
yyDay = (yyvsp[0].Number);
}
break;
case 32:
{
yyMonth = (yyvsp[-3].Number);
yyDay = (yyvsp[-2].Number);
yyYear = (yyvsp[0].Number);
}
break;
case 33:
{
yyMonth = (yyvsp[0].Number);
yyDay = (yyvsp[-1].Number);
}
break;
case 34:
{
yyMonth = 1;
yyDay = 1;
yyYear = EPOCH;
}
break;
case 35:
{
yyMonth = (yyvsp[-1].Number);
yyDay = (yyvsp[-2].Number);
yyYear = (yyvsp[0].Number);
}
break;
case 36:
{
yyMonthOrdinal = 1;
yyMonth = (yyvsp[0].Number);
}
break;
case 37:
{
yyMonthOrdinal = (yyvsp[-1].Number);
yyMonth = (yyvsp[0].Number);
}
break;
case 38:
{
if ((yyvsp[-1].Number) != HOUR( 7)) YYABORT;
yyYear = (yyvsp[-2].Number) / 10000;
yyMonth = ((yyvsp[-2].Number) % 10000)/100;
yyDay = (yyvsp[-2].Number) % 100;
yyHour = (yyvsp[0].Number) / 10000;
yyMinutes = ((yyvsp[0].Number) % 10000)/100;
yySeconds = (yyvsp[0].Number) % 100;
}
break;
case 39:
{
if ((yyvsp[-5].Number) != HOUR( 7)) 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);
}
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;
}
break;
case 41:
{
/*
* Offset computed year by -377 so that the returned years will be
* in a range accessible with a 32 bit clock seconds value.
*/
yyYear = (yyvsp[-2].Number)/1000 + 2323 - 377;
yyDay = 1;
yyMonth = 1;
yyRelDay += (((yyvsp[-2].Number)%1000)*(365 + IsLeapYear(yyYear)))/1000;
yyRelSeconds += (yyvsp[0].Number) * 144 * 60;
}
break;
case 42:
{
yyRelSeconds *= -1;
yyRelMonth *= -1;
yyRelDay *= -1;
}
break;
case 44:
{
*yyRelPointer += (yyvsp[-2].Number) * (yyvsp[-1].Number) * (yyvsp[0].Number);
}
break;
case 45:
{
*yyRelPointer += (yyvsp[-1].Number) * (yyvsp[0].Number);
}
break;
case 46:
{
*yyRelPointer += (yyvsp[0].Number);
}
break;
case 47:
{
*yyRelPointer += (yyvsp[-1].Number) * (yyvsp[0].Number);
}
break;
case 48:
{
*yyRelPointer += (yyvsp[0].Number);
}
break;
case 49:
{
(yyval.Number) = -1;
}
break;
case 50:
{
(yyval.Number) = 1;
}
break;
case 51:
{
(yyval.Number) = (yyvsp[0].Number);
yyRelPointer = &yyRelSeconds;
}
break;
case 52:
{
(yyval.Number) = (yyvsp[0].Number);
yyRelPointer = &yyRelDay;
}
break;
case 53:
{
(yyval.Number) = (yyvsp[0].Number);
yyRelPointer = &yyRelMonth;
}
break;
case 54:
{
if (yyHaveTime && yyHaveDate && !yyHaveRel) {
yyYear = (yyvsp[0].Number);
} else {
yyHaveTime++;
if (yyDigitCount <= 2) {
yyHour = (yyvsp[0].Number);
yyMinutes = 0;
} else {
yyHour = (yyvsp[0].Number) / 100;
yyMinutes = (yyvsp[0].Number) % 100;
}
yySeconds = 0;
yyMeridian = MER24;
}
}
break;
case 55:
{
(yyval.Meridian) = MER24;
}
break;
case 56:
{
(yyval.Meridian) = (yyvsp[0].Meridian);
}
break;
default: break;
}
/* User semantic actions sometimes alter yychar, and that requires
that yytoken be updated with the new translation. We take the
approach of translating immediately before every use of yytoken.
One alternative is translating here after every semantic action,
but that translation would be missed if the semantic action invokes
YYABORT, YYACCEPT, or YYERROR immediately after altering yychar or
if it invokes YYBACKUP. In the case of YYABORT or YYACCEPT, an
incorrect destructor might then be invoked immediately. In the
case of YYERROR or YYBACKUP, subsequent parser actions might lead
to an incorrect destructor call or verbose syntax error message
before the lookahead is translated. */
YY_SYMBOL_PRINT ("-> $$ =", 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
that goes to, based on the state we popped back to and the rule
number reduced by. */
yyn = yyr1[yyn];
yystate = yypgoto[yyn - YYNTOKENS] + *yyssp;
if (0 <= yystate && yystate <= YYLAST && yycheck[yystate] == *yyssp)
yystate = yytable[yystate];
else
yystate = yydefgoto[yyn - YYNTOKENS];
goto yynewstate;
/*--------------------------------------.
| yyerrlab -- here on detecting error. |
`--------------------------------------*/
yyerrlab:
/* Make sure we have latest lookahead translation. See comments at
user semantic actions for why this is necessary. */
yytoken = yychar == YYEMPTY ? 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
#endif
}
yyerror_range[1] = yylloc;
if (yyerrstatus == 3)
{
/* If just tried and failed to reuse lookahead token after an
error, discard it. */
if (yychar <= YYEOF)
{
/* Return failure if at end of input. */
if (yychar == YYEOF)
YYABORT;
}
else
{
yydestruct ("Error: discarding",
yytoken, &yylval, &yylloc, info);
yychar = YYEMPTY;
}
}
/* Else will try to reuse lookahead token after shifting the error
token. */
goto yyerrlab1;
/*---------------------------------------------------.
| yyerrorlab -- error raised explicitly by YYERROR. |
`---------------------------------------------------*/
yyerrorlab:
/* Pacify compilers like GCC when the user code never invokes
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
this YYERROR. */
YYPOPSTACK (yylen);
yylen = 0;
YY_STACK_PRINT (yyss, yyssp);
yystate = *yyssp;
goto yyerrlab1;
/*-------------------------------------------------------------.
| yyerrlab1 -- common code for both syntax error and YYERROR. |
`-------------------------------------------------------------*/
yyerrlab1:
yyerrstatus = 3; /* Each real token shifted decrements this. */
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;
}
}
/* Pop the current state because it cannot handle the error token. */
if (yyssp == yyss)
YYABORT;
yyerror_range[1] = *yylsp;
yydestruct ("Error: popping",
yystos[yystate], yyvsp, yylsp, info);
YYPOPSTACK (1);
yystate = *yyssp;
YY_STACK_PRINT (yyss, yyssp);
}
YY_IGNORE_MAYBE_UNINITIALIZED_BEGIN
*++yyvsp = yylval;
YY_IGNORE_MAYBE_UNINITIALIZED_END
yyerror_range[2] = yylloc;
/* Using YYLLOC is tempting, but would change the location of
the lookahead. YYLOC is available though. */
YYLLOC_DEFAULT (yyloc, yyerror_range, 2);
*++yylsp = yyloc;
/* Shift the error token. */
YY_SYMBOL_PRINT ("Shifting", yystos[yyn], yyvsp, yylsp);
yystate = yyn;
goto yynewstate;
|
| ︙ | ︙ | |||
2242 2243 2244 2245 2246 2247 2248 | /*-----------------------------------. | yyabortlab -- YYABORT comes here. | `-----------------------------------*/ yyabortlab: yyresult = 1; goto yyreturn; | | | > > > > | | > | | < | < < | 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 |
/*-----------------------------------.
| yyabortlab -- YYABORT comes here. |
`-----------------------------------*/
yyabortlab:
yyresult = 1;
goto yyreturn;
#if !defined yyoverflow || YYERROR_VERBOSE
/*-------------------------------------------------.
| yyexhaustedlab -- memory exhaustion comes here. |
`-------------------------------------------------*/
yyexhaustedlab:
yyerror (&yylloc, info, YY_("memory exhausted"));
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
this YYABORT or YYACCEPT. */
YYPOPSTACK (yylen);
YY_STACK_PRINT (yyss, yyssp);
while (yyssp != yyss)
{
yydestruct ("Cleanup: popping",
yystos[*yyssp], yyvsp, yylsp, info);
YYPOPSTACK (1);
}
#ifndef yyoverflow
if (yyss != yyssa)
YYSTACK_FREE (yyss);
#endif
#if YYERROR_VERBOSE
if (yymsg != yymsgbuf)
YYSTACK_FREE (yymsg);
#endif
return yyresult;
}
/*
* Month and day table.
*/
static const TABLE MonthDayTable[] = {
|
| ︙ | ︙ | |||
2676 2677 2678 2679 2680 2681 2682 |
register char c;
register char *p;
char buff[20];
int Count;
location->first_column = yyInput - info->dateStart;
for ( ; ; ) {
| | | 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 |
register char c;
register char *p;
char buff[20];
int Count;
location->first_column = yyInput - info->dateStart;
for ( ; ; ) {
while (TclIsSpaceProc(UCHAR(*yyInput))) {
yyInput++;
}
if (isdigit(UCHAR(c = *yyInput))) { /* INTL: digit */
/*
* Convert the string into a number; count the number of digits.
*/
|
| ︙ | ︙ | |||
2739 2740 2741 2742 2743 2744 2745 |
}
} while (Count > 0);
}
}
int
TclClockOldscanObjCmd(
| | | | 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 |
}
} while (Count > 0);
}
}
int
TclClockOldscanObjCmd(
void *clientData, /* Unused */
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Count of paraneters */
Tcl_Obj *const *objv) /* Parameters */
{
Tcl_Obj *result, *resultElement;
int yr, mo, da;
DateInfo dateInfo;
DateInfo* info = &dateInfo;
int status;
if (objc != 5) {
Tcl_WrongNumArgs(interp, 1, objv,
"stringToParse baseYear baseMonth baseDay" );
return TCL_ERROR;
}
yyInput = TclGetString(objv[1]);
dateInfo.dateStart = yyInput;
yyHaveDate = 0;
if (Tcl_GetIntFromObj(interp, objv[2], &yr) != TCL_OK
|| Tcl_GetIntFromObj(interp, objv[3], &mo) != TCL_OK
|| Tcl_GetIntFromObj(interp, objv[4], &da) != TCL_OK) {
return TCL_ERROR;
|
| ︙ | ︙ | |||
2843 2844 2845 2846 2847 2848 2849 |
return TCL_ERROR;
}
result = Tcl_NewObj();
resultElement = Tcl_NewObj();
if (yyHaveDate) {
Tcl_ListObjAppendElement(interp, resultElement,
| | | | | | | | | | | | | < | 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 |
return TCL_ERROR;
}
result = Tcl_NewObj();
resultElement = Tcl_NewObj();
if (yyHaveDate) {
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj(yyYear));
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj(yyMonth));
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj(yyDay));
}
Tcl_ListObjAppendElement(interp, result, resultElement);
if (yyHaveTime) {
Tcl_ListObjAppendElement(interp, result, Tcl_NewIntObj(
ToSeconds(yyHour, yyMinutes, yySeconds, yyMeridian)));
} else {
Tcl_ListObjAppendElement(interp, result, Tcl_NewObj());
}
resultElement = Tcl_NewObj();
if (yyHaveZone) {
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj(-yyTimezone));
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj(1 - yyDSTmode));
}
Tcl_ListObjAppendElement(interp, result, resultElement);
resultElement = Tcl_NewObj();
if (yyHaveRel) {
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj(yyRelMonth));
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj(yyRelDay));
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj(yyRelSeconds));
}
Tcl_ListObjAppendElement(interp, result, resultElement);
resultElement = Tcl_NewObj();
if (yyHaveDay && !yyHaveDate) {
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj(yyDayOrdinal));
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj(yyDayNumber));
}
Tcl_ListObjAppendElement(interp, result, resultElement);
resultElement = Tcl_NewObj();
if (yyHaveOrdinalMonth) {
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj(yyMonthOrdinal));
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj(yyMonth));
}
Tcl_ListObjAppendElement(interp, result, resultElement);
Tcl_SetObjResult(interp, result);
return TCL_OK;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclDecls.h.
| ︙ | ︙ | |||
43 44 45 46 47 48 49 | /* 1 */ TCLAPI const char * Tcl_PkgRequireEx(Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr); /* 2 */ TCLAPI TCL_NORETURN void Tcl_Panic(const char *format, ...) TCL_FORMAT_PRINTF(1, 2); /* 3 */ | | | | | | | | | | 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 | /* 1 */ TCLAPI const char * Tcl_PkgRequireEx(Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr); /* 2 */ TCLAPI TCL_NORETURN void Tcl_Panic(const char *format, ...) TCL_FORMAT_PRINTF(1, 2); /* 3 */ TCLAPI void * Tcl_Alloc(size_t size); /* 4 */ TCLAPI void Tcl_Free(void *ptr); /* 5 */ TCLAPI void * Tcl_Realloc(void *ptr, size_t size); /* 6 */ TCLAPI void * Tcl_DbCkalloc(size_t size, const char *file, int line); /* 7 */ TCLAPI void Tcl_DbCkfree(void *ptr, const char *file, int line); /* 8 */ TCLAPI void * Tcl_DbCkrealloc(void *ptr, size_t size, const char *file, int line); #if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ /* 9 */ TCLAPI void Tcl_CreateFileHandler(int fd, int mask, Tcl_FileProc *proc, void *clientData); #endif /* UNIX */ #ifdef MAC_OSX_TCL /* MACOSX */ /* 9 */ TCLAPI void Tcl_CreateFileHandler(int fd, int mask, Tcl_FileProc *proc, void *clientData); #endif /* MACOSX */ #if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ /* 10 */ TCLAPI void Tcl_DeleteFileHandler(int fd); #endif /* UNIX */ #ifdef MAC_OSX_TCL /* MACOSX */ /* 10 */ |
| ︙ | ︙ | |||
87 88 89 90 91 92 93 | /* 14 */ TCLAPI int Tcl_AppendAllObjTypes(Tcl_Interp *interp, Tcl_Obj *objPtr); /* 15 */ TCLAPI void Tcl_AppendStringsToObj(Tcl_Obj *objPtr, ...); /* 16 */ TCLAPI void Tcl_AppendToObj(Tcl_Obj *objPtr, const char *bytes, | | | | | < | 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 | /* 14 */ TCLAPI int Tcl_AppendAllObjTypes(Tcl_Interp *interp, Tcl_Obj *objPtr); /* 15 */ TCLAPI void Tcl_AppendStringsToObj(Tcl_Obj *objPtr, ...); /* 16 */ TCLAPI void Tcl_AppendToObj(Tcl_Obj *objPtr, const char *bytes, size_t length); /* 17 */ TCLAPI Tcl_Obj * Tcl_ConcatObj(int objc, Tcl_Obj *const objv[]); /* 18 */ TCLAPI int Tcl_ConvertToType(Tcl_Interp *interp, Tcl_Obj *objPtr, const Tcl_ObjType *typePtr); /* 19 */ TCLAPI void Tcl_DbDecrRefCount(Tcl_Obj *objPtr, const char *file, int line); /* 20 */ TCLAPI void Tcl_DbIncrRefCount(Tcl_Obj *objPtr, const char *file, int line); /* 21 */ TCLAPI int Tcl_DbIsShared(Tcl_Obj *objPtr, const char *file, int line); /* Slot 22 is reserved */ /* 23 */ TCLAPI Tcl_Obj * Tcl_DbNewByteArrayObj(const unsigned char *bytes, size_t length, const char *file, int line); /* 24 */ TCLAPI Tcl_Obj * Tcl_DbNewDoubleObj(double doubleValue, const char *file, int line); /* 25 */ TCLAPI Tcl_Obj * Tcl_DbNewListObj(int objc, Tcl_Obj *const *objv, const char *file, int line); /* Slot 26 is reserved */ /* 27 */ TCLAPI Tcl_Obj * Tcl_DbNewObj(const char *file, int line); /* 28 */ TCLAPI Tcl_Obj * Tcl_DbNewStringObj(const char *bytes, size_t length, const char *file, int line); /* 29 */ TCLAPI Tcl_Obj * Tcl_DuplicateObj(Tcl_Obj *objPtr); /* Slot 30 is reserved */ /* 31 */ TCLAPI int Tcl_GetBoolean(Tcl_Interp *interp, const char *src, int *boolPtr); /* 32 */ TCLAPI int Tcl_GetBooleanFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int *boolPtr); /* 33 */ |
| ︙ | ︙ | |||
177 178 179 180 181 182 183 | /* 48 */ TCLAPI int Tcl_ListObjReplace(Tcl_Interp *interp, Tcl_Obj *listPtr, int first, int count, int objc, Tcl_Obj *const objv[]); /* Slot 49 is reserved */ /* 50 */ TCLAPI Tcl_Obj * Tcl_NewByteArrayObj(const unsigned char *bytes, | | | | > | | | | | < | < | | | | | | | | | | | | | | < | | | | | | < | < | | > | | 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 | /* 48 */ TCLAPI int Tcl_ListObjReplace(Tcl_Interp *interp, Tcl_Obj *listPtr, int first, int count, int objc, Tcl_Obj *const objv[]); /* Slot 49 is reserved */ /* 50 */ TCLAPI Tcl_Obj * Tcl_NewByteArrayObj(const unsigned char *bytes, size_t length); /* 51 */ TCLAPI Tcl_Obj * Tcl_NewDoubleObj(double doubleValue); /* Slot 52 is reserved */ /* 53 */ TCLAPI Tcl_Obj * Tcl_NewListObj(int objc, Tcl_Obj *const objv[]); /* Slot 54 is reserved */ /* 55 */ TCLAPI Tcl_Obj * Tcl_NewObj(void); /* 56 */ TCLAPI Tcl_Obj * Tcl_NewStringObj(const char *bytes, size_t length); /* Slot 57 is reserved */ /* 58 */ TCLAPI unsigned char * Tcl_SetByteArrayLength(Tcl_Obj *objPtr, size_t length); /* 59 */ TCLAPI void Tcl_SetByteArrayObj(Tcl_Obj *objPtr, const unsigned char *bytes, size_t length); /* 60 */ TCLAPI void Tcl_SetDoubleObj(Tcl_Obj *objPtr, double doubleValue); /* Slot 61 is reserved */ /* 62 */ TCLAPI void Tcl_SetListObj(Tcl_Obj *objPtr, int objc, Tcl_Obj *const objv[]); /* Slot 63 is reserved */ /* 64 */ TCLAPI void Tcl_SetObjLength(Tcl_Obj *objPtr, size_t length); /* 65 */ TCLAPI void Tcl_SetStringObj(Tcl_Obj *objPtr, const char *bytes, size_t length); /* Slot 66 is reserved */ /* Slot 67 is reserved */ /* 68 */ TCLAPI void Tcl_AllowExceptions(Tcl_Interp *interp); /* 69 */ TCLAPI void Tcl_AppendElement(Tcl_Interp *interp, const char *element); /* 70 */ TCLAPI void Tcl_AppendResult(Tcl_Interp *interp, ...); /* 71 */ TCLAPI Tcl_AsyncHandler Tcl_AsyncCreate(Tcl_AsyncProc *proc, void *clientData); /* 72 */ TCLAPI void Tcl_AsyncDelete(Tcl_AsyncHandler async); /* 73 */ TCLAPI int Tcl_AsyncInvoke(Tcl_Interp *interp, int code); /* 74 */ TCLAPI void Tcl_AsyncMark(Tcl_AsyncHandler async); /* 75 */ TCLAPI int Tcl_AsyncReady(void); /* Slot 76 is reserved */ /* Slot 77 is reserved */ /* 78 */ TCLAPI int Tcl_BadChannelOption(Tcl_Interp *interp, const char *optionName, const char *optionList); /* 79 */ TCLAPI void Tcl_CallWhenDeleted(Tcl_Interp *interp, Tcl_InterpDeleteProc *proc, void *clientData); /* 80 */ TCLAPI void Tcl_CancelIdleCall(Tcl_IdleProc *idleProc, void *clientData); /* 81 */ TCLAPI int Tcl_Close(Tcl_Interp *interp, Tcl_Channel chan); /* 82 */ TCLAPI int Tcl_CommandComplete(const char *cmd); /* 83 */ TCLAPI char * Tcl_Concat(int argc, const char *const *argv); /* 84 */ TCLAPI size_t Tcl_ConvertElement(const char *src, char *dst, int flags); /* 85 */ TCLAPI size_t Tcl_ConvertCountedElement(const char *src, size_t length, char *dst, int flags); /* 86 */ TCLAPI int Tcl_CreateAlias(Tcl_Interp *slave, const char *slaveCmd, Tcl_Interp *target, const char *targetCmd, int argc, const char *const *argv); /* 87 */ TCLAPI int Tcl_CreateAliasObj(Tcl_Interp *slave, const char *slaveCmd, Tcl_Interp *target, const char *targetCmd, int objc, Tcl_Obj *const objv[]); /* 88 */ TCLAPI Tcl_Channel Tcl_CreateChannel(const Tcl_ChannelType *typePtr, const char *chanName, void *instanceData, int mask); /* 89 */ TCLAPI void Tcl_CreateChannelHandler(Tcl_Channel chan, int mask, Tcl_ChannelProc *proc, void *clientData); /* 90 */ TCLAPI void Tcl_CreateCloseHandler(Tcl_Channel chan, Tcl_CloseProc *proc, void *clientData); /* 91 */ TCLAPI Tcl_Command Tcl_CreateCommand(Tcl_Interp *interp, const char *cmdName, Tcl_CmdProc *proc, void *clientData, Tcl_CmdDeleteProc *deleteProc); /* 92 */ TCLAPI void Tcl_CreateEventSource(Tcl_EventSetupProc *setupProc, Tcl_EventCheckProc *checkProc, void *clientData); /* 93 */ TCLAPI void Tcl_CreateExitHandler(Tcl_ExitProc *proc, void *clientData); /* 94 */ TCLAPI Tcl_Interp * Tcl_CreateInterp(void); /* Slot 95 is reserved */ /* 96 */ TCLAPI Tcl_Command Tcl_CreateObjCommand(Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc *proc, void *clientData, Tcl_CmdDeleteProc *deleteProc); /* 97 */ TCLAPI Tcl_Interp * Tcl_CreateSlave(Tcl_Interp *interp, const char *slaveName, int isSafe); /* 98 */ TCLAPI Tcl_TimerToken Tcl_CreateTimerHandler(int milliseconds, Tcl_TimerProc *proc, void *clientData); /* 99 */ TCLAPI Tcl_Trace Tcl_CreateTrace(Tcl_Interp *interp, int level, Tcl_CmdTraceProc *proc, void *clientData); /* 100 */ TCLAPI void Tcl_DeleteAssocData(Tcl_Interp *interp, const char *name); /* 101 */ TCLAPI void Tcl_DeleteChannelHandler(Tcl_Channel chan, Tcl_ChannelProc *proc, void *clientData); /* 102 */ TCLAPI void Tcl_DeleteCloseHandler(Tcl_Channel chan, Tcl_CloseProc *proc, void *clientData); /* 103 */ TCLAPI int Tcl_DeleteCommand(Tcl_Interp *interp, const char *cmdName); /* 104 */ TCLAPI int Tcl_DeleteCommandFromToken(Tcl_Interp *interp, Tcl_Command command); /* 105 */ TCLAPI void Tcl_DeleteEvents(Tcl_EventDeleteProc *proc, void *clientData); /* 106 */ TCLAPI void Tcl_DeleteEventSource(Tcl_EventSetupProc *setupProc, Tcl_EventCheckProc *checkProc, void *clientData); /* 107 */ TCLAPI void Tcl_DeleteExitHandler(Tcl_ExitProc *proc, void *clientData); /* 108 */ TCLAPI void Tcl_DeleteHashEntry(Tcl_HashEntry *entryPtr); /* 109 */ TCLAPI void Tcl_DeleteHashTable(Tcl_HashTable *tablePtr); /* 110 */ TCLAPI void Tcl_DeleteInterp(Tcl_Interp *interp); /* 111 */ TCLAPI void Tcl_DetachPids(int numPids, Tcl_Pid *pidPtr); /* 112 */ TCLAPI void Tcl_DeleteTimerHandler(Tcl_TimerToken token); /* 113 */ TCLAPI void Tcl_DeleteTrace(Tcl_Interp *interp, Tcl_Trace trace); /* 114 */ TCLAPI void Tcl_DontCallWhenDeleted(Tcl_Interp *interp, Tcl_InterpDeleteProc *proc, void *clientData); /* 115 */ TCLAPI int Tcl_DoOneEvent(int flags); /* 116 */ TCLAPI void Tcl_DoWhenIdle(Tcl_IdleProc *proc, void *clientData); /* 117 */ TCLAPI char * Tcl_DStringAppend(Tcl_DString *dsPtr, const char *bytes, size_t length); /* 118 */ TCLAPI char * Tcl_DStringAppendElement(Tcl_DString *dsPtr, const char *element); /* 119 */ TCLAPI void Tcl_DStringEndSublist(Tcl_DString *dsPtr); /* 120 */ TCLAPI void Tcl_DStringFree(Tcl_DString *dsPtr); /* 121 */ TCLAPI void Tcl_DStringGetResult(Tcl_Interp *interp, Tcl_DString *dsPtr); /* 122 */ TCLAPI void Tcl_DStringInit(Tcl_DString *dsPtr); /* 123 */ TCLAPI void Tcl_DStringResult(Tcl_Interp *interp, Tcl_DString *dsPtr); /* 124 */ TCLAPI void Tcl_DStringSetLength(Tcl_DString *dsPtr, size_t length); /* 125 */ TCLAPI void Tcl_DStringStartSublist(Tcl_DString *dsPtr); /* 126 */ TCLAPI int Tcl_Eof(Tcl_Channel chan); /* 127 */ TCLAPI const char * Tcl_ErrnoId(void); /* 128 */ TCLAPI const char * Tcl_ErrnoMsg(int err); /* Slot 129 is reserved */ /* 130 */ TCLAPI int Tcl_EvalFile(Tcl_Interp *interp, const char *fileName); /* Slot 131 is reserved */ /* 132 */ TCLAPI void Tcl_EventuallyFree(void *clientData, Tcl_FreeProc *freeProc); /* 133 */ TCLAPI TCL_NORETURN void Tcl_Exit(int status); /* 134 */ TCLAPI int Tcl_ExposeCommand(Tcl_Interp *interp, const char *hiddenCmdToken, const char *cmdName); |
| ︙ | ︙ | |||
436 437 438 439 440 441 442 | /* 149 */ TCLAPI int Tcl_GetAliasObj(Tcl_Interp *interp, const char *slaveCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, int *objcPtr, Tcl_Obj ***objv); /* 150 */ | | | | | 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 | /* 149 */ TCLAPI int Tcl_GetAliasObj(Tcl_Interp *interp, const char *slaveCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, int *objcPtr, Tcl_Obj ***objv); /* 150 */ TCLAPI void * Tcl_GetAssocData(Tcl_Interp *interp, const char *name, Tcl_InterpDeleteProc **procPtr); /* 151 */ TCLAPI Tcl_Channel Tcl_GetChannel(Tcl_Interp *interp, const char *chanName, int *modePtr); /* 152 */ TCLAPI int Tcl_GetChannelBufferSize(Tcl_Channel chan); /* 153 */ TCLAPI int Tcl_GetChannelHandle(Tcl_Channel chan, int direction, void **handlePtr); /* 154 */ TCLAPI void * Tcl_GetChannelInstanceData(Tcl_Channel chan); /* 155 */ TCLAPI int Tcl_GetChannelMode(Tcl_Channel chan); /* 156 */ TCLAPI const char * Tcl_GetChannelName(Tcl_Channel chan); /* 157 */ TCLAPI int Tcl_GetChannelOption(Tcl_Interp *interp, Tcl_Channel chan, const char *optionName, |
| ︙ | ︙ | |||
482 483 484 485 486 487 488 | TCLAPI const char * Tcl_GetNameOfExecutable(void); /* 166 */ TCLAPI Tcl_Obj * Tcl_GetObjResult(Tcl_Interp *interp); #if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ /* 167 */ TCLAPI int Tcl_GetOpenFile(Tcl_Interp *interp, const char *chanID, int forWriting, | | | | | | < | 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 | TCLAPI const char * Tcl_GetNameOfExecutable(void); /* 166 */ TCLAPI Tcl_Obj * Tcl_GetObjResult(Tcl_Interp *interp); #if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ /* 167 */ TCLAPI int Tcl_GetOpenFile(Tcl_Interp *interp, const char *chanID, int forWriting, int checkUsage, void **filePtr); #endif /* UNIX */ #ifdef MAC_OSX_TCL /* MACOSX */ /* 167 */ TCLAPI int Tcl_GetOpenFile(Tcl_Interp *interp, const char *chanID, int forWriting, int checkUsage, void **filePtr); #endif /* MACOSX */ /* 168 */ TCLAPI Tcl_PathType Tcl_GetPathType(const char *path); /* 169 */ TCLAPI size_t Tcl_Gets(Tcl_Channel chan, Tcl_DString *dsPtr); /* 170 */ TCLAPI size_t Tcl_GetsObj(Tcl_Channel chan, Tcl_Obj *objPtr); /* 171 */ TCLAPI int Tcl_GetServiceMode(void); /* 172 */ TCLAPI Tcl_Interp * Tcl_GetSlave(Tcl_Interp *interp, const char *slaveName); /* 173 */ TCLAPI Tcl_Channel Tcl_GetStdChannel(int type); /* Slot 174 is reserved */ /* Slot 175 is reserved */ /* 176 */ TCLAPI const char * Tcl_GetVar2(Tcl_Interp *interp, const char *part1, const char *part2, int flags); /* Slot 177 is reserved */ /* Slot 178 is reserved */ /* 179 */ |
| ︙ | ︙ | |||
533 534 535 536 537 538 539 | /* 185 */ TCLAPI int Tcl_IsSafe(Tcl_Interp *interp); /* 186 */ TCLAPI char * Tcl_JoinPath(int argc, const char *const *argv, Tcl_DString *resultPtr); /* 187 */ TCLAPI int Tcl_LinkVar(Tcl_Interp *interp, const char *varName, | | | | | 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 | /* 185 */ TCLAPI int Tcl_IsSafe(Tcl_Interp *interp); /* 186 */ TCLAPI char * Tcl_JoinPath(int argc, const char *const *argv, Tcl_DString *resultPtr); /* 187 */ TCLAPI int Tcl_LinkVar(Tcl_Interp *interp, const char *varName, void *addr, int type); /* Slot 188 is reserved */ /* 189 */ TCLAPI Tcl_Channel Tcl_MakeFileChannel(void *handle, int mode); /* 190 */ TCLAPI int Tcl_MakeSafe(Tcl_Interp *interp); /* 191 */ TCLAPI Tcl_Channel Tcl_MakeTcpClientChannel(void *tcpSocket); /* 192 */ TCLAPI char * Tcl_Merge(int argc, const char *const *argv); /* 193 */ TCLAPI Tcl_HashEntry * Tcl_NextHashEntry(Tcl_HashSearch *searchPtr); /* 194 */ TCLAPI void Tcl_NotifyChannel(Tcl_Channel channel, int mask); /* 195 */ |
| ︙ | ︙ | |||
569 570 571 572 573 574 575 | TCLAPI Tcl_Channel Tcl_OpenTcpClient(Tcl_Interp *interp, int port, const char *address, const char *myaddr, int myport, int async); /* 200 */ TCLAPI Tcl_Channel Tcl_OpenTcpServer(Tcl_Interp *interp, int port, const char *host, Tcl_TcpAcceptProc *acceptProc, | | | | > | 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 | TCLAPI Tcl_Channel Tcl_OpenTcpClient(Tcl_Interp *interp, int port, const char *address, const char *myaddr, int myport, int async); /* 200 */ TCLAPI Tcl_Channel Tcl_OpenTcpServer(Tcl_Interp *interp, int port, const char *host, Tcl_TcpAcceptProc *acceptProc, void *callbackData); /* 201 */ TCLAPI void Tcl_Preserve(void *data); /* 202 */ TCLAPI void Tcl_PrintDouble(Tcl_Interp *interp, double value, char *dst); /* 203 */ TCLAPI int Tcl_PutEnv(const char *assignment); /* 204 */ TCLAPI const char * Tcl_PosixError(Tcl_Interp *interp); /* 205 */ TCLAPI void Tcl_QueueEvent(Tcl_Event *evPtr, Tcl_QueuePosition position); /* 206 */ TCLAPI size_t Tcl_Read(Tcl_Channel chan, char *bufPtr, size_t toRead); /* 207 */ TCLAPI void Tcl_ReapDetachedProcs(void); /* 208 */ TCLAPI int Tcl_RecordAndEval(Tcl_Interp *interp, const char *cmd, int flags); /* 209 */ TCLAPI int Tcl_RecordAndEvalObj(Tcl_Interp *interp, |
| ︙ | ︙ | |||
607 608 609 610 611 612 613 | /* 213 */ TCLAPI int Tcl_RegExpExec(Tcl_Interp *interp, Tcl_RegExp regexp, const char *text, const char *start); /* 214 */ TCLAPI int Tcl_RegExpMatch(Tcl_Interp *interp, const char *text, const char *pattern); /* 215 */ | | | | | | | | 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 | /* 213 */ TCLAPI int Tcl_RegExpExec(Tcl_Interp *interp, Tcl_RegExp regexp, const char *text, const char *start); /* 214 */ TCLAPI int Tcl_RegExpMatch(Tcl_Interp *interp, const char *text, const char *pattern); /* 215 */ TCLAPI void Tcl_RegExpRange(Tcl_RegExp regexp, size_t index, const char **startPtr, const char **endPtr); /* 216 */ TCLAPI void Tcl_Release(void *clientData); /* 217 */ TCLAPI void Tcl_ResetResult(Tcl_Interp *interp); /* 218 */ TCLAPI size_t Tcl_ScanElement(const char *src, int *flagPtr); /* 219 */ TCLAPI size_t Tcl_ScanCountedElement(const char *src, size_t length, int *flagPtr); /* Slot 220 is reserved */ /* 221 */ TCLAPI int Tcl_ServiceAll(void); /* 222 */ TCLAPI int Tcl_ServiceEvent(int flags); /* 223 */ TCLAPI void Tcl_SetAssocData(Tcl_Interp *interp, const char *name, Tcl_InterpDeleteProc *proc, void *clientData); /* 224 */ TCLAPI void Tcl_SetChannelBufferSize(Tcl_Channel chan, int sz); /* 225 */ TCLAPI int Tcl_SetChannelOption(Tcl_Interp *interp, Tcl_Channel chan, const char *optionName, const char *newValue); /* 226 */ |
| ︙ | ︙ | |||
675 676 677 678 679 680 681 | /* 242 */ TCLAPI int Tcl_SplitList(Tcl_Interp *interp, const char *listStr, int *argcPtr, const char ***argvPtr); /* 243 */ TCLAPI void Tcl_SplitPath(const char *path, int *argcPtr, const char ***argvPtr); | | < < < < | < | < | | | | | | > | < < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | < | | | | | | | < | > | | < | | < | | | | | | 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 | /* 242 */ TCLAPI int Tcl_SplitList(Tcl_Interp *interp, const char *listStr, int *argcPtr, const char ***argvPtr); /* 243 */ TCLAPI 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 */ /* 248 */ TCLAPI int Tcl_TraceVar2(Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *proc, void *clientData); /* 249 */ TCLAPI char * Tcl_TranslateFileName(Tcl_Interp *interp, const char *name, Tcl_DString *bufferPtr); /* 250 */ TCLAPI size_t Tcl_Ungets(Tcl_Channel chan, const char *str, size_t len, int atHead); /* 251 */ TCLAPI void Tcl_UnlinkVar(Tcl_Interp *interp, const char *varName); /* 252 */ TCLAPI int Tcl_UnregisterChannel(Tcl_Interp *interp, Tcl_Channel chan); /* Slot 253 is reserved */ /* 254 */ TCLAPI int Tcl_UnsetVar2(Tcl_Interp *interp, const char *part1, const char *part2, int flags); /* Slot 255 is reserved */ /* 256 */ TCLAPI void Tcl_UntraceVar2(Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *proc, void *clientData); /* 257 */ TCLAPI void Tcl_UpdateLinkedVar(Tcl_Interp *interp, const char *varName); /* Slot 258 is reserved */ /* 259 */ TCLAPI int Tcl_UpVar2(Tcl_Interp *interp, const char *frameName, const char *part1, const char *part2, const char *localName, int flags); /* Slot 260 is reserved */ /* Slot 261 is reserved */ /* 262 */ TCLAPI void * Tcl_VarTraceInfo2(Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *procPtr, void *prevClientData); /* 263 */ TCLAPI size_t Tcl_Write(Tcl_Channel chan, const char *s, size_t slen); /* 264 */ TCLAPI void Tcl_WrongNumArgs(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], const char *message); /* 265 */ TCLAPI int Tcl_DumpActiveMemory(const char *fileName); /* 266 */ TCLAPI void Tcl_ValidateAllMemory(const char *file, int line); /* Slot 267 is reserved */ /* Slot 268 is reserved */ /* 269 */ TCLAPI char * Tcl_HashStats(Tcl_HashTable *tablePtr); /* 270 */ TCLAPI const char * Tcl_ParseVar(Tcl_Interp *interp, const char *start, const char **termPtr); /* Slot 271 is reserved */ /* 272 */ TCLAPI 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 */ /* 277 */ TCLAPI Tcl_Pid Tcl_WaitPid(Tcl_Pid pid, int *statPtr, int options); /* Slot 278 is reserved */ /* 279 */ TCLAPI void Tcl_GetVersion(int *major, int *minor, int *patchLevel, int *type); /* 280 */ TCLAPI void Tcl_InitMemory(Tcl_Interp *interp); /* 281 */ TCLAPI Tcl_Channel Tcl_StackChannel(Tcl_Interp *interp, const Tcl_ChannelType *typePtr, void *instanceData, int mask, Tcl_Channel prevChan); /* 282 */ TCLAPI int Tcl_UnstackChannel(Tcl_Interp *interp, Tcl_Channel chan); /* 283 */ TCLAPI Tcl_Channel Tcl_GetStackedChannel(Tcl_Channel chan); /* 284 */ TCLAPI void Tcl_SetMainLoop(Tcl_MainLoopProc *proc); /* Slot 285 is reserved */ /* 286 */ TCLAPI void Tcl_AppendObjToObj(Tcl_Obj *objPtr, Tcl_Obj *appendObjPtr); /* 287 */ TCLAPI Tcl_Encoding Tcl_CreateEncoding(const Tcl_EncodingType *typePtr); /* 288 */ TCLAPI void Tcl_CreateThreadExitHandler(Tcl_ExitProc *proc, void *clientData); /* 289 */ TCLAPI void Tcl_DeleteThreadExitHandler(Tcl_ExitProc *proc, void *clientData); /* Slot 290 is reserved */ /* 291 */ TCLAPI int Tcl_EvalEx(Tcl_Interp *interp, const char *script, size_t numBytes, int flags); /* 292 */ TCLAPI int Tcl_EvalObjv(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int flags); /* 293 */ TCLAPI int Tcl_EvalObjEx(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); /* 294 */ TCLAPI TCL_NORETURN void Tcl_ExitThread(int status); /* 295 */ TCLAPI 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); /* 296 */ TCLAPI char * Tcl_ExternalToUtfDString(Tcl_Encoding encoding, const char *src, size_t srcLen, Tcl_DString *dsPtr); /* 297 */ TCLAPI void Tcl_FinalizeThread(void); /* 298 */ TCLAPI void Tcl_FinalizeNotifier(void *clientData); /* 299 */ TCLAPI void Tcl_FreeEncoding(Tcl_Encoding encoding); /* 300 */ TCLAPI Tcl_ThreadId Tcl_GetCurrentThread(void); /* 301 */ TCLAPI Tcl_Encoding Tcl_GetEncoding(Tcl_Interp *interp, const char *name); /* 302 */ TCLAPI const char * Tcl_GetEncodingName(Tcl_Encoding encoding); /* 303 */ TCLAPI void Tcl_GetEncodingNames(Tcl_Interp *interp); /* 304 */ TCLAPI int Tcl_GetIndexFromObjStruct(Tcl_Interp *interp, Tcl_Obj *objPtr, const void *tablePtr, size_t offset, const char *msg, int flags, int *indexPtr); /* 305 */ TCLAPI void * Tcl_GetThreadData(Tcl_ThreadDataKey *keyPtr, size_t size); /* 306 */ TCLAPI Tcl_Obj * Tcl_GetVar2Ex(Tcl_Interp *interp, const char *part1, const char *part2, int flags); /* 307 */ TCLAPI void * Tcl_InitNotifier(void); /* 308 */ TCLAPI void Tcl_MutexLock(Tcl_Mutex *mutexPtr); /* 309 */ TCLAPI void Tcl_MutexUnlock(Tcl_Mutex *mutexPtr); /* 310 */ TCLAPI void Tcl_ConditionNotify(Tcl_Condition *condPtr); /* 311 */ TCLAPI void Tcl_ConditionWait(Tcl_Condition *condPtr, Tcl_Mutex *mutexPtr, const Tcl_Time *timePtr); /* 312 */ TCLAPI size_t Tcl_NumUtfChars(const char *src, size_t length); /* 313 */ TCLAPI size_t Tcl_ReadChars(Tcl_Channel channel, Tcl_Obj *objPtr, size_t charsToRead, int appendFlag); /* Slot 314 is reserved */ /* Slot 315 is reserved */ /* 316 */ TCLAPI int Tcl_SetSystemEncoding(Tcl_Interp *interp, const char *name); /* 317 */ TCLAPI Tcl_Obj * Tcl_SetVar2Ex(Tcl_Interp *interp, const char *part1, const char *part2, Tcl_Obj *newValuePtr, int flags); /* 318 */ TCLAPI void Tcl_ThreadAlert(Tcl_ThreadId threadId); /* 319 */ TCLAPI void Tcl_ThreadQueueEvent(Tcl_ThreadId threadId, Tcl_Event *evPtr, Tcl_QueuePosition position); /* 320 */ TCLAPI int Tcl_UniCharAtIndex(const char *src, size_t index); /* 321 */ TCLAPI int Tcl_UniCharToLower(int ch); /* 322 */ TCLAPI int Tcl_UniCharToTitle(int ch); /* 323 */ TCLAPI int Tcl_UniCharToUpper(int ch); /* 324 */ TCLAPI int Tcl_UniCharToUtf(int ch, char *buf); /* 325 */ TCLAPI const char * Tcl_UtfAtIndex(const char *src, size_t index); /* 326 */ TCLAPI int Tcl_UtfCharComplete(const char *src, size_t length); /* 327 */ TCLAPI size_t Tcl_UtfBackslash(const char *src, int *readPtr, char *dst); /* 328 */ TCLAPI const char * Tcl_UtfFindFirst(const char *src, int ch); /* 329 */ TCLAPI const char * Tcl_UtfFindLast(const char *src, int ch); /* 330 */ TCLAPI const char * Tcl_UtfNext(const char *src); /* 331 */ TCLAPI const char * Tcl_UtfPrev(const char *src, const char *start); /* 332 */ TCLAPI 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); /* 333 */ TCLAPI char * Tcl_UtfToExternalDString(Tcl_Encoding encoding, const char *src, size_t srcLen, Tcl_DString *dsPtr); /* 334 */ TCLAPI int Tcl_UtfToLower(char *src); /* 335 */ TCLAPI int Tcl_UtfToTitle(char *src); /* 336 */ TCLAPI int Tcl_UtfToUniChar(const char *src, Tcl_UniChar *chPtr); /* 337 */ TCLAPI int Tcl_UtfToUpper(char *src); /* 338 */ TCLAPI size_t Tcl_WriteChars(Tcl_Channel chan, const char *src, size_t srcLen); /* 339 */ TCLAPI size_t Tcl_WriteObj(Tcl_Channel chan, Tcl_Obj *objPtr); /* 340 */ TCLAPI char * Tcl_GetString(Tcl_Obj *objPtr); /* Slot 341 is reserved */ /* Slot 342 is reserved */ /* 343 */ TCLAPI void Tcl_AlertNotifier(void *clientData); /* 344 */ TCLAPI void Tcl_ServiceModeHook(int mode); /* 345 */ TCLAPI int Tcl_UniCharIsAlnum(int ch); /* 346 */ TCLAPI int Tcl_UniCharIsAlpha(int ch); /* 347 */ TCLAPI int Tcl_UniCharIsDigit(int ch); /* 348 */ TCLAPI int Tcl_UniCharIsLower(int ch); /* 349 */ TCLAPI int Tcl_UniCharIsSpace(int ch); /* 350 */ TCLAPI int Tcl_UniCharIsUpper(int ch); /* 351 */ TCLAPI int Tcl_UniCharIsWordChar(int ch); /* 352 */ TCLAPI size_t Tcl_UniCharLen(const Tcl_UniChar *uniStr); /* 353 */ TCLAPI int Tcl_UniCharNcmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, size_t numChars); /* 354 */ TCLAPI char * Tcl_UniCharToUtfDString(const Tcl_UniChar *uniStr, size_t uniLength, Tcl_DString *dsPtr); /* 355 */ TCLAPI Tcl_UniChar * Tcl_UtfToUniCharDString(const char *src, size_t length, Tcl_DString *dsPtr); /* 356 */ TCLAPI Tcl_RegExp Tcl_GetRegExpFromObj(Tcl_Interp *interp, Tcl_Obj *patObj, int flags); /* Slot 357 is reserved */ /* 358 */ TCLAPI void Tcl_FreeParse(Tcl_Parse *parsePtr); /* 359 */ TCLAPI void Tcl_LogCommandInfo(Tcl_Interp *interp, const char *script, const char *command, size_t length); /* 360 */ TCLAPI int Tcl_ParseBraces(Tcl_Interp *interp, const char *start, size_t numBytes, Tcl_Parse *parsePtr, int append, const char **termPtr); /* 361 */ TCLAPI int Tcl_ParseCommand(Tcl_Interp *interp, const char *start, size_t numBytes, int nested, Tcl_Parse *parsePtr); /* 362 */ TCLAPI int Tcl_ParseExpr(Tcl_Interp *interp, const char *start, size_t numBytes, Tcl_Parse *parsePtr); /* 363 */ TCLAPI int Tcl_ParseQuotedString(Tcl_Interp *interp, const char *start, size_t numBytes, Tcl_Parse *parsePtr, int append, const char **termPtr); /* 364 */ TCLAPI int Tcl_ParseVarName(Tcl_Interp *interp, const char *start, size_t numBytes, Tcl_Parse *parsePtr, int append); /* 365 */ TCLAPI char * Tcl_GetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr); /* 366 */ TCLAPI int Tcl_Chdir(const char *dirName); /* 367 */ TCLAPI int Tcl_Access(const char *path, int mode); /* 368 */ TCLAPI int Tcl_Stat(const char *path, struct stat *bufPtr); /* 369 */ TCLAPI int Tcl_UtfNcmp(const char *s1, const char *s2, size_t n); /* 370 */ TCLAPI int Tcl_UtfNcasecmp(const char *s1, const char *s2, size_t n); /* 371 */ TCLAPI int Tcl_StringCaseMatch(const char *str, const char *pattern, int nocase); /* 372 */ TCLAPI int Tcl_UniCharIsControl(int ch); /* 373 */ TCLAPI int Tcl_UniCharIsGraph(int ch); /* 374 */ TCLAPI int Tcl_UniCharIsPrint(int ch); /* 375 */ TCLAPI int Tcl_UniCharIsPunct(int ch); /* 376 */ TCLAPI int Tcl_RegExpExecObj(Tcl_Interp *interp, Tcl_RegExp regexp, Tcl_Obj *textObj, size_t offset, size_t nmatches, int flags); /* 377 */ TCLAPI void Tcl_RegExpGetInfo(Tcl_RegExp regexp, Tcl_RegExpInfo *infoPtr); /* 378 */ TCLAPI Tcl_Obj * Tcl_NewUnicodeObj(const Tcl_UniChar *unicode, size_t numChars); /* 379 */ TCLAPI void Tcl_SetUnicodeObj(Tcl_Obj *objPtr, const Tcl_UniChar *unicode, size_t numChars); /* 380 */ TCLAPI size_t Tcl_GetCharLength(Tcl_Obj *objPtr); /* 381 */ TCLAPI int Tcl_GetUniChar(Tcl_Obj *objPtr, size_t index); /* Slot 382 is reserved */ /* 383 */ TCLAPI Tcl_Obj * Tcl_GetRange(Tcl_Obj *objPtr, size_t first, size_t last); /* 384 */ TCLAPI void Tcl_AppendUnicodeToObj(Tcl_Obj *objPtr, const Tcl_UniChar *unicode, size_t length); /* 385 */ TCLAPI int Tcl_RegExpMatchObj(Tcl_Interp *interp, Tcl_Obj *textObj, Tcl_Obj *patternObj); /* 386 */ TCLAPI void Tcl_SetNotifier(Tcl_NotifierProcs *notifierProcPtr); /* 387 */ TCLAPI Tcl_Mutex * Tcl_GetAllocMutex(void); /* 388 */ TCLAPI int Tcl_GetChannelNames(Tcl_Interp *interp); /* 389 */ TCLAPI int Tcl_GetChannelNamesEx(Tcl_Interp *interp, const char *pattern); /* 390 */ TCLAPI int Tcl_ProcObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 391 */ TCLAPI void Tcl_ConditionFinalize(Tcl_Condition *condPtr); /* 392 */ TCLAPI void Tcl_MutexFinalize(Tcl_Mutex *mutex); /* 393 */ TCLAPI int Tcl_CreateThread(Tcl_ThreadId *idPtr, Tcl_ThreadCreateProc *proc, void *clientData, size_t stackSize, int flags); /* 394 */ TCLAPI size_t Tcl_ReadRaw(Tcl_Channel chan, char *dst, size_t bytesToRead); /* 395 */ TCLAPI size_t Tcl_WriteRaw(Tcl_Channel chan, const char *src, size_t srcLen); /* 396 */ TCLAPI Tcl_Channel Tcl_GetTopChannel(Tcl_Channel chan); /* 397 */ TCLAPI int Tcl_ChannelBuffered(Tcl_Channel chan); /* 398 */ TCLAPI const char * Tcl_ChannelName(const Tcl_ChannelType *chanTypePtr); /* 399 */ |
| ︙ | ︙ | |||
1119 1120 1121 1122 1123 1124 1125 | TCLAPI void Tcl_SpliceChannel(Tcl_Channel channel); /* 417 */ TCLAPI void Tcl_ClearChannelHandlers(Tcl_Channel channel); /* 418 */ TCLAPI int Tcl_IsChannelExisting(const char *channelName); /* 419 */ TCLAPI int Tcl_UniCharNcasecmp(const Tcl_UniChar *ucs, | | < | | | < | < | | | | | | > | 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 | TCLAPI void Tcl_SpliceChannel(Tcl_Channel channel); /* 417 */ TCLAPI void Tcl_ClearChannelHandlers(Tcl_Channel channel); /* 418 */ TCLAPI int Tcl_IsChannelExisting(const char *channelName); /* 419 */ TCLAPI int Tcl_UniCharNcasecmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, size_t numChars); /* 420 */ TCLAPI int Tcl_UniCharCaseMatch(const Tcl_UniChar *uniStr, const Tcl_UniChar *uniPattern, int nocase); /* Slot 421 is reserved */ /* Slot 422 is reserved */ /* 423 */ TCLAPI void Tcl_InitCustomHashTable(Tcl_HashTable *tablePtr, int keyType, const Tcl_HashKeyType *typePtr); /* 424 */ TCLAPI void Tcl_InitObjHashTable(Tcl_HashTable *tablePtr); /* 425 */ TCLAPI void * Tcl_CommandTraceInfo(Tcl_Interp *interp, const char *varName, int flags, Tcl_CommandTraceProc *procPtr, void *prevClientData); /* 426 */ TCLAPI int Tcl_TraceCommand(Tcl_Interp *interp, const char *varName, int flags, Tcl_CommandTraceProc *proc, void *clientData); /* 427 */ TCLAPI void Tcl_UntraceCommand(Tcl_Interp *interp, const char *varName, int flags, Tcl_CommandTraceProc *proc, void *clientData); /* 428 */ TCLAPI void * Tcl_AttemptAlloc(size_t size); /* 429 */ TCLAPI void * Tcl_AttemptDbCkalloc(size_t size, const char *file, int line); /* 430 */ TCLAPI void * Tcl_AttemptRealloc(void *ptr, size_t size); /* 431 */ TCLAPI void * Tcl_AttemptDbCkrealloc(void *ptr, size_t size, const char *file, int line); /* 432 */ TCLAPI int Tcl_AttemptSetObjLength(Tcl_Obj *objPtr, size_t length); /* 433 */ TCLAPI Tcl_ThreadId Tcl_GetChannelThread(Tcl_Channel channel); /* 434 */ TCLAPI Tcl_UniChar * Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr, int *lengthPtr); /* Slot 435 is reserved */ /* Slot 436 is reserved */ |
| ︙ | ︙ | |||
1245 1246 1247 1248 1249 1250 1251 | /* 463 */ TCLAPI Tcl_Obj * Tcl_FSGetNormalizedPath(Tcl_Interp *interp, Tcl_Obj *pathPtr); /* 464 */ TCLAPI Tcl_Obj * Tcl_FSJoinToPath(Tcl_Obj *pathPtr, int objc, Tcl_Obj *const objv[]); /* 465 */ | | | | | | | | 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 | /* 463 */ TCLAPI Tcl_Obj * Tcl_FSGetNormalizedPath(Tcl_Interp *interp, Tcl_Obj *pathPtr); /* 464 */ TCLAPI Tcl_Obj * Tcl_FSJoinToPath(Tcl_Obj *pathPtr, int objc, Tcl_Obj *const objv[]); /* 465 */ TCLAPI void * Tcl_FSGetInternalRep(Tcl_Obj *pathPtr, const Tcl_Filesystem *fsPtr); /* 466 */ TCLAPI Tcl_Obj * Tcl_FSGetTranslatedPath(Tcl_Interp *interp, Tcl_Obj *pathPtr); /* 467 */ TCLAPI int Tcl_FSEvalFile(Tcl_Interp *interp, Tcl_Obj *fileName); /* 468 */ TCLAPI Tcl_Obj * Tcl_FSNewNativePath( const Tcl_Filesystem *fromFilesystem, void *clientData); /* 469 */ TCLAPI const void * Tcl_FSGetNativePath(Tcl_Obj *pathPtr); /* 470 */ TCLAPI Tcl_Obj * Tcl_FSFileSystemInfo(Tcl_Obj *pathPtr); /* 471 */ TCLAPI Tcl_Obj * Tcl_FSPathSeparator(Tcl_Obj *pathPtr); /* 472 */ TCLAPI Tcl_Obj * Tcl_FSListVolumes(void); /* 473 */ TCLAPI int Tcl_FSRegister(void *clientData, const Tcl_Filesystem *fsPtr); /* 474 */ TCLAPI int Tcl_FSUnregister(const Tcl_Filesystem *fsPtr); /* 475 */ TCLAPI void * Tcl_FSData(const Tcl_Filesystem *fsPtr); /* 476 */ TCLAPI const char * Tcl_FSGetTranslatedStringPath(Tcl_Interp *interp, Tcl_Obj *pathPtr); /* 477 */ TCLAPI const Tcl_Filesystem * Tcl_FSGetFileSystemForPath(Tcl_Obj *pathPtr); /* 478 */ TCLAPI Tcl_PathType Tcl_FSGetPathType(Tcl_Obj *pathPtr); /* 479 */ TCLAPI int Tcl_OutputBuffered(Tcl_Channel chan); /* 480 */ TCLAPI void Tcl_FSMountsChanged(const Tcl_Filesystem *fsPtr); /* 481 */ TCLAPI int Tcl_EvalTokensStandard(Tcl_Interp *interp, Tcl_Token *tokenPtr, size_t count); /* 482 */ TCLAPI void Tcl_GetTime(Tcl_Time *timeBuf); /* 483 */ TCLAPI Tcl_Trace Tcl_CreateObjTrace(Tcl_Interp *interp, int level, int flags, Tcl_CmdObjTraceProc *objProc, void *clientData, Tcl_CmdObjTraceDeleteProc *delProc); /* 484 */ TCLAPI int Tcl_GetCommandInfoFromToken(Tcl_Command token, Tcl_CmdInfo *infoPtr); /* 485 */ TCLAPI int Tcl_SetCommandInfoFromToken(Tcl_Command token, const Tcl_CmdInfo *infoPtr); |
| ︙ | ︙ | |||
1361 1362 1363 1364 1365 1366 1367 | /* 505 */ TCLAPI void Tcl_RegisterConfig(Tcl_Interp *interp, const char *pkgName, const Tcl_Config *configuration, const char *valEncoding); /* 506 */ TCLAPI Tcl_Namespace * Tcl_CreateNamespace(Tcl_Interp *interp, | | | 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 | /* 505 */ TCLAPI void Tcl_RegisterConfig(Tcl_Interp *interp, const char *pkgName, const Tcl_Config *configuration, const char *valEncoding); /* 506 */ TCLAPI Tcl_Namespace * Tcl_CreateNamespace(Tcl_Interp *interp, const char *name, void *clientData, Tcl_NamespaceDeleteProc *deleteProc); /* 507 */ TCLAPI void Tcl_DeleteNamespace(Tcl_Namespace *nsPtr); /* 508 */ TCLAPI int Tcl_AppendExportList(Tcl_Interp *interp, Tcl_Namespace *nsPtr, Tcl_Obj *objPtr); /* 509 */ |
| ︙ | ︙ | |||
1397 1398 1399 1400 1401 1402 1403 | Tcl_Obj *objPtr); /* 517 */ TCLAPI void Tcl_GetCommandFullName(Tcl_Interp *interp, Tcl_Command command, Tcl_Obj *objPtr); /* 518 */ TCLAPI int Tcl_FSEvalFileEx(Tcl_Interp *interp, Tcl_Obj *fileName, const char *encodingName); | | < | | | 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 | Tcl_Obj *objPtr); /* 517 */ TCLAPI void Tcl_GetCommandFullName(Tcl_Interp *interp, Tcl_Command command, Tcl_Obj *objPtr); /* 518 */ TCLAPI int Tcl_FSEvalFileEx(Tcl_Interp *interp, Tcl_Obj *fileName, const char *encodingName); /* Slot 519 is reserved */ /* 520 */ TCLAPI void Tcl_LimitAddHandler(Tcl_Interp *interp, int type, Tcl_LimitHandlerProc *handlerProc, void *clientData, Tcl_LimitHandlerDeleteProc *deleteProc); /* 521 */ TCLAPI void Tcl_LimitRemoveHandler(Tcl_Interp *interp, int type, Tcl_LimitHandlerProc *handlerProc, void *clientData); /* 522 */ TCLAPI int Tcl_LimitReady(Tcl_Interp *interp); /* 523 */ TCLAPI int Tcl_LimitCheck(Tcl_Interp *interp); /* 524 */ TCLAPI int Tcl_LimitExceeded(Tcl_Interp *interp); /* 525 */ |
| ︙ | ︙ | |||
1490 1491 1492 1493 1494 1495 1496 | /* 551 */ TCLAPI int Tcl_GetEnsembleNamespace(Tcl_Interp *interp, Tcl_Command token, Tcl_Namespace **namespacePtrPtr); /* 552 */ TCLAPI void Tcl_SetTimeProc(Tcl_GetTimeProc *getProc, Tcl_ScaleTimeProc *scaleProc, | | | | 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 | /* 551 */ TCLAPI int Tcl_GetEnsembleNamespace(Tcl_Interp *interp, Tcl_Command token, Tcl_Namespace **namespacePtrPtr); /* 552 */ TCLAPI void Tcl_SetTimeProc(Tcl_GetTimeProc *getProc, Tcl_ScaleTimeProc *scaleProc, void *clientData); /* 553 */ TCLAPI void Tcl_QueryTimeProc(Tcl_GetTimeProc **getProc, Tcl_ScaleTimeProc **scaleProc, void **clientData); /* 554 */ TCLAPI Tcl_DriverThreadActionProc * Tcl_ChannelThreadActionProc( const Tcl_ChannelType *chanTypePtr); /* 555 */ TCLAPI Tcl_Obj * Tcl_NewBignumObj(mp_int *value); /* 556 */ TCLAPI Tcl_Obj * Tcl_DbNewBignumObj(mp_int *value, const char *file, |
| ︙ | ︙ | |||
1555 1556 1557 1558 1559 1560 1561 | const char *name, int objc, Tcl_Obj *const objv[], void *clientDataPtr); /* 574 */ TCLAPI void Tcl_AppendObjToErrorInfo(Tcl_Interp *interp, Tcl_Obj *objPtr); /* 575 */ TCLAPI void Tcl_AppendLimitedToObj(Tcl_Obj *objPtr, | | | | | < | | < | < | | 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 | const char *name, int objc, Tcl_Obj *const objv[], void *clientDataPtr); /* 574 */ TCLAPI void Tcl_AppendObjToErrorInfo(Tcl_Interp *interp, Tcl_Obj *objPtr); /* 575 */ TCLAPI void Tcl_AppendLimitedToObj(Tcl_Obj *objPtr, const char *bytes, size_t length, size_t limit, const char *ellipsis); /* 576 */ TCLAPI Tcl_Obj * Tcl_Format(Tcl_Interp *interp, const char *format, int objc, Tcl_Obj *const objv[]); /* 577 */ TCLAPI int Tcl_AppendFormatToObj(Tcl_Interp *interp, Tcl_Obj *objPtr, const char *format, int objc, Tcl_Obj *const objv[]); /* 578 */ TCLAPI Tcl_Obj * Tcl_ObjPrintf(const char *format, ...) TCL_FORMAT_PRINTF(1, 2); /* 579 */ TCLAPI void Tcl_AppendPrintfToObj(Tcl_Obj *objPtr, const char *format, ...) TCL_FORMAT_PRINTF(2, 3); /* 580 */ TCLAPI int Tcl_CancelEval(Tcl_Interp *interp, Tcl_Obj *resultObjPtr, void *clientData, int flags); /* 581 */ TCLAPI int Tcl_Canceled(Tcl_Interp *interp, int flags); /* 582 */ TCLAPI int Tcl_CreatePipe(Tcl_Interp *interp, Tcl_Channel *rchan, Tcl_Channel *wchan, int flags); /* 583 */ TCLAPI Tcl_Command Tcl_NRCreateCommand(Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc *proc, Tcl_ObjCmdProc *nreProc, void *clientData, Tcl_CmdDeleteProc *deleteProc); /* 584 */ TCLAPI int Tcl_NREvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); /* 585 */ TCLAPI int Tcl_NREvalObjv(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int flags); /* 586 */ TCLAPI int Tcl_NRCmdSwap(Tcl_Interp *interp, Tcl_Command cmd, int objc, Tcl_Obj *const objv[], int flags); /* 587 */ TCLAPI void Tcl_NRAddCallback(Tcl_Interp *interp, Tcl_NRPostProc *postProcPtr, void *data0, void *data1, void *data2, void *data3); /* 588 */ TCLAPI int Tcl_NRCallObjProc(Tcl_Interp *interp, Tcl_ObjCmdProc *objProc, void *clientData, int objc, Tcl_Obj *const objv[]); /* 589 */ TCLAPI unsigned Tcl_GetFSDeviceFromStat(const Tcl_StatBuf *statPtr); /* 590 */ TCLAPI unsigned Tcl_GetFSInodeFromStat(const Tcl_StatBuf *statPtr); /* 591 */ TCLAPI unsigned Tcl_GetModeFromStat(const Tcl_StatBuf *statPtr); /* 592 */ |
| ︙ | ︙ | |||
1658 1659 1660 1661 1662 1663 1664 | TCLAPI void Tcl_BackgroundException(Tcl_Interp *interp, int code); /* 610 */ TCLAPI int Tcl_ZlibDeflate(Tcl_Interp *interp, int format, Tcl_Obj *data, int level, Tcl_Obj *gzipHeaderDictObj); /* 611 */ TCLAPI int Tcl_ZlibInflate(Tcl_Interp *interp, int format, | | | | | | 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 | TCLAPI void Tcl_BackgroundException(Tcl_Interp *interp, int code); /* 610 */ TCLAPI int Tcl_ZlibDeflate(Tcl_Interp *interp, int format, Tcl_Obj *data, int level, Tcl_Obj *gzipHeaderDictObj); /* 611 */ TCLAPI int Tcl_ZlibInflate(Tcl_Interp *interp, int format, Tcl_Obj *data, size_t buffersize, Tcl_Obj *gzipHeaderDictObj); /* 612 */ TCLAPI unsigned int Tcl_ZlibCRC32(unsigned int crc, const unsigned char *buf, size_t len); /* 613 */ TCLAPI unsigned int Tcl_ZlibAdler32(unsigned int adler, const unsigned char *buf, size_t len); /* 614 */ TCLAPI int Tcl_ZlibStreamInit(Tcl_Interp *interp, int mode, int format, int level, Tcl_Obj *dictObj, Tcl_ZlibStream *zshandle); /* 615 */ TCLAPI Tcl_Obj * Tcl_ZlibStreamGetCommandName(Tcl_ZlibStream zshandle); /* 616 */ TCLAPI int Tcl_ZlibStreamEof(Tcl_ZlibStream zshandle); /* 617 */ TCLAPI int Tcl_ZlibStreamChecksum(Tcl_ZlibStream zshandle); /* 618 */ TCLAPI int Tcl_ZlibStreamPut(Tcl_ZlibStream zshandle, Tcl_Obj *data, int flush); /* 619 */ TCLAPI int Tcl_ZlibStreamGet(Tcl_ZlibStream zshandle, Tcl_Obj *data, size_t count); /* 620 */ TCLAPI int Tcl_ZlibStreamClose(Tcl_ZlibStream zshandle); /* 621 */ TCLAPI int Tcl_ZlibStreamReset(Tcl_ZlibStream zshandle); /* 622 */ TCLAPI void Tcl_SetStartupScript(Tcl_Obj *path, const char *encoding); |
| ︙ | ︙ | |||
1719 1720 1721 1722 1723 1724 1725 | Tcl_ZlibStream zhandle, Tcl_Obj *compressionDictionaryObj); /* 631 */ TCLAPI Tcl_Channel Tcl_OpenTcpServerEx(Tcl_Interp *interp, const char *service, const char *host, unsigned int flags, Tcl_TcpAcceptProc *acceptProc, | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 |
Tcl_ZlibStream zhandle,
Tcl_Obj *compressionDictionaryObj);
/* 631 */
TCLAPI Tcl_Channel Tcl_OpenTcpServerEx(Tcl_Interp *interp,
const char *service, const char *host,
unsigned int flags,
Tcl_TcpAcceptProc *acceptProc,
void *callbackData);
/* 632 */
TCLAPI int TclZipfs_Mount(Tcl_Interp *interp,
const char *mountPoint, const char *zipname,
const char *passwd);
/* 633 */
TCLAPI int TclZipfs_Unmount(Tcl_Interp *interp,
const char *mountPoint);
/* 634 */
TCLAPI Tcl_Obj * TclZipfs_TclLibrary(void);
/* 635 */
TCLAPI int TclZipfs_MountBuffer(Tcl_Interp *interp,
const char *mountPoint, unsigned char *data,
size_t datalen, int copy);
/* 636 */
TCLAPI void Tcl_FreeIntRep(Tcl_Obj *objPtr);
/* 637 */
TCLAPI char * Tcl_InitStringRep(Tcl_Obj *objPtr, const char *bytes,
size_t numBytes);
/* 638 */
TCLAPI Tcl_ObjIntRep * Tcl_FetchIntRep(Tcl_Obj *objPtr,
const Tcl_ObjType *typePtr);
/* 639 */
TCLAPI void Tcl_StoreIntRep(Tcl_Obj *objPtr,
const Tcl_ObjType *typePtr,
const Tcl_ObjIntRep *irPtr);
/* 640 */
TCLAPI int Tcl_HasStringRep(Tcl_Obj *objPtr);
/* 641 */
TCLAPI void Tcl_IncrRefCount(Tcl_Obj *objPtr);
/* 642 */
TCLAPI void Tcl_DecrRefCount(Tcl_Obj *objPtr);
/* 643 */
TCLAPI int Tcl_IsShared(Tcl_Obj *objPtr);
/* 644 */
TCLAPI int Tcl_LinkArray(Tcl_Interp *interp,
const char *varName, void *addr, int type,
size_t size);
/* 645 */
TCLAPI int Tcl_GetIntForIndex(Tcl_Interp *interp,
Tcl_Obj *objPtr, size_t endValue,
size_t *indexPtr);
typedef struct {
const struct TclPlatStubs *tclPlatStubs;
const struct TclIntStubs *tclIntStubs;
const struct TclIntPlatStubs *tclIntPlatStubs;
const struct TclOOStubs *tclOOStubs;
const struct TclOOIntStubs *tclOOIntStubs;
} 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 (*reserved30)(void);
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 */
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 */
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_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 */
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_AllowExceptions) (Tcl_Interp *interp); /* 68 */
void (*tcl_AppendElement) (Tcl_Interp *interp, const char *element); /* 69 */
void (*tcl_AppendResult) (Tcl_Interp *interp, ...); /* 70 */
Tcl_AsyncHandler (*tcl_AsyncCreate) (Tcl_AsyncProc *proc, void *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 */
int (*tcl_Close) (Tcl_Interp *interp, Tcl_Channel chan); /* 81 */
int (*tcl_CommandComplete) (const char *cmd); /* 82 */
char * (*tcl_Concat) (int argc, const char *const *argv); /* 83 */
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 *slave, const char *slaveCmd, Tcl_Interp *target, const char *targetCmd, int argc, const char *const *argv); /* 86 */
int (*tcl_CreateAliasObj) (Tcl_Interp *slave, const char *slaveCmd, Tcl_Interp *target, const char *targetCmd, int objc, Tcl_Obj *const objv[]); /* 87 */
Tcl_Channel (*tcl_CreateChannel) (const Tcl_ChannelType *typePtr, const char *chanName, 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 */
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_CreateSlave) (Tcl_Interp *interp, const char *slaveName, 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 */
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_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 */
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_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_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 */
int (*tcl_ExprBooleanObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int *ptr); /* 136 */
int (*tcl_ExprDouble) (Tcl_Interp *interp, const char *expr, double *ptr); /* 137 */
int (*tcl_ExprDoubleObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, double *ptr); /* 138 */
int (*tcl_ExprLong) (Tcl_Interp *interp, const char *expr, long *ptr); /* 139 */
int (*tcl_ExprLongObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, long *ptr); /* 140 */
int (*tcl_ExprObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Obj **resultPtrPtr); /* 141 */
int (*tcl_ExprString) (Tcl_Interp *interp, const char *expr); /* 142 */
void (*tcl_Finalize) (void); /* 143 */
void (*reserved144)(void);
Tcl_HashEntry * (*tcl_FirstHashEntry) (Tcl_HashTable *tablePtr, Tcl_HashSearch *searchPtr); /* 145 */
int (*tcl_Flush) (Tcl_Channel chan); /* 146 */
void (*tcl_FreeResult) (Tcl_Interp *interp); /* 147 */
int (*tcl_GetAlias) (Tcl_Interp *interp, const char *slaveCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, int *argcPtr, const char ***argvPtr); /* 148 */
int (*tcl_GetAliasObj) (Tcl_Interp *interp, const char *slaveCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, int *objcPtr, Tcl_Obj ***objv); /* 149 */
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 */
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_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 */
int (*tcl_GetErrno) (void); /* 161 */
const char * (*tcl_GetHostName) (void); /* 162 */
int (*tcl_GetInterpPath) (Tcl_Interp *askInterp, Tcl_Interp *slaveInterp); /* 163 */
Tcl_Interp * (*tcl_GetMaster) (Tcl_Interp *interp); /* 164 */
const char * (*tcl_GetNameOfExecutable) (void); /* 165 */
Tcl_Obj * (*tcl_GetObjResult) (Tcl_Interp *interp); /* 166 */
#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */
int (*tcl_GetOpenFile) (Tcl_Interp *interp, const char *chanID, int forWriting, int checkUsage, void **filePtr); /* 167 */
#endif /* UNIX */
#if defined(_WIN32) /* WIN */
void (*reserved167)(void);
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
int (*tcl_GetOpenFile) (Tcl_Interp *interp, const char *chanID, int forWriting, int checkUsage, void **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 */
int (*tcl_GetServiceMode) (void); /* 171 */
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 */
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 */
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_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 */
void (*tcl_PrintDouble) (Tcl_Interp *interp, double value, char *dst); /* 202 */
int (*tcl_PutEnv) (const char *assignment); /* 203 */
const char * (*tcl_PosixError) (Tcl_Interp *interp); /* 204 */
void (*tcl_QueueEvent) (Tcl_Event *evPtr, Tcl_QueuePosition position); /* 205 */
size_t (*tcl_Read) (Tcl_Channel chan, char *bufPtr, size_t toRead); /* 206 */
void (*tcl_ReapDetachedProcs) (void); /* 207 */
int (*tcl_RecordAndEval) (Tcl_Interp *interp, const char *cmd, int flags); /* 208 */
int (*tcl_RecordAndEvalObj) (Tcl_Interp *interp, Tcl_Obj *cmdPtr, int flags); /* 209 */
void (*tcl_RegisterChannel) (Tcl_Interp *interp, Tcl_Channel chan); /* 210 */
void (*tcl_RegisterObjType) (const Tcl_ObjType *typePtr); /* 211 */
Tcl_RegExp (*tcl_RegExpCompile) (Tcl_Interp *interp, const char *pattern); /* 212 */
int (*tcl_RegExpExec) (Tcl_Interp *interp, Tcl_RegExp regexp, const char *text, const char *start); /* 213 */
int (*tcl_RegExpMatch) (Tcl_Interp *interp, const char *text, const char *pattern); /* 214 */
void (*tcl_RegExpRange) (Tcl_RegExp regexp, size_t index, const char **startPtr, const char **endPtr); /* 215 */
void (*tcl_Release) (void *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_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_SetChannelBufferSize) (Tcl_Channel chan, int sz); /* 224 */
int (*tcl_SetChannelOption) (Tcl_Interp *interp, Tcl_Channel chan, const char *optionName, const char *newValue); /* 225 */
int (*tcl_SetCommandInfo) (Tcl_Interp *interp, const char *cmdName, const Tcl_CmdInfo *infoPtr); /* 226 */
void (*tcl_SetErrno) (int err); /* 227 */
void (*tcl_SetErrorCode) (Tcl_Interp *interp, ...); /* 228 */
void (*tcl_SetMaxBlockTime) (const Tcl_Time *timePtr); /* 229 */
void (*reserved230)(void);
int (*tcl_SetRecursionLimit) (Tcl_Interp *interp, int depth); /* 231 */
void (*reserved232)(void);
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 */
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_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 */
void (*reserved260)(void);
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);
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);
Tcl_Pid (*tcl_WaitPid) (Tcl_Pid pid, int *statPtr, int options); /* 277 */
void (*reserved278)(void);
void (*tcl_GetVersion) (int *major, int *minor, int *patchLevel, int *type); /* 279 */
void (*tcl_InitMemory) (Tcl_Interp *interp); /* 280 */
Tcl_Channel (*tcl_StackChannel) (Tcl_Interp *interp, const Tcl_ChannelType *typePtr, void *instanceData, int mask, Tcl_Channel prevChan); /* 281 */
int (*tcl_UnstackChannel) (Tcl_Interp *interp, Tcl_Channel chan); /* 282 */
Tcl_Channel (*tcl_GetStackedChannel) (Tcl_Channel chan); /* 283 */
void (*tcl_SetMainLoop) (Tcl_MainLoopProc *proc); /* 284 */
void (*reserved285)(void);
void (*tcl_AppendObjToObj) (Tcl_Obj *objPtr, Tcl_Obj *appendObjPtr); /* 286 */
Tcl_Encoding (*tcl_CreateEncoding) (const Tcl_EncodingType *typePtr); /* 287 */
void (*tcl_CreateThreadExitHandler) (Tcl_ExitProc *proc, 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 */
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_FinalizeThread) (void); /* 297 */
void (*tcl_FinalizeNotifier) (void *clientData); /* 298 */
void (*tcl_FreeEncoding) (Tcl_Encoding encoding); /* 299 */
Tcl_ThreadId (*tcl_GetCurrentThread) (void); /* 300 */
Tcl_Encoding (*tcl_GetEncoding) (Tcl_Interp *interp, const char *name); /* 301 */
const char * (*tcl_GetEncodingName) (Tcl_Encoding encoding); /* 302 */
void (*tcl_GetEncodingNames) (Tcl_Interp *interp); /* 303 */
int (*tcl_GetIndexFromObjStruct) (Tcl_Interp *interp, Tcl_Obj *objPtr, const void *tablePtr, 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 */
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_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 */
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 */
int (*tcl_UtfToLower) (char *src); /* 334 */
int (*tcl_UtfToTitle) (char *src); /* 335 */
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 */
char * (*tcl_GetString) (Tcl_Obj *objPtr); /* 340 */
void (*reserved341)(void);
void (*reserved342)(void);
void (*tcl_AlertNotifier) (void *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 */
size_t (*tcl_UniCharLen) (const Tcl_UniChar *uniStr); /* 352 */
int (*tcl_UniCharNcmp) (const Tcl_UniChar *ucs, const Tcl_UniChar *uct, size_t numChars); /* 353 */
char * (*tcl_UniCharToUtfDString) (const Tcl_UniChar *uniStr, size_t uniLength, Tcl_DString *dsPtr); /* 354 */
Tcl_UniChar * (*tcl_UtfToUniCharDString) (const char *src, size_t length, Tcl_DString *dsPtr); /* 355 */
Tcl_RegExp (*tcl_GetRegExpFromObj) (Tcl_Interp *interp, Tcl_Obj *patObj, int flags); /* 356 */
void (*reserved357)(void);
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 */
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_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 */
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 (*tcl_AppendUnicodeToObj) (Tcl_Obj *objPtr, const Tcl_UniChar *unicode, size_t 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 */
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 */
Tcl_Channel (*tcl_GetTopChannel) (Tcl_Channel chan); /* 396 */
int (*tcl_ChannelBuffered) (Tcl_Channel chan); /* 397 */
const char * (*tcl_ChannelName) (const Tcl_ChannelType *chanTypePtr); /* 398 */
Tcl_ChannelTypeVersion (*tcl_ChannelVersion) (const Tcl_ChannelType *chanTypePtr); /* 399 */
Tcl_DriverBlockModeProc * (*tcl_ChannelBlockModeProc) (const Tcl_ChannelType *chanTypePtr); /* 400 */
Tcl_DriverCloseProc * (*tcl_ChannelCloseProc) (const Tcl_ChannelType *chanTypePtr); /* 401 */
Tcl_DriverClose2Proc * (*tcl_ChannelClose2Proc) (const Tcl_ChannelType *chanTypePtr); /* 402 */
|
| ︙ | ︙ | |||
2176 2177 2178 2179 2180 2181 2182 |
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 */
| | | | | | | | | | | 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 |
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 */
int (*tcl_UniCharNcasecmp) (const Tcl_UniChar *ucs, const Tcl_UniChar *uct, size_t numChars); /* 419 */
int (*tcl_UniCharCaseMatch) (const Tcl_UniChar *uniStr, const Tcl_UniChar *uniPattern, int nocase); /* 420 */
void (*reserved421)(void);
void (*reserved422)(void);
void (*tcl_InitCustomHashTable) (Tcl_HashTable *tablePtr, int keyType, const 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 */
Tcl_ThreadId (*tcl_GetChannelThread) (Tcl_Channel channel); /* 433 */
Tcl_UniChar * (*tcl_GetUnicodeFromObj) (Tcl_Obj *objPtr, int *lengthPtr); /* 434 */
void (*reserved435)(void);
void (*reserved436)(void);
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 */
|
| ︙ | ︙ | |||
2222 2223 2224 2225 2226 2227 2228 |
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 */
| | | | | | | | 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 |
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_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_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 */
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_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 */
int (*tcl_GetCommandInfoFromToken) (Tcl_Command token, Tcl_CmdInfo *infoPtr); /* 484 */
int (*tcl_SetCommandInfoFromToken) (Tcl_Command token, const Tcl_CmdInfo *infoPtr); /* 485 */
Tcl_Obj * (*tcl_DbNewWideIntObj) (Tcl_WideInt wideValue, const char *file, int line); /* 486 */
int (*tcl_GetWideIntFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_WideInt *widePtr); /* 487 */
Tcl_Obj * (*tcl_NewWideIntObj) (Tcl_WideInt wideValue); /* 488 */
void (*tcl_SetWideIntObj) (Tcl_Obj *objPtr, Tcl_WideInt wideValue); /* 489 */
Tcl_StatBuf * (*tcl_AllocStatBuf) (void); /* 490 */
|
| ︙ | ︙ | |||
2263 2264 2265 2266 2267 2268 2269 |
void (*tcl_DictObjNext) (Tcl_DictSearch *searchPtr, Tcl_Obj **keyPtrPtr, Tcl_Obj **valuePtrPtr, int *donePtr); /* 499 */
void (*tcl_DictObjDone) (Tcl_DictSearch *searchPtr); /* 500 */
int (*tcl_DictObjPutKeyList) (Tcl_Interp *interp, Tcl_Obj *dictPtr, int keyc, Tcl_Obj *const *keyv, Tcl_Obj *valuePtr); /* 501 */
int (*tcl_DictObjRemoveKeyList) (Tcl_Interp *interp, Tcl_Obj *dictPtr, int keyc, Tcl_Obj *const *keyv); /* 502 */
Tcl_Obj * (*tcl_NewDictObj) (void); /* 503 */
Tcl_Obj * (*tcl_DbNewDictObj) (const char *file, int line); /* 504 */
void (*tcl_RegisterConfig) (Tcl_Interp *interp, const char *pkgName, const Tcl_Config *configuration, const char *valEncoding); /* 505 */
| | | | | | 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 |
void (*tcl_DictObjNext) (Tcl_DictSearch *searchPtr, Tcl_Obj **keyPtrPtr, Tcl_Obj **valuePtrPtr, int *donePtr); /* 499 */
void (*tcl_DictObjDone) (Tcl_DictSearch *searchPtr); /* 500 */
int (*tcl_DictObjPutKeyList) (Tcl_Interp *interp, Tcl_Obj *dictPtr, int keyc, Tcl_Obj *const *keyv, Tcl_Obj *valuePtr); /* 501 */
int (*tcl_DictObjRemoveKeyList) (Tcl_Interp *interp, Tcl_Obj *dictPtr, int keyc, Tcl_Obj *const *keyv); /* 502 */
Tcl_Obj * (*tcl_NewDictObj) (void); /* 503 */
Tcl_Obj * (*tcl_DbNewDictObj) (const char *file, int line); /* 504 */
void (*tcl_RegisterConfig) (Tcl_Interp *interp, const char *pkgName, const Tcl_Config *configuration, const char *valEncoding); /* 505 */
Tcl_Namespace * (*tcl_CreateNamespace) (Tcl_Interp *interp, const char *name, void *clientData, Tcl_NamespaceDeleteProc *deleteProc); /* 506 */
void (*tcl_DeleteNamespace) (Tcl_Namespace *nsPtr); /* 507 */
int (*tcl_AppendExportList) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, Tcl_Obj *objPtr); /* 508 */
int (*tcl_Export) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int resetListFirst); /* 509 */
int (*tcl_Import) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int allowOverwrite); /* 510 */
int (*tcl_ForgetImport) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern); /* 511 */
Tcl_Namespace * (*tcl_GetCurrentNamespace) (Tcl_Interp *interp); /* 512 */
Tcl_Namespace * (*tcl_GetGlobalNamespace) (Tcl_Interp *interp); /* 513 */
Tcl_Namespace * (*tcl_FindNamespace) (Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 514 */
Tcl_Command (*tcl_FindCommand) (Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 515 */
Tcl_Command (*tcl_GetCommandFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 516 */
void (*tcl_GetCommandFullName) (Tcl_Interp *interp, Tcl_Command command, Tcl_Obj *objPtr); /* 517 */
int (*tcl_FSEvalFileEx) (Tcl_Interp *interp, Tcl_Obj *fileName, const char *encodingName); /* 518 */
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_LimitReady) (Tcl_Interp *interp); /* 522 */
int (*tcl_LimitCheck) (Tcl_Interp *interp); /* 523 */
int (*tcl_LimitExceeded) (Tcl_Interp *interp); /* 524 */
void (*tcl_LimitSetCommands) (Tcl_Interp *interp, int commandLimit); /* 525 */
void (*tcl_LimitSetTime) (Tcl_Interp *interp, Tcl_Time *timeLimitPtr); /* 526 */
void (*tcl_LimitSetGranularity) (Tcl_Interp *interp, int type, int granularity); /* 527 */
int (*tcl_LimitTypeEnabled) (Tcl_Interp *interp, int type); /* 528 */
|
| ︙ | ︙ | |||
2309 2310 2311 2312 2313 2314 2315 |
int (*tcl_SetEnsembleUnknownHandler) (Tcl_Interp *interp, Tcl_Command token, Tcl_Obj *unknownList); /* 545 */
int (*tcl_SetEnsembleFlags) (Tcl_Interp *interp, Tcl_Command token, int flags); /* 546 */
int (*tcl_GetEnsembleSubcommandList) (Tcl_Interp *interp, Tcl_Command token, Tcl_Obj **subcmdListPtr); /* 547 */
int (*tcl_GetEnsembleMappingDict) (Tcl_Interp *interp, Tcl_Command token, Tcl_Obj **mapDictPtr); /* 548 */
int (*tcl_GetEnsembleUnknownHandler) (Tcl_Interp *interp, Tcl_Command token, Tcl_Obj **unknownListPtr); /* 549 */
int (*tcl_GetEnsembleFlags) (Tcl_Interp *interp, Tcl_Command token, int *flagsPtr); /* 550 */
int (*tcl_GetEnsembleNamespace) (Tcl_Interp *interp, Tcl_Command token, Tcl_Namespace **namespacePtrPtr); /* 551 */
| | | | 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 |
int (*tcl_SetEnsembleUnknownHandler) (Tcl_Interp *interp, Tcl_Command token, Tcl_Obj *unknownList); /* 545 */
int (*tcl_SetEnsembleFlags) (Tcl_Interp *interp, Tcl_Command token, int flags); /* 546 */
int (*tcl_GetEnsembleSubcommandList) (Tcl_Interp *interp, Tcl_Command token, Tcl_Obj **subcmdListPtr); /* 547 */
int (*tcl_GetEnsembleMappingDict) (Tcl_Interp *interp, Tcl_Command token, Tcl_Obj **mapDictPtr); /* 548 */
int (*tcl_GetEnsembleUnknownHandler) (Tcl_Interp *interp, Tcl_Command token, Tcl_Obj **unknownListPtr); /* 549 */
int (*tcl_GetEnsembleFlags) (Tcl_Interp *interp, Tcl_Command token, int *flagsPtr); /* 550 */
int (*tcl_GetEnsembleNamespace) (Tcl_Interp *interp, Tcl_Command token, Tcl_Namespace **namespacePtrPtr); /* 551 */
void (*tcl_SetTimeProc) (Tcl_GetTimeProc *getProc, Tcl_ScaleTimeProc *scaleProc, 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) (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 */
|
| ︙ | ︙ | |||
2332 2333 2334 2335 2336 2337 2338 |
int (*tcl_SetNamespaceUnknownHandler) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, Tcl_Obj *handlerPtr); /* 568 */
int (*tcl_GetEncodingFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Encoding *encodingPtr); /* 569 */
Tcl_Obj * (*tcl_GetEncodingSearchPath) (void); /* 570 */
int (*tcl_SetEncodingSearchPath) (Tcl_Obj *searchPath); /* 571 */
const char * (*tcl_GetEncodingNameFromEnvironment) (Tcl_DString *bufPtr); /* 572 */
int (*tcl_PkgRequireProc) (Tcl_Interp *interp, const char *name, int objc, Tcl_Obj *const objv[], void *clientDataPtr); /* 573 */
void (*tcl_AppendObjToErrorInfo) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 574 */
| | | | | | | 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 |
int (*tcl_SetNamespaceUnknownHandler) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, Tcl_Obj *handlerPtr); /* 568 */
int (*tcl_GetEncodingFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Encoding *encodingPtr); /* 569 */
Tcl_Obj * (*tcl_GetEncodingSearchPath) (void); /* 570 */
int (*tcl_SetEncodingSearchPath) (Tcl_Obj *searchPath); /* 571 */
const char * (*tcl_GetEncodingNameFromEnvironment) (Tcl_DString *bufPtr); /* 572 */
int (*tcl_PkgRequireProc) (Tcl_Interp *interp, const char *name, int objc, Tcl_Obj *const objv[], void *clientDataPtr); /* 573 */
void (*tcl_AppendObjToErrorInfo) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 574 */
void (*tcl_AppendLimitedToObj) (Tcl_Obj *objPtr, const char *bytes, 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 */
|
| ︙ | ︙ | |||
2368 2369 2370 2371 2372 2373 2374 |
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 result, 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 */
| | | | | | > > > > > > > > > > > > > > | 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 |
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 result, 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 */
} TclStubs;
extern const TclStubs *tclStubsPtr;
#ifdef __cplusplus
}
#endif
|
| ︙ | ︙ | |||
2473 2474 2475 2476 2477 2478 2479 | /* Slot 26 is reserved */ #define Tcl_DbNewObj \ (tclStubsPtr->tcl_DbNewObj) /* 27 */ #define Tcl_DbNewStringObj \ (tclStubsPtr->tcl_DbNewStringObj) /* 28 */ #define Tcl_DuplicateObj \ (tclStubsPtr->tcl_DuplicateObj) /* 29 */ | < | | 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 | /* Slot 26 is reserved */ #define Tcl_DbNewObj \ (tclStubsPtr->tcl_DbNewObj) /* 27 */ #define Tcl_DbNewStringObj \ (tclStubsPtr->tcl_DbNewStringObj) /* 28 */ #define Tcl_DuplicateObj \ (tclStubsPtr->tcl_DuplicateObj) /* 29 */ /* Slot 30 is reserved */ #define Tcl_GetBoolean \ (tclStubsPtr->tcl_GetBoolean) /* 31 */ #define Tcl_GetBooleanFromObj \ (tclStubsPtr->tcl_GetBooleanFromObj) /* 32 */ #define Tcl_GetByteArrayFromObj \ (tclStubsPtr->tcl_GetByteArrayFromObj) /* 33 */ #define Tcl_GetDouble \ |
| ︙ | ︙ | |||
2556 2557 2558 2559 2560 2561 2562 | (tclStubsPtr->tcl_AsyncDelete) /* 72 */ #define Tcl_AsyncInvoke \ (tclStubsPtr->tcl_AsyncInvoke) /* 73 */ #define Tcl_AsyncMark \ (tclStubsPtr->tcl_AsyncMark) /* 74 */ #define Tcl_AsyncReady \ (tclStubsPtr->tcl_AsyncReady) /* 75 */ | | < | 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 | (tclStubsPtr->tcl_AsyncDelete) /* 72 */ #define Tcl_AsyncInvoke \ (tclStubsPtr->tcl_AsyncInvoke) /* 73 */ #define Tcl_AsyncMark \ (tclStubsPtr->tcl_AsyncMark) /* 74 */ #define Tcl_AsyncReady \ (tclStubsPtr->tcl_AsyncReady) /* 75 */ /* Slot 76 is reserved */ /* Slot 77 is reserved */ #define Tcl_BadChannelOption \ (tclStubsPtr->tcl_BadChannelOption) /* 78 */ #define Tcl_CallWhenDeleted \ (tclStubsPtr->tcl_CallWhenDeleted) /* 79 */ #define Tcl_CancelIdleCall \ (tclStubsPtr->tcl_CancelIdleCall) /* 80 */ |
| ︙ | ︙ | |||
2753 2754 2755 2756 2757 2758 2759 | (tclStubsPtr->tcl_GetsObj) /* 170 */ #define Tcl_GetServiceMode \ (tclStubsPtr->tcl_GetServiceMode) /* 171 */ #define Tcl_GetSlave \ (tclStubsPtr->tcl_GetSlave) /* 172 */ #define Tcl_GetStdChannel \ (tclStubsPtr->tcl_GetStdChannel) /* 173 */ | < | | 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 | (tclStubsPtr->tcl_GetsObj) /* 170 */ #define Tcl_GetServiceMode \ (tclStubsPtr->tcl_GetServiceMode) /* 171 */ #define Tcl_GetSlave \ (tclStubsPtr->tcl_GetSlave) /* 172 */ #define Tcl_GetStdChannel \ (tclStubsPtr->tcl_GetStdChannel) /* 173 */ /* Slot 174 is reserved */ /* Slot 175 is reserved */ #define Tcl_GetVar2 \ (tclStubsPtr->tcl_GetVar2) /* 176 */ /* Slot 177 is reserved */ /* Slot 178 is reserved */ #define Tcl_HideCommand \ (tclStubsPtr->tcl_HideCommand) /* 179 */ |
| ︙ | ︙ | |||
2885 2886 2887 2888 2889 2890 2891 | (tclStubsPtr->tcl_SignalMsg) /* 240 */ #define Tcl_SourceRCFile \ (tclStubsPtr->tcl_SourceRCFile) /* 241 */ #define Tcl_SplitList \ (tclStubsPtr->tcl_SplitList) /* 242 */ #define Tcl_SplitPath \ (tclStubsPtr->tcl_SplitPath) /* 243 */ | < | < | | 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 | (tclStubsPtr->tcl_SignalMsg) /* 240 */ #define Tcl_SourceRCFile \ (tclStubsPtr->tcl_SourceRCFile) /* 241 */ #define Tcl_SplitList \ (tclStubsPtr->tcl_SplitList) /* 242 */ #define Tcl_SplitPath \ (tclStubsPtr->tcl_SplitPath) /* 243 */ /* Slot 244 is reserved */ /* Slot 245 is reserved */ /* Slot 246 is reserved */ /* Slot 247 is reserved */ #define Tcl_TraceVar2 \ (tclStubsPtr->tcl_TraceVar2) /* 248 */ #define Tcl_TranslateFileName \ (tclStubsPtr->tcl_TranslateFileName) /* 249 */ #define Tcl_Ungets \ |
| ︙ | ︙ | |||
2933 2934 2935 2936 2937 2938 2939 | #define Tcl_HashStats \ (tclStubsPtr->tcl_HashStats) /* 269 */ #define Tcl_ParseVar \ (tclStubsPtr->tcl_ParseVar) /* 270 */ /* Slot 271 is reserved */ #define Tcl_PkgPresentEx \ (tclStubsPtr->tcl_PkgPresentEx) /* 272 */ | < | | 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 | #define Tcl_HashStats \ (tclStubsPtr->tcl_HashStats) /* 269 */ #define Tcl_ParseVar \ (tclStubsPtr->tcl_ParseVar) /* 270 */ /* Slot 271 is reserved */ #define Tcl_PkgPresentEx \ (tclStubsPtr->tcl_PkgPresentEx) /* 272 */ /* Slot 273 is reserved */ /* Slot 274 is reserved */ /* Slot 275 is reserved */ /* Slot 276 is reserved */ #define Tcl_WaitPid \ (tclStubsPtr->tcl_WaitPid) /* 277 */ /* Slot 278 is reserved */ #define Tcl_GetVersion \ |
| ︙ | ︙ | |||
3140 3141 3142 3143 3144 3145 3146 | (tclStubsPtr->tcl_NewUnicodeObj) /* 378 */ #define Tcl_SetUnicodeObj \ (tclStubsPtr->tcl_SetUnicodeObj) /* 379 */ #define Tcl_GetCharLength \ (tclStubsPtr->tcl_GetCharLength) /* 380 */ #define Tcl_GetUniChar \ (tclStubsPtr->tcl_GetUniChar) /* 381 */ | < | | 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 | (tclStubsPtr->tcl_NewUnicodeObj) /* 378 */ #define Tcl_SetUnicodeObj \ (tclStubsPtr->tcl_SetUnicodeObj) /* 379 */ #define Tcl_GetCharLength \ (tclStubsPtr->tcl_GetCharLength) /* 380 */ #define Tcl_GetUniChar \ (tclStubsPtr->tcl_GetUniChar) /* 381 */ /* Slot 382 is reserved */ #define Tcl_GetRange \ (tclStubsPtr->tcl_GetRange) /* 383 */ #define Tcl_AppendUnicodeToObj \ (tclStubsPtr->tcl_AppendUnicodeToObj) /* 384 */ #define Tcl_RegExpMatchObj \ (tclStubsPtr->tcl_RegExpMatchObj) /* 385 */ #define Tcl_SetNotifier \ |
| ︙ | ︙ | |||
3410 3411 3412 3413 3414 3415 3416 | (tclStubsPtr->tcl_FindCommand) /* 515 */ #define Tcl_GetCommandFromObj \ (tclStubsPtr->tcl_GetCommandFromObj) /* 516 */ #define Tcl_GetCommandFullName \ (tclStubsPtr->tcl_GetCommandFullName) /* 517 */ #define Tcl_FSEvalFileEx \ (tclStubsPtr->tcl_FSEvalFileEx) /* 518 */ | < | | 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 | (tclStubsPtr->tcl_FindCommand) /* 515 */ #define Tcl_GetCommandFromObj \ (tclStubsPtr->tcl_GetCommandFromObj) /* 516 */ #define Tcl_GetCommandFullName \ (tclStubsPtr->tcl_GetCommandFullName) /* 517 */ #define Tcl_FSEvalFileEx \ (tclStubsPtr->tcl_FSEvalFileEx) /* 518 */ /* Slot 519 is reserved */ #define Tcl_LimitAddHandler \ (tclStubsPtr->tcl_LimitAddHandler) /* 520 */ #define Tcl_LimitRemoveHandler \ (tclStubsPtr->tcl_LimitRemoveHandler) /* 521 */ #define Tcl_LimitReady \ (tclStubsPtr->tcl_LimitReady) /* 522 */ #define Tcl_LimitCheck \ |
| ︙ | ︙ | |||
3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 | (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 */ #endif /* defined(USE_TCL_STUBS) */ /* !END!: Do not edit above this line. */ #if defined(USE_TCL_STUBS) # undef Tcl_CreateInterp | > > > > > > > > > > > > > > > > > > > > > > > > > > > > < < < < > > > > > > | 3662 3663 3664 3665 3666 3667 3668 3669 3670 3671 3672 3673 3674 3675 3676 3677 3678 3679 3680 3681 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 3695 3696 3697 3698 3699 3700 3701 3702 3703 3704 3705 3706 3707 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 3729 |
(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 */
#endif /* defined(USE_TCL_STUBS) */
/* !END!: Do not edit above this line. */
#if defined(USE_TCL_STUBS)
# undef Tcl_CreateInterp
# undef Tcl_Init
# undef Tcl_ObjSetVar2
# define Tcl_CreateInterp() (tclStubsPtr->tcl_CreateInterp())
# define Tcl_Init(interp) (tclStubsPtr->tcl_Init(interp))
# define Tcl_ObjSetVar2(interp, part1, part2, newValue, flags) \
(tclStubsPtr->tcl_ObjSetVar2(interp, part1, part2, newValue, flags))
#endif
#if defined(_WIN32) && defined(UNICODE)
# define Tcl_FindExecutable(arg) ((Tcl_FindExecutable)((const char *)(arg)))
# define Tcl_MainEx Tcl_MainExW
TCLAPI TCL_NORETURN void Tcl_MainExW(int argc, wchar_t **argv,
Tcl_AppInitProc *appInitProc, Tcl_Interp *interp);
TCLAPI int TclZipfs_AppHook(int *argc, wchar_t ***argv);
#endif
#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS DLLIMPORT
#define Tcl_PkgPresent(interp, name, version, exact) \
Tcl_PkgPresentEx(interp, name, version, exact, NULL)
#define Tcl_PkgProvide(interp, name, version) \
Tcl_PkgProvideEx(interp, name, version, NULL)
#define Tcl_PkgRequire(interp, name, version, exact) \
Tcl_PkgRequireEx(interp, name, version, exact, NULL)
#define Tcl_GetIndexFromObj(interp, objPtr, tablePtr, msg, flags, indexPtr) \
|
| ︙ | ︙ | |||
3697 3698 3699 3700 3701 3702 3703 3704 3705 3706 3707 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 |
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_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))
| > < | | 3753 3754 3755 3756 3757 3758 3759 3760 3761 3762 3763 3764 3765 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 3782 3783 3784 3785 3786 3787 3788 3789 |
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 { \
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(__result); \
} else { \
(*__freeProc)(__result); \
} \
} \
} while(0)
#if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS)
|
| ︙ | ︙ | |||
3756 3757 3758 3759 3760 3761 3762 3763 3764 3765 | int result = tclStubsPtr->tcl_ExprLongObj(interp, obj, (long *)&intValue); if (result == TCL_OK) *ptr = (long)intValue; return result; } # endif #endif #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) | > > > > > > > > > > > > > > > > > > | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 3812 3813 3814 3815 3816 3817 3818 3819 3820 3821 3822 3823 3824 3825 3826 3827 3828 3829 3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 3846 3847 3848 3849 3850 3851 3852 3853 3854 3855 3856 3857 3858 3859 3860 3861 3862 3863 3864 3865 3866 3867 3868 3869 3870 3871 3872 3873 3874 3875 3876 3877 3878 3879 3880 3881 3882 3883 3884 3885 3886 3887 3888 3889 3890 3891 |
int result = tclStubsPtr->tcl_ExprLongObj(interp, obj, (long *)&intValue);
if (result == TCL_OK) *ptr = (long)intValue;
return result;
}
# 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)
/*
* 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
#endif /* _TCLDECLS */
|
Changes to generic/tclDictObj.c.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 | * * 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.h" /* * Forward declaration. */ struct Dict; /* * Prototypes for functions defined later in this file: */ 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 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); | > > > | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 | * * 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.h" #include <assert.h> /* * Forward declaration. */ struct Dict; /* * Prototypes for functions defined later in this file: */ 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 DictGetCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); static int DictGetDefCmd(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); |
| ︙ | ︙ | |||
60 61 62 63 64 65 66 | 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); | | | 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 | 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); static Tcl_NRPostProc FinalizeDictUpdate; static Tcl_NRPostProc FinalizeDictWith; |
| ︙ | ︙ | |||
84 85 86 87 88 89 90 91 92 93 94 95 96 97 |
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 },
{"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 },
| > > > | 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 |
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 },
|
| ︙ | ︙ | |||
137 138 139 140 141 142 143 |
* dictionary. Used for doing traversal of the
* entries in the order that they are
* created. */
ChainEntry *entryChainTail; /* Other end of linked list of all entries in
* the dictionary. Used for doing traversal of
* the entries in the order that they are
* created. */
| | < < < < < < < > > > > > > > > > > > > > > > | 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 |
* dictionary. Used for doing traversal of the
* entries in the order that they are
* created. */
ChainEntry *entryChainTail; /* Other end of linked list of all entries in
* the dictionary. Used for doing traversal of
* the entries in the order that they are
* created. */
size_t epoch; /* Epoch counter */
size_t refCount; /* Reference counter (see above) */
Tcl_Obj *chain; /* Linked list used for invalidating the
* string representations of updated nested
* dictionaries. */
} Dict;
/*
* The structure below defines the dictionary object type by means of
* functions that can be invoked by generic object code.
*/
const Tcl_ObjType tclDictType = {
"dict",
FreeDictInternalRep, /* freeIntRepProc */
DupDictInternalRep, /* dupIntRepProc */
UpdateStringOfDict, /* updateStringProc */
SetDictFromAny /* setFromAnyProc */
};
#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 ? 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.
*
|
| ︙ | ︙ | |||
225 226 227 228 229 230 231 |
*/
static Tcl_HashEntry *
AllocChainEntry(
Tcl_HashTable *tablePtr,
void *keyPtr)
{
| | | | 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 |
*/
static Tcl_HashEntry *
AllocChainEntry(
Tcl_HashTable *tablePtr,
void *keyPtr)
{
Tcl_Obj *objPtr = (Tcl_Obj *)keyPtr;
ChainEntry *cPtr;
cPtr = Tcl_Alloc(sizeof(ChainEntry));
cPtr->entry.key.objPtr = objPtr;
Tcl_IncrRefCount(objPtr);
Tcl_SetHashValue(&cPtr->entry, NULL);
cPtr->prevPtr = cPtr->nextPtr = NULL;
return &cPtr->entry;
}
|
| ︙ | ︙ | |||
359 360 361 362 363 364 365 |
*/
static void
DupDictInternalRep(
Tcl_Obj *srcPtr,
Tcl_Obj *copyPtr)
{
| < | > > | 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 |
*/
static void
DupDictInternalRep(
Tcl_Obj *srcPtr,
Tcl_Obj *copyPtr)
{
Dict *oldDict, *newDict = Tcl_Alloc(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) {
|
| ︙ | ︙ | |||
394 395 396 397 398 399 400 |
newDict->chain = NULL;
newDict->refCount = 1;
/*
* Store in the object.
*/
| | < < | 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 |
newDict->chain = NULL;
newDict->refCount = 1;
/*
* Store in the object.
*/
DictSetIntRep(copyPtr, newDict);
}
/*
*----------------------------------------------------------------------
*
* FreeDictInternalRep --
*
|
| ︙ | ︙ | |||
421 422 423 424 425 426 427 |
*----------------------------------------------------------------------
*/
static void
FreeDictInternalRep(
Tcl_Obj *dictPtr)
{
| | > > < | 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 |
*----------------------------------------------------------------------
*/
static void
FreeDictInternalRep(
Tcl_Obj *dictPtr)
{
Dict *dict;
DictGetIntRep(dictPtr, dict);
if (dict->refCount-- <= 1) {
DeleteDict(dict);
}
}
/*
*----------------------------------------------------------------------
*
* DeleteDict --
*
|
| ︙ | ︙ | |||
454 455 456 457 458 459 460 |
*/
static void
DeleteDict(
Dict *dict)
{
DeleteChainTable(dict);
| | | 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 |
*/
static void
DeleteDict(
Dict *dict)
{
DeleteChainTable(dict);
Tcl_Free(dict);
}
/*
*----------------------------------------------------------------------
*
* UpdateStringOfDict --
*
|
| ︙ | ︙ | |||
485 486 487 488 489 490 491 |
static void
UpdateStringOfDict(
Tcl_Obj *dictPtr)
{
#define LOCAL_SIZE 64
char localFlags[LOCAL_SIZE], *flagPtr = NULL;
| | > > > > > > | < | | | < < < < < | < | | < | < | < | | | 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 |
static void
UpdateStringOfDict(
Tcl_Obj *dictPtr)
{
#define LOCAL_SIZE 64
char localFlags[LOCAL_SIZE], *flagPtr = NULL;
Dict *dict;
ChainEntry *cPtr;
Tcl_Obj *keyPtr, *valuePtr;
size_t i, length, bytesNeeded = 0;
const char *elem;
char *dst;
/*
* This field is the most useful one in the whole hash structure, and it
* is not exposed by any API function...
*/
size_t numElems;
DictGetIntRep(dictPtr, dict);
assert (dict != NULL);
numElems = dict->table.numEntries * 2;
/* Handle empty list case first, simplifies what follows */
if (numElems == 0) {
Tcl_InitStringRep(dictPtr, NULL, 0);
return;
}
/*
* Pass 1: estimate space, gather flags.
*/
if (numElems <= LOCAL_SIZE) {
flagPtr = localFlags;
} else {
flagPtr = Tcl_Alloc(numElems);
}
for (i=0,cPtr=dict->entryChainHead; i<numElems; i+=2,cPtr=cPtr->nextPtr) {
/*
* Assume that cPtr is never NULL since we know the number of array
* elements already.
*/
flagPtr[i] = ( i ? TCL_DONT_QUOTE_HASH : 0 );
keyPtr = Tcl_GetHashKey(&dict->table, &cPtr->entry);
elem = TclGetStringFromObj(keyPtr, &length);
bytesNeeded += TclScanElement(elem, length, flagPtr+i);
flagPtr[i+1] = TCL_DONT_QUOTE_HASH;
valuePtr = Tcl_GetHashValue(&cPtr->entry);
elem = TclGetStringFromObj(valuePtr, &length);
bytesNeeded += TclScanElement(elem, length, flagPtr+i+1);
}
bytesNeeded += numElems;
/*
* Pass 2: copy into string rep buffer.
*/
dst = Tcl_InitStringRep(dictPtr, NULL, bytesNeeded - 1);
TclOOM(dst, bytesNeeded);
for (i=0,cPtr=dict->entryChainHead; i<numElems; i+=2,cPtr=cPtr->nextPtr) {
flagPtr[i] |= ( i ? TCL_DONT_QUOTE_HASH : 0 );
keyPtr = Tcl_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_GetHashValue(&cPtr->entry);
elem = TclGetStringFromObj(valuePtr, &length);
dst += TclConvertElement(elem, length, dst, flagPtr[i+1]);
*dst++ = ' ';
}
(void)Tcl_InitStringRep(dictPtr, NULL, bytesNeeded - 1);
if (flagPtr != localFlags) {
Tcl_Free(flagPtr);
}
}
/*
*----------------------------------------------------------------------
*
* SetDictFromAny --
|
| ︙ | ︙ | |||
594 595 596 597 598 599 600 |
static int
SetDictFromAny(
Tcl_Interp *interp,
Tcl_Obj *objPtr)
{
Tcl_HashEntry *hPtr;
int isNew;
| | | | 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 |
static int
SetDictFromAny(
Tcl_Interp *interp,
Tcl_Obj *objPtr)
{
Tcl_HashEntry *hPtr;
int isNew;
Dict *dict = Tcl_Alloc(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)) {
int objc, i;
Tcl_Obj **objv;
/* Cannot fail, we already know the Tcl_ObjType is "list". */
TclListObjGetElements(NULL, objPtr, &objc, &objv);
if (objc & 1) {
goto missingValue;
|
| ︙ | ︙ | |||
627 628 629 630 631 632 633 | /* * Not really a well-formed dictionary as there are duplicate * keys, so better get the string rep here so that we can * convert back. */ | | | > | > > > > | > | < > > | > > > | < | 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 |
/*
* Not really a well-formed dictionary as there are duplicate
* keys, so better get the string rep here so that we can
* convert back.
*/
(void) TclGetString(objPtr);
TclDecrRefCount(discardedValue);
}
Tcl_SetHashValue(hPtr, objv[i+1]);
Tcl_IncrRefCount(objv[i+1]); /* Since hash now holds ref to it */
}
} else {
size_t length;
const char *nextElem = TclGetStringFromObj(objPtr, &length);
const char *limit = (nextElem + length);
while (nextElem < limit) {
Tcl_Obj *keyPtr, *valuePtr;
const char *elemStart;
size_t elemSize;
int literal;
if (TclFindDictElement(interp, nextElem, (limit - nextElem),
&elemStart, &nextElem, &elemSize, &literal) != TCL_OK) {
goto errorInFindDictElement;
}
if (elemStart == limit) {
break;
}
if (nextElem == limit) {
goto missingValue;
}
if (literal) {
TclNewStringObj(keyPtr, elemStart, elemSize);
} else {
/* Avoid double copy */
char *dst;
TclNewObj(keyPtr);
Tcl_InvalidateStringRep(keyPtr);
dst = Tcl_InitStringRep(keyPtr, NULL, elemSize);
TclOOM(dst, elemSize); /* Consider error */
(void)Tcl_InitStringRep(keyPtr, NULL,
TclCopyAndCollapse(elemSize, elemStart, dst));
}
if (TclFindDictElement(interp, nextElem, (limit - nextElem),
&elemStart, &nextElem, &elemSize, &literal) != TCL_OK) {
TclDecrRefCount(keyPtr);
goto errorInFindDictElement;
}
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));
}
/* Store key and value in the hash table we're building. */
hPtr = CreateChainEntry(dict, keyPtr, &isNew);
if (!isNew) {
Tcl_Obj *discardedValue = Tcl_GetHashValue(hPtr);
|
| ︙ | ︙ | |||
700 701 702 703 704 705 706 |
/*
* 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.
*/
| < | < < | > > > > > > > > > > > > > > > > > | 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 |
/*
* 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;
dict->chain = NULL;
dict->refCount = 1;
DictSetIntRep(objPtr, dict);
return TCL_OK;
missingValue:
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"missing value to go with key", -1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "DICTIONARY", NULL);
}
errorInFindDictElement:
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;
}
/*
*----------------------------------------------------------------------
*
* TclTraceDictPath --
*
* Trace through a tree of dictionaries using the array of keys given. If
|
| ︙ | ︙ | |||
764 765 766 767 768 769 770 |
int keyc,
Tcl_Obj *const keyv[],
int flags)
{
Dict *dict, *newDict;
int i;
| > | | | | | > | 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 |
int keyc,
Tcl_Obj *const keyv[],
int flags)
{
Dict *dict, *newDict;
int i;
DictGetIntRep(dictPtr, dict);
if (dict == NULL) {
if (SetDictFromAny(interp, dictPtr) != TCL_OK) {
return NULL;
}
DictGetIntRep(dictPtr, dict);
}
if (flags & DICT_PATH_UPDATE) {
dict->chain = NULL;
}
for (i=0 ; i<keyc ; i++) {
Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&dict->table, keyv[i]);
Tcl_Obj *tmpObj;
|
| ︙ | ︙ | |||
804 805 806 807 808 809 810 |
hPtr = CreateChainEntry(dict, keyv[i], &isNew);
tmpObj = Tcl_NewDictObj();
Tcl_IncrRefCount(tmpObj);
Tcl_SetHashValue(hPtr, tmpObj);
} else {
tmpObj = Tcl_GetHashValue(hPtr);
| | > > > | | > | | | 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 |
hPtr = CreateChainEntry(dict, keyv[i], &isNew);
tmpObj = Tcl_NewDictObj();
Tcl_IncrRefCount(tmpObj);
Tcl_SetHashValue(hPtr, tmpObj);
} else {
tmpObj = Tcl_GetHashValue(hPtr);
DictGetIntRep(tmpObj, newDict);
if (newDict == NULL) {
if (SetDictFromAny(interp, tmpObj) != TCL_OK) {
return NULL;
}
}
}
DictGetIntRep(tmpObj, newDict);
if (flags & DICT_PATH_UPDATE) {
if (Tcl_IsShared(tmpObj)) {
TclDecrRefCount(tmpObj);
tmpObj = Tcl_DuplicateObj(tmpObj);
Tcl_IncrRefCount(tmpObj);
Tcl_SetHashValue(hPtr, tmpObj);
dict->epoch++;
DictGetIntRep(tmpObj, newDict);
}
newDict->chain = dictPtr;
}
dict = newDict;
dictPtr = tmpObj;
}
|
| ︙ | ︙ | |||
853 854 855 856 857 858 859 |
*----------------------------------------------------------------------
*/
static void
InvalidateDictChain(
Tcl_Obj *dictObj)
{
| | > > > > > > > | | 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 |
*----------------------------------------------------------------------
*/
static void
InvalidateDictChain(
Tcl_Obj *dictObj)
{
Dict *dict;
DictGetIntRep(dictObj, dict);
assert( dict != NULL);
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);
} while (dict != NULL);
}
/*
*----------------------------------------------------------------------
*
* Tcl_DictObjPut --
|
| ︙ | ︙ | |||
901 902 903 904 905 906 907 |
Tcl_HashEntry *hPtr;
int isNew;
if (Tcl_IsShared(dictPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_DictObjPut");
}
| < | > < | < < > > > | 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 |
Tcl_HashEntry *hPtr;
int isNew;
if (Tcl_IsShared(dictPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_DictObjPut");
}
dict = GetDictFromObj(interp, dictPtr);
if (dict == NULL) {
return TCL_ERROR;
}
TclInvalidateStringRep(dictPtr);
hPtr = CreateChainEntry(dict, keyPtr, &isNew);
dict->refCount++;
TclFreeIntRep(dictPtr)
DictSetIntRep(dictPtr, dict);
Tcl_IncrRefCount(valuePtr);
if (!isNew) {
Tcl_Obj *oldValuePtr = Tcl_GetHashValue(hPtr);
TclDecrRefCount(oldValuePtr);
}
Tcl_SetHashValue(hPtr, valuePtr);
|
| ︙ | ︙ | |||
952 953 954 955 956 957 958 |
Tcl_Obj *dictPtr,
Tcl_Obj *keyPtr,
Tcl_Obj **valuePtrPtr)
{
Dict *dict;
Tcl_HashEntry *hPtr;
| < | > < | 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 |
Tcl_Obj *dictPtr,
Tcl_Obj *keyPtr,
Tcl_Obj **valuePtrPtr)
{
Dict *dict;
Tcl_HashEntry *hPtr;
dict = GetDictFromObj(interp, dictPtr);
if (dict == NULL) {
*valuePtrPtr = NULL;
return TCL_ERROR;
}
hPtr = Tcl_FindHashEntry(&dict->table, keyPtr);
if (hPtr == NULL) {
*valuePtrPtr = NULL;
} else {
*valuePtrPtr = Tcl_GetHashValue(hPtr);
}
return TCL_OK;
|
| ︙ | ︙ | |||
999 1000 1001 1002 1003 1004 1005 |
{
Dict *dict;
if (Tcl_IsShared(dictPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_DictObjRemove");
}
| < | > < < | < | 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 |
{
Dict *dict;
if (Tcl_IsShared(dictPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_DictObjRemove");
}
dict = GetDictFromObj(interp, dictPtr);
if (dict == NULL) {
return TCL_ERROR;
}
if (DeleteChainEntry(dict, keyPtr)) {
TclInvalidateStringRep(dictPtr);
dict->epoch++;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
1040 1041 1042 1043 1044 1045 1046 |
Tcl_DictObjSize(
Tcl_Interp *interp,
Tcl_Obj *dictPtr,
int *sizePtr)
{
Dict *dict;
| < | > < | 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 |
Tcl_DictObjSize(
Tcl_Interp *interp,
Tcl_Obj *dictPtr,
int *sizePtr)
{
Dict *dict;
dict = GetDictFromObj(interp, dictPtr);
if (dict == NULL) {
return TCL_ERROR;
}
*sizePtr = dict->table.numEntries;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1092 1093 1094 1095 1096 1097 1098 |
* written into when there are no further
* values in the dictionary, or a 0
* otherwise. */
{
Dict *dict;
ChainEntry *cPtr;
| < | > < | 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 |
* written into when there are no further
* values in the dictionary, or a 0
* otherwise. */
{
Dict *dict;
ChainEntry *cPtr;
dict = GetDictFromObj(interp, dictPtr);
if (dict == NULL) {
return TCL_ERROR;
}
cPtr = dict->entryChainHead;
if (cPtr == NULL) {
searchPtr->epoch = 0;
*donePtr = 1;
} else {
*donePtr = 0;
searchPtr->dictionaryPtr = (Tcl_Dict) dict;
|
| ︙ | ︙ | |||
1271 1272 1273 1274 1275 1276 1277 |
}
dictPtr = TclTraceDictPath(interp, dictPtr, keyc-1,keyv, DICT_PATH_CREATE);
if (dictPtr == NULL) {
return TCL_ERROR;
}
| | > | 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 |
}
dictPtr = TclTraceDictPath(interp, dictPtr, keyc-1,keyv, DICT_PATH_CREATE);
if (dictPtr == NULL) {
return TCL_ERROR;
}
DictGetIntRep(dictPtr, dict);
assert(dict != NULL);
hPtr = CreateChainEntry(dict, keyv[keyc-1], &isNew);
Tcl_IncrRefCount(valuePtr);
if (!isNew) {
Tcl_Obj *oldValuePtr = Tcl_GetHashValue(hPtr);
TclDecrRefCount(oldValuePtr);
}
|
| ︙ | ︙ | |||
1328 1329 1330 1331 1332 1333 1334 |
}
dictPtr = TclTraceDictPath(interp, dictPtr, keyc-1,keyv, DICT_PATH_UPDATE);
if (dictPtr == NULL) {
return TCL_ERROR;
}
| | > | 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 |
}
dictPtr = TclTraceDictPath(interp, dictPtr, keyc-1,keyv, DICT_PATH_UPDATE);
if (dictPtr == NULL) {
return TCL_ERROR;
}
DictGetIntRep(dictPtr, dict);
assert(dict != NULL);
DeleteChainEntry(dict, keyv[keyc-1]);
InvalidateDictChain(dictPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
1369 1370 1371 1372 1373 1374 1375 |
#else /* !TCL_MEM_DEBUG */
Tcl_Obj *dictPtr;
Dict *dict;
TclNewObj(dictPtr);
TclInvalidateStringRep(dictPtr);
| | | < < | 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 |
#else /* !TCL_MEM_DEBUG */
Tcl_Obj *dictPtr;
Dict *dict;
TclNewObj(dictPtr);
TclInvalidateStringRep(dictPtr);
dict = Tcl_Alloc(sizeof(Dict));
InitChainTable(dict);
dict->epoch = 1;
dict->chain = NULL;
dict->refCount = 1;
DictSetIntRep(dictPtr, dict);
return dictPtr;
#endif
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1419 1420 1421 1422 1423 1424 1425 |
{
#ifdef TCL_MEM_DEBUG
Tcl_Obj *dictPtr;
Dict *dict;
TclDbNewObj(dictPtr, file, line);
TclInvalidateStringRep(dictPtr);
| | | < < | 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 |
{
#ifdef TCL_MEM_DEBUG
Tcl_Obj *dictPtr;
Dict *dict;
TclDbNewObj(dictPtr, file, line);
TclInvalidateStringRep(dictPtr);
dict = Tcl_Alloc(sizeof(Dict));
InitChainTable(dict);
dict->epoch = 1;
dict->chain = NULL;
dict->refCount = 1;
DictSetIntRep(dictPtr, dict);
return dictPtr;
#else /* !TCL_MEM_DEBUG */
return Tcl_NewDictObj();
#endif
}
/***** START OF FUNCTIONS IMPLEMENTING TCL COMMANDS *****/
|
| ︙ | ︙ | |||
1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 |
Tcl_SetObjResult(interp, valuePtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* DictReplaceCmd --
*
* This function implements the "dict replace" Tcl command. See the user
* documentation for details on what it does, and TIP#111 for the formal
* specification.
*
* Results:
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 |
Tcl_SetObjResult(interp, valuePtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* DictGetDefCmd --
*
* This function implements the "dict getdef" and "dict getwithdefault"
* Tcl commands. See the user documentation for details on what it does,
* and TIP#342 for the formal specification.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
DictGetDefCmd(
ClientData dummy,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Obj *dictPtr, *keyPtr, *valuePtr, *defaultPtr;
Tcl_Obj *const *keyPath;
int numKeys;
if (objc < 4) {
Tcl_WrongNumArgs(interp, 1, objv, "dictionary ?key ...? key default");
return TCL_ERROR;
}
/*
* Give the bits of arguments names for clarity.
*/
dictPtr = objv[1];
keyPath = &objv[2];
numKeys = objc - 4; /* Number of keys in keyPath; there's always
* one extra key afterwards too. */
keyPtr = objv[objc - 2];
defaultPtr = objv[objc - 1];
/*
* Implement the getting-with-default operation.
*/
dictPtr = TclTraceDictPath(interp, dictPtr, numKeys, keyPath,
DICT_PATH_EXISTS);
if (dictPtr == NULL) {
return TCL_ERROR;
} else if (dictPtr == DICT_PATH_NON_EXISTENT) {
Tcl_SetObjResult(interp, defaultPtr);
} else if (Tcl_DictObjGet(interp, dictPtr, keyPtr, &valuePtr) != TCL_OK) {
return TCL_ERROR;
} else if (valuePtr == NULL) {
Tcl_SetObjResult(interp, defaultPtr);
} else {
Tcl_SetObjResult(interp, valuePtr);
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* DictReplaceCmd --
*
* This function implements the "dict replace" Tcl command. See the user
* documentation for details on what it does, and TIP#111 for the formal
* specification.
*
* Results:
|
| ︙ | ︙ | |||
1612 1613 1614 1615 1616 1617 1618 |
if ((objc < 2) || (objc & 1)) {
Tcl_WrongNumArgs(interp, 1, objv, "dictionary ?key value ...?");
return TCL_ERROR;
}
dictPtr = objv[1];
| < | < | < | 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 |
if ((objc < 2) || (objc & 1)) {
Tcl_WrongNumArgs(interp, 1, objv, "dictionary ?key value ...?");
return TCL_ERROR;
}
dictPtr = objv[1];
if (GetDictFromObj(interp, dictPtr) == NULL) {
return TCL_ERROR;
}
if (Tcl_IsShared(dictPtr)) {
dictPtr = Tcl_DuplicateObj(dictPtr);
}
TclInvalidateStringRep(dictPtr);
for (i=2 ; i<objc ; i+=2) {
Tcl_DictObjPut(NULL, dictPtr, objv[i], objv[i+1]);
}
Tcl_SetObjResult(interp, dictPtr);
return TCL_OK;
}
|
| ︙ | ︙ | |||
1663 1664 1665 1666 1667 1668 1669 |
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "dictionary ?key ...?");
return TCL_ERROR;
}
dictPtr = objv[1];
| < | < | < | 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 |
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "dictionary ?key ...?");
return TCL_ERROR;
}
dictPtr = objv[1];
if (GetDictFromObj(interp, dictPtr) == NULL) {
return TCL_ERROR;
}
if (Tcl_IsShared(dictPtr)) {
dictPtr = Tcl_DuplicateObj(dictPtr);
}
TclInvalidateStringRep(dictPtr);
for (i=2 ; i<objc ; i++) {
Tcl_DictObjRemove(NULL, dictPtr, objv[i]);
}
Tcl_SetObjResult(interp, dictPtr);
return TCL_OK;
}
|
| ︙ | ︙ | |||
1723 1724 1725 1726 1727 1728 1729 |
}
/*
* Make sure first argument is a dictionary.
*/
targetObj = objv[1];
| < | | 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 |
}
/*
* Make sure first argument is a dictionary.
*/
targetObj = objv[1];
if (GetDictFromObj(interp, targetObj) == NULL) {
return TCL_ERROR;
}
if (objc == 2) {
/*
* Single argument, return it.
*/
|
| ︙ | ︙ | |||
1807 1808 1809 1810 1811 1812 1813 |
/*
* 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]
*/
| < | | 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 |
/*
* 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 (objc == 3) {
pattern = TclGetString(objv[2]);
}
listPtr = Tcl_NewListObj(0, NULL);
|
| ︙ | ︙ | |||
1941 1942 1943 1944 1945 1946 1947 |
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "dictionary");
return TCL_ERROR;
}
result = Tcl_DictObjSize(interp, objv[1], &size);
if (result == TCL_OK) {
| | | 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 |
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "dictionary");
return TCL_ERROR;
}
result = Tcl_DictObjSize(interp, objv[1], &size);
if (result == TCL_OK) {
Tcl_SetObjResult(interp, Tcl_NewIntObj(size));
}
return result;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1978 1979 1980 1981 1982 1983 1984 |
Tcl_Obj *dictPtr, *valuePtr;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv, "dictionary key ?key ...?");
return TCL_ERROR;
}
| | < | < | | | | 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 |
Tcl_Obj *dictPtr, *valuePtr;
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) {
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0));
} else {
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(valuePtr != NULL));
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
2015 2016 2017 2018 2019 2020 2021 |
static int
DictInfoCmd(
ClientData dummy,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
| < | | < < | | 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 |
static int
DictInfoCmd(
ClientData dummy,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Dict *dict;
char *statsStr;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "dictionary");
return TCL_ERROR;
}
dict = GetDictFromObj(interp, objv[1]);
if (dict == NULL) {
return TCL_ERROR;
}
statsStr = Tcl_HashStats(&dict->table);
Tcl_SetObjResult(interp, Tcl_NewStringObj(statsStr, -1));
Tcl_Free(statsStr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* DictIncrCmd --
|
| ︙ | ︙ | |||
2090 2091 2092 2093 2094 2095 2096 |
}
if (Tcl_IsShared(dictPtr)) {
/*
* A little internals surgery to avoid copying a string rep that will
* soon be no good.
*/
| < | | | | 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 |
}
if (Tcl_IsShared(dictPtr)) {
/*
* A little internals surgery to avoid copying a string rep that will
* soon be no good.
*/
Tcl_Obj *oldPtr = dictPtr;
TclNewObj(dictPtr);
TclInvalidateStringRep(dictPtr);
DupDictInternalRep(oldPtr, dictPtr);
}
if (valuePtr == NULL) {
/*
* Key not in dictionary. Create new key with increment as value.
*/
if (objc == 4) {
|
| ︙ | ︙ | |||
2136 2137 2138 2139 2140 2141 2142 |
if (Tcl_IsShared(valuePtr)) {
valuePtr = Tcl_DuplicateObj(valuePtr);
Tcl_DictObjPut(NULL, dictPtr, objv[2], valuePtr);
}
if (objc == 4) {
code = TclIncrObj(interp, valuePtr, objv[3]);
} else {
| | | 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 |
if (Tcl_IsShared(valuePtr)) {
valuePtr = Tcl_DuplicateObj(valuePtr);
Tcl_DictObjPut(NULL, dictPtr, objv[2], valuePtr);
}
if (objc == 4) {
code = TclIncrObj(interp, valuePtr, objv[3]);
} else {
Tcl_Obj *incrPtr = Tcl_NewIntObj(1);
Tcl_IncrRefCount(incrPtr);
code = TclIncrObj(interp, valuePtr, incrPtr);
TclDecrRefCount(incrPtr);
}
}
if (code == TCL_OK) {
|
| ︙ | ︙ | |||
2232 2233 2234 2235 2236 2237 2238 |
return TCL_ERROR;
}
}
}
if (allocatedValue) {
Tcl_DictObjPut(NULL, dictPtr, objv[2], valuePtr);
| | | 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 |
return TCL_ERROR;
}
}
}
if (allocatedValue) {
Tcl_DictObjPut(NULL, dictPtr, objv[2], valuePtr);
} else {
TclInvalidateStringRep(dictPtr);
}
resultPtr = Tcl_ObjSetVar2(interp, objv[1], NULL, dictPtr,
TCL_LEAVE_ERR_MSG);
if (resultPtr == NULL) {
return TCL_ERROR;
|
| ︙ | ︙ | |||
2915 2916 2917 2918 2919 2920 2921 |
int index, varc, done, result, satisfied;
const char *pattern;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv, "dictionary filterType ?arg ...?");
return TCL_ERROR;
}
| | | | 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 |
int index, varc, done, result, satisfied;
const char *pattern;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv, "dictionary filterType ?arg ...?");
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:
/*
* Create a dictionary whose keys all match a certain pattern.
|
| ︙ | ︙ | |||
3207 3208 3209 3210 3211 3212 3213 |
for (i=2 ; i+2<objc ; i+=2) {
if (Tcl_DictObjGet(interp, dictPtr, objv[i], &objPtr) != TCL_OK) {
TclDecrRefCount(dictPtr);
return TCL_ERROR;
}
if (objPtr == NULL) {
/* ??? */
| | | 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 |
for (i=2 ; i+2<objc ; i+=2) {
if (Tcl_DictObjGet(interp, dictPtr, objv[i], &objPtr) != TCL_OK) {
TclDecrRefCount(dictPtr);
return TCL_ERROR;
}
if (objPtr == NULL) {
/* ??? */
Tcl_UnsetVar(interp, TclGetString(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);
|
| ︙ | ︙ |
Changes to generic/tclDisassemble.c.
| ︙ | ︙ | |||
34 35 36 37 38 39 40 | 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. */ | | < > > | < > > > > | > > > > > | | 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 |
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
|
| ︙ | ︙ | |||
182 183 184 185 186 187 188 |
*/
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. */
| | | | 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 |
*/
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));
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
213 214 215 216 217 218 219 |
*----------------------------------------------------------------------
*/
void
TclPrintSource(
FILE *outFile, /* The file to print the source to. */
const char *stringPtr, /* The string to print. */
| | | 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 |
*----------------------------------------------------------------------
*/
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);
|
| ︙ | ︙ | |||
241 242 243 244 245 246 247 |
*/
static Tcl_Obj *
DisassembleByteCodeObj(
Tcl_Interp *interp,
Tcl_Obj *objPtr) /* The bytecode object to disassemble. */
{
| | | > > > > | < | | | 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 |
*/
static Tcl_Obj *
DisassembleByteCodeObj(
Tcl_Interp *interp,
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 > -1 && 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
|
| ︙ | ︙ | |||
308 309 310 311 312 313 314 |
*/
if (codePtr->procPtr != NULL) {
Proc *procPtr = codePtr->procPtr;
int numCompiledLocals = procPtr->numCompiledLocals;
Tcl_AppendPrintfToObj(bufferObj,
| | | | 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 |
*/
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,
|
| ︙ | ︙ | |||
392 393 394 395 396 397 398 |
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++) {
| | | | | | 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 |
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++;
}
|
| ︙ | ︙ | |||
451 452 453 454 455 456 457 |
codeDeltaNext = codePtr->codeDeltaStart;
srcDeltaNext = codePtr->srcDeltaStart;
srcLengthNext = codePtr->srcLengthStart;
codeOffset = srcOffset = 0;
pc = codeStart;
for (i = 0; i < numCmds; i++) {
| | | | | 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 |
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++;
}
|
| ︙ | ︙ | |||
551 552 553 554 555 556 557 | break; case OPERAND_INT4: opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4; Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd); break; case OPERAND_UINT1: opnd = TclGetUInt1AtPtr(pc+numBytes); numBytes++; | | | | | | | 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 |
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) {
|
| ︙ | ︙ | |||
611 612 613 614 615 616 617 |
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)",
| | | | | | 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 |
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) {
|
| ︙ | ︙ | |||
792 793 794 795 796 797 798 |
Tcl_Obj *
TclNewInstNameObj(
unsigned char inst)
{
Tcl_Obj *objPtr = Tcl_NewObj();
| | | < | | > > | > > | < > | < | < < | | > | 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 |
Tcl_Obj *
TclNewInstNameObj(
unsigned char inst)
{
Tcl_Obj *objPtr = Tcl_NewObj();
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, 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 --
*
|
| ︙ | ︙ | |||
890 891 892 893 894 895 896 |
continue;
default:
#if TCL_UTF_MAX > 4
if (ch > 0xffff) {
Tcl_AppendPrintfToObj(appendObj, "\\U%08x", ch);
i += 10;
} else
| | | 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 |
continue;
default:
#if TCL_UTF_MAX > 4
if (ch > 0xffff) {
Tcl_AppendPrintfToObj(appendObj, "\\U%08x", ch);
i += 10;
} else
#else
/* If len == 0, this means we have a char > 0xffff, resulting in
* TclUtfToUniChar producing a surrogate pair. We want to output
* this pair as a single Unicode character.
*/
if (len == 0) {
int upper = ((ch & 0x3ff) + 1) << 10;
len = TclUtfToUniChar(p, &ch);
|
| ︙ | ︙ | |||
938 939 940 941 942 943 944 |
static Tcl_Obj *
DisassembleByteCodeAsDicts(
Tcl_Interp *interp, /* Used for looking up the CmdFrame for the
* procedure, if one exists. */
Tcl_Obj *objPtr) /* The bytecode-holding value to take apart */
{
| | > > | 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 |
static Tcl_Obj *
DisassembleByteCodeAsDicts(
Tcl_Interp *interp, /* Used for looking up the CmdFrame for the
* procedure, if one exists. */
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.
*/
literals = Tcl_NewObj();
for (i=0 ; i<codePtr->numLitObjects ; i++) {
|
| ︙ | ︙ | |||
1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 |
DISAS_SCRIPT
};
int idx, result;
Tcl_Obj *codeObjPtr = NULL;
Proc *procPtr = NULL;
Tcl_HashEntry *hPtr;
Object *oPtr;
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.
| > < < < < | > | < < | < < < | 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 |
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);
|
| ︙ | ︙ | |||
1370 1371 1372 1373 1374 1375 1376 |
* Compile and disassemble a script.
*/
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "script");
return TCL_ERROR;
}
| > | | | 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 |
* 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) {
|
| ︙ | ︙ | |||
1421 1422 1423 1424 1425 1426 1427 | return TCL_ERROR; } /* * Compile if necessary. */ | | | 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 |
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.
*/
|
| ︙ | ︙ | |||
1486 1487 1488 1489 1490 1491 1492 | return TCL_ERROR; } /* * Compile if necessary. */ | | | 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 |
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.
*/
|
| ︙ | ︙ | |||
1571 1572 1573 1574 1575 1576 1577 |
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;
}
| | | 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 |
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.
*/
|
| ︙ | ︙ | |||
1599 1600 1601 1602 1603 1604 1605 |
CLANG_ASSERT(0);
}
/*
* Do the actual disassembly.
*/
| > > | | | 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 |
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(interp, codeObjPtr));
} else {
Tcl_SetObjResult(interp,
DisassembleByteCodeObj(interp, codeObjPtr));
}
return TCL_OK;
|
| ︙ | ︙ |
Changes to generic/tclEncoding.c.
| ︙ | ︙ | |||
230 231 232 233 234 235 236 | 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); | | | | 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 | 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 UniCharToUtfProc(ClientData clientData, const char *src, int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); static int UtfToUniCharProc(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, |
| ︙ | ︙ | |||
275 276 277 278 279 280 281 282 283 284 285 286 287 288 |
* of the intrep. This should help the lifetime of encodings be more useful.
* See concerns raised in [Bug 1077262].
*/
static const Tcl_ObjType encodingType = {
"encoding", FreeEncodingIntRep, DupEncodingIntRep, NULL, NULL
};
/*
*----------------------------------------------------------------------
*
* Tcl_GetEncodingFromObj --
*
* Writes to (*encodingPtr) the Tcl_Encoding value of (*objPtr), if
| > > > > > > > > > > > > > > > | 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 |
* of the intrep. This should help the lifetime of encodings be more useful.
* See concerns raised in [Bug 1077262].
*/
static const 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 ? irPtr->twoPtrValue.ptr1 : NULL; \
} while (0)
/*
*----------------------------------------------------------------------
*
* Tcl_GetEncodingFromObj --
*
* Writes to (*encodingPtr) the Tcl_Encoding value of (*objPtr), if
|
| ︙ | ︙ | |||
301 302 303 304 305 306 307 308 309 |
int
Tcl_GetEncodingFromObj(
Tcl_Interp *interp,
Tcl_Obj *objPtr,
Tcl_Encoding *encodingPtr)
{
const char *name = TclGetString(objPtr);
| > > | | < | < < > > > | < | | | 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 |
int
Tcl_GetEncodingFromObj(
Tcl_Interp *interp,
Tcl_Obj *objPtr,
Tcl_Encoding *encodingPtr)
{
Tcl_Encoding encoding;
const char *name = TclGetString(objPtr);
EncodingGetIntRep(objPtr, encoding);
if (encoding == NULL) {
encoding = Tcl_GetEncoding(interp, name);
if (encoding == NULL) {
return TCL_ERROR;
}
EncodingSetIntRep(objPtr, encoding);
}
*encodingPtr = Tcl_GetEncoding(NULL, name);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* FreeEncodingIntRep --
*
* The Tcl_FreeInternalRepProc for the "encoding" Tcl_ObjType.
*
*----------------------------------------------------------------------
*/
static void
FreeEncodingIntRep(
Tcl_Obj *objPtr)
{
Tcl_Encoding encoding;
EncodingGetIntRep(objPtr, encoding);
Tcl_FreeEncoding(encoding);
}
/*
*----------------------------------------------------------------------
*
* DupEncodingIntRep --
*
* The Tcl_DupInternalRepProc for the "encoding" Tcl_ObjType.
*
*----------------------------------------------------------------------
*/
static void
DupEncodingIntRep(
Tcl_Obj *srcPtr,
Tcl_Obj *dupPtr)
{
Tcl_Encoding encoding = Tcl_GetEncoding(NULL, TclGetString(srcPtr));
EncodingSetIntRep(dupPtr, encoding);
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetEncodingSearchPath --
*
|
| ︙ | ︙ | |||
576 577 578 579 580 581 582 |
type.fromUtfProc = UtfIntToUtfExtProc;
type.freeProc = NULL;
type.nullSize = 1;
type.clientData = NULL;
Tcl_CreateEncoding(&type);
type.encodingName = "unicode";
| | | | | | | 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 |
type.fromUtfProc = UtfIntToUtfExtProc;
type.freeProc = NULL;
type.nullSize = 1;
type.clientData = NULL;
Tcl_CreateEncoding(&type);
type.encodingName = "unicode";
type.toUtfProc = UniCharToUtfProc;
type.fromUtfProc = UtfToUniCharProc;
type.freeProc = NULL;
type.nullSize = 2;
type.clientData = NULL;
Tcl_CreateEncoding(&type);
/*
* Need the iso8859-1 encoding in order to process binary data, so force
* it to always be embedded. Note that this encoding *must* be a proper
* table encoding or some of the escape encodings crash! Hence the ugly
* code to duplicate the structure of a table encoding here.
*/
dataPtr = Tcl_Alloc(sizeof(TableEncodingData));
memset(dataPtr, 0, sizeof(TableEncodingData));
dataPtr->fallback = '?';
size = 256*(sizeof(unsigned short *) + sizeof(unsigned short));
dataPtr->toUnicode = Tcl_Alloc(size);
memset(dataPtr->toUnicode, 0, size);
dataPtr->fromUnicode = 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;
|
| ︙ | ︙ | |||
786 787 788 789 790 791 792 |
if (encodingPtr->freeProc != NULL) {
encodingPtr->freeProc(encodingPtr->clientData);
}
if (encodingPtr->hPtr != NULL) {
Tcl_DeleteHashEntry(encodingPtr->hPtr);
}
if (encodingPtr->name) {
| | | | 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 |
if (encodingPtr->freeProc != NULL) {
encodingPtr->freeProc(encodingPtr->clientData);
}
if (encodingPtr->hPtr != NULL) {
Tcl_DeleteHashEntry(encodingPtr->hPtr);
}
if (encodingPtr->name) {
Tcl_Free(encodingPtr->name);
}
Tcl_Free(encodingPtr);
}
}
/*
*-------------------------------------------------------------------------
*
* Tcl_GetEncodingName --
|
| ︙ | ︙ | |||
976 977 978 979 980 981 982 |
*/
Tcl_Encoding
Tcl_CreateEncoding(
const Tcl_EncodingType *typePtr)
/* The encoding type. */
{
| | | 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 |
*/
Tcl_Encoding
Tcl_CreateEncoding(
const Tcl_EncodingType *typePtr)
/* The encoding type. */
{
Encoding *encodingPtr = Tcl_Alloc(sizeof(Encoding));
encodingPtr->name = NULL;
encodingPtr->toUtfProc = typePtr->toUtfProc;
encodingPtr->fromUtfProc = typePtr->fromUtfProc;
encodingPtr->freeProc = typePtr->freeProc;
encodingPtr->nullSize = typePtr->nullSize;
encodingPtr->clientData = typePtr->clientData;
if (typePtr->nullSize == 1) {
|
| ︙ | ︙ | |||
1008 1009 1010 1011 1012 1013 1014 |
* reference goes away.
*/
Encoding *replaceMe = Tcl_GetHashValue(hPtr);
replaceMe->hPtr = NULL;
}
| | | 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 |
* reference goes away.
*/
Encoding *replaceMe = Tcl_GetHashValue(hPtr);
replaceMe->hPtr = NULL;
}
name = 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;
|
| ︙ | ︙ | |||
1044 1045 1046 1047 1048 1049 1050 |
*/
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. */
| | | > | | 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 |
*/
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
* 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;
Tcl_DStringInit(dstPtr);
dst = Tcl_DStringValue(dstPtr);
dstLen = dstPtr->spaceAvl - 1;
if (encoding == NULL) {
encoding = systemEncoding;
}
encodingPtr = (Encoding *) encoding;
if (src == NULL) {
srcLen = 0;
} else if (srcLen == TCL_AUTO_LENGTH) {
srcLen = encodingPtr->lengthProc(src);
}
flags = TCL_ENCODING_START | TCL_ENCODING_END;
while (1) {
result = encodingPtr->toUtfProc(encodingPtr->clientData, src, srcLen,
|
| ︙ | ︙ | |||
1117 1118 1119 1120 1121 1122 1123 |
int
Tcl_ExternalToUtf(
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. */
| | | | | 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 |
int
Tcl_ExternalToUtf(
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 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
* 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
|
| ︙ | ︙ | |||
1155 1156 1157 1158 1159 1160 1161 |
if (encoding == NULL) {
encoding = systemEncoding;
}
encodingPtr = (Encoding *) encoding;
if (src == NULL) {
srcLen = 0;
| | | 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 |
if (encoding == NULL) {
encoding = systemEncoding;
}
encodingPtr = (Encoding *) encoding;
if (src == NULL) {
srcLen = 0;
} else if (srcLen == TCL_AUTO_LENGTH) {
srcLen = encodingPtr->lengthProc(src);
}
if (statePtr == NULL) {
flags |= TCL_ENCODING_START | TCL_ENCODING_END;
statePtr = &state;
}
if (srcReadPtr == NULL) {
|
| ︙ | ︙ | |||
1234 1235 1236 1237 1238 1239 1240 |
*/
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. */
| | | > | | 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 |
*/
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
* 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;
Tcl_DStringInit(dstPtr);
dst = Tcl_DStringValue(dstPtr);
dstLen = dstPtr->spaceAvl - 1;
if (encoding == NULL) {
encoding = systemEncoding;
}
encodingPtr = (Encoding *) encoding;
if (src == NULL) {
srcLen = 0;
} else if (srcLen == TCL_AUTO_LENGTH) {
srcLen = strlen(src);
}
flags = TCL_ENCODING_START | TCL_ENCODING_END;
while (1) {
result = encodingPtr->fromUtfProc(encodingPtr->clientData, src,
srcLen, flags, &state, dst, dstLen, &srcRead, &dstWrote,
&dstChars);
|
| ︙ | ︙ | |||
1309 1310 1311 1312 1313 1314 1315 |
int
Tcl_UtfToExternal(
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. */
| | | | | 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 |
int
Tcl_UtfToExternal(
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 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
* 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
|
| ︙ | ︙ | |||
1344 1345 1346 1347 1348 1349 1350 |
if (encoding == NULL) {
encoding = systemEncoding;
}
encodingPtr = (Encoding *) encoding;
if (src == NULL) {
srcLen = 0;
| | | 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 |
if (encoding == NULL) {
encoding = systemEncoding;
}
encodingPtr = (Encoding *) encoding;
if (src == NULL) {
srcLen = 0;
} else if (srcLen == TCL_AUTO_LENGTH) {
srcLen = strlen(src);
}
if (statePtr == NULL) {
flags |= TCL_ENCODING_START | TCL_ENCODING_END;
statePtr = &state;
}
if (srcReadPtr == NULL) {
|
| ︙ | ︙ | |||
1655 1656 1657 1658 1659 1660 1661 |
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 192 ... 207 */
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 208 ... 223 */
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 224 ... 239 */
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 240 ... 255 */
};
Tcl_DStringInit(&lineString);
| | > > | | > | > > | 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 |
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 192 ... 207 */
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 208 ... 223 */
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 224 ... 239 */
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 240 ... 255 */
};
Tcl_DStringInit(&lineString);
if (Tcl_Gets(chan, &lineString) == TCL_IO_FAILURE) {
return NULL;
}
line = Tcl_DStringValue(&lineString);
fallback = (int) strtol(line, &line, 16);
symbol = (int) strtol(line, &line, 10);
numPages = (int) strtol(line, &line, 10);
Tcl_DStringFree(&lineString);
if (numPages < 0) {
numPages = 0;
} else if (numPages > 256) {
numPages = 256;
}
memset(used, 0, sizeof(used));
#undef PAGESIZE
#define PAGESIZE (256 * sizeof(unsigned short))
dataPtr = Tcl_Alloc(sizeof(TableEncodingData));
memset(dataPtr, 0, sizeof(TableEncodingData));
dataPtr->fallback = fallback;
/*
* Read the table that maps characters to Unicode. Performs a single
* malloc to get the memory for the array and all the pages needed by the
* array.
*/
size = 256 * sizeof(unsigned short *) + numPages * PAGESIZE;
dataPtr->toUnicode = Tcl_Alloc(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);
if (Tcl_ReadChars(chan, objPtr, expected, 0) != expected) {
return NULL;
}
p = TclGetString(objPtr);
hi = (staticHex[UCHAR(p[0])] << 4) + staticHex[UCHAR(p[1])];
dataPtr->toUnicode[hi] = pageMemPtr;
p += 2;
for (lo = 0; lo < 256; lo++) {
if ((lo & 0x0f) == 0) {
p++;
|
| ︙ | ︙ | |||
1744 1745 1746 1747 1748 1749 1750 |
numPages = 0;
for (hi = 0; hi < 256; hi++) {
if (used[hi]) {
numPages++;
}
}
size = 256 * sizeof(unsigned short *) + numPages * PAGESIZE;
| | | 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 |
numPages = 0;
for (hi = 0; hi < 256; hi++) {
if (used[hi]) {
numPages++;
}
}
size = 256 * sizeof(unsigned short *) + numPages * PAGESIZE;
dataPtr->fromUnicode = Tcl_Alloc(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;
|
| ︙ | ︙ | |||
1840 1841 1842 1843 1844 1845 1846 |
}
/*
* Read lines from the encoding until EOF.
*/
for (TclDStringClear(&lineString);
| | | 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 |
}
/*
* Read lines from the encoding until EOF.
*/
for (TclDStringClear(&lineString);
(len = Tcl_Gets(chan, &lineString)) != -1;
TclDStringClear(&lineString)) {
const unsigned char *p;
int to, from;
/*
* Skip short lines.
*/
|
| ︙ | ︙ | |||
1934 1935 1936 1937 1938 1939 1940 |
while (1) {
int argc;
const char **argv;
char *line;
Tcl_DString lineString;
Tcl_DStringInit(&lineString);
| | | 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 |
while (1) {
int argc;
const char **argv;
char *line;
Tcl_DString lineString;
Tcl_DStringInit(&lineString);
if (Tcl_Gets(chan, &lineString) == TCL_IO_FAILURE) {
break;
}
line = Tcl_DStringValue(&lineString);
if (Tcl_SplitList(NULL, line, &argc, &argv) != TCL_OK) {
Tcl_DStringFree(&lineString);
continue;
}
|
| ︙ | ︙ | |||
1976 1977 1978 1979 1980 1981 1982 | Tcl_FreeEncoding((Tcl_Encoding) e); e = NULL; } est.encodingPtr = e; Tcl_DStringAppend(&escapeData, (char *) &est, sizeof(est)); } } | | | | | | | 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 |
Tcl_FreeEncoding((Tcl_Encoding) e);
e = NULL;
}
est.encodingPtr = e;
Tcl_DStringAppend(&escapeData, (char *) &est, sizeof(est));
}
}
Tcl_Free((void *)argv);
Tcl_DStringFree(&lineString);
}
size = sizeof(EscapeEncodingData) - sizeof(EscapeSubTable)
+ Tcl_DStringLength(&escapeData);
dataPtr = Tcl_Alloc(size);
dataPtr->initLen = strlen(init);
memcpy(dataPtr->init, init, dataPtr->initLen + 1);
dataPtr->finalLen = strlen(final);
memcpy(dataPtr->final, final, dataPtr->finalLen + 1);
dataPtr->numSubTables =
Tcl_DStringLength(&escapeData) / sizeof(EscapeSubTable);
memcpy(dataPtr->subTables, Tcl_DStringValue(&escapeData),
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;
}
if (dataPtr->init[0] != '\0') {
|
| ︙ | ︙ | |||
2078 2079 2080 2081 2082 2083 2084 |
srcLen = dstLen;
result = TCL_CONVERT_NOSPACE;
}
*srcReadPtr = srcLen;
*dstWrotePtr = srcLen;
*dstCharsPtr = srcLen;
| | | 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 |
srcLen = dstLen;
result = TCL_CONVERT_NOSPACE;
}
*srcReadPtr = srcLen;
*dstWrotePtr = srcLen;
*dstCharsPtr = srcLen;
memcpy(dst, src, srcLen);
return result;
}
/*
*-------------------------------------------------------------------------
*
* UtfExtToUtfIntProc --
|
| ︙ | ︙ | |||
2291 2292 2293 2294 2295 2296 2297 |
* incomplete char its bytes are made to represent themselves.
*/
*chPtr = (unsigned char) *src;
src += 1;
dst += Tcl_UniCharToUtf(*chPtr, dst);
} else {
| > > > > > | | > > | | | 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 |
* incomplete char its bytes are made to represent themselves.
*/
*chPtr = (unsigned char) *src;
src += 1;
dst += Tcl_UniCharToUtf(*chPtr, dst);
} else {
int len = TclUtfToUniChar(src, chPtr);
src += len;
dst += Tcl_UniCharToUtf(*chPtr, dst);
#if TCL_UTF_MAX <= 4
if ((*chPtr >= 0xD800) && (len < 3)) {
src += TclUtfToUniChar(src + len, chPtr);
dst += Tcl_UniCharToUtf(*chPtr, dst);
}
#endif
}
}
*srcReadPtr = src - srcStart;
*dstWrotePtr = dst - dstStart;
*dstCharsPtr = numChars;
return result;
}
/*
*-------------------------------------------------------------------------
*
* UniCharToUtfProc --
*
* Convert from Unicode to UTF-8.
*
* Results:
* Returns TCL_OK if conversion was successful.
*
* Side effects:
* None.
*
*-------------------------------------------------------------------------
*/
static int
UniCharToUtfProc(
ClientData clientData, /* Not used. */
const char *src, /* Source string in Unicode. */
int srcLen, /* Source string length in bytes. */
int flags, /* Conversion control flags. */
Tcl_EncodingState *statePtr,/* Place for conversion routine to store state
* information used during a piecewise
* conversion. Contents of statePtr are
|
| ︙ | ︙ | |||
2348 2349 2350 2351 2352 2353 2354 |
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;
| < | < < | | | | | | | | | | | | | 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 |
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;
unsigned short ch;
if (flags & TCL_ENCODING_CHAR_LIMIT) {
charLimit = *dstCharsPtr;
}
result = TCL_OK;
if ((srcLen % sizeof(unsigned short)) != 0) {
result = TCL_CONVERT_MULTIBYTE;
srcLen /= sizeof(unsigned short);
srcLen *= sizeof(unsigned short);
}
srcStart = src;
srcEnd = src + srcLen;
dstStart = dst;
dstEnd = dst + dstLen - TCL_UTF_MAX;
for (numChars = 0; src < srcEnd && numChars <= charLimit; numChars++) {
if (dst > dstEnd) {
result = TCL_CONVERT_NOSPACE;
break;
}
/*
* Special case for 1-byte utf chars for speed. Make sure we work with
* unsigned short-size data.
*/
ch = *(unsigned short *)src;
if (ch && ch < 0x80) {
*dst++ = (ch & 0xFF);
} else {
dst += Tcl_UniCharToUtf(ch, dst);
}
src += sizeof(unsigned short);
}
*srcReadPtr = src - srcStart;
*dstWrotePtr = dst - dstStart;
*dstCharsPtr = numChars;
return result;
}
/*
*-------------------------------------------------------------------------
*
* UtfToUniCharProc --
*
* Convert from UTF-8 to Unicode.
*
* Results:
* Returns TCL_OK if conversion was successful.
*
* Side effects:
* None.
*
*-------------------------------------------------------------------------
*/
static int
UtfToUniCharProc(
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
|
| ︙ | ︙ | |||
2480 2481 2482 2483 2484 2485 2486 | /* * Need to handle this in a way that won't cause misalignment by * casting dst to a Tcl_UniChar. [Bug 1122671] */ #ifdef WORDS_BIGENDIAN #if TCL_UTF_MAX > 4 | > | | > | | > > > > | | > | > | > > | 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 |
/*
* Need to handle this in a way that won't cause misalignment by
* casting dst to a Tcl_UniChar. [Bug 1122671]
*/
#ifdef WORDS_BIGENDIAN
#if TCL_UTF_MAX > 4
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
#else
#if TCL_UTF_MAX > 4
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
#endif
}
*srcReadPtr = src - srcStart;
|
| ︙ | ︙ | |||
2698 2699 2700 2701 2702 2703 2704 | */ result = TCL_CONVERT_MULTIBYTE; break; } len = TclUtfToUniChar(src, &ch); | | > > > > | 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 |
*/
result = TCL_CONVERT_MULTIBYTE;
break;
}
len = TclUtfToUniChar(src, &ch);
#if TCL_UTF_MAX > 4
/*
* This prevents a crash condition. More evaluation is required for
* full support of int Tcl_UniChar. [Bug 1004065]
*/
if (ch & 0xffff0000) {
word = 0;
} else
#else
if (!len) {
word = 0;
} else
#endif
word = fromUnicode[(ch >> 8)][ch & 0xff];
if ((word == 0) && (ch != 0)) {
if (flags & TCL_ENCODING_STOPONERROR) {
result = TCL_CONVERT_UNKNOWN;
break;
|
| ︙ | ︙ | |||
2904 2905 2906 2907 2908 2909 2910 | } len = TclUtfToUniChar(src, &ch); /* * Check for illegal characters. */ | | > > > > | > > | 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 |
}
len = TclUtfToUniChar(src, &ch);
/*
* Check for illegal characters.
*/
if (ch > 0xff
#if TCL_UTF_MAX <= 4
|| ((ch >= 0xD800) && (len < 3))
#endif
) {
if (flags & TCL_ENCODING_STOPONERROR) {
result = TCL_CONVERT_UNKNOWN;
break;
}
#if TCL_UTF_MAX <= 4
if ((ch >= 0xD800) && (len < 3)) len = 4;
#endif
/*
* Plunge on, using '?' as a fallback character.
*/
ch = (Tcl_UniChar) '?';
}
|
| ︙ | ︙ | |||
2959 2960 2961 2962 2963 2964 2965 |
{
TableEncodingData *dataPtr = clientData;
/*
* Make sure we aren't freeing twice on shutdown. [Bug 219314]
*/
| | | | | 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 |
{
TableEncodingData *dataPtr = clientData;
/*
* 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);
}
/*
*-------------------------------------------------------------------------
*
* EscapeToUtfProc --
*
|
| ︙ | ︙ | |||
3258 3259 3260 3261 3262 3263 3264 |
if (flags & TCL_ENCODING_START) {
state = 0;
if ((dst + dataPtr->initLen) > dstEnd) {
*srcReadPtr = 0;
*dstWrotePtr = 0;
return TCL_CONVERT_NOSPACE;
}
| | | 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 |
if (flags & TCL_ENCODING_START) {
state = 0;
if ((dst + dataPtr->initLen) > dstEnd) {
*srcReadPtr = 0;
*dstWrotePtr = 0;
return TCL_CONVERT_NOSPACE;
}
memcpy(dst, dataPtr->init, dataPtr->initLen);
dst += dataPtr->initLen;
} else {
state = PTR2INT(*statePtr);
}
encodingPtr = GetTableEncoding(dataPtr, state);
tableDataPtr = encodingPtr->clientData;
|
| ︙ | ︙ | |||
3336 3337 3338 3339 3340 3341 3342 | * in the next conversion. */ state = oldState; result = TCL_CONVERT_NOSPACE; break; } | | < | 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 |
* in the next conversion.
*/
state = oldState;
result = TCL_CONVERT_NOSPACE;
break;
}
memcpy(dst, subTablePtr->sequence, subTablePtr->sequenceLen);
dst += subTablePtr->sequenceLen;
}
}
if (tablePrefixBytes[(word >> 8)] != 0) {
if (dst + 1 > dstEnd) {
result = TCL_CONVERT_NOSPACE;
|
| ︙ | ︙ | |||
3380 3381 3382 3383 3384 3385 3386 |
if ((dst + dataPtr->finalLen + (state?len:0)) > dstEnd) {
result = TCL_CONVERT_NOSPACE;
} else {
if (state) {
memcpy(dst, dataPtr->subTables[0].sequence, len);
dst += len;
}
| | | 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 |
if ((dst + dataPtr->finalLen + (state?len:0)) > dstEnd) {
result = TCL_CONVERT_NOSPACE;
} else {
if (state) {
memcpy(dst, dataPtr->subTables[0].sequence, len);
dst += len;
}
memcpy(dst, dataPtr->final, dataPtr->finalLen);
dst += dataPtr->finalLen;
state &= ~TCL_ENCODING_END;
}
}
*statePtr = (Tcl_EncodingState) INT2PTR(state);
*srcReadPtr = src - srcStart;
|
| ︙ | ︙ | |||
3442 3443 3444 3445 3446 3447 3448 |
subTablePtr = dataPtr->subTables;
for (i = 0; i < dataPtr->numSubTables; i++) {
FreeEncoding((Tcl_Encoding) subTablePtr->encodingPtr);
subTablePtr->encodingPtr = NULL;
subTablePtr++;
}
}
| | | 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 |
subTablePtr = dataPtr->subTables;
for (i = 0; i < dataPtr->numSubTables; i++) {
FreeEncoding((Tcl_Encoding) subTablePtr->encodingPtr);
subTablePtr->encodingPtr = NULL;
subTablePtr++;
}
}
Tcl_Free(dataPtr);
}
/*
*---------------------------------------------------------------------------
*
* GetTableEncoding --
*
|
| ︙ | ︙ | |||
3577 3578 3579 3580 3581 3582 3583 |
Tcl_DecrRefCount(libPathObj);
Tcl_DecrRefCount(encodingObj);
*encodingPtr = libraryPath.encoding;
if (*encodingPtr) {
((Encoding *)(*encodingPtr))->refCount++;
}
| | < < | | 3623 3624 3625 3626 3627 3628 3629 3630 3631 3632 3633 3634 3635 3636 3637 3638 3639 3640 3641 3642 |
Tcl_DecrRefCount(libPathObj);
Tcl_DecrRefCount(encodingObj);
*encodingPtr = libraryPath.encoding;
if (*encodingPtr) {
((Encoding *)(*encodingPtr))->refCount++;
}
bytes = TclGetStringFromObj(searchPathObj, lengthPtr);
*valuePtr = Tcl_Alloc(*lengthPtr + 1);
memcpy(*valuePtr, bytes, *lengthPtr + 1);
Tcl_DecrRefCount(searchPathObj);
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclEnsemble.c.
| ︙ | ︙ | |||
17 18 19 20 21 22 23 | * 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); | < < | 17 18 19 20 21 22 23 24 25 26 27 28 29 30 | * 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, |
| ︙ | ︙ | |||
82 83 84 85 86 87 88 89 |
"ensembleCommand", /* the type's name */
FreeEnsembleCmdRep, /* freeIntRepProc */
DupEnsembleCmdRep, /* dupIntRepProc */
NULL, /* updateStringProc */
NULL /* setFromAnyProc */
};
/*
| > > > > > > > > > > > > > > > | | | | < < < > | 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 |
"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 ? 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)
{
register Namespace *nsPtr = (Namespace *) namespacePtr;
if (namespacePtr == TclGetGlobalNamespace(nsPtr->interp)) {
return Tcl_NewStringObj("::", 2);
}
return Tcl_NewStringObj(nsPtr->fullName, -1);
}
/*
*----------------------------------------------------------------------
*
* TclNamespaceEnsembleCmd --
*
|
| ︙ | ︙ | |||
143 144 145 146 147 148 149 |
ClientData dummy,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Namespace *namespacePtr;
Namespace *nsPtr = (Namespace *) TclGetCurrentNamespace(interp), *cxtPtr,
| | | | | 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 |
ClientData dummy,
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;
|
| ︙ | ︙ | |||
204 205 206 207 208 209 210 |
* 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) {
| | | | 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 |
* 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:
|
| ︙ | ︙ | |||
298 299 300 301 302 303 304 |
Tcl_ListObjReplace(NULL, newList, 0, 1, 1, &newCmd);
if (patchedDict == NULL) {
patchedDict = Tcl_DuplicateObj(objv[1]);
}
Tcl_DictObjPut(NULL, patchedDict, subcmdWordsObj,
newList);
}
| | > | 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 |
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) {
|
| ︙ | ︙ | |||
332 333 334 335 336 337 338 | } unknownObj = (len > 0 ? objv[1] : NULL); continue; } } TclGetNamespaceForQualName(interp, name, cxtPtr, | | | | | | 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 | } 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 |
| ︙ | ︙ | |||
384 385 386 387 388 389 390 |
if (token == NULL) {
return TCL_ERROR;
}
if (objc == 4) {
Tcl_Obj *resultObj = NULL; /* silence gcc 4 warning */
| | | | 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 |
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);
|
| ︙ | ︙ | |||
505 506 507 508 509 510 511 |
* 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) {
| | | | 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 |
* 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) {
|
| ︙ | ︙ | |||
572 573 574 575 576 577 578 |
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]);
| | > | 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 |
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,
|
| ︙ | ︙ | |||
646 647 648 649 650 651 652 |
*
*----------------------------------------------------------------------
*/
Tcl_Command
TclCreateEnsembleInNs(
Tcl_Interp *interp,
| < | | | | | | | < | | | | | 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 |
*
*----------------------------------------------------------------------
*/
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 = 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;
|
| ︙ | ︙ | |||
697 698 699 700 701 702 703 |
nsPtr->exportLookupEpoch++;
if (flags & ENSEMBLE_COMPILE) {
((Command *) ensemblePtr->token)->compileProc = TclCompileEnsemble;
}
return ensemblePtr->token;
| | | < < | < | | | | | < | 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 |
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.
|
| ︙ | ︙ | |||
770 771 772 773 774 775 776 |
Tcl_Command token,
Tcl_Obj *subcmdList)
{
Command *cmdPtr = (Command *) token;
EnsembleConfig *ensemblePtr;
Tcl_Obj *oldList;
| | | 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 |
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;
|
| ︙ | ︙ | |||
846 847 848 849 850 851 852 |
Tcl_Obj *paramList)
{
Command *cmdPtr = (Command *) token;
EnsembleConfig *ensemblePtr;
Tcl_Obj *oldList;
int length;
| | | 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 |
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;
|
| ︙ | ︙ | |||
922 923 924 925 926 927 928 |
Tcl_Command token,
Tcl_Obj *mapDict)
{
Command *cmdPtr = (Command *) token;
EnsembleConfig *ensemblePtr;
Tcl_Obj *oldDict;
| | | 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 |
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;
|
| ︙ | ︙ | |||
1021 1022 1023 1024 1025 1026 1027 |
Tcl_Command token,
Tcl_Obj *unknownList)
{
Command *cmdPtr = (Command *) token;
EnsembleConfig *ensemblePtr;
Tcl_Obj *oldList;
| | | 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 |
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;
|
| ︙ | ︙ | |||
1087 1088 1089 1090 1091 1092 1093 |
Tcl_Command token,
int flags)
{
Command *cmdPtr = (Command *) token;
EnsembleConfig *ensemblePtr;
int wasCompiled;
| | | 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 |
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 = cmdPtr->objClientData;
|
| ︙ | ︙ | |||
1163 1164 1165 1166 1167 1168 1169 |
Tcl_Interp *interp,
Tcl_Command token,
Tcl_Obj **subcmdListPtr)
{
Command *cmdPtr = (Command *) token;
EnsembleConfig *ensemblePtr;
| | | 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 |
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;
}
|
| ︙ | ︙ | |||
1205 1206 1207 1208 1209 1210 1211 |
Tcl_Interp *interp,
Tcl_Command token,
Tcl_Obj **paramListPtr)
{
Command *cmdPtr = (Command *) token;
EnsembleConfig *ensemblePtr;
| | | 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 |
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;
}
|
| ︙ | ︙ | |||
1247 1248 1249 1250 1251 1252 1253 |
Tcl_Interp *interp,
Tcl_Command token,
Tcl_Obj **mapDictPtr)
{
Command *cmdPtr = (Command *) token;
EnsembleConfig *ensemblePtr;
| | | 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 |
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;
}
|
| ︙ | ︙ | |||
1288 1289 1290 1291 1292 1293 1294 |
Tcl_Interp *interp,
Tcl_Command token,
Tcl_Obj **unknownListPtr)
{
Command *cmdPtr = (Command *) token;
EnsembleConfig *ensemblePtr;
| | | 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 |
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;
}
|
| ︙ | ︙ | |||
1329 1330 1331 1332 1333 1334 1335 |
Tcl_Interp *interp,
Tcl_Command token,
int *flagsPtr)
{
Command *cmdPtr = (Command *) token;
EnsembleConfig *ensemblePtr;
| | | 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 |
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;
}
|
| ︙ | ︙ | |||
1370 1371 1372 1373 1374 1375 1376 |
Tcl_Interp *interp,
Tcl_Command token,
Tcl_Namespace **namespacePtrPtr)
{
Command *cmdPtr = (Command *) token;
EnsembleConfig *ensemblePtr;
| | | 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 |
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;
}
|
| ︙ | ︙ | |||
1420 1421 1422 1423 1424 1425 1426 |
cmdPtr = (Command *)
Tcl_FindCommand(interp, TclGetString(cmdNameObj), NULL, flags);
if (cmdPtr == NULL) {
return NULL;
}
| | | > | 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 |
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);
}
|
| ︙ | ︙ | |||
1466 1467 1468 1469 1470 1471 1472 |
int
Tcl_IsEnsemble(
Tcl_Command token)
{
Command *cmdPtr = (Command *) token;
| | | | 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 |
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;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
1612 1613 1614 1615 1616 1617 1618 |
if (map[i].unsafe && Tcl_IsSafe(interp)) {
cmdPtr = (Command *)
Tcl_NRCreateCommand(interp, "___tmp", map[i].proc,
map[i].nreProc, map[i].clientData, NULL);
Tcl_DStringSetLength(&hiddenBuf, hiddenLen);
if (Tcl_HideCommand(interp, "___tmp",
Tcl_DStringAppend(&hiddenBuf, map[i].name, -1))) {
| | | | | | | 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 |
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);
|
| ︙ | ︙ | |||
1745 1746 1747 1748 1749 1750 1751 |
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.
*/
| < < | > > | 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 |
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_GetHashValue(ensembleCmd->hPtr);
Tcl_IncrRefCount(prefixObj);
if (ensembleCmd->fix) {
TclSpellFix(interp, objv, objc, subIdx, subObj, ensembleCmd->fix);
}
|
| ︙ | ︙ | |||
1799 1800 1801 1802 1803 1804 1805 | * 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; | | < | 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 |
* 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 ; i<tableLength ; i++) {
register int cmp = strncmp(subcmdName,
ensemblePtr->subcommandArrayPtr[i],
stringLength);
if (cmp == 0) {
if (fullName != NULL) {
|
| ︙ | ︙ | |||
2068 2069 2070 2071 2072 2073 2074 | } /* *---------------------------------------------------------------------- * * TclSpellFix -- * | | | | > | | | | > | > | > | > > | | > > | > > | | | > | | | > > > > > > > > > | < | 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 |
}
/*
*----------------------------------------------------------------------
*
* 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_Interp *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_Alloc(3 * sizeof(Tcl_Obj *));
store = 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);
}
|
| ︙ | ︙ | |||
2376 2377 2378 2379 2380 2381 2382 |
Tcl_Obj *objPtr,
EnsembleConfig *ensemblePtr,
Tcl_HashEntry *hPtr,
Tcl_Obj *fix)
{
register EnsembleCmdRep *ensembleCmd;
| | | < | | < | 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 |
Tcl_Obj *objPtr,
EnsembleConfig *ensemblePtr,
Tcl_HashEntry *hPtr,
Tcl_Obj *fix)
{
register 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 = Tcl_Alloc(sizeof(EnsembleCmdRep));
ECRSetIntRep(objPtr, ensembleCmd);
}
/*
* Populate the internal rep.
*/
ensembleCmd->epoch = ensemblePtr->epoch;
|
| ︙ | ︙ | |||
2443 2444 2445 2446 2447 2448 2449 |
Tcl_HashEntry *hPtr = Tcl_FirstHashEntry(hash, &search);
while (hPtr != NULL) {
Tcl_Obj *prefixObj = Tcl_GetHashValue(hPtr);
Tcl_DecrRefCount(prefixObj);
hPtr = Tcl_NextHashEntry(&search);
}
| | | 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 |
Tcl_HashEntry *hPtr = Tcl_FirstHashEntry(hash, &search);
while (hPtr != NULL) {
Tcl_Obj *prefixObj = Tcl_GetHashValue(hPtr);
Tcl_DecrRefCount(prefixObj);
hPtr = Tcl_NextHashEntry(&search);
}
Tcl_Free(ensemblePtr->subcommandArrayPtr);
}
Tcl_DeleteHashTable(hash);
}
static void
DeleteEnsembleConfig(
ClientData clientData)
|
| ︙ | ︙ | |||
2540 2541 2542 2543 2544 2545 2546 |
static void
BuildEnsembleConfig(
EnsembleConfig *ensemblePtr)
{
Tcl_HashSearch search; /* Used for scanning the set of commands in
* the namespace that backs up this
* ensemble. */
| > | | 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 |
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);
|
| ︙ | ︙ | |||
2566 2567 2568 2569 2570 2571 2572 |
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.
*/
| | > | > | > | > > | | | > | 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 |
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) {
|
| ︙ | ︙ | |||
2658 2659 2660 2661 2662 2663 2664 |
* 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);
| < | | | 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 |
* 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 ; i<ensemblePtr->nsPtr->numExportPatterns ; i++) {
if (Tcl_StringMatch(nsCmdName,
ensemblePtr->nsPtr->exportArrayPtr[i])) {
hPtr = Tcl_CreateHashEntry(hash, nsCmdName, &isNew);
/*
* Remember, hash entries have a full reference to the
* substituted part of the command (as a list) as their
* content!
*/
|
| ︙ | ︙ | |||
2703 2704 2705 2706 2707 2708 2709 |
*
* 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 =
| | | 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 |
*
* 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 =
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 ;
|
| ︙ | ︙ | |||
2790 2791 2792 2793 2794 2795 2796 |
*----------------------------------------------------------------------
*/
static void
FreeEnsembleCmdRep(
Tcl_Obj *objPtr)
{
| | > | < | 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 |
*----------------------------------------------------------------------
*/
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 --
*
|
| ︙ | ︙ | |||
2823 2824 2825 2826 2827 2828 2829 |
*/
static void
DupEnsembleCmdRep(
Tcl_Obj *objPtr,
Tcl_Obj *copyPtr)
{
| | | | > | | 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 |
*/
static void
DupEnsembleCmdRep(
Tcl_Obj *objPtr,
Tcl_Obj *copyPtr)
{
EnsembleCmdRep *ensembleCmd;
EnsembleCmdRep *ensembleCopy = 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);
}
|
| ︙ | ︙ | |||
2875 2876 2877 2878 2879 2880 2881 |
Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
Tcl_Obj *mapObj, *subcmdObj, *targetCmdObj, *listObj, **elems;
Tcl_Obj *replaced = Tcl_NewObj(), *replacement;
Tcl_Command ensemble = (Tcl_Command) cmdPtr;
Command *oldCmdPtr = cmdPtr, *newCmdPtr;
int len, result, flags = 0, i, depth = 1, invokeAnyway = 0;
int ourResult = TCL_ERROR;
| | | 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 |
Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
Tcl_Obj *mapObj, *subcmdObj, *targetCmdObj, *listObj, **elems;
Tcl_Obj *replaced = Tcl_NewObj(), *replacement;
Tcl_Command ensemble = (Tcl_Command) cmdPtr;
Command *oldCmdPtr = cmdPtr, *newCmdPtr;
int len, result, flags = 0, i, depth = 1, invokeAnyway = 0;
int ourResult = TCL_ERROR;
size_t numBytes;
const char *word;
DefineLineInformation;
Tcl_IncrRefCount(replaced);
if (parsePtr->numWords < depth + 1) {
goto failed;
}
|
| ︙ | ︙ | |||
2945 2946 2947 2948 2949 2950 2951 |
* 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) {
| | | | 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 |
* 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 ; i<len ; i++) {
str = TclGetStringFromObj(elems[i], &sclen);
if ((sclen == numBytes) && !memcmp(word, str, numBytes)) {
/*
* Exact match! Excellent!
*/
result = Tcl_DictObjGet(NULL, mapObj,elems[i], &targetCmdObj);
if (result != TCL_OK || targetCmdObj == NULL) {
goto failed;
|
| ︙ | ︙ | |||
3001 3002 3003 3004 3005 3006 3007 | int done, matched; Tcl_Obj *tmpObj; /* * No map, so check the dictionary directly. */ | | | 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 |
int done, matched;
Tcl_Obj *tmpObj;
/*
* No map, so check the dictionary directly.
*/
TclNewStringObj(subcmdObj, word, numBytes);
result = Tcl_DictObjGet(NULL, mapObj, subcmdObj, &targetCmdObj);
if (result == TCL_OK && targetCmdObj != NULL) {
/*
* Got it. Skip the fiddling around with prefixes.
*/
replacement = subcmdObj;
|
| ︙ | ︙ | |||
3142 3143 3144 3145 3146 3147 3148 |
/*
* Throw out any line information generated by the failed compile attempt.
*/
while (mapPtr->nuloc - 1 > eclIndex) {
mapPtr->nuloc--;
| | | 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 |
/*
* 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.
*/
|
| ︙ | ︙ | |||
3317 3318 3319 3320 3321 3322 3323 |
* way to fix it anyway.
*/
int diff = envPtr->currStackDepth - savedStackDepth;
if (diff != 1) {
Tcl_Panic("bad stack adjustment when compiling"
| | | 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 |
* 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;
}
|
| ︙ | ︙ | |||
3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 |
Command *cmdPtr,
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *tokPtr;
Tcl_Obj *objPtr, **words;
char *bytes;
int i, numWords, cmdLit, extraLiteralFlags = LITERAL_CMD_NAME;
DefineLineInformation;
/*
* 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) {
| > | | | 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 |
Command *cmdPtr,
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *tokPtr;
Tcl_Obj *objPtr, **words;
char *bytes;
int i, numWords, cmdLit, extraLiteralFlags = LITERAL_CMD_NAME;
size_t length;
DefineLineInformation;
/*
* 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);
|
| ︙ | ︙ | |||
3384 3385 3386 3387 3388 3389 3390 |
/*
* Push the name of the command we're actually dispatching to as part of
* the implementation.
*/
objPtr = Tcl_NewObj();
Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr);
| | | | 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 |
/*
* Push the name of the command we're actually dispatching to as part of
* the implementation.
*/
objPtr = Tcl_NewObj();
Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr);
bytes = 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.
*/
|
| ︙ | ︙ |
Changes to generic/tclEnv.c.
| ︙ | ︙ | |||
14 15 16 17 18 19 20 |
*/
#include "tclInt.h"
TCL_DECLARE_MUTEX(envMutex) /* To serialize access to environ. */
static struct {
| | | | 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 |
*/
#include "tclInt.h"
TCL_DECLARE_MUTEX(envMutex) /* To serialize access to environ. */
static struct {
size_t cacheSize; /* Number of env strings in cache. */
char **cache; /* Array containing all of the environment
* strings that Tcl has allocated. */
#ifndef USE_PUTENV
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
* 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;
|
| ︙ | ︙ | |||
115 116 117 118 119 120 121 |
if (environ[0] != NULL) {
int i;
Tcl_MutexLock(&envMutex);
for (i = 0; environ[i] != NULL; i++) {
Tcl_Obj *obj1, *obj2;
| > | > > > > > > > > > > > > | 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 |
if (environ[0] != NULL) {
int i;
Tcl_MutexLock(&envMutex);
for (i = 0; environ[i] != NULL; i++) {
Tcl_Obj *obj1, *obj2;
const char *p1;
char *p2;
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_DStringFree(&envString);
Tcl_IncrRefCount(obj1);
Tcl_IncrRefCount(obj2);
Tcl_ObjSetVar2(interp, varNamePtr, obj1, obj2, TCL_GLOBAL_ONLY);
|
| ︙ | ︙ | |||
199 200 201 202 203 204 205 |
void
TclSetEnv(
const char *name, /* Name of variable whose value is to be set
* (UTF-8). */
const char *value) /* New value for variable (UTF-8). */
{
Tcl_DString envString;
| | | | | | | 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 |
void
TclSetEnv(
const char *name, /* Name of variable whose value is to be set
* (UTF-8). */
const char *value) /* New value for variable (UTF-8). */
{
Tcl_DString envString;
size_t nameLength, valueLength;
size_t index, length;
char *p, *oldValue;
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.
*/
Tcl_MutexLock(&envMutex);
index = TclpFindVariable(name, &length);
if (index == TCL_INDEX_NONE) {
#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 != environ) || (length+2 > env.ourEnvironSize)) {
char **newEnviron = Tcl_Alloc((length + 5) * sizeof(char *));
memcpy(newEnviron, environ, length * sizeof(char *));
if ((env.ourEnvironSize != 0) && (env.ourEnviron != NULL)) {
Tcl_Free(env.ourEnviron);
}
environ = env.ourEnviron = newEnviron;
env.ourEnvironSize = length + 5;
}
index = length;
environ[index + 1] = NULL;
#endif /* USE_PUTENV */
|
| ︙ | ︙ | |||
256 257 258 259 260 261 262 | Tcl_DStringFree(&envString); Tcl_MutexUnlock(&envMutex); return; } Tcl_DStringFree(&envString); oldValue = environ[index]; | | | | | | | | 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 |
Tcl_DStringFree(&envString);
Tcl_MutexUnlock(&envMutex);
return;
}
Tcl_DStringFree(&envString);
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 = Tcl_Alloc(nameLength + valueLength + 2);
memcpy(p, name, nameLength);
p[nameLength] = '=';
memcpy(p+nameLength+1, value, valueLength+1);
p2 = Tcl_UtfToExternalDString(NULL, p, -1, &envString);
/*
* Copy the native string to heap memory.
*/
p = Tcl_Realloc(p, Tcl_DStringLength(&envString) + 1);
memcpy(p, p2, Tcl_DStringLength(&envString) + 1);
Tcl_DStringFree(&envString);
#ifdef USE_PUTENV
/*
* Update the system environment.
*/
putenv(p);
index = TclpFindVariable(name, &length);
#else
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) && (environ[index] == p)) {
ReplaceString(oldValue, p);
#ifdef HAVE_PUTENV_THAT_COPIES
} else {
/*
* This putenv() copies instead of taking ownership.
*/
Tcl_Free(p);
#endif /* HAVE_PUTENV_THAT_COPIES */
}
Tcl_MutexUnlock(&envMutex);
if (!strcmp(name, "HOME")) {
/*
|
| ︙ | ︙ | |||
397 398 399 400 401 402 403 |
*/
void
TclUnsetEnv(
const char *name) /* Name of variable to remove (UTF-8). */
{
char *oldValue;
| | < | | 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 |
*/
void
TclUnsetEnv(
const char *name) /* Name of variable to remove (UTF-8). */
{
char *oldValue;
size_t length, index;
#ifdef USE_PUTENV_FOR_UNSET
Tcl_DString envString;
char *string;
#else
char **envPtr;
#endif /* USE_PUTENV_FOR_UNSET */
Tcl_MutexLock(&envMutex);
index = TclpFindVariable(name, &length);
/*
* First make sure that the environment variable exists to avoid doing
* needless work and to avoid recursion on the unset.
*/
if (index == TCL_AUTO_LENGTH) {
Tcl_MutexUnlock(&envMutex);
return;
}
/*
* Remember the old value so we can free it if Tcl created the string.
*/
|
| ︙ | ︙ | |||
437 438 439 440 441 442 443 |
#ifdef USE_PUTENV_FOR_UNSET
/*
* For those platforms that support putenv to unset, Linux indicates
* that no = should be included, and Windows requires it.
*/
#if defined(_WIN32)
| | | | | | | | | 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 |
#ifdef USE_PUTENV_FOR_UNSET
/*
* For those platforms that support putenv to unset, Linux indicates
* that no = should be included, and Windows requires it.
*/
#if defined(_WIN32)
string = Tcl_Alloc(length + 2);
memcpy(string, name, length);
string[length] = '=';
string[length+1] = '\0';
#else
string = Tcl_Alloc(length + 1);
memcpy(string, name, length);
string[length] = '\0';
#endif /* _WIN32 */
Tcl_UtfToExternalDString(NULL, string, -1, &envString);
string = Tcl_Realloc(string, Tcl_DStringLength(&envString) + 1);
memcpy(string, Tcl_DStringValue(&envString),
Tcl_DStringLength(&envString)+1);
Tcl_DStringFree(&envString);
putenv(string);
/*
* Watch out for versions of putenv that copy the string (e.g. VC++). In
* this case we need to free the string immediately. Otherwise update the
* string in the cache.
*/
if (environ[index] == string) {
ReplaceString(oldValue, string);
#ifdef HAVE_PUTENV_THAT_COPIES
} else {
/*
* This putenv() copies instead of taking ownership.
*/
Tcl_Free(string);
#endif /* HAVE_PUTENV_THAT_COPIES */
}
#else /* !USE_PUTENV_FOR_UNSET */
for (envPtr = environ+index+1; ; envPtr++) {
envPtr[-1] = *envPtr;
if (*envPtr == NULL) {
break;
|
| ︙ | ︙ | |||
513 514 515 516 517 518 519 |
TclGetEnv(
const char *name, /* Name of environment variable to find
* (UTF-8). */
Tcl_DString *valuePtr) /* Uninitialized or free DString in which the
* value of the environment variable is
* stored. */
{
| | | | 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 |
TclGetEnv(
const char *name, /* Name of environment variable to find
* (UTF-8). */
Tcl_DString *valuePtr) /* Uninitialized or free DString in which the
* value of the environment variable is
* stored. */
{
size_t length, index;
const char *result;
Tcl_MutexLock(&envMutex);
index = TclpFindVariable(name, &length);
result = NULL;
if (index != TCL_AUTO_LENGTH) {
Tcl_DString envStr;
result = Tcl_ExternalToUtfDString(NULL, environ[index], -1, &envStr);
result += length;
if (*result == '=') {
result++;
Tcl_DStringInit(valuePtr);
|
| ︙ | ︙ | |||
646 647 648 649 650 651 652 |
*/
static void
ReplaceString(
const char *oldStr, /* Old environment string. */
char *newStr) /* New environment string. */
{
| | | | | | 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 |
*/
static void
ReplaceString(
const char *oldStr, /* Old environment string. */
char *newStr) /* New environment string. */
{
size_t i;
/*
* Check to see if the old value was allocated by Tcl. If so, it needs to
* be deallocated to avoid memory leaks. Note that this algorithm is O(n),
* not O(1). This will result in n-squared behavior if lots of environment
* changes are being made.
*/
for (i = 0; i < env.cacheSize; i++) {
if (env.cache[i]==oldStr || env.cache[i]==NULL) {
break;
}
}
if (i < env.cacheSize) {
/*
* Replace or delete the old value.
*/
if (env.cache[i]) {
Tcl_Free(env.cache[i]);
}
if (newStr) {
env.cache[i] = newStr;
} else {
for (; i < env.cacheSize-1; i++) {
env.cache[i] = env.cache[i+1];
}
env.cache[env.cacheSize-1] = NULL;
}
} else {
/*
* We need to grow the cache in order to hold the new string.
*/
const int growth = 5;
env.cache = Tcl_Realloc(env.cache,
(env.cacheSize + growth) * sizeof(char *));
env.cache[env.cacheSize] = newStr;
(void) memset(env.cache+env.cacheSize+1, 0,
(growth-1) * sizeof(char *));
env.cacheSize += growth;
}
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
719 720 721 722 723 724 725 |
TclFinalizeEnvironment(void)
{
/*
* 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
| | > > > > > > > | > > > > | 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 |
TclFinalizeEnvironment(void)
{
/*
* 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.
*/
if (env.cache) {
#ifdef PURIFY
int i;
for (i = 0; i < env.cacheSize; i++) {
Tcl_Free(env.cache[i]);
}
#endif
Tcl_Free(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
}
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclEvent.c.
| ︙ | ︙ | |||
85 86 87 88 89 90 91 | /* * 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. */ | | | | 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 |
/*
* 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;
typedef struct ThreadSpecificData {
ExitHandler *firstExitPtr; /* First in list of all exit handlers for this
* thread. */
int inExit; /* True when this thread is exiting. This is
* used as a hack to decide to close the
* standard channels. */
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
#if TCL_THREADS
typedef struct {
Tcl_ThreadCreateProc *proc; /* Main() function of the thread */
ClientData clientData; /* The one argument to Main() */
} ThreadClientData;
static Tcl_ThreadCreateType NewThreadProc(ClientData clientData);
#endif /* TCL_THREADS */
|
| ︙ | ︙ | |||
120 121 122 123 124 125 126 | const char *name2, int flags); static void InvokeExitHandlers(void); static void FinalizeThread(int quick); /* *---------------------------------------------------------------------- * | | < < < < < < < < | | 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 |
const char *name2, int flags);
static void InvokeExitHandlers(void);
static void FinalizeThread(int quick);
/*
*----------------------------------------------------------------------
*
* Tcl_BackgroundException --
*
* This function is invoked to handle errors that occur in Tcl commands
* that are invoked in "background" (e.g. from event or timer bindings).
*
* Results:
* None.
*
* Side effects:
* A handler command is invoked later as an idle handler to process the
* error, passing it the interp result and return options.
*
*----------------------------------------------------------------------
*/
void
Tcl_BackgroundException(
Tcl_Interp *interp, /* Interpreter in which an exception has
* occurred. */
int code) /* The exception code value */
{
BgError *errPtr;
ErrAssocData *assocPtr;
if (code == TCL_OK) {
return;
}
errPtr = Tcl_Alloc(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);
|
| ︙ | ︙ | |||
223 224 225 226 227 228 229 | */ Tcl_Obj *copyObj = TclListObjCopy(NULL, assocPtr->cmdPrefix); errPtr = assocPtr->firstBgPtr; Tcl_ListObjGetElements(NULL, copyObj, &prefixObjc, &prefixObjv); | | | | | | 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 |
*/
Tcl_Obj *copyObj = TclListObjCopy(NULL, assocPtr->cmdPrefix);
errPtr = assocPtr->firstBgPtr;
Tcl_ListObjGetElements(NULL, copyObj, &prefixObjc, &prefixObjv);
tempObjv = Tcl_Alloc((prefixObjc+2) * sizeof(Tcl_Obj *));
memcpy(tempObjv, prefixObjv, prefixObjc*sizeof(Tcl_Obj *));
tempObjv[prefixObjc] = errPtr->errorMsg;
tempObjv[prefixObjc+1] = errPtr->returnOpts;
Tcl_AllowExceptions(interp);
code = Tcl_EvalObjv(interp, prefixObjc+2, tempObjv, TCL_EVAL_GLOBAL);
/*
* Discard the command and the information about the error report.
*/
Tcl_DecrRefCount(copyObj);
Tcl_DecrRefCount(errPtr->errorMsg);
Tcl_DecrRefCount(errPtr->returnOpts);
assocPtr->firstBgPtr = errPtr->nextPtr;
Tcl_Free(errPtr);
Tcl_Free(tempObjv);
if (code == TCL_BREAK) {
/*
* Break means cancel any remaining error reports for this
* interpreter.
*/
while (assocPtr->firstBgPtr != NULL) {
errPtr = assocPtr->firstBgPtr;
assocPtr->firstBgPtr = errPtr->nextPtr;
Tcl_DecrRefCount(errPtr->errorMsg);
Tcl_DecrRefCount(errPtr->returnOpts);
Tcl_Free(errPtr);
}
} else if ((code == TCL_ERROR) && !Tcl_IsSafe(interp)) {
Tcl_Channel errChannel = Tcl_GetStdChannel(TCL_STDERR);
if (errChannel != NULL) {
Tcl_Obj *options = Tcl_GetReturnOptions(interp, code);
Tcl_Obj *keyPtr, *valuePtr = NULL;
|
| ︙ | ︙ | |||
521 522 523 524 525 526 527 |
Tcl_Panic("TclSetBgErrorHandler: NULL cmdPrefix argument");
}
if (assocPtr == NULL) {
/*
* First access: initialize.
*/
| | | 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 |
Tcl_Panic("TclSetBgErrorHandler: NULL cmdPrefix argument");
}
if (assocPtr == NULL) {
/*
* First access: initialize.
*/
assocPtr = Tcl_Alloc(sizeof(ErrAssocData));
assocPtr->interp = interp;
assocPtr->cmdPrefix = NULL;
assocPtr->firstBgPtr = NULL;
assocPtr->lastBgPtr = NULL;
Tcl_SetAssocData(interp, "tclBgError", BgErrorDeleteProc, assocPtr);
}
if (assocPtr->cmdPrefix) {
|
| ︙ | ︙ | |||
600 601 602 603 604 605 606 |
BgError *errPtr;
while (assocPtr->firstBgPtr != NULL) {
errPtr = assocPtr->firstBgPtr;
assocPtr->firstBgPtr = errPtr->nextPtr;
Tcl_DecrRefCount(errPtr->errorMsg);
Tcl_DecrRefCount(errPtr->returnOpts);
| | | 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 |
BgError *errPtr;
while (assocPtr->firstBgPtr != NULL) {
errPtr = assocPtr->firstBgPtr;
assocPtr->firstBgPtr = errPtr->nextPtr;
Tcl_DecrRefCount(errPtr->errorMsg);
Tcl_DecrRefCount(errPtr->returnOpts);
Tcl_Free(errPtr);
}
Tcl_CancelIdleCall(HandleBgErrors, assocPtr);
Tcl_DecrRefCount(assocPtr->cmdPrefix);
Tcl_EventuallyFree(assocPtr, TCL_DYNAMIC);
}
/*
|
| ︙ | ︙ | |||
630 631 632 633 634 635 636 |
*/
void
Tcl_CreateExitHandler(
Tcl_ExitProc *proc, /* Function to invoke. */
ClientData clientData) /* Arbitrary value to pass to proc. */
{
| | | 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 |
*/
void
Tcl_CreateExitHandler(
Tcl_ExitProc *proc, /* Function to invoke. */
ClientData clientData) /* Arbitrary value to pass to proc. */
{
ExitHandler *exitPtr = Tcl_Alloc(sizeof(ExitHandler));
exitPtr->proc = proc;
exitPtr->clientData = clientData;
Tcl_MutexLock(&exitMutex);
exitPtr->nextPtr = firstExitPtr;
firstExitPtr = exitPtr;
Tcl_MutexUnlock(&exitMutex);
|
| ︙ | ︙ | |||
663 664 665 666 667 668 669 |
*/
void
TclCreateLateExitHandler(
Tcl_ExitProc *proc, /* Function to invoke. */
ClientData clientData) /* Arbitrary value to pass to proc. */
{
| | | 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 |
*/
void
TclCreateLateExitHandler(
Tcl_ExitProc *proc, /* Function to invoke. */
ClientData clientData) /* Arbitrary value to pass to proc. */
{
ExitHandler *exitPtr = Tcl_Alloc(sizeof(ExitHandler));
exitPtr->proc = proc;
exitPtr->clientData = clientData;
Tcl_MutexLock(&exitMutex);
exitPtr->nextPtr = firstLateExitPtr;
firstLateExitPtr = exitPtr;
Tcl_MutexUnlock(&exitMutex);
|
| ︙ | ︙ | |||
708 709 710 711 712 713 714 |
if ((exitPtr->proc == proc)
&& (exitPtr->clientData == clientData)) {
if (prevPtr == NULL) {
firstExitPtr = exitPtr->nextPtr;
} else {
prevPtr->nextPtr = exitPtr->nextPtr;
}
| | | 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 |
if ((exitPtr->proc == proc)
&& (exitPtr->clientData == clientData)) {
if (prevPtr == NULL) {
firstExitPtr = exitPtr->nextPtr;
} else {
prevPtr->nextPtr = exitPtr->nextPtr;
}
Tcl_Free(exitPtr);
break;
}
}
Tcl_MutexUnlock(&exitMutex);
return;
}
|
| ︙ | ︙ | |||
751 752 753 754 755 756 757 |
if ((exitPtr->proc == proc)
&& (exitPtr->clientData == clientData)) {
if (prevPtr == NULL) {
firstLateExitPtr = exitPtr->nextPtr;
} else {
prevPtr->nextPtr = exitPtr->nextPtr;
}
| | | 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 |
if ((exitPtr->proc == proc)
&& (exitPtr->clientData == clientData)) {
if (prevPtr == NULL) {
firstLateExitPtr = exitPtr->nextPtr;
} else {
prevPtr->nextPtr = exitPtr->nextPtr;
}
Tcl_Free(exitPtr);
break;
}
}
Tcl_MutexUnlock(&exitMutex);
return;
}
|
| ︙ | ︙ | |||
785 786 787 788 789 790 791 |
Tcl_CreateThreadExitHandler(
Tcl_ExitProc *proc, /* Function to invoke. */
ClientData clientData) /* Arbitrary value to pass to proc. */
{
ExitHandler *exitPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
| | | 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 |
Tcl_CreateThreadExitHandler(
Tcl_ExitProc *proc, /* Function to invoke. */
ClientData clientData) /* Arbitrary value to pass to proc. */
{
ExitHandler *exitPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
exitPtr = Tcl_Alloc(sizeof(ExitHandler));
exitPtr->proc = proc;
exitPtr->clientData = clientData;
exitPtr->nextPtr = tsdPtr->firstExitPtr;
tsdPtr->firstExitPtr = exitPtr;
}
/*
|
| ︙ | ︙ | |||
827 828 829 830 831 832 833 |
if ((exitPtr->proc == proc)
&& (exitPtr->clientData == clientData)) {
if (prevPtr == NULL) {
tsdPtr->firstExitPtr = exitPtr->nextPtr;
} else {
prevPtr->nextPtr = exitPtr->nextPtr;
}
| | | 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 |
if ((exitPtr->proc == proc)
&& (exitPtr->clientData == clientData)) {
if (prevPtr == NULL) {
tsdPtr->firstExitPtr = exitPtr->nextPtr;
} else {
prevPtr->nextPtr = exitPtr->nextPtr;
}
Tcl_Free(exitPtr);
return;
}
}
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
853 854 855 856 857 858 859 | * Sets the application wide exit handler to the specified value. * *---------------------------------------------------------------------- */ Tcl_ExitProc * Tcl_SetExitProc( | | | 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 |
* Sets the application wide exit handler to the specified value.
*
*----------------------------------------------------------------------
*/
Tcl_ExitProc *
Tcl_SetExitProc(
TCL_NORETURN1 Tcl_ExitProc *proc) /* New exit handler for app or NULL */
{
Tcl_ExitProc *prevExitProc;
/*
* Swap the old exit proc for the new one, saving the old one for our
* return value.
*/
|
| ︙ | ︙ | |||
905 906 907 908 909 910 911 | * 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); | | | 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 |
* 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);
}
|
| ︙ | ︙ | |||
934 935 936 937 938 939 940 |
*/
TCL_NORETURN void
Tcl_Exit(
int status) /* Exit status for application; typically 0
* for normal return, 1 for error return. */
{
| | | 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 |
*/
TCL_NORETURN void
Tcl_Exit(
int status) /* Exit status for application; typically 0
* for normal return, 1 for error return. */
{
TCL_NORETURN1 Tcl_ExitProc *currentAppExitPtr;
Tcl_MutexLock(&exitMutex);
currentAppExitPtr = appExitPtr;
Tcl_MutexUnlock(&exitMutex);
if (currentAppExitPtr) {
/*
|
| ︙ | ︙ | |||
1039 1040 1041 1042 1043 1044 1045 | */ TclInitThreadStorage(); /* Creates master hash table for * thread local storage */ #if USE_TCLALLOC TclInitAlloc(); /* Process wide mutex init */ #endif | | | 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 | */ TclInitThreadStorage(); /* Creates master hash table for * thread local storage */ #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) */ |
| ︙ | ︙ | |||
1128 1129 1130 1131 1132 1133 1134 | * 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); | | | 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 |
* 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);
Tcl_MutexLock(&exitMutex);
}
firstLateExitPtr = NULL;
Tcl_MutexUnlock(&exitMutex);
/*
* Now finalize the Tcl execution environment. Note that this must be done
|
| ︙ | ︙ | |||
1216 1217 1218 1219 1220 1221 1222 |
TclFinalizeSynchronization();
/*
* Close down the thread-specific object allocator.
*/
| | | 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 |
TclFinalizeSynchronization();
/*
* Close down the thread-specific object allocator.
*/
#if TCL_THREADS && defined(USE_THREAD_ALLOC)
TclFinalizeThreadAlloc();
#endif
/*
* We defer unloading of packages until very late to avoid memory access
* issues. Both exit callbacks and synchronization variables may be stored
* in packages.
|
| ︙ | ︙ | |||
1239 1240 1241 1242 1243 1244 1245 |
* original state.
*/
TclFinalizeLoad();
TclResetFilesystem();
/*
| | | 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 |
* original state.
*/
TclFinalizeLoad();
TclResetFilesystem();
/*
* At this point, there should no longer be any Tcl_Alloc'ed memory.
*/
TclFinalizeMemorySubsystem();
alreadyFinalized:
TclFinalizeLock();
}
|
| ︙ | ︙ | |||
1298 1299 1300 1301 1302 1303 1304 | * Be careful to remove the handler from the list before invoking * its callback. This protects us against double-freeing if the * callback should call Tcl_DeleteThreadExitHandler on itself. */ tsdPtr->firstExitPtr = exitPtr->nextPtr; exitPtr->proc(exitPtr->clientData); | | | 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 |
* Be careful to remove the handler from the list before invoking
* its callback. This protects us against double-freeing if the
* callback should call Tcl_DeleteThreadExitHandler on itself.
*/
tsdPtr->firstExitPtr = exitPtr->nextPtr;
exitPtr->proc(exitPtr->clientData);
Tcl_Free(exitPtr);
}
TclFinalizeIOSubsystem();
TclFinalizeNotifier();
TclFinalizeAsync();
TclFinalizeThreadObjects();
}
|
| ︙ | ︙ | |||
1399 1400 1401 1402 1403 1404 1405 |
int done, foundEvent;
const char *nameString;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "name");
return TCL_ERROR;
}
| | | 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 |
int done, foundEvent;
const char *nameString;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "name");
return TCL_ERROR;
}
nameString = TclGetString(objv[1]);
if (Tcl_TraceVar2(interp, nameString, NULL,
TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
VwaitVarProc, &done) != TCL_OK) {
return TCL_ERROR;
};
done = 0;
foundEvent = 1;
|
| ︙ | ︙ | |||
1534 1535 1536 1537 1538 1539 1540 |
* executed commands.
*/
Tcl_ResetResult(interp);
return TCL_OK;
}
| | | 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 |
* executed commands.
*/
Tcl_ResetResult(interp);
return TCL_OK;
}
#if TCL_THREADS
/*
*----------------------------------------------------------------------
*
* NewThreadProc --
*
* Bootstrap function of a new Tcl thread.
*
|
| ︙ | ︙ | |||
1561 1562 1563 1564 1565 1566 1567 |
{
ThreadClientData *cdPtr = clientData;
ClientData threadClientData;
Tcl_ThreadCreateProc *threadProc;
threadProc = cdPtr->proc;
threadClientData = cdPtr->clientData;
| | | 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 |
{
ThreadClientData *cdPtr = clientData;
ClientData threadClientData;
Tcl_ThreadCreateProc *threadProc;
threadProc = cdPtr->proc;
threadClientData = cdPtr->clientData;
Tcl_Free(clientData); /* Allocated in Tcl_CreateThread() */
threadProc(threadClientData);
TCL_THREAD_CREATE_RETURN;
}
#endif
|
| ︙ | ︙ | |||
1593 1594 1595 1596 1597 1598 1599 |
*/
int
Tcl_CreateThread(
Tcl_ThreadId *idPtr, /* Return, the ID of the thread */
Tcl_ThreadCreateProc *proc, /* Main() function of the thread */
ClientData clientData, /* The one argument to Main() */
| | | | | | 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 |
*/
int
Tcl_CreateThread(
Tcl_ThreadId *idPtr, /* Return, the ID of the thread */
Tcl_ThreadCreateProc *proc, /* Main() function of the thread */
ClientData clientData, /* The one argument to Main() */
size_t stackSize, /* Size of stack for the new thread */
int flags) /* Flags controlling behaviour of the new
* thread. */
{
#if TCL_THREADS
ThreadClientData *cdPtr = Tcl_Alloc(sizeof(ThreadClientData));
int result;
cdPtr->proc = proc;
cdPtr->clientData = clientData;
result = TclpThreadCreate(idPtr, NewThreadProc, cdPtr, stackSize, flags);
if (result != TCL_OK) {
Tcl_Free(cdPtr);
}
return result;
#else
return TCL_ERROR;
#endif /* TCL_THREADS */
}
|
| ︙ | ︙ |
Changes to generic/tclExecute.c.
| ︙ | ︙ | |||
93 94 95 96 97 98 99 | #endif /* * These are used by evalstats to monitor object usage in Tcl. */ #ifdef TCL_COMPILE_STATS | | | | | 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 |
#endif
/*
* 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 };
#endif /* TCL_COMPILE_STATS */
/*
* NR_TEBC
* Helpers for NR - non-recursive calls to TEBC
* Minimal data required to fully reconstruct the execution state.
*/
|
| ︙ | ︙ | |||
149 150 151 152 153 154 155 |
} while (0)
/*
* These variable-access macros have to coincide with those in tclVar.c
*/
#define VarHashGetValue(hPtr) \
| | | 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 |
} while (0)
/*
* These variable-access macros have to coincide with those in tclVar.c
*/
#define VarHashGetValue(hPtr) \
((Var *) ((char *)hPtr - offsetof(VarInHash, entry)))
static inline Var *
VarHashCreateVar(
TclVarHashTable *tablePtr,
Tcl_Obj *key,
int *newPtr)
{
|
| ︙ | ︙ | |||
437 438 439 440 441 442 443 | * 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) \ | | | | | | | 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 |
* 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 *) \
(&((objPtr)->internalRep.wideValue)), TCL_OK) : \
TclHasIntRep((objPtr), &tclDoubleType) \
? (((TclIsNaN((objPtr)->internalRep.doubleValue)) \
? (*(tPtr) = TCL_NUMBER_NAN) \
: (*(tPtr) = TCL_NUMBER_DOUBLE)), \
*(ptrPtr) = (void *) \
(&((objPtr)->internalRep.doubleValue)), TCL_OK) : \
(((objPtr)->bytes != NULL) && ((objPtr)->length == 0)) \
? TCL_ERROR : \
TclGetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr)))
/*
* Macro used to make the check for type overflow more mnemonic. This works by
|
| ︙ | ︙ | |||
621 622 623 624 625 626 627 | Tcl_Obj *valuePtr, Tcl_Obj *value2Ptr); static Tcl_Obj * ExecuteExtendedUnaryMathOp(int opcode, Tcl_Obj *valuePtr); static void FreeExprCodeInternalRep(Tcl_Obj *objPtr); static ExceptionRange * GetExceptRangeForPc(const unsigned char *pc, int searchMode, ByteCode *codePtr); static const char * GetSrcInfoForPc(const unsigned char *pc, | | | | | 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 | 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 Tcl_Obj ** GrowEvaluationStack(ExecEnv *eePtr, int growth, int move); static void IllegalExprOperandType(Tcl_Interp *interp, const unsigned char *pc, Tcl_Obj *opndPtr); static void InitByteCodeExecution(Tcl_Interp *interp); static inline int wordSkip(void *ptr); static void ReleaseDictIterator(Tcl_Obj *objPtr); /* Useful elsewhere, make available in tclInt.h or stubs? */ static Tcl_Obj ** StackAllocWords(Tcl_Interp *interp, 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; /* |
| ︙ | ︙ | |||
686 687 688 689 690 691 692 693 694 695 696 697 698 |
static void
ReleaseDictIterator(
Tcl_Obj *objPtr)
{
Tcl_DictSearch *searchPtr;
Tcl_Obj *dictPtr;
/*
* First kill the search, and then release the reference to the dictionary
* that we were holding.
*/
| > > > > | | | < < | 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 |
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 = irPtr->twoPtrValue.ptr1;
Tcl_DictObjDone(searchPtr);
Tcl_Free(searchPtr);
dictPtr = irPtr->twoPtrValue.ptr2;
TclDecrRefCount(dictPtr);
}
/*
*----------------------------------------------------------------------
*
* InitByteCodeExecution --
*
|
| ︙ | ︙ | |||
766 767 768 769 770 771 772 |
*----------------------------------------------------------------------
*/
ExecEnv *
TclCreateExecEnv(
Tcl_Interp *interp, /* Interpreter for which the execution
* environment is being created. */
| | | | | | 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 |
*----------------------------------------------------------------------
*/
ExecEnv *
TclCreateExecEnv(
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 = Tcl_Alloc(sizeof(ExecEnv));
ExecStack *esPtr = Tcl_Alloc(sizeof(ExecStack)
+ (size-1) * sizeof(Tcl_Obj *));
eePtr->execStackPtr = esPtr;
TclNewIntObj(eePtr->constants[0], 0);
Tcl_IncrRefCount(eePtr->constants[0]);
TclNewIntObj(eePtr->constants[1], 1);
Tcl_IncrRefCount(eePtr->constants[1]);
eePtr->interp = interp;
|
| ︙ | ︙ | |||
830 831 832 833 834 835 836 |
if (esPtr->prevPtr) {
esPtr->prevPtr->nextPtr = esPtr->nextPtr;
}
if (esPtr->nextPtr) {
esPtr->nextPtr->prevPtr = esPtr->prevPtr;
}
| | | 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 |
if (esPtr->prevPtr) {
esPtr->prevPtr->nextPtr = esPtr->nextPtr;
}
if (esPtr->nextPtr) {
esPtr->nextPtr->prevPtr = esPtr->prevPtr;
}
Tcl_Free(esPtr);
}
void
TclDeleteExecEnv(
ExecEnv *eePtr) /* Execution environment to free. */
{
ExecStack *esPtr = eePtr->execStackPtr, *tmpPtr;
|
| ︙ | ︙ | |||
862 863 864 865 866 867 868 |
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");
}
| | | 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 |
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);
}
/*
*----------------------------------------------------------------------
*
* TclFinalizeExecution --
*
|
| ︙ | ︙ | |||
953 954 955 956 957 958 959 |
ExecEnv *eePtr, /* Points to the ExecEnv with an evaluation
* stack to enlarge. */
int growth, /* How much larger than the current used
* size. */
int move) /* 1 if move words since last marker. */
{
ExecStack *esPtr = eePtr->execStackPtr, *oldPtr = NULL;
| | | | 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 |
ExecEnv *eePtr, /* Points to the ExecEnv with an evaluation
* stack to enlarge. */
int growth, /* How much larger than the current used
* size. */
int move) /* 1 if move words since last marker. */
{
ExecStack *esPtr = eePtr->execStackPtr, *oldPtr = NULL;
size_t newBytes;
int newElems, currElems, needed = growth - (esPtr->endPtr - esPtr->tosPtr);
Tcl_Obj **markerPtr = esPtr->markerPtr, **memStart;
int moveWords = 0;
if (move) {
if (!markerPtr) {
Tcl_Panic("STACK: Reallocating with no previous alloc");
}
|
| ︙ | ︙ | |||
1039 1040 1041 1042 1043 1044 1045 |
#else
newElems = needed;
#endif
newBytes = sizeof(ExecStack) + (newElems-1) * sizeof(Tcl_Obj *);
oldPtr = esPtr;
| | | 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 |
#else
newElems = needed;
#endif
newBytes = sizeof(ExecStack) + (newElems-1) * sizeof(Tcl_Obj *);
oldPtr = esPtr;
esPtr = Tcl_Alloc(newBytes);
oldPtr->nextPtr = esPtr;
esPtr->prevPtr = oldPtr;
esPtr->nextPtr = NULL;
esPtr->endPtr = &esPtr->stackWords[newElems-1];
newStackReady:
|
| ︙ | ︙ | |||
1099 1100 1101 1102 1103 1104 1105 |
*
*--------------------------------------------------------------
*/
static Tcl_Obj **
StackAllocWords(
Tcl_Interp *interp,
| | | | | 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 |
*
*--------------------------------------------------------------
*/
static Tcl_Obj **
StackAllocWords(
Tcl_Interp *interp,
size_t numWords)
{
/*
* Note that GrowEvaluationStack sets a marker in the stack. This marker
* is read when rewinding, e.g., by TclStackFree.
*/
Interp *iPtr = (Interp *) interp;
ExecEnv *eePtr = iPtr->execEnvPtr;
Tcl_Obj **resPtr = GrowEvaluationStack(eePtr, numWords, 0);
eePtr->execStackPtr->tosPtr += numWords;
return resPtr;
}
static Tcl_Obj **
StackReallocWords(
Tcl_Interp *interp,
size_t numWords)
{
Interp *iPtr = (Interp *) interp;
ExecEnv *eePtr = iPtr->execEnvPtr;
Tcl_Obj **resPtr = GrowEvaluationStack(eePtr, numWords, 1);
eePtr->execStackPtr->tosPtr += numWords;
return resPtr;
}
void
TclStackFree(
Tcl_Interp *interp,
void *freePtr)
{
Interp *iPtr = (Interp *) interp;
ExecEnv *eePtr;
ExecStack *esPtr;
Tcl_Obj **markerPtr, *marker;
if (iPtr == NULL || iPtr->execEnvPtr == NULL) {
Tcl_Free(freePtr);
return;
}
/*
* Rewind the stack to the previous marker position. The current marker,
* as set in the last call to GrowEvaluationStack, contains a pointer to
* the previous marker.
|
| ︙ | ︙ | |||
1196 1197 1198 1199 1200 1201 1202 |
eePtr->execStackPtr = esPtr;
}
}
void *
TclStackAlloc(
Tcl_Interp *interp,
| | | | | | | | | 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 |
eePtr->execStackPtr = esPtr;
}
}
void *
TclStackAlloc(
Tcl_Interp *interp,
size_t numBytes)
{
Interp *iPtr = (Interp *) interp;
size_t numWords;
if (iPtr == NULL || iPtr->execEnvPtr == NULL) {
return (void *) Tcl_Alloc(numBytes);
}
numWords = (numBytes + (sizeof(Tcl_Obj *) - 1))/sizeof(Tcl_Obj *);
return StackAllocWords(interp, numWords);
}
void *
TclStackRealloc(
Tcl_Interp *interp,
void *ptr,
size_t numBytes)
{
Interp *iPtr = (Interp *) interp;
ExecEnv *eePtr;
ExecStack *esPtr;
Tcl_Obj **markerPtr;
size_t numWords;
if (iPtr == NULL || iPtr->execEnvPtr == NULL) {
return Tcl_Realloc(ptr, numBytes);
}
eePtr = iPtr->execEnvPtr;
esPtr = eePtr->execStackPtr;
markerPtr = esPtr->markerPtr;
if (MEMSTART(markerPtr) != (Tcl_Obj **)ptr) {
|
| ︙ | ︙ | |||
1263 1264 1265 1266 1267 1268 1269 |
*--------------------------------------------------------------
*/
int
Tcl_ExprObj(
Tcl_Interp *interp, /* Context in which to evaluate the
* expression. */
| | | 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 |
*--------------------------------------------------------------
*/
int
Tcl_ExprObj(
Tcl_Interp *interp, /* Context in which to evaluate the
* expression. */
Tcl_Obj *objPtr, /* Points to Tcl object containing expression
* to evaluate. */
Tcl_Obj **resultPtrPtr) /* Where the Tcl_Obj* that is the expression
* result is stored if no errors occur. */
{
NRE_callback *rootPtr = TOP_CB(interp);
Tcl_Obj *resultPtr;
|
| ︙ | ︙ | |||
1380 1381 1382 1383 1384 1385 1386 |
CompileExprObj(
Tcl_Interp *interp,
Tcl_Obj *objPtr)
{
Interp *iPtr = (Interp *) interp;
CompileEnv compEnv; /* Compilation environment structure allocated
* in frame. */
| | | > > > < | > | > > | | | | 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 |
CompileExprObj(
Tcl_Interp *interp,
Tcl_Obj *objPtr)
{
Interp *iPtr = (Interp *) interp;
CompileEnv compEnv; /* Compilation environment structure allocated
* in frame. */
ByteCode *codePtr = NULL;
/* Tcl Internal type of bytecode. Initialized
* to avoid compiler warning. */
/*
* Get the expression ByteCode from the object. If it exists, make sure it
* is valid in the current context.
*/
ByteCodeGetIntRep(objPtr, &exprCodeType, codePtr);
if (codePtr != NULL) {
Namespace *namespacePtr = iPtr->varFramePtr->nsPtr;
if (((Interp *) *codePtr->interpHandle != iPtr)
|| (codePtr->compileEpoch != iPtr->compileEpoch)
|| (codePtr->nsPtr != namespacePtr)
|| (codePtr->nsEpoch != namespacePtr->resolverEpoch)
|| (codePtr->localCachePtr != iPtr->varFramePtr->localCachePtr)) {
Tcl_StoreIntRep(objPtr, &exprCodeType, NULL);
codePtr = NULL;
}
}
if (codePtr == NULL) {
/*
* TIP #280: No invoker (yet) - Expression compilation.
*/
size_t length;
const char *string = TclGetStringFromObj(objPtr, &length);
TclInitCompileEnv(interp, &compEnv, string, length, NULL, 0);
TclCompileExpr(interp, string, length, &compEnv, 0);
/*
* Successful compilation. If the expression yielded no instructions,
* push an zero object as the expression's result.
*/
if (compEnv.codeNext == compEnv.codeStart) {
|
| ︙ | ︙ | |||
1500 1501 1502 1503 1504 1505 1506 |
*----------------------------------------------------------------------
*/
static void
FreeExprCodeInternalRep(
Tcl_Obj *objPtr)
{
| | > > | 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 |
*----------------------------------------------------------------------
*/
static void
FreeExprCodeInternalRep(
Tcl_Obj *objPtr)
{
ByteCode *codePtr;
ByteCodeGetIntRep(objPtr, &exprCodeType, codePtr);
assert(codePtr != NULL);
TclReleaseByteCode(codePtr);
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1528 1529 1530 1531 1532 1533 1534 |
ByteCode *
TclCompileObj(
Tcl_Interp *interp,
Tcl_Obj *objPtr,
const CmdFrame *invoker,
int word)
{
| | | | > < | 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 |
ByteCode *
TclCompileObj(
Tcl_Interp *interp,
Tcl_Obj *objPtr,
const CmdFrame *invoker,
int word)
{
Interp *iPtr = (Interp *) interp;
ByteCode *codePtr; /* Tcl Internal type of bytecode. */
Namespace *namespacePtr = iPtr->varFramePtr->nsPtr;
/*
* If the object is not already of tclByteCodeType, compile it (and reset
* the compilation flags in the interpreter; this should be done after any
* compilation). Otherwise, check that it is "fresh" enough.
*/
ByteCodeGetIntRep(objPtr, &tclByteCodeType, codePtr);
if (codePtr != NULL) {
/*
* 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
* namespace, or for the same namespace but with different name
* resolution rules. Precompiled objects, however, are immutable and
* therefore they are not recompiled, even if the epoch has changed.
*
* To be pedantically correct, we should also check that the
* originating procPtr is the same as the current context procPtr
* (assuming one exists at all - none for global level). This code is
* #def'ed out because [info body] was changed to never return a
* bytecode type object, which should obviate us from the extra checks
* here.
*/
if (((Interp *) *codePtr->interpHandle != iPtr)
|| (codePtr->compileEpoch != iPtr->compileEpoch)
|| (codePtr->nsPtr != namespacePtr)
|| (codePtr->nsEpoch != namespacePtr->resolverEpoch)) {
if (!(codePtr->flags & TCL_BYTECODE_PRECOMPILED)) {
goto recompileObj;
}
|
| ︙ | ︙ | |||
1684 1685 1686 1687 1688 1689 1690 |
* information.
*/
iPtr->invokeCmdFramePtr = invoker;
iPtr->invokeWord = word;
TclSetByteCodeFromAny(interp, objPtr, NULL, NULL);
iPtr->invokeCmdFramePtr = NULL;
| | | 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 |
* information.
*/
iPtr->invokeCmdFramePtr = invoker;
iPtr->invokeWord = word;
TclSetByteCodeFromAny(interp, objPtr, NULL, NULL);
iPtr->invokeCmdFramePtr = NULL;
ByteCodeGetIntRep(objPtr, &tclByteCodeType, codePtr);
if (iPtr->varFramePtr->localCachePtr) {
codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr;
codePtr->localCachePtr->refCount++;
}
return codePtr;
}
|
| ︙ | ︙ | |||
1760 1761 1762 1763 1764 1765 1766 |
*/
TclGetIntFromObj(interp, incrPtr, &type1);
Tcl_AddErrorInfo(interp, "\n (reading increment)");
return TCL_ERROR;
}
| | | | | 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 |
*/
TclGetIntFromObj(interp, incrPtr, &type1);
Tcl_AddErrorInfo(interp, "\n (reading increment)");
return TCL_ERROR;
}
if ((type1 == TCL_NUMBER_INT) && (type2 == TCL_NUMBER_INT)) {
Tcl_WideInt w1, w2, sum;
w1 = *((const Tcl_WideInt *)ptr1);
w2 = *((const Tcl_WideInt *)ptr2);
sum = w1 + w2;
/*
* Check for overflow.
*/
if (!Overflowing(w1, w2, sum)) {
|
| ︙ | ︙ | |||
1839 1840 1841 1842 1843 1844 1845 | * * Side effects: * Almost certainly, depending on the ByteCode's instructions. * *---------------------------------------------------------------------- */ #define bcFramePtr (&TD->cmdFrame) | | | 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 |
*
* 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(
Tcl_Interp *interp, /* Token for command interpreter. */
ByteCode *codePtr) /* The bytecode sequence to interpret. */
|
| ︙ | ︙ | |||
2423 2424 2425 2426 2427 2428 2429 |
CACHE_STACK_INFO();
goto gotError;
}
#ifdef TCL_COMPILE_DEBUG
/* FIXME: What is the right thing to trace? */
{
| | | 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 |
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((" "));
}
|
| ︙ | ︙ | |||
2545 2546 2547 2548 2549 2550 2551 |
case INST_EXPAND_START:
/*
* Push an element to the auxObjList. This records the current
* stack depth - i.e., the point in the stack where the expanded
* command starts.
*
* Use a Tcl_Obj as linked list element; slight mem waste, but faster
| | | 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 |
case INST_EXPAND_START:
/*
* Push an element to the auxObjList. This records the current
* stack depth - i.e., the point in the stack where the expanded
* command starts.
*
* Use a Tcl_Obj as linked list element; slight mem waste, but faster
* allocation than Tcl_Alloc. This also abuses the Tcl_Obj structure, as
* we do not define a special tclObjType for it. It is not dangerous
* as the obj is never passed anywhere, so that all manipulations are
* performed here and in INST_INVOKE_EXPANDED (in case of an expansion
* error, also in INST_EXPAND_STKTOP).
*/
TclNewObj(objPtr);
|
| ︙ | ︙ | |||
3473 3474 3475 3476 3477 3478 3479 |
if (TclIsVarDirectModifyable(varPtr)) {
ClientData ptr;
int type;
objPtr = varPtr->value.objPtr;
if (GetNumberFromObj(NULL, objPtr, &ptr, &type) == TCL_OK) {
| | | 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 |
if (TclIsVarDirectModifyable(varPtr)) {
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.
|
| ︙ | ︙ | |||
3515 3516 3517 3518 3519 3520 3521 | * 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; | | | 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 |
* 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 (Tcl_IsShared(objPtr)) {
objPtr->refCount--; /* We know it's shared */
objResultPtr = Tcl_DuplicateObj(objPtr);
Tcl_IncrRefCount(objResultPtr);
varPtr->value.objPtr = objResultPtr;
} else {
|
| ︙ | ︙ | |||
3550 3551 3552 3553 3554 3555 3556 |
varPtr = LOCAL(opnd);
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
arrayPtr = NULL;
part1Ptr = part2Ptr = NULL;
cleanup = 0;
| | | 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 |
varPtr = LOCAL(opnd);
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
arrayPtr = NULL;
part1Ptr = part2Ptr = NULL;
cleanup = 0;
TRACE(("%u %s => ", opnd, TclGetString(incrPtr)));
doIncrVar:
if (TclIsVarDirectModifyable2(varPtr, arrayPtr)) {
objPtr = varPtr->value.objPtr;
if (Tcl_IsShared(objPtr)) {
objPtr->refCount--; /* We know it's shared */
objResultPtr = Tcl_DuplicateObj(objPtr);
|
| ︙ | ︙ | |||
3743 3744 3745 3746 3747 3748 3749 |
part2Ptr = OBJ_AT_TOS;
arrayPtr = LOCAL(opnd);
while (TclIsVarLink(arrayPtr)) {
arrayPtr = arrayPtr->value.linkPtr;
}
TRACE(("%s %u \"%.30s\" => ",
(flags ? "normal" : "noerr"), opnd, O2S(part2Ptr)));
| | > | 3752 3753 3754 3755 3756 3757 3758 3759 3760 3761 3762 3763 3764 3765 3766 3767 |
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...
*/
|
| ︙ | ︙ | |||
3845 3846 3847 3848 3849 3850 3851 |
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:
| < < | | < < | | | | < | 3855 3856 3857 3858 3859 3860 3861 3862 3863 3864 3865 3866 3867 3868 3869 3870 3871 3872 3873 3874 |
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)));
|
| ︙ | ︙ | |||
3904 3905 3906 3907 3908 3909 3910 | "variable isn't array", opnd); DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "TCL", "WRITE", "ARRAY", NULL); CACHE_STACK_INFO(); TRACE_ERROR(interp); goto gotError; } | | < < < | 3909 3910 3911 3912 3913 3914 3915 3916 3917 3918 3919 3920 3921 3922 3923 |
"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);
|
| ︙ | ︙ | |||
4175 4176 4177 4178 4179 4180 4181 |
}
case INST_INFO_LEVEL_NUM:
TclNewIntObj(objResultPtr, iPtr->varFramePtr->level);
TRACE_WITH_OBJ(("=> "), objResultPtr);
NEXT_INST_F(1, 0, 1);
case INST_INFO_LEVEL_ARGS: {
int level;
| | | | 4177 4178 4179 4180 4181 4182 4183 4184 4185 4186 4187 4188 4189 4190 4191 4192 |
}
case INST_INFO_LEVEL_NUM:
TclNewIntObj(objResultPtr, iPtr->varFramePtr->level);
TRACE_WITH_OBJ(("=> "), objResultPtr);
NEXT_INST_F(1, 0, 1);
case INST_INFO_LEVEL_ARGS: {
int level;
CallFrame *framePtr = iPtr->varFramePtr;
CallFrame *rootFramePtr = iPtr->rootFramePtr;
TRACE(("\"%.30s\" => ", O2S(OBJ_AT_TOS)));
if (TclGetIntFromObj(interp, OBJ_AT_TOS, &level) != TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
}
if (level <= 0) {
|
| ︙ | ︙ | |||
4473 4474 4475 4476 4477 4478 4479 |
|| contextPtr->callPtr->flags & FILTER_HANDLING) {
oPtr->flags |= FILTER_HANDLING;
} else {
oPtr->flags &= ~FILTER_HANDLING;
}
{
| | | 4475 4476 4477 4478 4479 4480 4481 4482 4483 4484 4485 4486 4487 4488 4489 |
|| 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:
|
| ︙ | ︙ | |||
4518 4519 4520 4521 4522 4523 4524 |
/*
* End of TclOO support instructions.
* -----------------------------------------------------------------
* Start of INST_LIST and related instructions.
*/
{
| | | | 4520 4521 4522 4523 4524 4525 4526 4527 4528 4529 4530 4531 4532 4533 4534 4535 |
/*
* End of TclOO support instructions.
* -----------------------------------------------------------------
* 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:
/*
* Pop the opnd (objc) top stack elements into a new list obj and then
* decrement their ref counts.
*/
|
| ︙ | ︙ | |||
4553 4554 4555 4556 4557 4558 4559 |
TRACE(("\"%.30s\" \"%.30s\" => ", O2S(valuePtr), O2S(value2Ptr)));
/*
* Extract the desired list element.
*/
if ((TclListObjGetElements(interp, valuePtr, &objc, &objv) == TCL_OK)
| | | | 4555 4556 4557 4558 4559 4560 4561 4562 4563 4564 4565 4566 4567 4568 4569 4570 |
TRACE(("\"%.30s\" \"%.30s\" => ", O2S(valuePtr), O2S(value2Ptr)));
/*
* Extract the desired list element.
*/
if ((TclListObjGetElements(interp, valuePtr, &objc, &objv) == TCL_OK)
&& !TclHasIntRep(value2Ptr, &tclListType)
&& (TclGetIntForIndexM(NULL, value2Ptr, objc-1,
&index) == TCL_OK)) {
TclDecrRefCount(value2Ptr);
tosPtr--;
pcAdjustment = 1;
goto lindexFastPath;
}
|
| ︙ | ︙ | |||
4602 4603 4604 4605 4606 4607 4608 |
/* Decode end-offset index values. */
index = TclIndexDecode(opnd, objc - 1);
pcAdjustment = 5;
lindexFastPath:
| | | 4604 4605 4606 4607 4608 4609 4610 4611 4612 4613 4614 4615 4616 4617 4618 |
/* Decode end-offset index values. */
index = TclIndexDecode(opnd, objc - 1);
pcAdjustment = 5;
lindexFastPath:
if (index < (size_t)objc) {
objResultPtr = objv[index];
} else {
TclNewObj(objResultPtr);
}
TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr)));
NEXT_INST_F(pcAdjustment, 1, 1);
|
| ︙ | ︙ | |||
4726 4727 4728 4729 4730 4731 4732 |
valuePtr = OBJ_AT_TOS;
fromIdx = TclGetInt4AtPtr(pc+1);
toIdx = TclGetInt4AtPtr(pc+5);
TRACE(("\"%.30s\" %d %d => ", O2S(valuePtr), TclGetInt4AtPtr(pc+1),
TclGetInt4AtPtr(pc+5)));
/*
| | | > > | | > > < < < < < | < < < < | > > > | | | | | < < | | < < < < < < < < < < < < < < < < < < | 4728 4729 4730 4731 4732 4733 4734 4735 4736 4737 4738 4739 4740 4741 4742 4743 4744 4745 4746 4747 4748 4749 4750 4751 4752 4753 4754 4755 4756 4757 4758 4759 4760 4761 4762 4763 4764 4765 4766 4767 4768 4769 4770 4771 4772 4773 4774 4775 4776 4777 4778 4779 4780 4781 4782 4783 4784 4785 4786 4787 4788 4789 4790 4791 4792 4793 4794 4795 4796 4797 4798 4799 |
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
* in the process.
*/
if (TclListObjLength(interp, valuePtr, &objc) != TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
}
/*
* Skip a lot of work if we're about to throw the result away (common
* with uses of [lassign]).
*/
#ifndef TCL_COMPILE_DEBUG
if (*(pc+9) == INST_POP) {
NEXT_INST_F(10, 1, 0);
}
#endif
/* Every range of an empty list is an empty list */
if (objc == 0) {
/* avoid return of not canonical list (e. g. spaces in string repr.) */
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:
objResultPtr = Tcl_NewObj();
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);
case INST_LIST_IN:
case INST_LIST_NOT_IN: /* Basic list containment operators. */
value2Ptr = OBJ_AT_TOS;
|
| ︙ | ︙ | |||
4895 4896 4897 4898 4899 4900 4901 |
case INST_STR_EQ:
case INST_STR_NEQ: /* String (in)equality check */
case INST_STR_CMP: /* String compare. */
stringCompare:
value2Ptr = OBJ_AT_TOS;
valuePtr = OBJ_UNDER_TOS;
| < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < | 4875 4876 4877 4878 4879 4880 4881 4882 4883 4884 4885 4886 4887 4888 4889 4890 4891 4892 |
case INST_STR_EQ:
case INST_STR_NEQ: /* String (in)equality check */
case INST_STR_CMP: /* String compare. */
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);
}
/*
* Make sure only -1,0,1 is returned
* TODO: consider peephole opt.
*/
|
| ︙ | ︙ | |||
5019 5020 5021 5022 5023 5024 5025 |
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;
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > | > > > | > | | | | | | | | | | | | < | < < | < | | | | | | < | < < | < | | | | | | | | | | | | | | | | | 4921 4922 4923 4924 4925 4926 4927 4928 4929 4930 4931 4932 4933 4934 4935 4936 4937 4938 4939 4940 4941 4942 4943 4944 4945 4946 4947 4948 4949 4950 4951 4952 4953 4954 4955 4956 4957 4958 4959 4960 4961 4962 4963 4964 4965 4966 4967 4968 4969 4970 4971 4972 4973 4974 4975 4976 4977 4978 4979 4980 4981 4982 4983 4984 4985 4986 4987 4988 4989 4990 4991 4992 4993 4994 4995 4996 4997 4998 4999 5000 5001 5002 5003 5004 5005 5006 5007 5008 5009 5010 5011 5012 5013 5014 5015 5016 5017 5018 5019 5020 5021 5022 5023 5024 5025 5026 5027 5028 5029 5030 5031 5032 5033 5034 5035 5036 5037 5038 5039 5040 5041 5042 5043 5044 5045 5046 5047 5048 5049 5050 5051 5052 5053 5054 5055 5056 5057 5058 5059 5060 5061 5062 5063 5064 5065 5066 5067 5068 5069 5070 5071 5072 5073 5074 5075 5076 5077 5078 5079 5080 5081 5082 5083 5084 5085 5086 5087 5088 5089 5090 5091 5092 5093 5094 5095 5096 5097 5098 5099 5100 5101 5102 5103 5104 5105 5106 5107 5108 5109 5110 5111 5112 5113 5114 5115 5116 5117 5118 5119 5120 5121 5122 5123 5124 5125 5126 5127 5128 5129 5130 5131 5132 5133 5134 5135 5136 5137 5138 5139 5140 5141 5142 5143 5144 5145 5146 5147 5148 5149 5150 5151 5152 5153 5154 5155 5156 5157 5158 5159 5160 |
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);
objResultPtr = TclNewWideIntObjFromSize(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);
if (TclGetIntForIndexM(interp, value2Ptr, slength-1, &index)!=TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
}
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) {
objResultPtr = Tcl_NewObj();
} 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;
if (TclGetIntForIndexM(interp, OBJ_UNDER_TOS, slength,
&fromIdx) != TCL_OK
|| TclGetIntForIndexM(interp, OBJ_AT_TOS, slength,
&toIdx) != TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
}
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\" %" TCL_LL_MODIFIER "d %" TCL_LL_MODIFIER "d => ", O2S(valuePtr), TclWideIntFromSize(fromIdx), TclWideIntFromSize(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)));
if (TclGetIntForIndexM(interp, OBJ_UNDER_TOS, slength,
&fromIdx) != TCL_OK
|| TclGetIntForIndexM(interp, OBJ_AT_TOS, slength,
&toIdx) != TCL_OK) {
TclDecrRefCount(value3Ptr);
TRACE_ERROR(interp);
goto gotError;
}
TclDecrRefCount(OBJ_AT_TOS);
(void) POP_OBJECT();
TclDecrRefCount(OBJ_AT_TOS);
(void) POP_OBJECT();
if ((toIdx == 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,
|
| ︙ | ︙ | |||
5278 5279 5280 5281 5282 5283 5284 |
if (value3Ptr == value2Ptr) {
objResultPtr = valuePtr;
goto doneStringMap;
} else if (valuePtr == value2Ptr) {
objResultPtr = value3Ptr;
goto doneStringMap;
}
| | | | | | | | | | 5178 5179 5180 5181 5182 5183 5184 5185 5186 5187 5188 5189 5190 5191 5192 5193 5194 5195 5196 5197 5198 5199 5200 5201 5202 5203 5204 5205 5206 5207 5208 5209 5210 5211 5212 5213 |
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) {
Tcl_AppendUnicodeToObj(objResultPtr, p, ustring1-p);
p = ustring1 + length2;
|
| ︙ | ︙ | |||
5328 5329 5330 5331 5332 5333 5334 |
}
doneStringMap:
TRACE_WITH_OBJ(("%.20s %.20s %.20s => ",
O2S(value2Ptr), O2S(value3Ptr), O2S(valuePtr)), objResultPtr);
NEXT_INST_V(1, 3, 1);
case INST_STR_FIND:
| | | | | | | | | | | | | 5228 5229 5230 5231 5232 5233 5234 5235 5236 5237 5238 5239 5240 5241 5242 5243 5244 5245 5246 5247 5248 5249 5250 5251 5252 5253 5254 5255 5256 5257 5258 5259 5260 5261 5262 5263 5264 5265 |
}
doneStringMap:
TRACE_WITH_OBJ(("%.20s %.20s %.20s => ",
O2S(value2Ptr), O2S(value3Ptr), O2S(valuePtr)), objResultPtr);
NEXT_INST_V(1, 3, 1);
case INST_STR_FIND:
slength = TclStringFirst(OBJ_UNDER_TOS, OBJ_AT_TOS, 0);
TRACE(("%.20s %.20s => %" TCL_LL_MODIFIER "d\n",
O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), TclWideIntFromSize(slength)));
objResultPtr = TclNewWideIntObjFromSize(slength);
NEXT_INST_F(1, 2, 1);
case INST_STR_FIND_LAST:
slength = TclStringLast(OBJ_UNDER_TOS, OBJ_AT_TOS, TCL_INDEX_END);
TRACE(("%.20s %.20s => %" TCL_LL_MODIFIER "d\n",
O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), TclWideIntFromSize(slength)));
objResultPtr = TclNewWideIntObjFromSize(slength);
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) {
end = ustring1 + slength;
for (p=ustring1 ; p<end ; p++) {
if (!tclStringClassTable[opnd].comparator(*p)) {
match = 0;
break;
}
}
}
|
| ︙ | ︙ | |||
5373 5374 5375 5376 5377 5378 5379 | value2Ptr = OBJ_UNDER_TOS; /* Pattern */ /* * Check that at least one of the objects is Unicode before promoting * both. */ | | | | | | > | | | | | | | | | | | 5273 5274 5275 5276 5277 5278 5279 5280 5281 5282 5283 5284 5285 5286 5287 5288 5289 5290 5291 5292 5293 5294 5295 5296 5297 5298 5299 5300 5301 5302 5303 5304 5305 5306 5307 5308 5309 5310 5311 5312 5313 5314 5315 5316 5317 5318 5319 5320 5321 5322 5323 5324 5325 5326 5327 5328 5329 5330 5331 5332 5333 5334 5335 5336 5337 5338 5339 5340 5341 5342 5343 5344 5345 |
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)) {
Tcl_UniChar *ustring1, *ustring2;
ustring1 = TclGetUnicodeFromObj(valuePtr, &slength);
ustring2 = TclGetUnicodeFromObj(value2Ptr, &length2);
match = TclUniCharMatch(ustring1, slength, ustring2, length2,
nocase);
} else if (TclIsPureByteArray(valuePtr) && !nocase) {
unsigned char *bytes1, *bytes2;
size_t wlen1 = 0, wlen2 = 0;
bytes1 = TclGetByteArrayFromObj(valuePtr, &wlen1);
bytes2 = TclGetByteArrayFromObj(value2Ptr, &wlen2);
match = TclByteArrayMatch(bytes1, wlen1, bytes2, wlen2, 0);
} else {
match = Tcl_StringCaseMatch(TclGetString(valuePtr),
TclGetString(value2Ptr), nocase);
}
/*
* Reuse value2Ptr object already on stack if possible. Adjustment is
* 2 due to the nocase byte
*/
TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), match));
/*
* Peep-hole optimisation: if you're about to jump, do jump from here.
*/
JUMP_PEEPHOLE_F(match, 2, 2);
{
const char *string1, *string2;
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
|
| ︙ | ︙ | |||
5453 5454 5455 5456 5457 5458 5459 |
if (traceInstructions) {
TclPrintObject(stdout, valuePtr, 30);
printf("\n");
}
#endif
NEXT_INST_F(1, 1, 0);
} else {
| | | 5354 5355 5356 5357 5358 5359 5360 5361 5362 5363 5364 5365 5366 5367 5368 |
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);
|
| ︙ | ︙ | |||
5513 5514 5515 5516 5517 5518 5519 |
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;
| < < < < < < < < < | | | | > > > > > > > > | 5414 5415 5416 5417 5418 5419 5420 5421 5422 5423 5424 5425 5426 5427 5428 5429 5430 5431 5432 5433 5434 5435 5436 5437 5438 5439 5440 5441 5442 5443 5444 5445 5446 5447 5448 5449 5450 5451 5452 5453 5454 5455 5456 5457 5458 |
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);
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;
}
if (GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK
|| GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2) != TCL_OK) {
/*
* At least one non-numeric argument - compare as strings.
*/
|
| ︙ | ︙ | |||
5566 5567 5568 5569 5570 5571 5572 |
iResult = (*pc == INST_NEQ);
goto foundResult;
}
if (valuePtr == value2Ptr) {
compare = MP_EQ;
goto convertComparison;
}
| | | 5466 5467 5468 5469 5470 5471 5472 5473 5474 5475 5476 5477 5478 5479 5480 |
iResult = (*pc == INST_NEQ);
goto foundResult;
}
if (valuePtr == value2Ptr) {
compare = MP_EQ;
goto convertComparison;
}
if ((type1 == TCL_NUMBER_INT) && (type2 == TCL_NUMBER_INT)) {
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);
}
|
| ︙ | ︙ | |||
5645 5646 5647 5648 5649 5650 5651 | goto gotError; } /* * Check for common, simple case. */ | | | 5545 5546 5547 5548 5549 5550 5551 5552 5553 5554 5555 5556 5557 5558 5559 |
goto gotError;
}
/*
* 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) {
TRACE(("%s %s => DIVIDE BY ZERO\n", O2S(valuePtr),
|
| ︙ | ︙ | |||
5885 5886 5887 5888 5889 5890 5891 | #endif /* * Handle (long,long) arithmetic as best we can without going out to * an external function. */ | | | 5785 5786 5787 5788 5789 5790 5791 5792 5793 5794 5795 5796 5797 5798 5799 |
#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);
switch (*pc) {
case INST_ADD:
wResult = w1 + w2;
/*
|
| ︙ | ︙ | |||
5932 5933 5934 5935 5936 5937 5938 |
NEXT_INST_F(1, 1, 0);
case INST_DIV:
if (w2 == 0) {
TRACE(("%s %s => DIVIDE BY ZERO\n",
O2S(valuePtr), O2S(value2Ptr)));
goto divideByZero;
| | | | 5832 5833 5834 5835 5836 5837 5838 5839 5840 5841 5842 5843 5844 5845 5846 5847 5848 |
NEXT_INST_F(1, 1, 0);
case INST_DIV:
if (w2 == 0) {
TRACE(("%s %s => DIVIDE BY ZERO\n",
O2S(valuePtr), O2S(value2Ptr)));
goto divideByZero;
} else if ((w1 == WIDE_MIN) && (w2 == -1)) {
/*
* Can't represent (-WIDE_MIN) as a Tcl_WideInt.
*/
goto overflow;
}
wResult = w1 / w2;
/*
|
| ︙ | ︙ | |||
6028 6029 6030 6031 6032 6033 6034 |
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;
}
| | | 5928 5929 5930 5931 5932 5933 5934 5935 5936 5937 5938 5939 5940 5941 5942 |
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);
|
| ︙ | ︙ | |||
6065 6066 6067 6068 6069 6070 6071 |
goto gotError;
}
switch (type1) {
case TCL_NUMBER_NAN:
/* -NaN => NaN */
TRACE_APPEND(("%s\n", O2S(valuePtr)));
NEXT_INST_F(1, 0, 0);
| | | | 5965 5966 5967 5968 5969 5970 5971 5972 5973 5974 5975 5976 5977 5978 5979 5980 5981 |
goto gotError;
}
switch (type1) {
case TCL_NUMBER_NAN:
/* -NaN => NaN */
TRACE_APPEND(("%s\n", O2S(valuePtr)));
NEXT_INST_F(1, 0, 0);
case TCL_NUMBER_INT:
w1 = *((const Tcl_WideInt *) ptr1);
if (w1 != WIDE_MIN) {
if (Tcl_IsShared(valuePtr)) {
TclNewIntObj(objResultPtr, -w1);
TRACE_APPEND(("%s\n", O2S(objResultPtr)));
NEXT_INST_F(1, 1, 1);
}
TclSetIntObj(valuePtr, -w1);
TRACE_APPEND(("%s\n", O2S(valuePtr)));
|
| ︙ | ︙ | |||
6181 6182 6183 6184 6185 6186 6187 |
/*
* End of numeric operator instructions.
* -----------------------------------------------------------------
*/
case INST_TRY_CVT_TO_BOOLEAN:
valuePtr = OBJ_AT_TOS;
| | | 6081 6082 6083 6084 6085 6086 6087 6088 6089 6090 6091 6092 6093 6094 6095 |
/*
* End of numeric operator instructions.
* -----------------------------------------------------------------
*/
case INST_TRY_CVT_TO_BOOLEAN:
valuePtr = OBJ_AT_TOS;
if (TclHasIntRep(valuePtr, &tclBooleanType)) {
objResultPtr = TCONST(1);
} else {
int result = (TclSetBooleanFromAny(NULL, valuePtr) == TCL_OK);
objResultPtr = TCONST(result);
}
TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(valuePtr)), objResultPtr);
NEXT_INST_F(1, 0, 1);
|
| ︙ | ︙ | |||
6493 6494 6495 6496 6497 6498 6499 |
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);
| < < | < < < | | | < | | | < < < < < | < | < | < < < < < < < < < < < < < < < < < < < > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 6393 6394 6395 6396 6397 6398 6399 6400 6401 6402 6403 6404 6405 6406 6407 6408 6409 6410 6411 6412 6413 6414 6415 6416 6417 6418 6419 6420 6421 6422 6423 6424 6425 6426 6427 6428 6429 6430 6431 6432 6433 6434 6435 6436 6437 6438 6439 6440 6441 6442 6443 6444 6445 6446 6447 6448 6449 6450 6451 6452 6453 6454 6455 6456 6457 6458 6459 6460 6461 6462 6463 6464 6465 6466 6467 6468 6469 6470 6471 6472 6473 6474 6475 6476 6477 6478 6479 6480 6481 6482 6483 6484 6485 6486 6487 6488 6489 6490 6491 6492 6493 6494 6495 6496 6497 6498 6499 6500 |
TRACE_APPEND(("ERROR verifying dictionary nature of \"%.30s\": %s\n",
O2S(dictPtr), O2S(Tcl_GetObjResult(interp))));
goto gotError;
}
TRACE_APPEND(("OK\n"));
NEXT_INST_F(1, 1, 0);
case INST_DICT_EXISTS: {
int found;
opnd = TclGetUInt4AtPtr(pc+1);
TRACE(("%u => ", opnd));
dictPtr = OBJ_AT_DEPTH(opnd);
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);
}
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);
case INST_DICT_SET:
case INST_DICT_UNSET:
case INST_DICT_INCR_IMM:
opnd = TclGetUInt4AtPtr(pc+1);
opnd2 = TclGetUInt4AtPtr(pc+5);
|
| ︙ | ︙ | |||
6808 6809 6810 6811 6812 6813 6814 |
TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
NEXT_INST_F(5, 2, 1);
case INST_DICT_FIRST:
opnd = TclGetUInt4AtPtr(pc+1);
TRACE(("%u => ", opnd));
dictPtr = POP_OBJECT();
| | | > > | < | | > > | < > | | > > | | > > > > | 6738 6739 6740 6741 6742 6743 6744 6745 6746 6747 6748 6749 6750 6751 6752 6753 6754 6755 6756 6757 6758 6759 6760 6761 6762 6763 6764 6765 6766 6767 6768 6769 6770 6771 6772 6773 6774 6775 6776 6777 6778 6779 6780 6781 6782 6783 6784 6785 6786 6787 6788 6789 6790 6791 6792 6793 6794 6795 6796 6797 6798 6799 |
TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
NEXT_INST_F(5, 2, 1);
case INST_DICT_FIRST:
opnd = TclGetUInt4AtPtr(pc+1);
TRACE(("%u => ", opnd));
dictPtr = POP_OBJECT();
searchPtr = Tcl_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);
if (varPtr->value.objPtr) {
if (TclHasIntRep(varPtr->value.objPtr, &dictIteratorType)) {
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 = irPtr->twoPtrValue.ptr1;
Tcl_DictObjNext(searchPtr, &keyPtr, &valuePtr, &done);
} else {
Tcl_Panic("mis-issued dictNext!");
}
}
pushDictIteratorResult:
if (done) {
TclNewObj(emptyPtr);
PUSH_OBJECT(emptyPtr);
PUSH_OBJECT(emptyPtr);
} else {
PUSH_OBJECT(valuePtr);
|
| ︙ | ︙ | |||
6895 6896 6897 6898 6899 6900 6901 |
}
Tcl_IncrRefCount(dictPtr);
if (TclListObjGetElements(interp, OBJ_AT_TOS, &length,
&keyPtrPtr) != TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
}
| | | 6834 6835 6836 6837 6838 6839 6840 6841 6842 6843 6844 6845 6846 6847 6848 |
}
Tcl_IncrRefCount(dictPtr);
if (TclListObjGetElements(interp, OBJ_AT_TOS, &length,
&keyPtrPtr) != TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
}
if ((size_t)length != duiPtr->length) {
Tcl_Panic("dictUpdateStart argument length mismatch");
}
for (i=0 ; i<length ; i++) {
if (Tcl_DictObjGet(interp, dictPtr, keyPtrPtr[i],
&valuePtr) != TCL_OK) {
TRACE_ERROR(interp);
Tcl_DecrRefCount(dictPtr);
|
| ︙ | ︙ | |||
7255 7256 7257 7258 7259 7260 7261 7262 |
checkForCatch:
if (iPtr->execEnvPtr->rewind) {
goto abnormalReturn;
}
if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
const unsigned char *pcBeg;
| > | | | 7194 7195 7196 7197 7198 7199 7200 7201 7202 7203 7204 7205 7206 7207 7208 7209 7210 7211 7212 7213 |
checkForCatch:
if (iPtr->execEnvPtr->rewind) {
goto abnormalReturn;
}
if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
const unsigned char *pcBeg;
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();
}
iPtr->flags &= ~ERR_ALREADY_LOGGED;
/*
* Clear all expansions that may have started after the last
* INST_BEGIN_CATCH.
|
| ︙ | ︙ | |||
7421 7422 7423 7424 7425 7426 7427 7428 7429 |
* case INST_START_CMD:
*/
instStartCmdFailed:
{
const char *bytes;
checkInterp = 1;
| > | | | | 7361 7362 7363 7364 7365 7366 7367 7368 7369 7370 7371 7372 7373 7374 7375 7376 7377 7378 7379 7380 7381 7382 7383 7384 7385 7386 7387 7388 7389 7390 7391 7392 7393 7394 7395 |
* case INST_START_CMD:
*/
instStartCmdFailed:
{
const char *bytes;
size_t xxx1length;
checkInterp = 1;
xxx1length = 0;
/*
* 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]
*/
if (TclInterpReady(interp) == TCL_ERROR) {
goto gotError;
}
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
|
| ︙ | ︙ | |||
7507 7508 7509 7510 7511 7512 7513 7514 7515 7516 7517 7518 7519 7520 |
contextPtr->index = PTR2INT(data[2]);
contextPtr->skip = PTR2INT(data[3]);
contextPtr->oPtr->flags |= FILTER_HANDLING;
return result;
}
/*
*----------------------------------------------------------------------
*
* 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
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 7448 7449 7450 7451 7452 7453 7454 7455 7456 7457 7458 7459 7460 7461 7462 7463 7464 7465 7466 7467 7468 7469 7470 7471 7472 7473 7474 7475 7476 7477 7478 7479 7480 7481 7482 7483 7484 7485 7486 7487 7488 7489 7490 7491 7492 7493 7494 7495 7496 7497 7498 7499 7500 7501 7502 7503 7504 7505 7506 7507 7508 7509 7510 7511 7512 7513 7514 7515 7516 7517 7518 7519 7520 7521 7522 7523 7524 7525 7526 7527 7528 7529 7530 7531 7532 7533 7534 7535 7536 7537 7538 7539 7540 7541 7542 7543 7544 7545 7546 |
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
|
| ︙ | ︙ | |||
7569 7570 7571 7572 7573 7574 7575 |
int type1, type2;
ClientData ptr1, ptr2;
double d1, d2, dResult;
Tcl_WideInt w1, w2, wResult;
mp_int big1, big2, bigResult, bigRemainder;
Tcl_Obj *objResultPtr;
| | | | | | | | | 7595 7596 7597 7598 7599 7600 7601 7602 7603 7604 7605 7606 7607 7608 7609 7610 7611 7612 7613 7614 7615 7616 7617 7618 7619 7620 7621 7622 7623 7624 7625 7626 7627 7628 7629 7630 7631 7632 7633 7634 7635 7636 7637 7638 7639 7640 7641 7642 7643 7644 7645 7646 7647 7648 7649 7650 7651 7652 7653 7654 7655 7656 |
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;
(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);
}
|
| ︙ | ︙ | |||
7650 7651 7652 7653 7654 7655 7656 | return NULL; } Tcl_GetBignumFromObj(NULL, valuePtr, &big1); Tcl_GetBignumFromObj(NULL, value2Ptr, &big2); mp_init(&bigResult); mp_init(&bigRemainder); mp_div(&big1, &big2, &bigResult, &bigRemainder); | | | | | | | | | | | | | | | < | < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < | | < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 7676 7677 7678 7679 7680 7681 7682 7683 7684 7685 7686 7687 7688 7689 7690 7691 7692 7693 7694 7695 7696 7697 7698 7699 7700 7701 7702 7703 7704 7705 7706 7707 7708 7709 7710 7711 7712 7713 7714 7715 7716 7717 7718 7719 7720 7721 7722 7723 7724 7725 7726 7727 7728 7729 7730 7731 7732 7733 7734 7735 7736 7737 7738 7739 7740 7741 7742 7743 7744 7745 7746 7747 7748 7749 7750 7751 7752 7753 7754 7755 7756 7757 7758 7759 7760 7761 7762 7763 7764 7765 7766 7767 7768 7769 7770 7771 7772 7773 7774 7775 7776 7777 7778 7779 7780 7781 7782 7783 7784 7785 7786 7787 7788 7789 7790 7791 7792 7793 7794 7795 7796 7797 7798 7799 7800 7801 7802 7803 7804 7805 7806 7807 7808 7809 7810 7811 7812 7813 7814 7815 7816 7817 7818 7819 7820 7821 7822 7823 7824 7825 7826 7827 7828 7829 7830 7831 7832 7833 7834 7835 7836 7837 7838 7839 7840 7841 7842 7843 7844 7845 7846 7847 7848 7849 7850 7851 7852 7853 7854 7855 7856 7857 7858 7859 7860 7861 7862 7863 7864 |
return NULL;
}
Tcl_GetBignumFromObj(NULL, valuePtr, &big1);
Tcl_GetBignumFromObj(NULL, value2Ptr, &big2);
mp_init(&bigResult);
mp_init(&bigRemainder);
mp_div(&big1, &big2, &bigResult, &bigRemainder);
if ((bigRemainder.used != 0) && (bigRemainder.sign != big2.sign)) {
/*
* 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);
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 = big2.sign != MP_ZPOS;
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 = (big1.sign == MP_ZPOS);
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);
mp_init(&bigResult);
if (opcode == INST_LSHIFT) {
mp_mul_2d(&big1, shift, &bigResult);
} else {
mp_signed_rsh(&big1, shift, &bigResult);
}
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);
mp_init(&bigResult);
switch (opcode) {
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);
BIG_RESULT(&bigResult);
}
w1 = *((const Tcl_WideInt *)ptr1);
w2 = *((const Tcl_WideInt *)ptr2);
switch (opcode) {
case INST_BITAND:
wResult = w1 & w2;
break;
|
| ︙ | ︙ | |||
8003 8004 8005 8006 8007 8008 8009 |
if (d1==0.0 && d2<0.0) {
return EXPONENT_OF_ZERO;
}
dResult = pow(d1, d2);
goto doubleResult;
}
| | | | < < < < < | | | < | | | < > > < | > > > | < | | > | > | | | | | | | | | | | | | | | | | < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | 7884 7885 7886 7887 7888 7889 7890 7891 7892 7893 7894 7895 7896 7897 7898 7899 7900 7901 7902 7903 7904 7905 7906 7907 7908 7909 7910 7911 7912 7913 7914 7915 7916 7917 7918 7919 7920 7921 7922 7923 7924 7925 7926 7927 7928 7929 7930 7931 7932 7933 7934 7935 7936 7937 7938 7939 7940 7941 7942 7943 7944 7945 7946 7947 7948 7949 7950 7951 7952 7953 7954 7955 7956 7957 7958 7959 7960 7961 7962 7963 7964 7965 7966 7967 7968 7969 7970 7971 7972 7973 7974 7975 7976 7977 7978 7979 7980 7981 7982 7983 7984 7985 7986 7987 7988 7989 7990 7991 7992 7993 7994 7995 7996 7997 7998 7999 8000 8001 8002 8003 8004 8005 8006 8007 8008 8009 8010 8011 8012 8013 8014 8015 8016 8017 8018 8019 8020 8021 8022 8023 8024 8025 8026 8027 8028 8029 8030 |
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 = big2.sign != MP_ZPOS;
mp_mod_2d(&big2, 1, &big2);
oddExponent = big2.used != 0;
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.
*/
|
| ︙ | ︙ | |||
8254 8255 8256 8257 8258 8259 8260 |
wResult = oddExponent ? -Exp64Value[base] : Exp64Value[base];
WIDE_RESULT(wResult);
}
}
overflowExpon:
| > | < | > | < | 8055 8056 8057 8058 8059 8060 8061 8062 8063 8064 8065 8066 8067 8068 8069 8070 8071 8072 8073 8074 8075 8076 8077 8078 8079 8080 |
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);
mp_init(&bigResult);
mp_expt_d_ex(&big1, w2, &bigResult, 1);
mp_clear(&big1);
BIG_RESULT(&bigResult);
}
case INST_ADD:
case INST_SUB:
case INST_MULT:
case INST_DIV:
|
| ︙ | ︙ | |||
8324 8325 8326 8327 8328 8329 8330 |
if (TclIsNaN(dResult)) {
TclExprFloatError(interp, dResult);
return GENERAL_ARITHMETIC_ERROR;
}
#endif
DOUBLE_RESULT(dResult);
}
| | | | | | | 8125 8126 8127 8128 8129 8130 8131 8132 8133 8134 8135 8136 8137 8138 8139 8140 8141 8142 8143 8144 8145 8146 8147 8148 8149 8150 8151 8152 8153 8154 8155 8156 8157 8158 8159 8160 |
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
|
| ︙ | ︙ | |||
8377 8378 8379 8380 8381 8382 8383 |
case INST_DIV:
if (w2 == 0) {
return DIVIDED_BY_ZERO;
}
/*
| | | | 8178 8179 8180 8181 8182 8183 8184 8185 8186 8187 8188 8189 8190 8191 8192 8193 8194 8195 |
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
|
| ︙ | ︙ | |||
8423 8424 8425 8426 8427 8428 8429 | case INST_SUB: mp_sub(&big1, &big2, &bigResult); break; case INST_MULT: mp_mul(&big1, &big2, &bigResult); break; case INST_DIV: | | | | 8224 8225 8226 8227 8228 8229 8230 8231 8232 8233 8234 8235 8236 8237 8238 8239 8240 8241 8242 8243 8244 8245 8246 8247 |
case INST_SUB:
mp_sub(&big1, &big2, &bigResult);
break;
case INST_MULT:
mp_mul(&big1, &big2, &bigResult);
break;
case INST_DIV:
if (big2.used == 0) {
mp_clear(&big1);
mp_clear(&big2);
mp_clear(&bigResult);
return DIVIDED_BY_ZERO;
}
mp_init(&bigRemainder);
mp_div(&big1, &big2, &bigResult, &bigRemainder);
/* TODO: internals intrusion */
if ((bigRemainder.used != 0)
&& (bigRemainder.sign != big2.sign)) {
/*
* Convert to Tcl's integer division rules.
*/
mp_sub_d(&bigResult, 1, &bigResult);
mp_add(&bigRemainder, &big2, &bigRemainder);
|
| ︙ | ︙ | |||
8468 8469 8470 8471 8472 8473 8474 |
mp_int big;
Tcl_Obj *objResultPtr;
(void) GetNumberFromObj(NULL, valuePtr, &ptr, &type);
switch (opcode) {
case INST_BITNOT:
| | | | | 8269 8270 8271 8272 8273 8274 8275 8276 8277 8278 8279 8280 8281 8282 8283 8284 8285 8286 8287 8288 8289 8290 8291 8292 8293 8294 8295 8296 8297 8298 |
mp_int big;
Tcl_Obj *objResultPtr;
(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 */
mp_neg(&big, &big);
mp_sub_d(&big, 1, &big);
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);
}
TclInitBignumFromWideInt(&big, w);
break;
default:
Tcl_TakeBignumFromObj(NULL, valuePtr, &big);
}
|
| ︙ | ︙ | |||
8535 8536 8537 8538 8539 8540 8541 |
double d1, d2, tmp;
Tcl_WideInt w1, w2;
(void) GetNumberFromObj(NULL, valuePtr, &ptr1, &type1);
(void) GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2);
switch (type1) {
| | | | 8336 8337 8338 8339 8340 8341 8342 8343 8344 8345 8346 8347 8348 8349 8350 8351 8352 8353 |
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;
|
| ︙ | ︙ | |||
8569 8570 8571 8572 8573 8574 8575 | * 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. */ | | | | | | | | | | | | 8370 8371 8372 8373 8374 8375 8376 8377 8378 8379 8380 8381 8382 8383 8384 8385 8386 8387 8388 8389 8390 8391 8392 8393 8394 8395 8396 8397 8398 8399 8400 8401 8402 8403 8404 8405 8406 8407 8408 8409 8410 8411 8412 8413 8414 8415 8416 8417 8418 8419 8420 8421 8422 8423 8424 8425 8426 8427 8428 8429 8430 8431 8432 8433 8434 8435 8436 8437 8438 8439 8440 8441 8442 8443 8444 8445 8446 8447 8448 8449 8450 8451 8452 8453 8454 8455 8456 8457 8458 8459 8460 8461 8462 8463 |
* 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 (big2.sign != MP_ZPOS) {
compare = MP_GT;
} else {
compare = MP_LT;
}
mp_clear(&big2);
return compare;
}
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 (big2.sign != MP_ZPOS) {
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;
}
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);
|
| ︙ | ︙ | |||
8696 8697 8698 8699 8700 8701 8702 | * None. * *---------------------------------------------------------------------- */ static void PrintByteCodeInfo( | | | | 8497 8498 8499 8500 8501 8502 8503 8504 8505 8506 8507 8508 8509 8510 8511 8512 8513 8514 8515 8516 8517 8518 |
* None.
*
*----------------------------------------------------------------------
*/
static void
PrintByteCodeInfo(
ByteCode *codePtr) /* The bytecode whose summary is printed to
* stdout. */
{
Proc *procPtr = codePtr->procPtr;
Interp *iPtr = (Interp *) *codePtr->interpHandle;
fprintf(stdout, "\nExecuting ByteCode 0x%p, refCt %" TCL_Z_MODIFIER "u, epoch %" TCL_Z_MODIFIER "u, interp 0x%p (epoch %" TCL_Z_MODIFIER "u)\n",
codePtr, codePtr->refCount, codePtr->compileEpoch, iPtr,
iPtr->compileEpoch);
fprintf(stdout, " Source: ");
TclPrintSource(stdout, codePtr->source, 60);
fprintf(stdout, "\n Cmds %d, src %d, inst %u, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n",
codePtr->numCommands, codePtr->numSrcBytes,
codePtr->numCodeBytes, codePtr->numLitObjects,
|
| ︙ | ︙ | |||
8730 8731 8732 8733 8734 8735 8736 |
(unsigned long) (codePtr->numLitObjects * sizeof(Tcl_Obj *)),
(unsigned long) (codePtr->numExceptRanges*sizeof(ExceptionRange)),
(unsigned long) (codePtr->numAuxDataItems * sizeof(AuxData)),
codePtr->numCmdLocBytes);
#endif /* TCL_COMPILE_STATS */
if (procPtr != NULL) {
fprintf(stdout,
| | | 8531 8532 8533 8534 8535 8536 8537 8538 8539 8540 8541 8542 8543 8544 8545 |
(unsigned long) (codePtr->numLitObjects * sizeof(Tcl_Obj *)),
(unsigned long) (codePtr->numExceptRanges*sizeof(ExceptionRange)),
(unsigned long) (codePtr->numAuxDataItems * sizeof(AuxData)),
codePtr->numCmdLocBytes);
#endif /* TCL_COMPILE_STATS */
if (procPtr != NULL) {
fprintf(stdout,
" Proc 0x%p, refCt %" TCL_Z_MODIFIER "u, args %d, compiled locals %d\n",
procPtr, procPtr->refCount, procPtr->numArgs,
procPtr->numCompiledLocals);
}
}
#endif /* TCL_COMPILE_DEBUG */
/*
|
| ︙ | ︙ | |||
8759 8760 8761 8762 8763 8764 8765 | * *---------------------------------------------------------------------- */ #ifdef TCL_COMPILE_DEBUG static void ValidatePcAndStackTop( | | | | | | | | | | 8560 8561 8562 8563 8564 8565 8566 8567 8568 8569 8570 8571 8572 8573 8574 8575 8576 8577 8578 8579 8580 8581 8582 8583 8584 8585 8586 8587 8588 8589 8590 8591 8592 8593 8594 8595 8596 8597 8598 8599 8600 8601 8602 8603 8604 8605 8606 8607 |
*
*----------------------------------------------------------------------
*/
#ifdef TCL_COMPILE_DEBUG
static void
ValidatePcAndStackTop(
ByteCode *codePtr, /* The bytecode whose summary is printed to
* stdout. */
const unsigned char *pc, /* Points to first byte of a bytecode
* instruction. The program counter. */
int stackTop, /* Current stack top. Must be between
* stackLowerBound and stackUpperBound
* (inclusive). */
int checkStack) /* 0 if the stack depth check should be
* skipped. */
{
int stackUpperBound = 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)
(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",
pc);
Tcl_Panic("TclNRExecuteByteCode execution failure: bad pc");
}
if ((unsigned) opCode >= LAST_INST_OPCODE) {
fprintf(stderr, "\nBad opcode %d at pc %" TCL_Z_MODIFIER "u in TclNRExecuteByteCode\n",
(unsigned) opCode, relativePc);
Tcl_Panic("TclNRExecuteByteCode execution failure: bad opcode");
}
if (checkStack &&
((stackTop < 0) || (stackTop > stackUpperBound))) {
size_t numChars;
const char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars, NULL, NULL);
fprintf(stderr, "\nBad stack top %d at pc %" TCL_Z_MODIFIER "u in TclNRExecuteByteCode (min 0, max %i)",
stackTop, relativePc, stackUpperBound);
if (cmd != NULL) {
Tcl_Obj *message;
TclNewLiteralStringObj(message, "\n executing ");
Tcl_IncrRefCount(message);
Tcl_AppendLimitedToObj(message, cmd, numChars, 100, NULL);
|
| ︙ | ︙ | |||
8861 8862 8863 8864 8865 8866 8867 |
} else {
/* TODO: No caller needs this. Eliminate? */
description = "(big) integer";
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't use %s \"%s\" as operand of \"%s\"", description,
| | | 8662 8663 8664 8665 8666 8667 8668 8669 8670 8671 8672 8673 8674 8675 8676 |
} else {
/* 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), operator));
Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", description, NULL);
}
/*
*----------------------------------------------------------------------
*
* TclGetSrcInfoForPc, GetSrcInfoForPc, TclGetSourceFromFrame --
|
| ︙ | ︙ | |||
8938 8939 8940 8941 8942 8943 8944 | /* * 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; | | > | 8739 8740 8741 8742 8743 8744 8745 8746 8747 8748 8749 8750 8751 8752 8753 8754 |
/*
* 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;
Interp *iPtr = (Interp *) *codePtr->interpHandle;
Tcl_HashEntry *hePtr =
Tcl_FindHashEntry(iPtr->lineBCPtr, codePtr);
if (!hePtr) {
return;
}
|
| ︙ | ︙ | |||
8984 8985 8986 8987 8988 8989 8990 |
GetSrcInfoForPc(
const unsigned char *pc, /* The program counter value for which to
* return the closest command's source info.
* This points within a bytecode instruction
* in codePtr's code. */
ByteCode *codePtr, /* The bytecode sequence in which to look up
* the command source for the pc. */
| | | | | | | 8786 8787 8788 8789 8790 8791 8792 8793 8794 8795 8796 8797 8798 8799 8800 8801 8802 8803 8804 8805 8806 8807 8808 8809 8810 8811 8812 8813 8814 8815 8816 8817 8818 8819 8820 8821 |
GetSrcInfoForPc(
const unsigned char *pc, /* The program counter value for which to
* return the closest command's source info.
* This points within a bytecode instruction
* in codePtr's code. */
ByteCode *codePtr, /* The bytecode sequence in which to look up
* the command source for the pc. */
size_t *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;
unsigned char *codeDeltaNext, *codeLengthNext;
unsigned char *srcDeltaNext, *srcLengthNext;
size_t 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);
/*
* Decode the code and source offset and length for each command. The
* closest enclosing command is the last one whose code started before
* pcOffset.
*/
|
| ︙ | ︙ | |||
9147 9148 9149 9150 9151 9152 9153 |
* for loop ranges that define a continue
* point or a catch range. */
ByteCode *codePtr) /* Points to the ByteCode in which to search
* for the enclosing ExceptionRange. */
{
ExceptionRange *rangeArrayPtr;
int numRanges = codePtr->numExceptRanges;
| | | | | 8949 8950 8951 8952 8953 8954 8955 8956 8957 8958 8959 8960 8961 8962 8963 8964 8965 |
* for loop ranges that define a continue
* point or a catch range. */
ByteCode *codePtr) /* Points to the ByteCode in which to search
* for the enclosing ExceptionRange. */
{
ExceptionRange *rangeArrayPtr;
int numRanges = codePtr->numExceptRanges;
ExceptionRange *rangePtr;
size_t pcOffset = pc - codePtr->codeStart;
size_t start;
if (numRanges == 0) {
return NULL;
}
/*
* This exploits peculiarities of our compiler: nested ranges are always
|
| ︙ | ︙ | |||
9281 9282 9283 9284 9285 9286 9287 | * None. * *---------------------------------------------------------------------- */ int TclLog2( | | | | | 9083 9084 9085 9086 9087 9088 9089 9090 9091 9092 9093 9094 9095 9096 9097 9098 9099 9100 9101 |
* None.
*
*----------------------------------------------------------------------
*/
int
TclLog2(
int value) /* The integer for which to compute the log
* base 2. */
{
int n = value;
int result = 0;
while (n > 1) {
n = n >> 1;
result++;
}
return result;
}
|
| ︙ | ︙ | |||
9328 9329 9330 9331 9332 9333 9334 |
#endif
ByteCodeStats *statsPtr = &iPtr->stats;
double totalCodeBytes, currentCodeBytes;
double totalLiteralBytes, currentLiteralBytes;
double objBytesIfUnshared, strBytesIfUnshared, sharingBytesSaved;
double strBytesSharedMultX, strBytesSharedOnce;
double numInstructions, currentHeaderBytes;
| | | | < | 9130 9131 9132 9133 9134 9135 9136 9137 9138 9139 9140 9141 9142 9143 9144 9145 9146 |
#endif
ByteCodeStats *statsPtr = &iPtr->stats;
double totalCodeBytes, currentCodeBytes;
double totalLiteralBytes, currentLiteralBytes;
double objBytesIfUnshared, strBytesIfUnshared, sharingBytesSaved;
double strBytesSharedMultX, strBytesSharedOnce;
double numInstructions, currentHeaderBytes;
size_t numCurrentByteCodes, numByteCodeLits;
size_t refCountSum, literalMgmtBytes, sum, decadeHigh, length;
size_t numSharedMultX, numSharedOnce, minSizeDecade, maxSizeDecade, i;
char *litTableStats;
LiteralEntry *entryPtr;
Tcl_Obj *objPtr;
#define Percent(a,b) ((a) * 100.0 / (b))
objPtr = Tcl_NewObj();
|
| ︙ | ︙ | |||
9380 9381 9382 9383 9384 9385 9386 |
/*
* Summary statistics, total and current source and ByteCode sizes.
*/
Tcl_AppendPrintfToObj(objPtr, "\n----------------------------------------------------------------\n");
Tcl_AppendPrintfToObj(objPtr,
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 9181 9182 9183 9184 9185 9186 9187 9188 9189 9190 9191 9192 9193 9194 9195 9196 9197 9198 9199 9200 9201 9202 9203 9204 9205 9206 9207 9208 9209 9210 9211 9212 9213 9214 9215 9216 9217 9218 9219 9220 9221 9222 9223 9224 9225 9226 9227 9228 9229 9230 9231 9232 9233 9234 9235 9236 9237 9238 9239 9240 9241 9242 9243 9244 9245 9246 9247 9248 9249 9250 9251 9252 9253 9254 9255 9256 9257 9258 9259 9260 9261 9262 9263 9264 9265 9266 9267 9268 9269 9270 9271 9272 9273 9274 9275 9276 9277 9278 9279 9280 9281 9282 9283 9284 9285 9286 9287 9288 9289 9290 9291 9292 9293 9294 9295 9296 9297 9298 9299 9300 9301 9302 9303 9304 9305 9306 9307 9308 9309 9310 9311 9312 9313 9314 9315 9316 9317 9318 9319 9320 9321 9322 9323 9324 9325 9326 9327 9328 9329 9330 9331 9332 9333 9334 9335 9336 9337 9338 |
/*
* 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",
iPtr);
Tcl_AppendPrintfToObj(objPtr, "\nNumber ByteCodes executed\t%" TCL_Z_MODIFIER "u\n",
statsPtr->numExecutions);
Tcl_AppendPrintfToObj(objPtr, "Number ByteCodes compiled\t%" TCL_Z_MODIFIER "u\n",
statsPtr->numCompilations);
Tcl_AppendPrintfToObj(objPtr, " Mean executions/compile\t%.1f\n",
statsPtr->numExecutions / (float)statsPtr->numCompilations);
Tcl_AppendPrintfToObj(objPtr, "\nInstructions executed\t\t%.0f\n",
numInstructions);
Tcl_AppendPrintfToObj(objPtr, " Mean inst/compile\t\t%.0f\n",
numInstructions / statsPtr->numCompilations);
Tcl_AppendPrintfToObj(objPtr, " Mean inst/execution\t\t%.0f\n",
numInstructions / statsPtr->numExecutions);
Tcl_AppendPrintfToObj(objPtr, "\nTotal ByteCodes\t\t\t%" TCL_Z_MODIFIER "u\n",
statsPtr->numCompilations);
Tcl_AppendPrintfToObj(objPtr, " Source bytes\t\t\t%.6g\n",
statsPtr->totalSrcBytes);
Tcl_AppendPrintfToObj(objPtr, " Code bytes\t\t\t%.6g\n",
totalCodeBytes);
Tcl_AppendPrintfToObj(objPtr, " ByteCode bytes\t\t%.6g\n",
statsPtr->totalByteCodeBytes);
Tcl_AppendPrintfToObj(objPtr, " Literal bytes\t\t%.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),
#if 0
iPtr->literalTable.numBuckets * sizeof(LiteralEntry *),
#else
0,
#endif
statsPtr->numLiteralsCreated * sizeof(LiteralEntry),
statsPtr->numLiteralsCreated * sizeof(Tcl_Obj),
statsPtr->totalLitStringBytes);
Tcl_AppendPrintfToObj(objPtr, " Mean code/compile\t\t%.1f\n",
totalCodeBytes / statsPtr->numCompilations);
Tcl_AppendPrintfToObj(objPtr, " Mean code/source\t\t%.1f\n",
totalCodeBytes / statsPtr->totalSrcBytes);
Tcl_AppendPrintfToObj(objPtr, "\nCurrent (active) ByteCodes\t%" TCL_Z_MODIFIER "u\n",
numCurrentByteCodes);
Tcl_AppendPrintfToObj(objPtr, " Source bytes\t\t\t%.6g\n",
statsPtr->currentSrcBytes);
Tcl_AppendPrintfToObj(objPtr, " Code bytes\t\t\t%.6g\n",
currentCodeBytes);
Tcl_AppendPrintfToObj(objPtr, " ByteCode bytes\t\t%.6g\n",
statsPtr->currentByteCodeBytes);
Tcl_AppendPrintfToObj(objPtr, " Literal bytes\t\t%.6g\n",
currentLiteralBytes);
Tcl_AppendPrintfToObj(objPtr, " table %" TCL_Z_MODIFIER "u + bkts %" TCL_Z_MODIFIER "u + entries %" TCL_Z_MODIFIER "u + objects %" TCL_Z_MODIFIER "u + strings %.6g\n",
sizeof(LiteralTable),
#if 0
iPtr->literalTable.numBuckets * sizeof(LiteralEntry *),
iPtr->literalTable.numEntries * sizeof(LiteralEntry),
iPtr->literalTable.numEntries * sizeof(Tcl_Obj),
#else
0, 0, 0,
#endif
statsPtr->currentLitStringBytes);
Tcl_AppendPrintfToObj(objPtr, " Mean code/source\t\t%.1f\n",
currentCodeBytes / statsPtr->currentSrcBytes);
Tcl_AppendPrintfToObj(objPtr, " Code + source bytes\t\t%.6g (%0.1f mean code/src)\n",
(currentCodeBytes + statsPtr->currentSrcBytes),
(currentCodeBytes / statsPtr->currentSrcBytes) + 1.0);
/*
* Tcl_IsShared statistics check
*
* This gives the refcount of each obj as Tcl_IsShared was called for it.
* 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",
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",
i, tclObjsShared[i]);
numSharedMultX += tclObjsShared[i];
}
Tcl_AppendPrintfToObj(objPtr, " refcount >=%" TCL_Z_MODIFIER "u\t\t%" TCL_Z_MODIFIER "u\n",
i, tclObjsShared[0]);
numSharedMultX += tclObjsShared[0];
Tcl_AppendPrintfToObj(objPtr, " Total shared objects\t\t\t%" TCL_Z_MODIFIER "u\n",
numSharedMultX);
/*
* Literal table statistics.
*/
numByteCodeLits = 0;
refCountSum = 0;
numSharedMultX = 0;
numSharedOnce = 0;
objBytesIfUnshared = 0.0;
strBytesIfUnshared = 0.0;
strBytesSharedMultX = 0.0;
strBytesSharedOnce = 0.0;
#if 0
for (i = 0; i < globalTablePtr->numBuckets; i++) {
for (entryPtr = globalTablePtr->buckets[i]; entryPtr != NULL;
entryPtr = entryPtr->nextPtr) {
if (TclHasIntRep(entryPtr->objPtr, &tclByteCodeType)) {
numByteCodeLits++;
}
(void) TclGetStringFromObj(entryPtr->objPtr, &length);
refCountSum += entryPtr->refCount;
objBytesIfUnshared += (entryPtr->refCount * sizeof(Tcl_Obj));
strBytesIfUnshared += (entryPtr->refCount * (length+1));
if (entryPtr->refCount > 1) {
numSharedMultX++;
strBytesSharedMultX += (length+1);
} else {
numSharedOnce++;
strBytesSharedOnce += (length+1);
}
}
}
#endif
sharingBytesSaved = (objBytesIfUnshared + strBytesIfUnshared)
- currentLiteralBytes;
Tcl_AppendPrintfToObj(objPtr, "\nTotal objects (all interps)\t%" TCL_Z_MODIFIER "u\n",
tclObjsAlloced);
Tcl_AppendPrintfToObj(objPtr, "Current objects\t\t\t%" TCL_Z_MODIFIER "u\n",
(tclObjsAlloced - tclObjsFreed));
Tcl_AppendPrintfToObj(objPtr, "Total literal objects\t\t%" TCL_Z_MODIFIER "u\n",
statsPtr->numLiteralsCreated);
Tcl_AppendPrintfToObj(objPtr, "\nCurrent literal objects\t\t%" TCL_Z_MODIFIER "u (%0.1f%% of current objects)\n",
#if 0
globalTablePtr->numEntries,
Percent(globalTablePtr->numEntries, tclObjsAlloced-tclObjsFreed));
#else
0, Percent(0, 1));
#endif
Tcl_AppendPrintfToObj(objPtr, " ByteCode literals\t\t%" TCL_Z_MODIFIER "u (%0.1f%% of current literals)\n",
numByteCodeLits,
Percent(numByteCodeLits, /*globalTablePtr->numEntries*/1));
Tcl_AppendPrintfToObj(objPtr, " Literals reused > 1x\t\t%" TCL_Z_MODIFIER "u\n",
numSharedMultX);
Tcl_AppendPrintfToObj(objPtr, " Mean reference count\t\t%.2f\n",
((double) refCountSum) / /*globalTablePtr->numEntries*/ 1);
Tcl_AppendPrintfToObj(objPtr, " Mean len, str reused >1x \t%.2f\n",
(numSharedMultX ? strBytesSharedMultX/numSharedMultX : 0.0));
Tcl_AppendPrintfToObj(objPtr, " Mean len, str used 1x\t\t%.2f\n",
(numSharedOnce ? strBytesSharedOnce/numSharedOnce : 0.0));
|
| ︙ | ︙ | |||
9552 9553 9554 9555 9556 9557 9558 |
statsPtr->currentLitStringBytes);
Tcl_AppendPrintfToObj(objPtr, " Bytes if no sharing\t\t%.6g = objects %.6g + strings %.6g\n",
(objBytesIfUnshared + strBytesIfUnshared),
objBytesIfUnshared, strBytesIfUnshared);
Tcl_AppendPrintfToObj(objPtr, " String sharing savings \t%.6g = unshared %.6g - shared %.6g\n",
(strBytesIfUnshared - statsPtr->currentLitStringBytes),
strBytesIfUnshared, statsPtr->currentLitStringBytes);
| | | 9353 9354 9355 9356 9357 9358 9359 9360 9361 9362 9363 9364 9365 9366 9367 |
statsPtr->currentLitStringBytes);
Tcl_AppendPrintfToObj(objPtr, " Bytes if no sharing\t\t%.6g = objects %.6g + strings %.6g\n",
(objBytesIfUnshared + strBytesIfUnshared),
objBytesIfUnshared, strBytesIfUnshared);
Tcl_AppendPrintfToObj(objPtr, " String sharing savings \t%.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",
literalMgmtBytes,
Percent(literalMgmtBytes, currentLiteralBytes));
Tcl_AppendPrintfToObj(objPtr, " table %lu + buckets %lu + entries %lu\n",
(unsigned long) sizeof(LiteralTable),
#if 0
(unsigned long) (iPtr->literalTable.numBuckets * sizeof(LiteralEntry *)),
(unsigned long) (iPtr->literalTable.numEntries * sizeof(LiteralEntry))
|
| ︙ | ︙ | |||
9607 9608 9609 9610 9611 9612 9613 |
/*
* Detailed literal statistics.
*/
Tcl_AppendPrintfToObj(objPtr, "\nLiteral string sizes:\n");
Tcl_AppendPrintfToObj(objPtr, "\t Up to length\t\tPercentage\n");
maxSizeDecade = 0;
| | > | | | 9408 9409 9410 9411 9412 9413 9414 9415 9416 9417 9418 9419 9420 9421 9422 9423 9424 9425 9426 9427 9428 9429 9430 9431 9432 9433 9434 9435 9436 9437 9438 9439 9440 9441 |
/*
* Detailed literal statistics.
*/
Tcl_AppendPrintfToObj(objPtr, "\nLiteral string sizes:\n");
Tcl_AppendPrintfToObj(objPtr, "\t Up to length\t\tPercentage\n");
maxSizeDecade = 0;
i = 32;
while (i-- > 0) {
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",
decadeHigh, Percent(sum, statsPtr->numLiteralsCreated));
}
/*
litTableStats = TclLiteralStats(globalTablePtr);
Tcl_AppendPrintfToObj(objPtr, "\nCurrent literal table statistics:\n%s\n",
litTableStats);
Tcl_Free(litTableStats);
*/
/*
* Source and ByteCode size distributions.
*/
Tcl_AppendPrintfToObj(objPtr, "\nSource sizes:\n");
|
| ︙ | ︙ | |||
9651 9652 9653 9654 9655 9656 9657 |
break;
}
}
sum = 0;
for (i = minSizeDecade; i <= maxSizeDecade; i++) {
decadeHigh = (1 << (i+1)) - 1;
sum += statsPtr->srcCount[i];
| | | 9453 9454 9455 9456 9457 9458 9459 9460 9461 9462 9463 9464 9465 9466 9467 |
break;
}
}
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",
decadeHigh, Percent(sum, statsPtr->numCompilations));
}
Tcl_AppendPrintfToObj(objPtr, "\nByteCode sizes:\n");
Tcl_AppendPrintfToObj(objPtr, "\t Up to size\t\tPercentage\n");
minSizeDecade = maxSizeDecade = 0;
for (i = 0; i < 31; i++) {
|
| ︙ | ︙ | |||
9674 9675 9676 9677 9678 9679 9680 |
break;
}
}
sum = 0;
for (i = minSizeDecade; i <= maxSizeDecade; i++) {
decadeHigh = (1 << (i+1)) - 1;
sum += statsPtr->byteCodeCount[i];
| | | 9476 9477 9478 9479 9480 9481 9482 9483 9484 9485 9486 9487 9488 9489 9490 |
break;
}
}
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",
decadeHigh, Percent(sum, statsPtr->numCompilations));
}
Tcl_AppendPrintfToObj(objPtr, "\nByteCode longevity (excludes Current ByteCodes):\n");
Tcl_AppendPrintfToObj(objPtr, "\t Up to ms\t\tPercentage\n");
minSizeDecade = maxSizeDecade = 0;
for (i = 0; i < 31; i++) {
|
| ︙ | ︙ | |||
9707 9708 9709 9710 9711 9712 9713 |
/*
* Instruction counts.
*/
Tcl_AppendPrintfToObj(objPtr, "\nInstruction counts:\n");
for (i = 0; i < LAST_INST_OPCODE; i++) {
| | | | 9509 9510 9511 9512 9513 9514 9515 9516 9517 9518 9519 9520 9521 9522 9523 9524 9525 9526 9527 9528 9529 9530 9531 9532 9533 9534 9535 |
/*
* Instruction counts.
*/
Tcl_AppendPrintfToObj(objPtr, "\nInstruction counts:\n");
for (i = 0; i < LAST_INST_OPCODE; i++) {
Tcl_AppendPrintfToObj(objPtr, "%20s %8" TCL_Z_MODIFIER "u ",
tclInstructionTable[i].name, statsPtr->instructionCount[i]);
if (statsPtr->instructionCount[i]) {
Tcl_AppendPrintfToObj(objPtr, "%6.1f%%\n",
Percent(statsPtr->instructionCount[i], numInstructions));
} else {
Tcl_AppendPrintfToObj(objPtr, "0\n");
}
}
#ifdef TCL_MEM_DEBUG
Tcl_AppendPrintfToObj(objPtr, "\nHeap Statistics:\n");
TclDumpMemoryInfo(objPtr, 1);
#endif
Tcl_AppendPrintfToObj(objPtr, "\n----------------------------------------------------------------\n");
if (objc == 1) {
Tcl_SetObjResult(interp, objPtr);
} else {
Tcl_Channel outChan;
|
| ︙ | ︙ |
Changes to generic/tclFCmd.c.
| ︙ | ︙ | |||
176 177 178 179 180 181 182 |
source = FileBasename(interp, objv[i]);
if (source == NULL) {
result = TCL_ERROR;
break;
}
jargv[0] = objv[objc - 1];
jargv[1] = source;
| | | 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 |
source = FileBasename(interp, objv[i]);
if (source == NULL) {
result = TCL_ERROR;
break;
}
jargv[0] = objv[objc - 1];
jargv[1] = source;
newFileName = TclJoinPath(2, jargv, 1);
Tcl_IncrRefCount(newFileName);
result = CopyRenameOneFile(interp, objv[i], newFileName, copyFlag,
force);
Tcl_DecrRefCount(newFileName);
Tcl_DecrRefCount(source);
if (result == TCL_ERROR) {
|
| ︙ | ︙ | |||
236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 |
Tcl_IncrRefCount(split);
if (pobjc == 0) {
errno = ENOENT;
errfile = objv[i];
break;
}
for (j = 0; j < pobjc; j++) {
target = Tcl_FSJoinPath(split, j + 1);
Tcl_IncrRefCount(target);
/*
* Call Tcl_FSStat() so that if target is a symlink that points to
* a directory we will create subdirectories in that directory.
*/
if (Tcl_FSStat(target, &statBuf) == 0) {
| > > > > | 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 |
Tcl_IncrRefCount(split);
if (pobjc == 0) {
errno = ENOENT;
errfile = objv[i];
break;
}
for (j = 0; j < pobjc; j++) {
int errCount = 2;
target = Tcl_FSJoinPath(split, j + 1);
Tcl_IncrRefCount(target);
createDir:
/*
* Call Tcl_FSStat() so that if target is a symlink that points to
* a directory we will create subdirectories in that directory.
*/
if (Tcl_FSStat(target, &statBuf) == 0) {
|
| ︙ | ︙ | |||
265 266 267 268 269 270 271 |
} else if (Tcl_FSCreateDirectory(target) != TCL_OK) {
/*
* Create might have failed because of being in a race
* condition with another process trying to create the same
* subdirectory.
*/
| | > > > > | | < < < < > > > | < | | | | | | | | | 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 |
} else if (Tcl_FSCreateDirectory(target) != TCL_OK) {
/*
* Create might have failed because of being in a race
* condition with another process trying to create the same
* subdirectory.
*/
if (errno == EEXIST) {
/* Be aware other workers could delete it immediately after
* creation, so give this worker still one chance (repeat once),
* see [270f78ca95] for description of the race-condition.
* Don't repeat the create always (to avoid endless loop). */
if (--errCount > 0) {
goto createDir;
}
/* Already tried, with delete in-between directly after
* creation, so just continue (assume created successful). */
goto nextPart;
}
/* return with error */
errfile = target;
goto done;
}
nextPart:
/*
* Forget about this sub-path.
*/
Tcl_DecrRefCount(target);
target = NULL;
}
|
| ︙ | ︙ | |||
359 360 361 362 363 364 365 |
}
/*
* Call lstat() to get info so can delete symbolic link itself.
*/
if (Tcl_FSLstat(objv[i], &statBuf) != 0) {
| < < < < < < | < | 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 |
}
/*
* Call lstat() to get info so can delete symbolic link itself.
*/
if (Tcl_FSLstat(objv[i], &statBuf) != 0) {
result = TCL_ERROR;
} else if (S_ISDIR(statBuf.st_mode)) {
/*
* We own a reference count on errorBuffer, if it was set as a
* result of this call.
*/
result = Tcl_FSRemoveDirectory(objv[i], force, &errorBuffer);
|
| ︙ | ︙ | |||
402 403 404 405 406 407 408 |
}
}
} else {
result = Tcl_FSDeleteFile(objv[i]);
}
if (result != TCL_OK) {
| > > > > > > | > | | | 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 |
}
}
} else {
result = Tcl_FSDeleteFile(objv[i]);
}
if (result != TCL_OK) {
/*
* Avoid possible race condition (file/directory deleted after call
* of lstat), so bypass ENOENT because not an error, just a no-op
*/
if (errno == ENOENT) {
result = TCL_OK;
continue;
}
/*
* It is important that we break on error, otherwise we might end
* up owning reference counts on numerous errorBuffers.
*/
result = TCL_ERROR;
break;
}
}
if (result != TCL_OK) {
if (errfile == NULL) {
/*
* We try to accomodate poor error results from our Tcl_FS calls.
|
| ︙ | ︙ | |||
1335 1336 1337 1338 1339 1340 1341 |
Tcl_DecrRefCount(contents);
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
| | | 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 |
Tcl_DecrRefCount(contents);
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
* TclFileTemporaryCmd --
*
* This function implements the "tempfile" subcommand of the "file"
* command.
*
* Results:
* Returns a standard Tcl result.
*
|
| ︙ | ︙ | |||
1379 1380 1381 1382 1383 1384 1385 |
}
if (objc > 1) {
nameVarObj = objv[1];
TclNewObj(nameObj);
}
if (objc > 2) {
| | | 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 |
}
if (objc > 1) {
nameVarObj = objv[1];
TclNewObj(nameObj);
}
if (objc > 2) {
size_t length;
Tcl_Obj *templateObj = objv[2];
const char *string = TclGetStringFromObj(templateObj, &length);
/*
* Treat an empty string as if it wasn't there.
*/
|
| ︙ | ︙ | |||
1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 |
Tcl_UnregisterChannel(interp, chan);
return TCL_ERROR;
}
}
Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_GetChannelName(chan), -1));
return TCL_OK;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 |
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(
ClientData 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:
*/
|
Changes to generic/tclFileName.c.
| ︙ | ︙ | |||
391 392 393 394 395 396 397 |
TclpGetNativePathType(
Tcl_Obj *pathPtr, /* Native path of interest */
int *driveNameLengthPtr, /* Returns length of drive, if non-NULL and
* path was absolute */
Tcl_Obj **driveNameRef)
{
Tcl_PathType type = TCL_PATH_ABSOLUTE;
| < | | 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 |
TclpGetNativePathType(
Tcl_Obj *pathPtr, /* Native path of interest */
int *driveNameLengthPtr, /* Returns length of drive, if non-NULL and
* path was absolute */
Tcl_Obj **driveNameRef)
{
Tcl_PathType type = TCL_PATH_ABSOLUTE;
const char *path = TclGetString(pathPtr);
if (path[0] == '~') {
/*
* This case is common to all platforms. Paths that begin with ~ are
* absolute.
*/
|
| ︙ | ︙ | |||
509 510 511 512 513 514 515 |
/*
* Perform platform specific splitting.
*/
switch (tclPlatform) {
case TCL_PLATFORM_UNIX:
| | | | 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 |
/*
* Perform platform specific splitting.
*/
switch (tclPlatform) {
case TCL_PLATFORM_UNIX:
resultPtr = SplitUnixPath(TclGetString(pathPtr));
break;
case TCL_PLATFORM_WINDOWS:
resultPtr = SplitWinPath(TclGetString(pathPtr));
break;
}
/*
* Compute the number of elements in the result.
*/
|
| ︙ | ︙ | |||
542 543 544 545 546 547 548 | * Results: * Returns a standard Tcl result. The interpreter result contains a list * of path components. *argvPtr will be filled in with the address of an * array whose elements point to the elements of path, in order. * *argcPtr will get filled in with the number of valid elements in the * array. A single block of memory is dynamically allocated to hold both * the argv array and a copy of the path elements. The caller must | | > | | | | | 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 |
* Results:
* Returns a standard Tcl result. The interpreter result contains a list
* of path components. *argvPtr will be filled in with the address of an
* array whose elements point to the elements of path, in order.
* *argcPtr will get filled in with the number of valid elements in the
* array. A single block of memory is dynamically allocated to hold both
* the argv array and a copy of the path elements. The caller must
* eventually free this memory by calling Tcl_Free() on *argvPtr. Note:
* *argvPtr and *argcPtr are only modified if the procedure returns
* normally.
*
* Side effects:
* Allocates memory.
*
*----------------------------------------------------------------------
*/
void
Tcl_SplitPath(
const char *path, /* Pointer to string containing a path. */
int *argcPtr, /* Pointer to location to fill in with the
* number of elements in the path. */
const char ***argvPtr) /* Pointer to place to store pointer to array
* of pointers to path elements. */
{
Tcl_Obj *resultPtr = NULL; /* Needed only to prevent gcc warnings. */
Tcl_Obj *tmpPtr, *eltPtr;
int i;
size_t size, len;
char *p;
const char *str;
/*
* Perform the splitting, using objectified, vfs-aware code.
*/
tmpPtr = Tcl_NewStringObj(path, -1);
Tcl_IncrRefCount(tmpPtr);
resultPtr = Tcl_FSSplitPath(tmpPtr, argcPtr);
Tcl_IncrRefCount(resultPtr);
Tcl_DecrRefCount(tmpPtr);
/*
* Calculate space required for the result.
*/
size = 1;
for (i = 0; i < *argcPtr; i++) {
Tcl_ListObjIndex(NULL, resultPtr, i, &eltPtr);
(void)TclGetStringFromObj(eltPtr, &len);
size += len + 1;
}
/*
* Allocate a buffer large enough to hold the contents of all of the list
* plus the argv pointers and the terminating NULL pointer.
*/
*argvPtr = Tcl_Alloc((((*argcPtr) + 1) * sizeof(char *)) + size);
/*
* Position p after the last argv pointer and copy the contents of the
* list in, piece by piece.
*/
p = (char *) &(*argvPtr)[(*argcPtr) + 1];
for (i = 0; i < *argcPtr; i++) {
Tcl_ListObjIndex(NULL, resultPtr, i, &eltPtr);
str = TclGetStringFromObj(eltPtr, &len);
memcpy(p, str, len+1);
p += len+1;
}
/*
* Now set up the argv pointers.
*/
|
| ︙ | ︙ | |||
647 648 649 650 651 652 653 |
*----------------------------------------------------------------------
*/
static Tcl_Obj *
SplitUnixPath(
const char *path) /* Pointer to string containing a path. */
{
| | | 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 |
*----------------------------------------------------------------------
*/
static Tcl_Obj *
SplitUnixPath(
const char *path) /* Pointer to string containing a path. */
{
size_t length;
const char *origPath = path, *elementStart;
Tcl_Obj *result = Tcl_NewObj();
/*
* Deal with the root directory as a special case.
*/
|
| ︙ | ︙ | |||
736 737 738 739 740 741 742 |
*----------------------------------------------------------------------
*/
static Tcl_Obj *
SplitWinPath(
const char *path) /* Pointer to string containing a path. */
{
| | | 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 |
*----------------------------------------------------------------------
*/
static Tcl_Obj *
SplitWinPath(
const char *path) /* Pointer to string containing a path. */
{
size_t length;
const char *p, *elementStart;
Tcl_PathType type = TCL_PATH_ABSOLUTE;
Tcl_DString buf;
Tcl_Obj *result = Tcl_NewObj();
Tcl_DStringInit(&buf);
p = ExtractWinRoot(path, &buf, 0, &type);
|
| ︙ | ︙ | |||
813 814 815 816 817 818 819 |
Tcl_Obj *
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. */
{
if (pathPtr == NULL) {
| | | | | | | | 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 |
Tcl_Obj *
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. */
{
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);
} else {
int elemc = objc + 1;
Tcl_Obj *ret, **elemv = 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;
}
}
/*
*---------------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
857 858 859 860 861 862 863 |
*/
void
TclpNativeJoinPath(
Tcl_Obj *prefix,
const char *joining)
{
| | > | 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 |
*/
void
TclpNativeJoinPath(
Tcl_Obj *prefix,
const char *joining)
{
int needsSep;
size_t length;
char *dest;
const char *p;
const char *start;
start = TclGetStringFromObj(prefix, &length);
/*
|
| ︙ | ︙ | |||
890 891 892 893 894 895 896 |
case TCL_PLATFORM_UNIX:
/*
* Append a separator if needed.
*/
if (length > 0 && (start[length-1] != '/')) {
Tcl_AppendToObj(prefix, "/", 1);
| | | | | | | | 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 |
case TCL_PLATFORM_UNIX:
/*
* Append a separator if needed.
*/
if (length > 0 && (start[length-1] != '/')) {
Tcl_AppendToObj(prefix, "/", 1);
(void)TclGetStringFromObj(prefix, &length);
}
needsSep = 0;
/*
* Append the element, eliminating duplicate and trailing slashes.
*/
Tcl_SetObjLength(prefix, length + (int) strlen(p));
dest = TclGetString(prefix) + length;
for (; *p != '\0'; p++) {
if (*p == '/') {
while (p[1] == '/') {
p++;
}
if (p[1] != '\0' && needsSep) {
*dest++ = '/';
}
} else {
*dest++ = *p;
needsSep = 1;
}
}
length = dest - TclGetString(prefix);
Tcl_SetObjLength(prefix, length);
break;
case TCL_PLATFORM_WINDOWS:
/*
* Check to see if we need to append a separator.
*/
if ((length > 0) &&
(start[length-1] != '/') && (start[length-1] != ':')) {
Tcl_AppendToObj(prefix, "/", 1);
(void)TclGetStringFromObj(prefix, &length);
}
needsSep = 0;
/*
* Append the element, eliminating duplicate and trailing slashes.
*/
Tcl_SetObjLength(prefix, length + (int) strlen(p));
dest = TclGetString(prefix) + length;
for (; *p != '\0'; p++) {
if ((*p == '/') || (*p == '\\')) {
while ((p[1] == '/') || (p[1] == '\\')) {
p++;
}
if ((p[1] != '\0') && needsSep) {
*dest++ = '/';
}
} else {
*dest++ = *p;
needsSep = 1;
}
}
length = dest - TclGetString(prefix);
Tcl_SetObjLength(prefix, length);
break;
}
return;
}
/*
|
| ︙ | ︙ | |||
981 982 983 984 985 986 987 |
char *
Tcl_JoinPath(
int argc,
const char *const *argv,
Tcl_DString *resultPtr) /* Pointer to previously initialized DString */
{
| | > | 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 |
char *
Tcl_JoinPath(
int argc,
const char *const *argv,
Tcl_DString *resultPtr) /* Pointer to previously initialized DString */
{
int i;
size_t len;
Tcl_Obj *listObj = Tcl_NewObj();
Tcl_Obj *resultObj;
const char *resultStr;
/*
* Build the list of paths.
*/
|
| ︙ | ︙ | |||
1254 1255 1256 1257 1258 1259 1260 |
globFlags = 0;
join = 0;
dir = PATH_NONE;
typePtr = NULL;
for (i = 1; i < objc; i++) {
if (Tcl_GetIndexFromObjStruct(interp, objv[i], options,
sizeof(char *), "option", 0, &index) != TCL_OK) {
| | | 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 |
globFlags = 0;
join = 0;
dir = PATH_NONE;
typePtr = NULL;
for (i = 1; i < objc; i++) {
if (Tcl_GetIndexFromObjStruct(interp, objv[i], options,
sizeof(char *), "option", 0, &index) != TCL_OK) {
string = TclGetString(objv[i]);
if (string[0] == '-') {
/*
* It looks like the command contains an option so signal an
* error.
*/
return TCL_ERROR;
|
| ︙ | ︙ | |||
1363 1364 1365 1366 1367 1368 1369 |
break;
case TCL_PLATFORM_WINDOWS:
separators = "/\\:";
break;
}
if (dir == PATH_GENERAL) {
| | | 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 |
break;
case TCL_PLATFORM_WINDOWS:
separators = "/\\:";
break;
}
if (dir == PATH_GENERAL) {
size_t pathlength;
const char *last;
const char *first = TclGetStringFromObj(pathOrDir,&pathlength);
/*
* Find the last path separator in the path
*/
|
| ︙ | ︙ | |||
1415 1416 1417 1418 1419 1420 1421 | /* * We must ensure that we haven't cut off too much, and turned * a valid path like '/' or 'C:/' into an incorrect path like * '' or 'C:'. The way we do this is to add a separator if * there are none presently in the prefix. */ | | | 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 |
/*
* We must ensure that we haven't cut off too much, and turned
* a valid path like '/' or 'C:/' into an incorrect path like
* '' or 'C:'. The way we do this is to add a separator if
* there are none presently in the prefix.
*/
if (strpbrk(TclGetString(pathOrDir), "\\/") == NULL) {
Tcl_AppendToObj(pathOrDir, last-1, 1);
}
}
/*
* Need to quote 'prefix'.
*/
|
| ︙ | ︙ | |||
1464 1465 1466 1467 1468 1469 1470 |
globTypes = TclStackAlloc(interp, sizeof(Tcl_GlobTypeData));
globTypes->type = 0;
globTypes->perm = 0;
globTypes->macType = NULL;
globTypes->macCreator = NULL;
while (--length >= 0) {
| | | 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 |
globTypes = TclStackAlloc(interp, sizeof(Tcl_GlobTypeData));
globTypes->type = 0;
globTypes->perm = 0;
globTypes->macType = NULL;
globTypes->macCreator = NULL;
while (--length >= 0) {
size_t len;
const char *str;
Tcl_ListObjIndex(interp, typePtr, length, &look);
str = TclGetStringFromObj(look, &len);
if (strcmp("readonly", str) == 0) {
globTypes->perm |= TCL_GLOB_PERM_RONLY;
} else if (strcmp("hidden", str) == 0) {
|
| ︙ | ︙ | |||
1522 1523 1524 1525 1526 1527 1528 1529 |
goto badMacTypesArg;
}
globTypes->macType = look;
Tcl_IncrRefCount(look);
} else {
Tcl_Obj *item;
| > | | | | | | | 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 |
goto badMacTypesArg;
}
globTypes->macType = look;
Tcl_IncrRefCount(look);
} else {
Tcl_Obj *item;
int llen;
if ((Tcl_ListObjLength(NULL, look, &llen) == TCL_OK)
&& (llen == 3)) {
Tcl_ListObjIndex(interp, look, 0, &item);
if (!strcmp("macintosh", TclGetString(item))) {
Tcl_ListObjIndex(interp, look, 1, &item);
if (!strcmp("type", TclGetString(item))) {
Tcl_ListObjIndex(interp, look, 2, &item);
if (globTypes->macType != NULL) {
goto badMacTypesArg;
}
globTypes->macType = item;
Tcl_IncrRefCount(item);
continue;
} else if (!strcmp("creator", TclGetString(item))) {
Tcl_ListObjIndex(interp, look, 2, &item);
if (globTypes->macCreator != NULL) {
goto badMacTypesArg;
}
globTypes->macCreator = item;
Tcl_IncrRefCount(item);
continue;
}
}
}
/*
* Error cases. We reset the 'join' flag to zero, since we
* haven't yet made use of it.
*/
badTypesArg:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad argument to \"-types\": %s",
TclGetString(look)));
Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "BAD", NULL);
result = TCL_ERROR;
join = 0;
goto endOfGlob;
badMacTypesArg:
Tcl_SetObjResult(interp, Tcl_NewStringObj(
|
| ︙ | ︙ | |||
1620 1621 1622 1623 1624 1625 1626 |
Tcl_DStringFree(&str);
goto endOfGlob;
}
}
Tcl_DStringFree(&str);
} else {
for (i = 0; i < objc; i++) {
| | | 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 |
Tcl_DStringFree(&str);
goto endOfGlob;
}
}
Tcl_DStringFree(&str);
} else {
for (i = 0; i < objc; i++) {
string = TclGetString(objv[i]);
if (TclGlob(interp, string, pathOrDir, globFlags,
globTypes) != TCL_OK) {
result = TCL_ERROR;
goto endOfGlob;
}
}
}
|
| ︙ | ︙ | |||
1820 1821 1822 1823 1824 1825 1826 |
Tcl_Obj *cwd = Tcl_FSGetCwd(interp);
if (cwd == NULL) {
Tcl_DecrRefCount(temp);
return TCL_ERROR;
}
| | | 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 |
Tcl_Obj *cwd = Tcl_FSGetCwd(interp);
if (cwd == NULL) {
Tcl_DecrRefCount(temp);
return TCL_ERROR;
}
pathPrefix = Tcl_NewStringObj(TclGetString(cwd), 3);
Tcl_DecrRefCount(cwd);
if (tail[0] == '/') {
tail++;
} else {
tail += 2;
}
Tcl_IncrRefCount(pathPrefix);
|
| ︙ | ︙ | |||
1854 1855 1856 1857 1858 1859 1860 |
* ':' no longer needed as a separator. It is only relevant to the
* beginning of the path.
*/
separators = "/\\";
} else if (tclPlatform == TCL_PLATFORM_UNIX) {
| | | 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 |
* ':' no longer needed as a separator. It is only relevant to the
* beginning of the path.
*/
separators = "/\\";
} else if (tclPlatform == TCL_PLATFORM_UNIX) {
if (pathPrefix == NULL && tail[0] == '/' && tail[1] != '/') {
pathPrefix = Tcl_NewStringObj(tail, 1);
tail++;
Tcl_IncrRefCount(pathPrefix);
}
}
/*
|
| ︙ | ︙ | |||
1954 1955 1956 1957 1958 1959 1960 |
*
* We do it by rewriting the result list in-place.
*/
if (globFlags & TCL_GLOBMODE_TAILS) {
int objc, i;
Tcl_Obj **objv;
| | | 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 |
*
* We do it by rewriting the result list in-place.
*/
if (globFlags & TCL_GLOBMODE_TAILS) {
int objc, i;
Tcl_Obj **objv;
size_t prefixLen;
const char *pre;
/*
* If this length has never been set, set it here.
*/
if (pathPrefix == NULL) {
|
| ︙ | ︙ | |||
1982 1983 1984 1985 1986 1987 1988 |
|| (pre[1] != ':')) {
prefixLen++;
}
}
Tcl_ListObjGetElements(NULL, filenamesObj, &objc, &objv);
for (i = 0; i< objc; i++) {
| | | 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 |
|| (pre[1] != ':')) {
prefixLen++;
}
}
Tcl_ListObjGetElements(NULL, filenamesObj, &objc, &objv);
for (i = 0; i< objc; i++) {
size_t len;
const char *oldStr = TclGetStringFromObj(objv[i], &len);
Tcl_Obj *elem;
if (len == prefixLen) {
if ((pattern[0] == '\0')
|| (strchr(separators, pattern[0]) == NULL)) {
TclNewLiteralStringObj(elem, ".");
|
| ︙ | ︙ | |||
2314 2315 2316 2317 2318 2319 2320 |
Tcl_Obj **subdirv;
result = Tcl_ListObjGetElements(interp, subdirsPtr,
&subdirc, &subdirv);
for (i=0; result==TCL_OK && i<subdirc; i++) {
Tcl_Obj *copy = NULL;
| | | | 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 |
Tcl_Obj **subdirv;
result = Tcl_ListObjGetElements(interp, subdirsPtr,
&subdirc, &subdirv);
for (i=0; result==TCL_OK && i<subdirc; i++) {
Tcl_Obj *copy = NULL;
if (pathPtr == NULL && TclGetString(subdirv[i])[0] == '~') {
Tcl_ListObjLength(NULL, matchesObj, &repair);
copy = subdirv[i];
subdirv[i] = Tcl_NewStringObj("./", 2);
Tcl_AppendObjToObj(subdirv[i], copy);
Tcl_IncrRefCount(subdirv[i]);
}
result = DoGlob(interp, matchesObj, separators, subdirv[i],
1, p+1, types);
if (copy) {
int end;
Tcl_DecrRefCount(subdirv[i]);
subdirv[i] = copy;
Tcl_ListObjLength(NULL, matchesObj, &end);
while (repair < end) {
const char *bytes;
size_t numBytes;
Tcl_Obj *fixme, *newObj;
Tcl_ListObjIndex(NULL, matchesObj, repair, &fixme);
bytes = TclGetStringFromObj(fixme, &numBytes);
newObj = Tcl_NewStringObj(bytes+2, numBytes-2);
Tcl_ListObjReplace(NULL, matchesObj, repair, 1,
1, &newObj);
|
| ︙ | ︙ | |||
2354 2355 2356 2357 2358 2359 2360 |
}
/*
* We reach here with no pattern char in current section
*/
if (*p == '\0') {
| | | 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 |
}
/*
* We reach here with no pattern char in current section
*/
if (*p == '\0') {
size_t length;
Tcl_DString append;
/*
* This is the code path reached by a command like 'glob foo'.
*
* There are no more wildcards in the pattern and no more unprocessed
* characters in the pattern, so now we can construct the path, and
|
| ︙ | ︙ | |||
2418 2419 2420 2421 2422 2423 2424 |
} else {
joinedPtr = Tcl_DuplicateObj(pathPtr);
if (strchr(separators, Tcl_DStringValue(&append)[0]) == NULL) {
/*
* The current prefix must end in a separator.
*/
| | | 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 |
} else {
joinedPtr = Tcl_DuplicateObj(pathPtr);
if (strchr(separators, Tcl_DStringValue(&append)[0]) == NULL) {
/*
* The current prefix must end in a separator.
*/
size_t len;
const char *joined = TclGetStringFromObj(joinedPtr,&len);
if (strchr(separators, joined[len-1]) == NULL) {
Tcl_AppendToObj(joinedPtr, "/", 1);
}
}
Tcl_AppendToObj(joinedPtr, Tcl_DStringValue(&append),
|
| ︙ | ︙ | |||
2455 2456 2457 2458 2459 2460 2461 | * The current prefix must end in a separator, unless this is a * volume-relative path. In particular globbing in Windows shares, * when not using -dir or -path, e.g. 'glob [file join * //machine/share/subdir *]' requires adding a separator here. * This behaviour is not currently tested for in the test suite. */ | | | 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 |
* The current prefix must end in a separator, unless this is a
* volume-relative path. In particular globbing in Windows shares,
* when not using -dir or -path, e.g. 'glob [file join
* //machine/share/subdir *]' requires adding a separator here.
* This behaviour is not currently tested for in the test suite.
*/
size_t len;
const char *joined = TclGetStringFromObj(joinedPtr,&len);
if (strchr(separators, joined[len-1]) == NULL) {
if (Tcl_FSGetPathType(pathPtr) != TCL_PATH_VOLUME_RELATIVE) {
Tcl_AppendToObj(joinedPtr, "/", 1);
}
}
|
| ︙ | ︙ | |||
2485 2486 2487 2488 2489 2490 2491 | * * This procedure allocates a Tcl_StatBuf on the heap. It exists so that * extensions may be used unchanged on systems where largefile support is * optional. * * Results: * A pointer to a Tcl_StatBuf which may be deallocated by being passed to | | | | 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 |
*
* This procedure allocates a Tcl_StatBuf on the heap. It exists so that
* extensions may be used unchanged on systems where largefile support is
* optional.
*
* Results:
* A pointer to a Tcl_StatBuf which may be deallocated by being passed to
* Tcl_Free().
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
Tcl_StatBuf *
Tcl_AllocStatBuf(void)
{
return Tcl_Alloc(sizeof(Tcl_StatBuf));
}
/*
*---------------------------------------------------------------------------
*
* Access functions for Tcl_StatBuf --
*
|
| ︙ | ︙ | |||
2521 2522 2523 2524 2525 2526 2527 |
*---------------------------------------------------------------------------
*/
unsigned
Tcl_GetFSDeviceFromStat(
const Tcl_StatBuf *statPtr)
{
| | | | | 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 |
*---------------------------------------------------------------------------
*/
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;
|
| ︙ | ︙ | |||
2612 2613 2614 2615 2616 2617 2618 |
}
unsigned
Tcl_GetBlockSizeFromStat(
const Tcl_StatBuf *statPtr)
{
#ifdef HAVE_STRUCT_STAT_ST_BLKSIZE
| | | 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 |
}
unsigned
Tcl_GetBlockSizeFromStat(
const Tcl_StatBuf *statPtr)
{
#ifdef HAVE_STRUCT_STAT_ST_BLKSIZE
return statPtr->st_blksize;
#else
/*
* Not a great guess, but will do...
*/
return GUESSED_BLOCK_SIZE;
#endif
|
| ︙ | ︙ |
Changes to generic/tclFileSystem.h.
| ︙ | ︙ | |||
26 27 28 29 30 31 32 | MODULE_SCOPE int TclFSNormalizeToUniquePath(Tcl_Interp *interp, Tcl_Obj *pathPtr, int startAt); MODULE_SCOPE Tcl_Obj * TclFSMakePathRelative(Tcl_Interp *interp, Tcl_Obj *pathPtr, Tcl_Obj *cwdPtr); MODULE_SCOPE int TclFSEnsureEpochOk(Tcl_Obj *pathPtr, const Tcl_Filesystem **fsPtrPtr); MODULE_SCOPE void TclFSSetPathDetails(Tcl_Obj *pathPtr, | | | 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 | MODULE_SCOPE int TclFSNormalizeToUniquePath(Tcl_Interp *interp, Tcl_Obj *pathPtr, int startAt); MODULE_SCOPE Tcl_Obj * TclFSMakePathRelative(Tcl_Interp *interp, Tcl_Obj *pathPtr, Tcl_Obj *cwdPtr); MODULE_SCOPE int TclFSEnsureEpochOk(Tcl_Obj *pathPtr, const Tcl_Filesystem **fsPtrPtr); MODULE_SCOPE void TclFSSetPathDetails(Tcl_Obj *pathPtr, const Tcl_Filesystem *fsPtr, void *clientData); MODULE_SCOPE Tcl_Obj * TclFSNormalizeAbsolutePath(Tcl_Interp *interp, Tcl_Obj *pathPtr); MODULE_SCOPE size_t TclFSEpoch(void); /* * Private shared variables for use by tclIOUtil.c and tclPathObj.c */ |
| ︙ | ︙ |
Changes to generic/tclGetDate.y.
| ︙ | ︙ | |||
85 86 87 88 89 90 91 |
const char *dateStart;
const char *dateInput;
time_t *dateRelPointer;
int dateDigitCount;
} DateInfo;
| | | | 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 |
const char *dateStart;
const char *dateInput;
time_t *dateRelPointer;
int dateDigitCount;
} DateInfo;
#define YYMALLOC Tcl_Alloc
#define YYFREE(x) (Tcl_Free((void*) (x)))
#define yyDSTmode (info->dateDSTmode)
#define yyDayOrdinal (info->dateDayOrdinal)
#define yyDayNumber (info->dateDayNumber)
#define yyMonthOrdinal (info->dateMonthOrdinal)
#define yyHaveDate (info->dateHaveDate)
#define yyHaveDay (info->dateHaveDay)
|
| ︙ | ︙ | |||
893 894 895 896 897 898 899 |
register char c;
register char *p;
char buff[20];
int Count;
location->first_column = yyInput - info->dateStart;
for ( ; ; ) {
| | | 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 |
register char c;
register char *p;
char buff[20];
int Count;
location->first_column = yyInput - info->dateStart;
for ( ; ; ) {
while (TclIsSpaceProc(UCHAR(*yyInput))) {
yyInput++;
}
if (isdigit(UCHAR(c = *yyInput))) { /* INTL: digit */
/*
* Convert the string into a number; count the number of digits.
*/
|
| ︙ | ︙ | |||
956 957 958 959 960 961 962 |
}
} while (Count > 0);
}
}
int
TclClockOldscanObjCmd(
| | | 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 |
}
} while (Count > 0);
}
}
int
TclClockOldscanObjCmd(
void *clientData, /* Unused */
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Count of paraneters */
Tcl_Obj *const *objv) /* Parameters */
{
Tcl_Obj *result, *resultElement;
int yr, mo, da;
DateInfo dateInfo;
|
| ︙ | ︙ | |||
1060 1061 1062 1063 1064 1065 1066 |
return TCL_ERROR;
}
result = Tcl_NewObj();
resultElement = Tcl_NewObj();
if (yyHaveDate) {
Tcl_ListObjAppendElement(interp, resultElement,
| | | | | | | | | | | | | | 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 |
return TCL_ERROR;
}
result = Tcl_NewObj();
resultElement = Tcl_NewObj();
if (yyHaveDate) {
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj(yyYear));
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj(yyMonth));
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj(yyDay));
}
Tcl_ListObjAppendElement(interp, result, resultElement);
if (yyHaveTime) {
Tcl_ListObjAppendElement(interp, result, Tcl_NewIntObj(
ToSeconds(yyHour, yyMinutes, yySeconds, yyMeridian)));
} else {
Tcl_ListObjAppendElement(interp, result, Tcl_NewObj());
}
resultElement = Tcl_NewObj();
if (yyHaveZone) {
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj(-yyTimezone));
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj(1 - yyDSTmode));
}
Tcl_ListObjAppendElement(interp, result, resultElement);
resultElement = Tcl_NewObj();
if (yyHaveRel) {
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj(yyRelMonth));
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj(yyRelDay));
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj(yyRelSeconds));
}
Tcl_ListObjAppendElement(interp, result, resultElement);
resultElement = Tcl_NewObj();
if (yyHaveDay && !yyHaveDate) {
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj(yyDayOrdinal));
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj(yyDayNumber));
}
Tcl_ListObjAppendElement(interp, result, resultElement);
resultElement = Tcl_NewObj();
if (yyHaveOrdinalMonth) {
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj(yyMonthOrdinal));
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj(yyMonth));
}
Tcl_ListObjAppendElement(interp, result, resultElement);
Tcl_SetObjResult(interp, result);
return TCL_OK;
}
|
| ︙ | ︙ |
Changes to generic/tclHash.c.
| ︙ | ︙ | |||
24 25 26 27 28 29 30 | * The following macro takes a preliminary integer hash value and produces an * index into a hash tables bucket list. The idea is to make it so that * preliminary values that are arbitrarily similar will end up in different * buckets. The hash function was taken from a random-number generator. */ #define RANDOM_INDEX(tablePtr, i) \ | | | 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 |
* The following macro takes a preliminary integer hash value and produces an
* index into a hash tables bucket list. The idea is to make it so that
* preliminary values that are arbitrarily similar will end up in different
* buckets. The hash function was taken from a random-number generator.
*/
#define RANDOM_INDEX(tablePtr, i) \
((((i)*(size_t)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);
|
| ︙ | ︙ | |||
186 187 188 189 190 191 192 193 194 195 196 197 198 199 |
} else {
/*
* The caller has not been rebuilt so the hash table is not extended.
*/
}
}
static Tcl_HashEntry *
FindHashEntry(
Tcl_HashTable *tablePtr, /* Table in which to lookup entry. */
const char *key) /* Key to use to find matching entry. */
{
return CreateHashEntry(tablePtr, key, NULL);
}
| > > > > > > > > > > > > > > > > > | 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 |
} else {
/*
* The caller has not been rebuilt so the hash table is not extended.
*/
}
}
/*
*----------------------------------------------------------------------
*
* FindHashEntry --
*
* Given a hash table find the entry with a matching key.
*
* Results:
* The return value is a token for the matching entry in the hash table,
* or NULL if there was no matching entry.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static Tcl_HashEntry *
FindHashEntry(
Tcl_HashTable *tablePtr, /* Table in which to lookup entry. */
const char *key) /* Key to use to find matching entry. */
{
return CreateHashEntry(tablePtr, key, NULL);
}
|
| ︙ | ︙ | |||
226 227 228 229 230 231 232 |
const char *key, /* Key to use to find or create matching
* entry. */
int *newPtr) /* Store info here telling whether a new entry
* was created. */
{
register Tcl_HashEntry *hPtr;
const Tcl_HashKeyType *typePtr;
| | < | 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 |
const char *key, /* Key to use to find or create matching
* entry. */
int *newPtr) /* Store info here telling whether a new entry
* was created. */
{
register Tcl_HashEntry *hPtr;
const Tcl_HashKeyType *typePtr;
size_t hash, index;
if (tablePtr->keyType == TCL_STRING_KEYS) {
typePtr = &tclStringHashKeyType;
} else if (tablePtr->keyType == TCL_ONE_WORD_KEYS) {
typePtr = &tclOneWordHashKeyType;
} else if (tablePtr->keyType == TCL_CUSTOM_TYPE_KEYS
|| tablePtr->keyType == TCL_CUSTOM_PTR_KEYS) {
|
| ︙ | ︙ | |||
264 265 266 267 268 269 270 |
Tcl_CompareHashKeysProc *compareKeysProc = typePtr->compareKeysProc;
for (hPtr = tablePtr->buckets[index]; hPtr != NULL;
hPtr = hPtr->nextPtr) {
if (hash != hPtr->hash) {
continue;
}
| > > | > | 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 |
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;
}
}
} else {
|
| ︙ | ︙ | |||
298 299 300 301 302 303 304 |
* Entry not found. Add a new one to the bucket.
*/
*newPtr = 1;
if (typePtr->allocEntryProc) {
hPtr = typePtr->allocEntryProc(tablePtr, (void *) key);
} else {
| | | 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 |
* Entry not found. Add a new one to the bucket.
*/
*newPtr = 1;
if (typePtr->allocEntryProc) {
hPtr = typePtr->allocEntryProc(tablePtr, (void *) key);
} else {
hPtr = Tcl_Alloc(sizeof(Tcl_HashEntry));
hPtr->key.oneWordValue = (char *) key;
Tcl_SetHashValue(hPtr, NULL);
}
hPtr->tablePtr = tablePtr;
hPtr->hash = hash;
hPtr->nextPtr = tablePtr->buckets[index];
|
| ︙ | ︙ | |||
346 347 348 349 350 351 352 |
Tcl_DeleteHashEntry(
Tcl_HashEntry *entryPtr)
{
register Tcl_HashEntry *prevPtr;
const Tcl_HashKeyType *typePtr;
Tcl_HashTable *tablePtr;
Tcl_HashEntry **bucketPtr;
| | | 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 |
Tcl_DeleteHashEntry(
Tcl_HashEntry *entryPtr)
{
register Tcl_HashEntry *prevPtr;
const Tcl_HashKeyType *typePtr;
Tcl_HashTable *tablePtr;
Tcl_HashEntry **bucketPtr;
size_t index;
tablePtr = entryPtr->tablePtr;
if (tablePtr->keyType == TCL_STRING_KEYS) {
typePtr = &tclStringHashKeyType;
} else if (tablePtr->keyType == TCL_ONE_WORD_KEYS) {
typePtr = &tclOneWordHashKeyType;
|
| ︙ | ︙ | |||
388 389 390 391 392 393 394 |
}
}
tablePtr->numEntries--;
if (typePtr->freeEntryProc) {
typePtr->freeEntryProc(entryPtr);
} else {
| | | 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 |
}
}
tablePtr->numEntries--;
if (typePtr->freeEntryProc) {
typePtr->freeEntryProc(entryPtr);
} else {
Tcl_Free(entryPtr);
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_DeleteHashTable --
|
| ︙ | ︙ | |||
439 440 441 442 443 444 445 |
for (i = 0; i < tablePtr->numBuckets; i++) {
hPtr = tablePtr->buckets[i];
while (hPtr != NULL) {
nextPtr = hPtr->nextPtr;
if (typePtr->freeEntryProc) {
typePtr->freeEntryProc(hPtr);
} else {
| | | | 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 |
for (i = 0; i < tablePtr->numBuckets; i++) {
hPtr = tablePtr->buckets[i];
while (hPtr != NULL) {
nextPtr = hPtr->nextPtr;
if (typePtr->freeEntryProc) {
typePtr->freeEntryProc(hPtr);
} else {
Tcl_Free(hPtr);
}
hPtr = nextPtr;
}
}
/*
* Free up the bucket array, if it was dynamically allocated.
*/
if (tablePtr->buckets != tablePtr->staticBuckets) {
if (typePtr->flags & TCL_HASH_KEY_SYSTEM_HASH) {
TclpSysFree((char *) tablePtr->buckets);
} else {
Tcl_Free(tablePtr->buckets);
}
}
/*
* Arrange for panics if the table is used again without
* re-initialization.
*/
|
| ︙ | ︙ | |||
598 599 600 601 602 603 604 |
}
}
/*
* Print out the histogram and a few other pieces of information.
*/
| | | | | | | | | 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 |
}
}
/*
* Print out the histogram and a few other pieces of information.
*/
result = Tcl_Alloc((NUM_COUNTERS * 60) + 300);
sprintf(result, "%" TCL_Z_MODIFIER "u entries in table, %" TCL_Z_MODIFIER "u buckets\n",
tablePtr->numEntries, tablePtr->numBuckets);
p = result + strlen(result);
for (i = 0; i < NUM_COUNTERS; i++) {
sprintf(p, "number of buckets with %" TCL_Z_MODIFIER "u entries: %" TCL_Z_MODIFIER "u\n",
i, count[i]);
p += strlen(p);
}
sprintf(p, "number of buckets with %d or more entries: %" TCL_Z_MODIFIER "u\n",
NUM_COUNTERS, overflow);
p += strlen(p);
sprintf(p, "average search distance for entry: %.1f", average);
return result;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
633 634 635 636 637 638 639 |
*
*----------------------------------------------------------------------
*/
static Tcl_HashEntry *
AllocArrayEntry(
Tcl_HashTable *tablePtr, /* Hash table. */
| | | | | 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 |
*
*----------------------------------------------------------------------
*/
static Tcl_HashEntry *
AllocArrayEntry(
Tcl_HashTable *tablePtr, /* Hash table. */
void *keyPtr) /* Key to store in the hash table entry. */
{
int *array = (int *) keyPtr;
register int *iPtr1, *iPtr2;
Tcl_HashEntry *hPtr;
int count;
size_t 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_Alloc(size);
for (iPtr1 = array, iPtr2 = hPtr->key.words;
count > 0; count--, iPtr1++, iPtr2++) {
*iPtr2 = *iPtr1;
}
Tcl_SetHashValue(hPtr, NULL);
|
| ︙ | ︙ | |||
677 678 679 680 681 682 683 | * None. * *---------------------------------------------------------------------- */ static int CompareArrayKeys( | | | | | 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 |
* None.
*
*----------------------------------------------------------------------
*/
static int
CompareArrayKeys(
void *keyPtr, /* New key to compare. */
Tcl_HashEntry *hPtr) /* Existing key to compare. */
{
const int *iPtr1 = keyPtr;
const int *iPtr2 = hPtr->key.words;
Tcl_HashTable *tablePtr = hPtr->tablePtr;
int count;
for (count = tablePtr->keyType; ; count--, iPtr1++, iPtr2++) {
if (count == 0) {
return 1;
}
|
| ︙ | ︙ | |||
717 718 719 720 721 722 723 |
*
*----------------------------------------------------------------------
*/
static TCL_HASH_TYPE
HashArrayKey(
Tcl_HashTable *tablePtr, /* Hash table. */
| | | 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 |
*
*----------------------------------------------------------------------
*/
static TCL_HASH_TYPE
HashArrayKey(
Tcl_HashTable *tablePtr, /* Hash table. */
void *keyPtr) /* Key from which to compute hash value. */
{
register const int *array = (const int *) keyPtr;
register TCL_HASH_TYPE result;
int count;
for (result = 0, count = tablePtr->keyType; count > 0;
count--, array++) {
|
| ︙ | ︙ | |||
749 750 751 752 753 754 755 |
*
*----------------------------------------------------------------------
*/
static Tcl_HashEntry *
AllocStringEntry(
Tcl_HashTable *tablePtr, /* Hash table. */
| | | | 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 |
*
*----------------------------------------------------------------------
*/
static Tcl_HashEntry *
AllocStringEntry(
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;
allocsize = size = strlen(string) + 1;
if (size < sizeof(hPtr->key)) {
allocsize = sizeof(hPtr->key);
}
hPtr = Tcl_Alloc(offsetof(Tcl_HashEntry, key) + allocsize);
memcpy(hPtr->key.string, string, size);
Tcl_SetHashValue(hPtr, NULL);
return hPtr;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
784 785 786 787 788 789 790 | * None. * *---------------------------------------------------------------------- */ static int CompareStringKeys( | | < < < | | 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 |
* None.
*
*----------------------------------------------------------------------
*/
static int
CompareStringKeys(
void *keyPtr, /* New key to compare. */
Tcl_HashEntry *hPtr) /* Existing key to compare. */
{
return !strcmp(keyPtr, hPtr->key.string);
}
/*
*----------------------------------------------------------------------
*
* HashStringKey --
*
|
| ︙ | ︙ | |||
813 814 815 816 817 818 819 |
*
*----------------------------------------------------------------------
*/
static TCL_HASH_TYPE
HashStringKey(
Tcl_HashTable *tablePtr, /* Hash table. */
| | | 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 |
*
*----------------------------------------------------------------------
*/
static TCL_HASH_TYPE
HashStringKey(
Tcl_HashTable *tablePtr, /* Hash table. */
void *keyPtr) /* Key from which to compute hash value. */
{
register const char *string = keyPtr;
register TCL_HASH_TYPE result;
register char c;
/*
* I tried a zillion different hash functions and asked many other people
|
| ︙ | ︙ | |||
968 969 970 971 972 973 974 |
/*
* Allocate and initialize the new bucket array, and set up hashing
* constants for new array size.
*/
tablePtr->numBuckets *= 4;
if (typePtr->flags & TCL_HASH_KEY_SYSTEM_HASH) {
| | | > | > | 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 |
/*
* Allocate and initialize the new bucket array, and set up hashing
* constants for new array size.
*/
tablePtr->numBuckets *= 4;
if (typePtr->flags & TCL_HASH_KEY_SYSTEM_HASH) {
tablePtr->buckets = TclpSysAlloc(
tablePtr->numBuckets * sizeof(Tcl_HashEntry *));
} else {
tablePtr->buckets =
Tcl_Alloc(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->mask = (tablePtr->mask << 2) + 3;
/*
* Rehash all of the existing entries into the new bucket array.
*/
for (oldChainPtr = oldBuckets; oldSize > 0; oldSize--, oldChainPtr++) {
|
| ︙ | ︙ | |||
1008 1009 1010 1011 1012 1013 1014 |
* Free up the old bucket array, if it was dynamically allocated.
*/
if (oldBuckets != tablePtr->staticBuckets) {
if (typePtr->flags & TCL_HASH_KEY_SYSTEM_HASH) {
TclpSysFree((char *) oldBuckets);
} else {
| | | 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 |
* Free up the old bucket array, if it was dynamically allocated.
*/
if (oldBuckets != tablePtr->staticBuckets) {
if (typePtr->flags & TCL_HASH_KEY_SYSTEM_HASH) {
TclpSysFree((char *) oldBuckets);
} else {
Tcl_Free(oldBuckets);
}
}
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclHistory.c.
| ︙ | ︙ | |||
126 127 128 129 130 131 132 |
Tcl_GetAssocData(interp, HISTORY_OBJS_KEY, NULL);
/*
* Create the references to the [::history add] command if necessary.
*/
if (histObjsPtr == NULL) {
| | | 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 |
Tcl_GetAssocData(interp, HISTORY_OBJS_KEY, NULL);
/*
* Create the references to the [::history add] command if necessary.
*/
if (histObjsPtr == NULL) {
histObjsPtr = 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);
}
|
| ︙ | ︙ | |||
206 207 208 209 210 211 212 |
ClientData clientData,
Tcl_Interp *interp)
{
register HistoryObjs *histObjsPtr = clientData;
TclDecrRefCount(histObjsPtr->historyObj);
TclDecrRefCount(histObjsPtr->addObj);
| | | 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 |
ClientData clientData,
Tcl_Interp *interp)
{
register HistoryObjs *histObjsPtr = clientData;
TclDecrRefCount(histObjsPtr->historyObj);
TclDecrRefCount(histObjsPtr->addObj);
Tcl_Free(histObjsPtr);
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclIO.c.
| ︙ | ︙ | |||
187 188 189 190 191 192 193 | Tcl_Interp *interp); static void DeleteScriptRecord(Tcl_Interp *interp, Channel *chanPtr, int mask); static int DetachChannel(Tcl_Interp *interp, Tcl_Channel chan); static void DiscardInputQueued(ChannelState *statePtr, int discardSavedBuffers); static void DiscardOutputQueued(ChannelState *chanPtr); | | | | 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 | Tcl_Interp *interp); static void DeleteScriptRecord(Tcl_Interp *interp, Channel *chanPtr, int mask); static int DetachChannel(Tcl_Interp *interp, Tcl_Channel chan); static void DiscardInputQueued(ChannelState *statePtr, int discardSavedBuffers); static void DiscardOutputQueued(ChannelState *chanPtr); static int DoRead(Channel *chanPtr, char *dst, size_t bytesToRead, int allowShortReads); static int DoReadChars(Channel *chan, Tcl_Obj *objPtr, size_t 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(); |
| ︙ | ︙ | |||
235 236 237 238 239 240 241 | /* * Simplifying helper macros. All may use their argument(s) multiple times. * The ANSI C "prototypes" for the macros are listed below, together with a * short description of what the macro does. * * -------------------------------------------------------------------------- | | | 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 | /* * 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) * * Returns the number of bytes of data remaining in the buffer. * * int SpaceLeft(ChannelBuffer *bufPtr) * * Returns the number of bytes of space remaining at the end of the * buffer. |
| ︙ | ︙ | |||
273 274 275 276 277 278 279 | * char *RemovePoint(ChannelBuffer *bufPtr) * * Returns a pointer to where characters should be removed from the * buffer. * -------------------------------------------------------------------------- */ | | | | 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 | * char *RemovePoint(ChannelBuffer *bufPtr) * * 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) |
| ︙ | ︙ | |||
332 333 334 335 336 337 338 339 340 341 342 343 344 345 |
static const Tcl_ObjType chanObjType = {
"channel", /* name for this type */
FreeChannelIntRep, /* freeIntRepProc */
DupChannelIntRep, /* dupIntRepProc */
NULL, /* updateStringProc */
NULL /* setFromAnyProc */
};
#define BUSY_STATE(st, fl) \
((((st)->csPtrR) && ((fl) & TCL_READABLE)) || \
(((st)->csPtrW) && ((fl) & TCL_WRITABLE)))
#define MAX_CHANNEL_BUFFER_SIZE (1024*1024)
| > > > > > > > > > > > > > > > > | 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 |
static const 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 ? irPtr->twoPtrValue.ptr1 : NULL; \
} while (0)
#define BUSY_STATE(st, fl) \
((((st)->csPtrR) && ((fl) & TCL_READABLE)) || \
(((st)->csPtrW) && ((fl) & TCL_WRITABLE)))
#define MAX_CHANNEL_BUFFER_SIZE (1024*1024)
|
| ︙ | ︙ | |||
420 421 422 423 424 425 426 |
*/
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;
| | | > > > > > > > > > < < < < < < < < < | 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 |
*/
if (GotFlag(chanPtr->state, CHANNEL_EOF)) {
chanPtr->state->inputEncodingFlags |= TCL_ENCODING_START;
}
ResetFlag(chanPtr->state, CHANNEL_BLOCKED | CHANNEL_EOF);
chanPtr->state->inputEncodingFlags &= ~TCL_ENCODING_END;
if (WillRead(chanPtr) == -1) {
return -1;
}
bytesRead = chanPtr->typePtr->inputProc(chanPtr->instanceData,
dst, dstSize, &result);
/*
* Stop any flag leakage through stacked channel levels.
*/
if (GotFlag(chanPtr->state, CHANNEL_EOF)) {
chanPtr->state->inputEncodingFlags |= TCL_ENCODING_START;
}
ResetFlag(chanPtr->state, CHANNEL_BLOCKED | CHANNEL_EOF);
chanPtr->state->inputEncodingFlags &= ~TCL_ENCODING_END;
if (bytesRead == -1) {
if ((result == EWOULDBLOCK) || (result == EAGAIN)) {
SetFlag(chanPtr->state, CHANNEL_BLOCKED);
result = EAGAIN;
}
Tcl_SetErrno(result);
} else if (bytesRead == 0) {
SetFlag(chanPtr->state, CHANNEL_EOF);
chanPtr->state->inputEncodingFlags |= TCL_ENCODING_END;
} else {
/*
* 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);
}
}
return bytesRead;
}
static inline Tcl_WideInt
ChanSeek(
Channel *chanPtr,
|
| ︙ | ︙ | |||
478 479 480 481 482 483 484 |
if (HaveVersion(chanPtr->typePtr, TCL_CHANNEL_VERSION_3) &&
chanPtr->typePtr->wideSeekProc != NULL) {
return chanPtr->typePtr->wideSeekProc(chanPtr->instanceData,
offset, mode, errnoPtr);
}
| | | | | | 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 |
if (HaveVersion(chanPtr->typePtr, TCL_CHANNEL_VERSION_3) &&
chanPtr->typePtr->wideSeekProc != NULL) {
return chanPtr->typePtr->wideSeekProc(chanPtr->instanceData,
offset, mode, errnoPtr);
}
if (offset<LONG_MIN || offset>LONG_MAX) {
*errnoPtr = EOVERFLOW;
return -1;
}
return chanPtr->typePtr->seekProc(chanPtr->instanceData,
offset, mode, errnoPtr);
}
static inline void
ChanThreadAction(
Channel *chanPtr,
int action)
{
|
| ︙ | ︙ | |||
653 654 655 656 657 658 659 | * Decrement the refcount which was earlier artificially * bumped up to keep the channel from being closed. */ statePtr->refCount--; } | | | 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 |
* Decrement the refcount which was earlier artificially
* bumped up to keep the channel from being closed.
*/
statePtr->refCount--;
}
if (statePtr->refCount + 1 <= 1) {
/*
* Close it only if the refcount indicates that the channel is
* not referenced from any interpreter. If it is, that
* interpreter will close the channel when it gets destroyed.
*/
(void) Tcl_Close(NULL, (Tcl_Channel) chanPtr);
|
| ︙ | ︙ | |||
840 841 842 843 844 845 846 |
* channel will be closed. */
ClientData clientData) /* Arbitrary data to pass to the close
* callback. */
{
ChannelState *statePtr = ((Channel *) chan)->state;
CloseCallback *cbPtr;
| | | 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 |
* channel will be closed. */
ClientData clientData) /* Arbitrary data to pass to the close
* callback. */
{
ChannelState *statePtr = ((Channel *) chan)->state;
CloseCallback *cbPtr;
cbPtr = Tcl_Alloc(sizeof(CloseCallback));
cbPtr->proc = proc;
cbPtr->clientData = clientData;
cbPtr->nextPtr = statePtr->closeCbPtr;
statePtr->closeCbPtr = cbPtr;
}
|
| ︙ | ︙ | |||
886 887 888 889 890 891 892 |
cbPtr != NULL; cbPtr = cbPtr->nextPtr) {
if ((cbPtr->proc == proc) && (cbPtr->clientData == clientData)) {
if (cbPrevPtr == NULL) {
statePtr->closeCbPtr = cbPtr->nextPtr;
} else {
cbPrevPtr->nextPtr = cbPtr->nextPtr;
}
| | | 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 |
cbPtr != NULL; cbPtr = cbPtr->nextPtr) {
if ((cbPtr->proc == proc) && (cbPtr->clientData == clientData)) {
if (cbPrevPtr == NULL) {
statePtr->closeCbPtr = cbPtr->nextPtr;
} else {
cbPrevPtr->nextPtr = cbPtr->nextPtr;
}
Tcl_Free(cbPtr);
break;
}
cbPrevPtr = cbPtr;
}
}
/*
|
| ︙ | ︙ | |||
921 922 923 924 925 926 927 |
Tcl_Interp *interp)
{
Tcl_HashTable *hTblPtr; /* Hash table of channels. */
Tcl_Channel stdinChan, stdoutChan, stderrChan;
hTblPtr = Tcl_GetAssocData(interp, "tclIO", NULL);
if (hTblPtr == NULL) {
| | | 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 |
Tcl_Interp *interp)
{
Tcl_HashTable *hTblPtr; /* Hash table of channels. */
Tcl_Channel stdinChan, stdoutChan, stderrChan;
hTblPtr = Tcl_GetAssocData(interp, "tclIO", NULL);
if (hTblPtr == NULL) {
hTblPtr = Tcl_Alloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(hTblPtr, TCL_STRING_KEYS);
Tcl_SetAssocData(interp, "tclIO",
(Tcl_InterpDeleteProc *) DeleteChannelTable, hTblPtr);
/*
* If the interpreter is trusted (not "safe"), insert channels for
* stdin, stdout and stderr (possibly creating them in the process).
|
| ︙ | ︙ | |||
1013 1014 1015 1016 1017 1018 1019 | prevPtr->nextPtr = nextPtr; } Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr, TclChannelEventScriptInvoker, sPtr); TclDecrRefCount(sPtr->scriptPtr); | | | 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 |
prevPtr->nextPtr = nextPtr;
}
Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr,
TclChannelEventScriptInvoker, sPtr);
TclDecrRefCount(sPtr->scriptPtr);
Tcl_Free(sPtr);
} else {
prevPtr = sPtr;
}
}
/*
* Cannot call Tcl_UnregisterChannel because that procedure calls
|
| ︙ | ︙ | |||
1036 1037 1038 1039 1040 1041 1042 |
if (!GotFlag(statePtr, BG_FLUSH_SCHEDULED)) {
(void) Tcl_Close(interp, (Tcl_Channel) chanPtr);
}
}
}
Tcl_DeleteHashTable(hTblPtr);
| | | 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 |
if (!GotFlag(statePtr, BG_FLUSH_SCHEDULED)) {
(void) Tcl_Close(interp, (Tcl_Channel) chanPtr);
}
}
}
Tcl_DeleteHashTable(hTblPtr);
Tcl_Free(hTblPtr);
}
/*
*----------------------------------------------------------------------
*
* CheckForStdChannelsBeingClosed --
*
|
| ︙ | ︙ | |||
1071 1072 1073 1074 1075 1076 1077 |
{
ChannelState *statePtr = ((Channel *) chan)->state;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (tsdPtr->stdinInitialized == 1
&& tsdPtr->stdinChannel != NULL
&& statePtr == ((Channel *)tsdPtr->stdinChannel)->state) {
| | | | | 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 |
{
ChannelState *statePtr = ((Channel *) chan)->state;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (tsdPtr->stdinInitialized == 1
&& tsdPtr->stdinChannel != NULL
&& statePtr == ((Channel *)tsdPtr->stdinChannel)->state) {
if (statePtr->refCount + 1 < 3) {
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) {
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) {
statePtr->refCount = 0;
tsdPtr->stderrChannel = NULL;
return;
}
}
}
|
| ︙ | ︙ | |||
1249 1250 1251 1252 1253 1254 1255 |
CheckForStdChannelsBeingClosed(chan);
/*
* If the refCount reached zero, close the actual channel.
*/
| | | 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 |
CheckForStdChannelsBeingClosed(chan);
/*
* If the refCount reached zero, close the actual channel.
*/
if (statePtr->refCount + 1 <= 1) {
Tcl_Preserve(statePtr);
if (!GotFlag(statePtr, BG_FLUSH_SCHEDULED)) {
/*
* We don't want to re-enter Tcl_Close().
*/
if (!GotFlag(statePtr, CHANNEL_CLOSED)) {
|
| ︙ | ︙ | |||
1511 1512 1513 1514 1515 1516 1517 |
ResolvedChanName *resPtr = NULL;
Tcl_Channel chan;
if (interp == NULL) {
return TCL_ERROR;
}
| | > < | | < < < | | < | | | 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 |
ResolvedChanName *resPtr = NULL;
Tcl_Channel chan;
if (interp == NULL) {
return TCL_ERROR;
}
ChanGetIntRep(objPtr, resPtr);
if (resPtr) {
/*
* Confirm validity of saved lookup results.
*/
statePtr = resPtr->statePtr;
if ((resPtr->interp == interp) /* Same interp context */
/* No epoch change in channel since lookup */
&& (resPtr->epoch == statePtr->epoch)) {
/*
* Have a valid saved lookup. Jump to end to return it.
*/
goto valid;
}
}
chan = Tcl_GetChannel(interp, TclGetString(objPtr), NULL);
if (chan == NULL) {
if (resPtr) {
Tcl_StoreIntRep(objPtr, &chanObjType, NULL);
}
return TCL_ERROR;
}
if (resPtr && resPtr->refCount == 1) {
/*
* Re-use the ResolvedCmdName struct.
*/
Tcl_Release(resPtr->statePtr);
} else {
resPtr = (ResolvedChanName *) Tcl_Alloc(sizeof(ResolvedChanName));
resPtr->refCount = 0;
ChanSetIntRep(objPtr, resPtr); /* Overwrites, if needed */
}
statePtr = ((Channel *)chan)->state;
resPtr->statePtr = statePtr;
Tcl_Preserve(statePtr);
resPtr->interp = interp;
resPtr->epoch = statePtr->epoch;
valid:
*channelPtr = (Tcl_Channel) statePtr->bottomChanPtr;
if (modePtr != NULL) {
|
| ︙ | ︙ | |||
1633 1634 1635 1636 1637 1638 1639 |
}
/*
* JH: We could subsequently memset these to 0 to avoid the numerous
* assignments to 0/NULL below.
*/
| | | | | | 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 |
}
/*
* JH: We could subsequently memset these to 0 to avoid the numerous
* assignments to 0/NULL below.
*/
chanPtr = Tcl_Alloc(sizeof(Channel));
statePtr = Tcl_Alloc(sizeof(ChannelState));
chanPtr->state = statePtr;
chanPtr->instanceData = instanceData;
chanPtr->typePtr = typePtr;
/*
* Set all the bits that are part of the stack-independent state
* information for the channel.
*/
if (chanName != NULL) {
unsigned len = strlen(chanName) + 1;
/*
* Make sure we allocate at least 7 bytes, so it fits for "stdout"
* later.
*/
tmp = Tcl_Alloc((len < 7) ? 7 : len);
strcpy(tmp, chanName);
} else {
tmp = Tcl_Alloc(7);
tmp[0] = '\0';
}
statePtr->channelName = tmp;
statePtr->flags = mask;
/*
* Set the channel to system default encoding.
|
| ︙ | ︙ | |||
1929 1930 1931 1932 1933 1934 1935 |
prevChanPtr->inQueueHead = statePtr->inQueueHead;
prevChanPtr->inQueueTail = statePtr->inQueueTail;
statePtr->inQueueHead = NULL;
statePtr->inQueueTail = NULL;
}
| | | 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 |
prevChanPtr->inQueueHead = statePtr->inQueueHead;
prevChanPtr->inQueueTail = statePtr->inQueueTail;
statePtr->inQueueHead = NULL;
statePtr->inQueueTail = NULL;
}
chanPtr = Tcl_Alloc(sizeof(Channel));
/*
* Save some of the current state into the new structure, reinitialize the
* parts which will stay with the transformation.
*
* Remarks:
*/
|
| ︙ | ︙ | |||
1991 1992 1993 1994 1995 1996 1997 |
if (chanPtr->refCount == 0) {
Tcl_Panic("Channel released more than preserved");
}
if (--chanPtr->refCount) {
return;
}
if (chanPtr->typePtr == NULL) {
| | | | | 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 |
if (chanPtr->refCount == 0) {
Tcl_Panic("Channel released more than preserved");
}
if (--chanPtr->refCount) {
return;
}
if (chanPtr->typePtr == NULL) {
Tcl_Free(chanPtr);
}
}
static void
ChannelFree(
Channel *chanPtr)
{
if (!chanPtr->refCount) {
Tcl_Free(chanPtr);
return;
}
chanPtr->typePtr = NULL;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
2171 2172 2173 2174 2175 2176 2177 |
}
} else {
/*
* This channel does not cover another one. Simply do a close, if
* necessary.
*/
| | | 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 |
}
} else {
/*
* This channel does not cover another one. Simply do a close, if
* necessary.
*/
if (statePtr->refCount + 1 <= 1) {
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".
*/
|
| ︙ | ︙ | |||
2458 2459 2460 2461 2462 2463 2464 |
AllocChannelBuffer(
int length) /* Desired length of channel buffer. */
{
ChannelBuffer *bufPtr;
int n;
n = length + CHANNELBUFFER_HEADER_SIZE + BUFFER_PADDING + BUFFER_PADDING;
| | | | | | 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 |
AllocChannelBuffer(
int length) /* Desired length of channel buffer. */
{
ChannelBuffer *bufPtr;
int n;
n = length + CHANNELBUFFER_HEADER_SIZE + BUFFER_PADDING + BUFFER_PADDING;
bufPtr = Tcl_Alloc(n);
bufPtr->nextAdded = BUFFER_PADDING;
bufPtr->nextRemoved = BUFFER_PADDING;
bufPtr->bufLength = length + BUFFER_PADDING;
bufPtr->nextPtr = NULL;
bufPtr->refCount = 1;
return bufPtr;
}
static void
PreserveChannelBuffer(
ChannelBuffer *bufPtr)
{
if (!bufPtr->refCount) {
Tcl_Panic("Reuse of ChannelBuffer! %p", bufPtr);
}
bufPtr->refCount++;
}
static void
ReleaseChannelBuffer(
ChannelBuffer *bufPtr)
{
if (--bufPtr->refCount) {
return;
}
Tcl_Free(bufPtr);
}
static int
IsShared(
ChannelBuffer *bufPtr)
{
return bufPtr->refCount + 1 > 2;
}
/*
*----------------------------------------------------------------------
*
* RecycleBuffer --
*
|
| ︙ | ︙ | |||
2927 2928 2929 2930 2931 2932 2933 |
/*
* 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.
*/
| | | 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 |
/*
* 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) &&
(statePtr->outQueueHead == NULL) &&
((statePtr->curOutPtr == NULL) ||
IsBufferEmpty(statePtr->curOutPtr))) {
errorCode = CloseChannel(interp, chanPtr, errorCode);
goto done;
}
|
| ︙ | ︙ | |||
3063 3064 3065 3066 3067 3068 3069 |
/*
* 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) {
| | | 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 |
/*
* 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);
statePtr->channelName = NULL;
}
Tcl_FreeEncoding(statePtr->encoding);
}
/*
|
| ︙ | ︙ | |||
3394 3395 3396 3397 3398 3399 3400 |
* This operation should occur at the top of a channel stack.
*/
chanPtr = (Channel *) chan;
statePtr = chanPtr->state;
chanPtr = statePtr->topChanPtr;
| | | 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 |
* This operation should occur at the top of a channel stack.
*/
chanPtr = (Channel *) chan;
statePtr = chanPtr->state;
chanPtr = statePtr->topChanPtr;
if (statePtr->refCount + 1 > 1) {
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"
|
| ︙ | ︙ | |||
3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 |
TclDecrRefCount(statePtr->chanMsg);
statePtr->chanMsg = NULL;
}
}
Tcl_ClearChannelHandlers(chan);
/*
* Invoke the registered close callbacks and delete their records.
*/
while (statePtr->closeCbPtr != NULL) {
cbPtr = statePtr->closeCbPtr;
statePtr->closeCbPtr = cbPtr->nextPtr;
cbPtr->proc(cbPtr->clientData);
| > > > > > | | 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 |
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);
}
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.
|
| ︙ | ︙ | |||
3924 3925 3926 3927 3928 3929 3930 |
/*
* Remove all the channel handler records attached to the channel itself.
*/
for (chPtr = statePtr->chPtr; chPtr != NULL; chPtr = chNext) {
chNext = chPtr->nextPtr;
| | | 3941 3942 3943 3944 3945 3946 3947 3948 3949 3950 3951 3952 3953 3954 3955 |
/*
* 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);
}
statePtr->chPtr = NULL;
/*
* Cancel any pending copy operation.
*/
|
| ︙ | ︙ | |||
3951 3952 3953 3954 3955 3956 3957 |
/*
* Remove any EventScript records for this channel.
*/
for (ePtr = statePtr->scriptRecordPtr; ePtr != NULL; ePtr = eNextPtr) {
eNextPtr = ePtr->nextPtr;
TclDecrRefCount(ePtr->scriptPtr);
| | | | | | | | | | | | | | | > | | | | | | | | | | | 3968 3969 3970 3971 3972 3973 3974 3975 3976 3977 3978 3979 3980 3981 3982 3983 3984 3985 3986 3987 3988 3989 3990 3991 3992 3993 3994 3995 3996 3997 3998 3999 4000 4001 4002 4003 4004 4005 4006 4007 4008 4009 4010 4011 4012 4013 4014 4015 4016 4017 4018 4019 4020 4021 4022 4023 4024 4025 4026 4027 4028 4029 4030 4031 4032 4033 4034 4035 4036 4037 4038 4039 4040 4041 4042 4043 4044 4045 4046 4047 4048 4049 4050 4051 4052 4053 4054 4055 4056 4057 4058 4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 4070 4071 4072 4073 4074 4075 4076 4077 4078 4079 4080 4081 4082 4083 4084 4085 4086 4087 4088 4089 4090 4091 4092 4093 4094 4095 4096 4097 4098 4099 4100 4101 4102 4103 4104 4105 4106 4107 4108 4109 4110 4111 4112 4113 4114 4115 4116 4117 4118 4119 4120 4121 4122 4123 4124 4125 4126 4127 4128 4129 4130 4131 4132 4133 4134 4135 4136 4137 4138 4139 4140 4141 4142 4143 4144 4145 4146 4147 4148 4149 4150 4151 4152 4153 4154 4155 4156 4157 4158 4159 4160 |
/*
* Remove any EventScript records for this channel.
*/
for (ePtr = statePtr->scriptRecordPtr; ePtr != NULL; ePtr = eNextPtr) {
eNextPtr = ePtr->nextPtr;
TclDecrRefCount(ePtr->scriptPtr);
Tcl_Free(ePtr);
}
statePtr->scriptRecordPtr = NULL;
}
/*
*----------------------------------------------------------------------
*
* Tcl_Write --
*
* Puts a sequence of bytes into an output buffer, may queue the buffer
* for output if it gets full, and also remembers whether the current
* buffer is ready e.g. if it contains a newline and we are in line
* buffering mode. Compensates stacking, i.e. will redirect the data from
* the specified channel to the topmost channel in a stack.
*
* No encoding conversions are applied to the bytes being read.
*
* Results:
* The number of bytes written or TCL_IO_FAILURE in case of error. If
* TCL_IO_FAILURE, 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
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
* strlen(). */
{
/*
* Always use the topmost channel of the stack
*/
Channel *chanPtr;
ChannelState *statePtr; /* State info for channel */
statePtr = ((Channel *) chan)->state;
chanPtr = statePtr->topChanPtr;
if (CheckChannelErrors(statePtr, TCL_WRITABLE) != 0) {
return TCL_IO_FAILURE;
}
if (srcLen == TCL_AUTO_LENGTH) {
srcLen = strlen(src);
}
if (WriteBytes(chanPtr, src, srcLen) == -1) {
return TCL_IO_FAILURE;
}
return srcLen;
}
/*
*----------------------------------------------------------------------
*
* Tcl_WriteRaw --
*
* Puts a sequence of bytes into an output buffer, may queue the buffer
* for output if it gets full, and also remembers whether the current
* buffer is ready e.g. if it contains a newline and we are in line
* buffering mode. Writes directly to the driver of the channel, does not
* compensate for stacking.
*
* No encoding conversions are applied to the bytes being read.
*
* Results:
* The number of bytes written or TCL_IO_FAILURE in case of error. If
* TCL_IO_FAILURE, 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
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
* strlen(). */
{
Channel *chanPtr = ((Channel *) chan);
ChannelState *statePtr = chanPtr->state;
/* State info for channel */
int errorCode;
size_t written;
if (CheckChannelErrors(statePtr, TCL_WRITABLE | CHANNEL_RAW_MODE) != 0) {
return TCL_IO_FAILURE;
}
if (srcLen == TCL_AUTO_LENGTH) {
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) {
Tcl_SetErrno(errorCode);
}
return written;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_WriteChars --
*
* Takes a sequence of UTF-8 characters and converts them for output
* using the channel's current encoding, may queue the buffer for output
* if it gets full, and also remembers whether the current buffer is
* ready e.g. if it contains a newline and we are in line buffering
* mode. Compensates stacking, i.e. will redirect the data from the
* specified channel to the topmost channel in a stack.
*
* Results:
* The number of bytes written or TCL_IO_FAILURE in case of error. If
* TCL_IO_FAILURE, 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
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
* 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;
}
chanPtr = statePtr->topChanPtr;
if (len == TCL_AUTO_LENGTH) {
len = strlen(src);
}
if (statePtr->encoding) {
return WriteChars(chanPtr, src, len);
}
/*
* Inefficient way to convert UTF-8 to byte-array, but the code
* parallels the way it is done for objects. Special case for 1-byte
* (used by eg [puts] for the \n) could be extended to more efficient
* translation of the src string.
*/
if ((len == 1) && (UCHAR(*src) < 0xC0)) {
return WriteBytes(chanPtr, src, len);
}
objPtr = Tcl_NewStringObj(src, len);
src = (char *) TclGetByteArrayFromObj(objPtr, &len);
result = WriteBytes(chanPtr, src, len);
TclDecrRefCount(objPtr);
return result;
}
/*
*---------------------------------------------------------------------------
|
| ︙ | ︙ | |||
4159 4160 4161 4162 4163 4164 4165 | * Side effects: * May buffer up output and may cause output to be produced on the * channel. * *---------------------------------------------------------------------- */ | | | | | | 4177 4178 4179 4180 4181 4182 4183 4184 4185 4186 4187 4188 4189 4190 4191 4192 4193 4194 4195 4196 4197 4198 4199 4200 4201 4202 4203 4204 4205 4206 4207 4208 4209 4210 4211 4212 |
* Side effects:
* May buffer up output and may cause output to be produced on the
* channel.
*
*----------------------------------------------------------------------
*/
size_t
Tcl_WriteObj(
Tcl_Channel chan, /* The channel to buffer output for. */
Tcl_Obj *objPtr) /* The object to write. */
{
/*
* Always use the topmost channel of the stack
*/
Channel *chanPtr;
ChannelState *statePtr; /* State info for channel */
const char *src;
size_t srcLen = 0;
statePtr = ((Channel *) chan)->state;
chanPtr = statePtr->topChanPtr;
if (CheckChannelErrors(statePtr, TCL_WRITABLE) != 0) {
return TCL_IO_FAILURE;
}
if (statePtr->encoding == NULL) {
src = (char *) TclGetByteArrayFromObj(objPtr, &srcLen);
return WriteBytes(chanPtr, src, srcLen);
} else {
src = TclGetStringFromObj(objPtr, &srcLen);
return WriteChars(chanPtr, src, srcLen);
}
}
|
| ︙ | ︙ | |||
4304 4305 4306 4307 4308 4309 4310 |
}
if (saved) {
/*
* Here's some translated bytes left over from the last buffer
* that we need to stick at the beginning of this buffer.
*/
| | | 4322 4323 4324 4325 4326 4327 4328 4329 4330 4331 4332 4333 4334 4335 4336 |
}
if (saved) {
/*
* 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);
bufPtr->nextAdded += saved;
saved = 0;
}
PreserveChannelBuffer(bufPtr);
dst = InsertPoint(bufPtr);
dstLen = SpaceLeft(bufPtr);
|
| ︙ | ︙ | |||
4391 4392 4393 4394 4395 4396 4397 | * 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. */ | | | | 4409 4410 4411 4412 4413 4414 4415 4416 4417 4418 4419 4420 4421 4422 4423 4424 |
* 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);
bufPtr->nextAdded = bufPtr->bufLength;
}
if ((srcLen + saved == 0) && (result == TCL_OK)) {
endEncoding = 0;
}
|
| ︙ | ︙ | |||
4431 4432 4433 4434 4435 4436 4437 4438 4439 4440 4441 4442 4443 4444 |
if ((flushed < total) && (GotFlag(statePtr, CHANNEL_UNBUFFERED) ||
(needNlFlush && GotFlag(statePtr, CHANNEL_LINEBUFFERED)))) {
if (FlushChannel(NULL, chanPtr, 0) != 0) {
return -1;
}
}
return total;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_Gets --
| > > | 4449 4450 4451 4452 4453 4454 4455 4456 4457 4458 4459 4460 4461 4462 4463 4464 |
if ((flushed < total) && (GotFlag(statePtr, CHANNEL_UNBUFFERED) ||
(needNlFlush && GotFlag(statePtr, CHANNEL_LINEBUFFERED)))) {
if (FlushChannel(NULL, chanPtr, 0) != 0) {
return -1;
}
}
UpdateInterest(chanPtr);
return total;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_Gets --
|
| ︙ | ︙ | |||
4453 4454 4455 4456 4457 4458 4459 | * Side effects: * May flush output on the channel. May cause input to be consumed from * the channel. * *--------------------------------------------------------------------------- */ | | | | | 4473 4474 4475 4476 4477 4478 4479 4480 4481 4482 4483 4484 4485 4486 4487 4488 4489 4490 4491 4492 4493 4494 4495 4496 4497 4498 4499 4500 |
* Side effects:
* May flush output on the channel. May cause input to be consumed from
* the channel.
*
*---------------------------------------------------------------------------
*/
size_t
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;
TclNewObj(objPtr);
charsStored = Tcl_GetsObj(chan, objPtr);
if (charsStored + 1 > 1) {
TclDStringAppendObj(lineRead, objPtr);
}
TclDecrRefCount(objPtr);
return charsStored;
}
/*
|
| ︙ | ︙ | |||
4496 4497 4498 4499 4500 4501 4502 | * * On reading EOF, leave channel pointing at EOF char. On reading EOL, * leave channel pointing after EOL, but don't return EOL in dst buffer. * *--------------------------------------------------------------------------- */ | | | > | | | 4516 4517 4518 4519 4520 4521 4522 4523 4524 4525 4526 4527 4528 4529 4530 4531 4532 4533 4534 4535 4536 4537 4538 4539 4540 4541 4542 4543 4544 4545 4546 4547 4548 4549 4550 4551 4552 4553 4554 4555 4556 4557 4558 4559 4560 4561 4562 4563 |
*
* On reading EOF, leave channel pointing at EOF char. On reading EOL,
* leave channel pointing after EOL, but don't return EOL in dst buffer.
*
*---------------------------------------------------------------------------
*/
size_t
Tcl_GetsObj(
Tcl_Channel chan, /* Channel from which to read. */
Tcl_Obj *objPtr) /* The line read will be appended to this
* object as UTF-8 characters. */
{
GetsState gs;
Channel *chanPtr = (Channel *) chan;
ChannelState *statePtr = chanPtr->state;
/* State info for channel */
ChannelBuffer *bufPtr;
int inEofChar, skip, copiedTotal, oldFlags, oldRemoved;
size_t oldLength;
Tcl_Encoding encoding;
char *dst, *dstEnd, *eol, *eof;
Tcl_EncodingState oldState;
if (CheckChannelErrors(statePtr, TCL_READABLE) != 0) {
return TCL_IO_FAILURE;
}
/*
* If we're sitting ready to read the eofchar, there's no need to
* do it.
*/
if (GotFlag(statePtr, CHANNEL_STICKY_EOF)) {
SetFlag(statePtr, CHANNEL_EOF);
assert(statePtr->inputEncodingFlags & TCL_ENCODING_END);
assert(!GotFlag(statePtr, CHANNEL_BLOCKED|INPUT_SAW_CR));
/* TODO: Do we need this? */
UpdateInterest(chanPtr);
return TCL_IO_FAILURE;
}
/*
* A binary version of Tcl_GetsObj. This could also handle encodings that
* are ascii-7 pure (iso8859, utf-8, ...) with a final encoding conversion
* done on objPtr.
*/
|
| ︙ | ︙ | |||
4558 4559 4560 4561 4562 4563 4564 |
encoding = statePtr->encoding;
/*
* Preserved so we can restore the channel's state in case we don't find a
* newline in the available input.
*/
| | | 4579 4580 4581 4582 4583 4584 4585 4586 4587 4588 4589 4590 4591 4592 4593 |
encoding = statePtr->encoding;
/*
* Preserved so we can restore the channel's state in case we don't find a
* newline in the available input.
*/
(void)TclGetStringFromObj(objPtr, &oldLength);
oldFlags = statePtr->inputEncodingFlags;
oldState = statePtr->inputEncodingState;
oldRemoved = BUFFER_PADDING;
if (bufPtr != NULL) {
oldRemoved = bufPtr->nextRemoved;
}
|
| ︙ | ︙ | |||
4655 4656 4657 4658 4659 4660 4661 |
/*
* If a CR is at the end of the buffer, then check for a
* LF at the begining of the next buffer, unless EOF char
* was found already.
*/
if (eol >= dstEnd) {
| | | 4676 4677 4678 4679 4680 4681 4682 4683 4684 4685 4686 4687 4688 4689 4690 |
/*
* If a CR is at the end of the buffer, then check for a
* LF at the begining of the next buffer, unless EOF char
* was found already.
*/
if (eol >= dstEnd) {
size_t offset;
if (eol != eof) {
offset = eol - objPtr->bytes;
dst = dstEnd;
if (FilterInputBytes(chanPtr, &gs) != 0) {
goto restore;
}
|
| ︙ | ︙ | |||
4701 4702 4703 4704 4705 4706 4707 | gs.rawRead, statePtr->inputEncodingFlags | TCL_ENCODING_NO_TERMINATE, &gs.state, tmp, TCL_UTF_MAX, &rawRead, NULL, NULL); bufPtr->nextRemoved += rawRead; gs.rawRead -= rawRead; gs.bytesWrote--; gs.charsWrote--; | | | 4722 4723 4724 4725 4726 4727 4728 4729 4730 4731 4732 4733 4734 4735 4736 |
gs.rawRead, statePtr->inputEncodingFlags
| TCL_ENCODING_NO_TERMINATE, &gs.state, tmp,
TCL_UTF_MAX, &rawRead, NULL, NULL);
bufPtr->nextRemoved += rawRead;
gs.rawRead -= rawRead;
gs.bytesWrote--;
gs.charsWrote--;
memmove(dst, dst + 1, dstEnd - dst);
dstEnd--;
}
}
for (eol = dst; eol < dstEnd; eol++) {
if (*eol == '\r') {
eol++;
if (eol == dstEnd) {
|
| ︙ | ︙ | |||
4922 4923 4924 4925 4926 4927 4928 |
Tcl_Obj *objPtr) /* The line read will be appended to this
* object as UTF-8 characters. */
{
Channel *chanPtr = (Channel *) chan;
ChannelState *statePtr = chanPtr->state;
/* State info for channel */
ChannelBuffer *bufPtr;
| | | > | | 4943 4944 4945 4946 4947 4948 4949 4950 4951 4952 4953 4954 4955 4956 4957 4958 4959 4960 4961 4962 4963 4964 4965 4966 4967 4968 4969 4970 4971 4972 4973 4974 4975 4976 |
Tcl_Obj *objPtr) /* The line read will be appended to this
* object as UTF-8 characters. */
{
Channel *chanPtr = (Channel *) chan;
ChannelState *statePtr = chanPtr->state;
/* State info for channel */
ChannelBuffer *bufPtr;
int inEofChar, skip, copiedTotal, oldFlags, oldRemoved;
size_t rawLen, byteLen = 0, oldLength;
int eolChar;
unsigned char *dst, *dstEnd, *eol, *eof, *byteArray;
/*
* This operation should occur at the top of a channel stack.
*/
chanPtr = statePtr->topChanPtr;
TclChannelPreserve((Tcl_Channel)chanPtr);
bufPtr = statePtr->inQueueHead;
/*
* Preserved so we can restore the channel's state in case we don't find a
* newline in the available input.
*/
byteArray = TclGetByteArrayFromObj(objPtr, &byteLen);
oldFlags = statePtr->inputEncodingFlags;
oldRemoved = BUFFER_PADDING;
oldLength = byteLen;
if (bufPtr != NULL) {
oldRemoved = bufPtr->nextRemoved;
}
|
| ︙ | ︙ | |||
5070 5071 5072 5073 5074 5075 5076 | /* * 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); | | | | 5092 5093 5094 5095 5096 5097 5098 5099 5100 5101 5102 5103 5104 5105 5106 5107 5108 5109 5110 5111 5112 5113 5114 5115 5116 5117 5118 5119 5120 5121 5122 5123 |
/*
* 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);
byteLen += rawLen;
}
/*
* Found EOL or EOF, but the output buffer may now contain too many bytes.
* We need to know how many bytes correspond to the number we want, so we
* can remove the correct number of bytes from the channel buffer.
*/
gotEOL:
if (bufPtr == NULL) {
Tcl_Panic("TclGetsObjBinary: gotEOL reached with bufPtr==NULL");
}
rawLen = eol - dst;
byteArray = Tcl_SetByteArrayLength(objPtr, byteLen + rawLen);
memcpy(byteArray + byteLen, dst, rawLen);
byteLen += rawLen;
bufPtr->nextRemoved += rawLen + skip;
/*
* Convert the buffer if there was an encoding.
* XXX - unimplemented.
*/
|
| ︙ | ︙ | |||
5383 5384 5385 5386 5387 5388 5389 |
if (nextPtr == NULL) {
nextPtr = AllocChannelBuffer(statePtr->bufSize);
bufPtr->nextPtr = nextPtr;
statePtr->inQueueTail = nextPtr;
}
extra = rawLen - gsPtr->rawRead;
memcpy(nextPtr->buf + (BUFFER_PADDING - extra),
| | | 5405 5406 5407 5408 5409 5410 5411 5412 5413 5414 5415 5416 5417 5418 5419 |
if (nextPtr == NULL) {
nextPtr = AllocChannelBuffer(statePtr->bufSize);
bufPtr->nextPtr = nextPtr;
statePtr->inQueueTail = nextPtr;
}
extra = rawLen - gsPtr->rawRead;
memcpy(nextPtr->buf + (BUFFER_PADDING - extra),
raw + gsPtr->rawRead, extra);
nextPtr->nextRemoved -= extra;
bufPtr->nextAdded -= extra;
}
}
gsPtr->bufPtr = bufPtr;
return 0;
|
| ︙ | ︙ | |||
5563 5564 5565 5566 5567 5568 5569 | * * Side effects: * May cause input to be buffered. * *---------------------------------------------------------------------- */ | | | | | 5585 5586 5587 5588 5589 5590 5591 5592 5593 5594 5595 5596 5597 5598 5599 5600 5601 5602 5603 5604 5605 5606 5607 5608 5609 5610 5611 5612 5613 5614 5615 5616 |
*
* Side effects:
* May cause input to be buffered.
*
*----------------------------------------------------------------------
*/
size_t
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. */
{
Channel *chanPtr = (Channel *) chan;
ChannelState *statePtr = chanPtr->state;
/* State info for channel */
/*
* This operation should occur at the top of a channel stack.
*/
chanPtr = statePtr->topChanPtr;
if (CheckChannelErrors(statePtr, TCL_READABLE) != 0) {
return TCL_IO_FAILURE;
}
return DoRead(chanPtr, dst, bytesToRead, 0);
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
5608 5609 5610 5611 5612 5613 5614 | * * Side effects: * May cause input to be buffered. * *---------------------------------------------------------------------- */ | | | | | | | | 5630 5631 5632 5633 5634 5635 5636 5637 5638 5639 5640 5641 5642 5643 5644 5645 5646 5647 5648 5649 5650 5651 5652 5653 5654 5655 5656 5657 5658 5659 5660 5661 5662 5663 5664 5665 5666 5667 5668 5669 5670 5671 5672 5673 5674 |
*
* Side effects:
* May cause input to be buffered.
*
*----------------------------------------------------------------------
*/
size_t
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. */
{
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;
}
/*
* 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);
bufPtr->nextRemoved += toCopy;
copied += toCopy;
readBuf += toCopy;
bytesToRead -= toCopy;
/*
* If the current buffer is empty recycle it.
|
| ︙ | ︙ | |||
5675 5676 5677 5678 5679 5680 5681 |
/*
* This test not needed.
*/
if (bytesToRead > 0) {
int nread = ChanRead(chanPtr, readBuf, bytesToRead);
| | < < < < < < > > > > > > | 5697 5698 5699 5700 5701 5702 5703 5704 5705 5706 5707 5708 5709 5710 5711 5712 5713 5714 5715 5716 5717 5718 5719 5720 5721 5722 5723 5724 5725 5726 5727 5728 5729 5730 |
/*
* This test not needed.
*/
if (bytesToRead > 0) {
int nread = ChanRead(chanPtr, readBuf, bytesToRead);
if (nread == -1) {
/*
* 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.
*/
}
}
return copied;
|
| ︙ | ︙ | |||
5726 5727 5728 5729 5730 5731 5732 | * * Side effects: * May cause input to be buffered. * *--------------------------------------------------------------------------- */ | | | | 5748 5749 5750 5751 5752 5753 5754 5755 5756 5757 5758 5759 5760 5761 5762 5763 5764 5765 5766 |
*
* Side effects:
* May cause input to be buffered.
*
*---------------------------------------------------------------------------
*/
size_t
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
* -1 to read all available data (up to EOF or
* when channel blocks). */
int appendFlag) /* If non-zero, data read from the channel
* will be appended to the object. Otherwise,
* the data will replace the existing contents
* of the object. */
{
|
| ︙ | ︙ | |||
5786 5787 5788 5789 5790 5791 5792 |
*---------------------------------------------------------------------------
*/
static int
DoReadChars(
Channel *chanPtr, /* The channel to read. */
Tcl_Obj *objPtr, /* Input data is stored in this object. */
| | | 5808 5809 5810 5811 5812 5813 5814 5815 5816 5817 5818 5819 5820 5821 5822 |
*---------------------------------------------------------------------------
*/
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
* -1 to read all available data (up to EOF or
* when channel blocks). */
int appendFlag) /* If non-zero, data read from the channel
* will be appended to the object. Otherwise,
* the data will replace the existing contents
* of the object. */
{
|
| ︙ | ︙ | |||
5872 5873 5874 5875 5876 5877 5878 |
*/
if (GotFlag(statePtr, CHANNEL_EOF)) {
statePtr->inputEncodingFlags |= TCL_ENCODING_START;
}
ResetFlag(statePtr, CHANNEL_BLOCKED|CHANNEL_EOF);
statePtr->inputEncodingFlags &= ~TCL_ENCODING_END;
| | | 5894 5895 5896 5897 5898 5899 5900 5901 5902 5903 5904 5905 5906 5907 5908 |
*/
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; ) {
copiedNow = -1;
if (statePtr->inQueueHead != NULL) {
if (binaryMode) {
copiedNow = ReadBytes(statePtr, objPtr, toRead);
} else {
copiedNow = ReadChars(statePtr, objPtr, toRead, &factor);
}
|
| ︙ | ︙ | |||
5990 5991 5992 5993 5994 5995 5996 |
ReadBytes(
ChannelState *statePtr, /* State of the channel to read. */
Tcl_Obj *objPtr, /* Input data is appended to this ByteArray
* object. Its length is how much space has
* been allocated to hold data, not how many
* bytes of data have been stored in the
* object. */
| | | 6012 6013 6014 6015 6016 6017 6018 6019 6020 6021 6022 6023 6024 6025 6026 |
ReadBytes(
ChannelState *statePtr, /* State of the channel to read. */
Tcl_Obj *objPtr, /* Input data is appended to this ByteArray
* object. Its length is how much space has
* been allocated to hold data, not how many
* bytes of data have been stored in the
* object. */
int bytesToRead) /* Maximum number of bytes to store, or -1 to
* get all available bytes. Bytes are obtained
* from the first buffer in the queue - even
* if this number is larger than the number of
* bytes available in the first buffer, only
* the bytes from the first buffer are
* returned. */
{
|
| ︙ | ︙ | |||
6067 6068 6069 6070 6071 6072 6073 |
Tcl_Encoding encoding = statePtr->encoding? statePtr->encoding
: GetBinaryEncoding();
Tcl_EncodingState savedState = statePtr->inputEncodingState;
ChannelBuffer *bufPtr = statePtr->inQueueHead;
int savedIEFlags = statePtr->inputEncodingFlags;
int savedFlags = statePtr->flags;
char *dst, *src = RemovePoint(bufPtr);
| > | | 6089 6090 6091 6092 6093 6094 6095 6096 6097 6098 6099 6100 6101 6102 6103 6104 |
Tcl_Encoding encoding = statePtr->encoding? statePtr->encoding
: GetBinaryEncoding();
Tcl_EncodingState savedState = statePtr->inputEncodingState;
ChannelBuffer *bufPtr = statePtr->inQueueHead;
int savedIEFlags = statePtr->inputEncodingFlags;
int savedFlags = statePtr->flags;
char *dst, *src = RemovePoint(bufPtr);
size_t numBytes;
int 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.
*/
|
| ︙ | ︙ | |||
6090 6091 6092 6093 6094 6095 6096 |
int factor = *factorPtr;
int dstLimit = TCL_UTF_MAX - 1 + toRead * factor / UTF_EXPANSION_FACTOR;
(void) TclGetStringFromObj(objPtr, &numBytes);
Tcl_AppendToObj(objPtr, NULL, dstLimit);
if (toRead == srcLen) {
| | | 6113 6114 6115 6116 6117 6118 6119 6120 6121 6122 6123 6124 6125 6126 6127 |
int factor = *factorPtr;
int dstLimit = TCL_UTF_MAX - 1 + toRead * factor / UTF_EXPANSION_FACTOR;
(void) TclGetStringFromObj(objPtr, &numBytes);
Tcl_AppendToObj(objPtr, NULL, dstLimit);
if (toRead == srcLen) {
size_t size;
dst = TclGetStringStorage(objPtr, &size) + numBytes;
dstLimit = size - numBytes;
} else {
dst = TclGetString(objPtr) + numBytes;
}
|
| ︙ | ︙ | |||
6200 6201 6202 6203 6204 6205 6206 |
{
/*
* 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.
*/
| | | 6223 6224 6225 6226 6227 6228 6229 6230 6231 6232 6233 6234 6235 6236 6237 |
{
/*
* 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);
statePtr->flags = savedFlags;
statePtr->inputEncodingFlags = savedIEFlags;
statePtr->inputEncodingState = savedState;
continue;
}
}
|
| ︙ | ︙ | |||
6225 6226 6227 6228 6229 6230 6231 | /* * 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. */ | | | 6248 6249 6250 6251 6252 6253 6254 6255 6256 6257 6258 6259 6260 6261 6262 | /* * 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); statePtr->flags = savedFlags; statePtr->inputEncodingFlags = savedIEFlags; statePtr->inputEncodingState = savedState; continue; } assert(dstWrote == 0); |
| ︙ | ︙ | |||
6318 6319 6320 6321 6322 6323 6324 | * 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! */ | | | 6341 6342 6343 6344 6345 6346 6347 6348 6349 6350 6351 6352 6353 6354 6355 |
* 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!
*/
dstLimit = Tcl_UtfAtIndex(dst, charsToRead) - dst + (TCL_UTF_MAX - 1);
statePtr->flags = savedFlags;
statePtr->inputEncodingFlags = savedIEFlags;
statePtr->inputEncodingState = savedState;
continue;
}
if (dstWrote == 0) {
|
| ︙ | ︙ | |||
6386 6387 6388 6389 6390 6391 6392 |
*/
if (nextPtr->nextRemoved - srcLen < 0) {
Tcl_Panic("Buffer Underflow, BUFFER_PADDING not enough");
}
nextPtr->nextRemoved -= srcLen;
| | | 6409 6410 6411 6412 6413 6414 6415 6416 6417 6418 6419 6420 6421 6422 6423 |
*/
if (nextPtr->nextRemoved - srcLen < 0) {
Tcl_Panic("Buffer Underflow, BUFFER_PADDING not enough");
}
nextPtr->nextRemoved -= srcLen;
memcpy(RemovePoint(nextPtr), src, srcLen);
RecycleBuffer(statePtr, bufPtr, 0);
statePtr->inQueueHead = nextPtr;
Tcl_SetObjLength(objPtr, numBytes);
return ReadChars(statePtr, objPtr, charsToRead, factorPtr);
}
statePtr->inputEncodingFlags &= ~TCL_ENCODING_START;
|
| ︙ | ︙ | |||
6492 6493 6494 6495 6496 6497 6498 |
}
}
switch (statePtr->inputTranslation) {
case TCL_TRANSLATE_LF:
case TCL_TRANSLATE_CR:
if (dstStart != srcStart) {
| | | 6515 6516 6517 6518 6519 6520 6521 6522 6523 6524 6525 6526 6527 6528 6529 |
}
}
switch (statePtr->inputTranslation) {
case TCL_TRANSLATE_LF:
case TCL_TRANSLATE_CR:
if (dstStart != srcStart) {
memcpy(dstStart, srcStart, srcLen);
}
if (statePtr->inputTranslation == TCL_TRANSLATE_CR) {
char *dst = dstStart;
char *dstEnd = dstStart + srcLen;
while ((dst = memchr(dst, '\r', dstEnd - dst))) {
*dst++ = '\n';
|
| ︙ | ︙ | |||
6596 6597 6598 6599 6600 6601 6602 | * * Tcl_Ungets -- * * Causes the supplied string to be added to the input queue of the * channel, at either the head or tail of the queue. * * Results: | | | | | 6619 6620 6621 6622 6623 6624 6625 6626 6627 6628 6629 6630 6631 6632 6633 6634 6635 6636 6637 6638 6639 6640 6641 6642 6643 6644 6645 |
*
* Tcl_Ungets --
*
* Causes the supplied string to be added to the input queue of the
* channel, at either the head or tail of the queue.
*
* Results:
* The number of bytes stored in the channel, or TCL_IO_FAILURE on error.
*
* Side effects:
* Adds input to the input queue of a channel.
*
*----------------------------------------------------------------------
*/
size_t
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 atEnd) /* If non-zero, add at end of queue; otherwise
* add at head of queue. */
{
Channel *chanPtr; /* The real IO channel. */
ChannelState *statePtr; /* State of actual channel. */
ChannelBuffer *bufPtr; /* Buffer to contain the data. */
int flags;
|
| ︙ | ︙ | |||
6632 6633 6634 6635 6636 6637 6638 |
/*
* CheckChannelErrors clears too many flag bits in this one case.
*/
flags = statePtr->flags;
if (CheckChannelErrors(statePtr, TCL_READABLE) != 0) {
| | | | 6655 6656 6657 6658 6659 6660 6661 6662 6663 6664 6665 6666 6667 6668 6669 6670 6671 6672 6673 6674 6675 6676 6677 6678 6679 6680 6681 6682 6683 6684 6685 6686 |
/*
* CheckChannelErrors clears too many flag bits in this one case.
*/
flags = statePtr->flags;
if (CheckChannelErrors(statePtr, TCL_READABLE) != 0) {
len = TCL_IO_FAILURE;
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);
bufPtr->nextAdded += len;
if (statePtr->inQueueHead == NULL) {
bufPtr->nextPtr = NULL;
statePtr->inQueueHead = bufPtr;
statePtr->inQueueTail = bufPtr;
} else if (atEnd) {
|
| ︙ | ︙ | |||
6949 6950 6951 6952 6953 6954 6955 |
int result; /* Of device driver operations. */
Tcl_WideInt curPos; /* Position on the device. */
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) {
| | | | | | 6972 6973 6974 6975 6976 6977 6978 6979 6980 6981 6982 6983 6984 6985 6986 6987 6988 6989 6990 6991 6992 6993 6994 6995 6996 6997 6998 6999 7000 7001 7002 7003 7004 7005 7006 7007 7008 7009 7010 7011 7012 7013 7014 7015 7016 7017 7018 7019 7020 7021 7022 7023 7024 7025 7026 |
int result; /* Of device driver operations. */
Tcl_WideInt curPos; /* Position on the device. */
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;
}
/*
* Disallow seek on dead channels - channels that have been closed but not
* yet been deallocated. Such channels can be found if the exit handler
* for channel cleanup has run but the channel is still registered in an
* interpreter.
*/
if (CheckForDeadChannel(NULL, statePtr)) {
return -1;
}
/*
* This operation should occur at the top of a channel stack.
*/
chanPtr = statePtr->topChanPtr;
/*
* Disallow seek on channels whose type does not have a seek procedure
* defined. This means that the channel does not support seeking.
*/
if (chanPtr->typePtr->seekProc == NULL) {
Tcl_SetErrno(EINVAL);
return -1;
}
/*
* Compute how much input and output is buffered. If both input and output
* is buffered, cannot compute the current position.
*/
inputBuffered = Tcl_InputBuffered(chan);
outputBuffered = Tcl_OutputBuffered(chan);
if ((inputBuffered != 0) && (outputBuffered != 0)) {
Tcl_SetErrno(EFAULT);
return -1;
}
/*
* If we are seeking relative to the current position, compute the
* corrected offset taking into account the amount of unread input.
*/
|
| ︙ | ︙ | |||
7032 7033 7034 7035 7036 7037 7038 |
*/
wasAsync = 0;
if (GotFlag(statePtr, CHANNEL_NONBLOCKING)) {
wasAsync = 1;
result = StackSetBlockMode(chanPtr, TCL_MODE_BLOCKING);
if (result != 0) {
| | | 7055 7056 7057 7058 7059 7060 7061 7062 7063 7064 7065 7066 7067 7068 7069 |
*/
wasAsync = 0;
if (GotFlag(statePtr, CHANNEL_NONBLOCKING)) {
wasAsync = 1;
result = StackSetBlockMode(chanPtr, TCL_MODE_BLOCKING);
if (result != 0) {
return -1;
}
ResetFlag(statePtr, CHANNEL_NONBLOCKING);
if (GotFlag(statePtr, BG_FLUSH_SCHEDULED)) {
ResetFlag(statePtr, BG_FLUSH_SCHEDULED);
}
}
|
| ︙ | ︙ | |||
7057 7058 7059 7060 7061 7062 7063 |
} else {
/*
* Now seek to the new position in the channel as requested by the
* caller.
*/
curPos = ChanSeek(chanPtr, offset, mode, &result);
| | | | 7080 7081 7082 7083 7084 7085 7086 7087 7088 7089 7090 7091 7092 7093 7094 7095 7096 7097 7098 7099 7100 7101 7102 7103 7104 7105 7106 7107 7108 7109 7110 |
} else {
/*
* Now seek to the new position in the channel as requested by the
* caller.
*/
curPos = ChanSeek(chanPtr, offset, mode, &result);
if (curPos == -1) {
Tcl_SetErrno(result);
}
}
/*
* Restore to nonblocking mode if that was the previous behavior.
*
* NOTE: Even if there was an async flush active we do not restore it now
* because we already flushed all the queued output, above.
*/
if (wasAsync) {
SetFlag(statePtr, CHANNEL_NONBLOCKING);
result = StackSetBlockMode(chanPtr, TCL_MODE_NONBLOCKING);
if (result != 0) {
return -1;
}
}
return curPos;
}
/*
|
| ︙ | ︙ | |||
7113 7114 7115 7116 7117 7118 7119 |
/* State info for channel */
int inputBuffered, outputBuffered;
/* # bytes held in buffers. */
int result; /* Of calling device driver. */
Tcl_WideInt curPos; /* Position on device. */
if (CheckChannelErrors(statePtr, TCL_WRITABLE | TCL_READABLE) != 0) {
| | | | | | | | 7136 7137 7138 7139 7140 7141 7142 7143 7144 7145 7146 7147 7148 7149 7150 7151 7152 7153 7154 7155 7156 7157 7158 7159 7160 7161 7162 7163 7164 7165 7166 7167 7168 7169 7170 7171 7172 7173 7174 7175 7176 7177 7178 7179 7180 7181 7182 7183 7184 7185 7186 7187 7188 7189 7190 7191 7192 7193 7194 7195 7196 7197 |
/* State info for channel */
int inputBuffered, outputBuffered;
/* # 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;
}
/*
* Disallow tell on dead channels -- channels that have been closed but
* not yet been deallocated. Such channels can be found if the exit
* handler for channel cleanup has run but the channel is still registered
* in an interpreter.
*/
if (CheckForDeadChannel(NULL, statePtr)) {
return -1;
}
/*
* This operation should occur at the top of a channel stack.
*/
chanPtr = statePtr->topChanPtr;
/*
* Disallow tell on channels whose type does not have a seek procedure
* defined. This means that the channel does not support seeking.
*/
if (chanPtr->typePtr->seekProc == NULL) {
Tcl_SetErrno(EINVAL);
return -1;
}
/*
* Compute how much input and output is buffered. If both input and output
* is buffered, cannot compute the current position.
*/
inputBuffered = Tcl_InputBuffered(chan);
outputBuffered = Tcl_OutputBuffered(chan);
/*
* 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) {
Tcl_SetErrno(result);
return -1;
}
if (inputBuffered != 0) {
return curPos - inputBuffered;
}
return curPos + outputBuffered;
}
|
| ︙ | ︙ | |||
7224 7225 7226 7227 7228 7229 7230 |
/*
* Seek first to force a total flush of all pending buffers and ditch any
* pre-read input data.
*/
WillWrite(chanPtr);
| | | 7247 7248 7249 7250 7251 7252 7253 7254 7255 7256 7257 7258 7259 7260 7261 |
/*
* Seek first to force a total flush of all pending buffers and ditch any
* pre-read input data.
*/
WillWrite(chanPtr);
if (WillRead(chanPtr) == -1) {
return TCL_ERROR;
}
/*
* We're all flushed to disk now and we also don't have any unfortunate
* input baggage around either; can truncate with impunity.
*/
|
| ︙ | ︙ | |||
7652 7653 7654 7655 7656 7657 7658 |
argc--;
for (i = 0; i < argc; i++) {
Tcl_AppendPrintfToObj(errObj, "-%s, ", argv[i]);
}
Tcl_AppendPrintfToObj(errObj, "or -%s", argv[i]);
Tcl_SetObjResult(interp, errObj);
Tcl_DStringFree(&ds);
| | | 7675 7676 7677 7678 7679 7680 7681 7682 7683 7684 7685 7686 7687 7688 7689 |
argc--;
for (i = 0; i < argc; i++) {
Tcl_AppendPrintfToObj(errObj, "-%s, ", argv[i]);
}
Tcl_AppendPrintfToObj(errObj, "or -%s", argv[i]);
Tcl_SetObjResult(interp, errObj);
Tcl_DStringFree(&ds);
Tcl_Free((void *)argv);
}
Tcl_SetErrno(EINVAL);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
8043 8044 8045 8046 8047 8048 8049 |
if (inValue & 0x80 || outValue & 0x80) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad value for -eofchar: must be non-NUL ASCII"
" character", -1));
}
| | | | | 8066 8067 8068 8069 8070 8071 8072 8073 8074 8075 8076 8077 8078 8079 8080 8081 8082 8083 8084 8085 8086 8087 8088 8089 8090 8091 8092 8093 8094 8095 8096 8097 8098 8099 |
if (inValue & 0x80 || outValue & 0x80) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad value for -eofchar: must be non-NUL ASCII"
" character", -1));
}
Tcl_Free((void *)argv);
return TCL_ERROR;
}
if (GotFlag(statePtr, TCL_READABLE)) {
statePtr->inEofChar = inValue;
}
if (GotFlag(statePtr, TCL_WRITABLE)) {
statePtr->outEofChar = outValue;
}
} else {
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad value for -eofchar: should be a list of zero,"
" one, or two elements", -1));
}
Tcl_Free((void *)argv);
return TCL_ERROR;
}
if (argv != NULL) {
Tcl_Free((void *)argv);
}
/*
* [Bug 930851] Reset EOF and BLOCKED flags. Changing the character
* which signals eof can transform a current eof condition into a 'go
* ahead'. Ditto for blocked.
*/
|
| ︙ | ︙ | |||
8096 8097 8098 8099 8100 8101 8102 |
writeMode = GotFlag(statePtr, TCL_WRITABLE) ? argv[1] : NULL;
} else {
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad value for -translation: must be a one or two"
" element list", -1));
}
| | | 8119 8120 8121 8122 8123 8124 8125 8126 8127 8128 8129 8130 8131 8132 8133 |
writeMode = GotFlag(statePtr, TCL_WRITABLE) ? argv[1] : NULL;
} else {
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad value for -translation: must be a one or two"
" element list", -1));
}
Tcl_Free((void *)argv);
return TCL_ERROR;
}
if (readMode) {
TclEolTranslation translation;
if (*readMode == '\0') {
|
| ︙ | ︙ | |||
8126 8127 8128 8129 8130 8131 8132 |
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));
}
| | | 8149 8150 8151 8152 8153 8154 8155 8156 8157 8158 8159 8160 8161 8162 8163 |
translation = TCL_PLATFORM_TRANSLATION;
} else {
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad value for -translation: must be one of "
"auto, binary, cr, lf, crlf, or platform", -1));
}
Tcl_Free((void *)argv);
return TCL_ERROR;
}
/*
* Reset the EOL flags since we need to look at any buffered data
* to see if the new translation mode allows us to complete the
* line.
|
| ︙ | ︙ | |||
8176 8177 8178 8179 8180 8181 8182 |
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));
}
| | | | 8199 8200 8201 8202 8203 8204 8205 8206 8207 8208 8209 8210 8211 8212 8213 8214 8215 8216 8217 |
statePtr->outputTranslation = TCL_PLATFORM_TRANSLATION;
} else {
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad value for -translation: must be one of "
"auto, binary, cr, lf, crlf, or platform", -1));
}
Tcl_Free((void *)argv);
return TCL_ERROR;
}
}
Tcl_Free((void *)argv);
return TCL_OK;
} else if (chanPtr->typePtr->setOptionProc != NULL) {
return chanPtr->typePtr->setOptionProc(chanPtr->instanceData, interp,
optionName, newValue);
} else {
return Tcl_BadChannelOption(interp, optionName, NULL);
}
|
| ︙ | ︙ | |||
8239 8240 8241 8242 8243 8244 8245 | prevPtr->nextPtr = nextPtr; } Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr, TclChannelEventScriptInvoker, sPtr); TclDecrRefCount(sPtr->scriptPtr); | | | 8262 8263 8264 8265 8266 8267 8268 8269 8270 8271 8272 8273 8274 8275 8276 |
prevPtr->nextPtr = nextPtr;
}
Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr,
TclChannelEventScriptInvoker, sPtr);
TclDecrRefCount(sPtr->scriptPtr);
Tcl_Free(sPtr);
} else {
prevPtr = sPtr;
}
}
}
/*
|
| ︙ | ︙ | |||
8459 8460 8461 8462 8463 8464 8465 | * - It does not process all events in the event queue, but only * one, at least in some situations. * * 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. | | | | 8482 8483 8484 8485 8486 8487 8488 8489 8490 8491 8492 8493 8494 8495 8496 8497 8498 | * - It does not process all events in the event queue, but only * one, at least in some situations. * * 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. * - The OS still reports the EXCEPTION condition on the file. * - And the extension gets the EXCEPTION 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 * (and at the C-level, deep in the bowels of Expect, * 'exp_get_next_event'. See marker 'SunOS' for commentary in |
| ︙ | ︙ | |||
8487 8488 8489 8490 8491 8492 8493 8494 8495 8496 8497 8498 8499 8500 |
if (!statePtr->timer) {
statePtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME,
ChannelTimerProc, chanPtr);
}
}
}
ChanWatch(chanPtr, mask);
}
/*
*----------------------------------------------------------------------
*
* ChannelTimerProc --
| > > > > > > > > > > | 8510 8511 8512 8513 8514 8515 8516 8517 8518 8519 8520 8521 8522 8523 8524 8525 8526 8527 8528 8529 8530 8531 8532 8533 |
if (!statePtr->timer) {
statePtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME,
ChannelTimerProc, chanPtr);
}
}
}
if (!statePtr->timer
&& mask & TCL_WRITABLE
&& GotFlag(statePtr, CHANNEL_NONBLOCKING)) {
statePtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME,
ChannelTimerProc,chanPtr);
}
ChanWatch(chanPtr, mask);
}
/*
*----------------------------------------------------------------------
*
* ChannelTimerProc --
|
| ︙ | ︙ | |||
8514 8515 8516 8517 8518 8519 8520 8521 8522 8523 8524 8525 8526 8527 8528 8529 8530 8531 8532 |
static void
ChannelTimerProc(
ClientData clientData)
{
Channel *chanPtr = clientData;
ChannelState *statePtr = chanPtr->state;
/* State info for channel */
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);
| > > > > > > > > > > > > > > > < < < > | 8547 8548 8549 8550 8551 8552 8553 8554 8555 8556 8557 8558 8559 8560 8561 8562 8563 8564 8565 8566 8567 8568 8569 8570 8571 8572 8573 8574 8575 8576 8577 8578 8579 8580 8581 8582 8583 8584 8585 8586 8587 8588 8589 8590 8591 8592 |
static void
ChannelTimerProc(
ClientData 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);
Tcl_NotifyChannel((Tcl_Channel) chanPtr, TCL_READABLE);
} else {
UpdateInterest(chanPtr);
}
Tcl_Release(statePtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_CreateChannelHandler --
*
|
| ︙ | ︙ | |||
8586 8587 8588 8589 8590 8591 8592 |
for (chPtr = statePtr->chPtr; chPtr != NULL; chPtr = chPtr->nextPtr) {
if ((chPtr->chanPtr == chanPtr) && (chPtr->proc == proc) &&
(chPtr->clientData == clientData)) {
break;
}
}
if (chPtr == NULL) {
| | | 8632 8633 8634 8635 8636 8637 8638 8639 8640 8641 8642 8643 8644 8645 8646 |
for (chPtr = statePtr->chPtr; chPtr != NULL; chPtr = chPtr->nextPtr) {
if ((chPtr->chanPtr == chanPtr) && (chPtr->proc == proc) &&
(chPtr->clientData == clientData)) {
break;
}
}
if (chPtr == NULL) {
chPtr = Tcl_Alloc(sizeof(ChannelHandler));
chPtr->mask = 0;
chPtr->proc = proc;
chPtr->clientData = clientData;
chPtr->chanPtr = chanPtr;
chPtr->nextPtr = statePtr->chPtr;
statePtr->chPtr = chPtr;
}
|
| ︙ | ︙ | |||
8690 8691 8692 8693 8694 8695 8696 |
*/
if (prevChPtr == NULL) {
statePtr->chPtr = chPtr->nextPtr;
} else {
prevChPtr->nextPtr = chPtr->nextPtr;
}
| | | 8736 8737 8738 8739 8740 8741 8742 8743 8744 8745 8746 8747 8748 8749 8750 |
*/
if (prevChPtr == NULL) {
statePtr->chPtr = chPtr->nextPtr;
} else {
prevChPtr->nextPtr = chPtr->nextPtr;
}
Tcl_Free(chPtr);
/*
* Recompute the interest list for the channel, so that infinite loops
* will not result if Tcl_DeleteChannelHandler is called inside an event.
*/
statePtr->interestMask = 0;
|
| ︙ | ︙ | |||
8749 8750 8751 8752 8753 8754 8755 | prevEsPtr->nextPtr = esPtr->nextPtr; } Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr, TclChannelEventScriptInvoker, esPtr); TclDecrRefCount(esPtr->scriptPtr); | | | 8795 8796 8797 8798 8799 8800 8801 8802 8803 8804 8805 8806 8807 8808 8809 |
prevEsPtr->nextPtr = esPtr->nextPtr;
}
Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr,
TclChannelEventScriptInvoker, esPtr);
TclDecrRefCount(esPtr->scriptPtr);
Tcl_Free(esPtr);
break;
}
}
}
/*
|
| ︙ | ︙ | |||
8798 8799 8800 8801 8802 8803 8804 |
break;
}
}
makeCH = (esPtr == NULL);
if (makeCH) {
| | | 8844 8845 8846 8847 8848 8849 8850 8851 8852 8853 8854 8855 8856 8857 8858 |
break;
}
}
makeCH = (esPtr == NULL);
if (makeCH) {
esPtr = Tcl_Alloc(sizeof(EventScriptRecord));
}
/*
* Initialize the structure before calling Tcl_CreateChannelHandler,
* because a reflected channel calling 'chan postevent' aka
* 'Tcl_NotifyChannel' in its 'watch'Proc will invoke
* 'TclChannelEventScriptInvoker' immediately, and we do not wish it to
|
| ︙ | ︙ | |||
9114 9115 9116 9117 9118 9119 9120 |
/*
* Allocate a new CopyState to maintain info about the current copy in
* progress. This structure will be deallocated when the copy is
* completed.
*/
| | | 9160 9161 9162 9163 9164 9165 9166 9167 9168 9169 9170 9171 9172 9173 9174 |
/*
* Allocate a new CopyState to maintain info about the current copy in
* progress. This structure will be deallocated when the copy is
* completed.
*/
csPtr = Tcl_Alloc(sizeof(CopyState) + !moveBytes * inStatePtr->bufSize);
csPtr->bufSize = !moveBytes * inStatePtr->bufSize;
csPtr->readPtr = inPtr;
csPtr->writePtr = outPtr;
csPtr->readFlags = readFlags;
csPtr->writeFlags = writeFlags;
csPtr->toRead = toRead;
csPtr->total = (Tcl_WideInt) 0;
|
| ︙ | ︙ | |||
9408 9409 9410 9411 9412 9413 9414 |
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;
| | > | 9454 9455 9456 9457 9458 9459 9460 9461 9462 9463 9464 9465 9466 9467 9468 9469 |
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;
Tcl_WideInt total;
const char *buffer;
int inBinary, outBinary, sameEncoding;
/* Encoding control */
int underflow; /* Input underflow */
inChan = (Tcl_Channel) csPtr->readPtr;
|
| ︙ | ︙ | |||
9474 9475 9476 9477 9478 9479 9480 |
* Read up to bufSize bytes.
*/
if ((csPtr->toRead == (Tcl_WideInt) -1)
|| (csPtr->toRead > (Tcl_WideInt) csPtr->bufSize)) {
sizeb = csPtr->bufSize;
} else {
| | | | 9521 9522 9523 9524 9525 9526 9527 9528 9529 9530 9531 9532 9533 9534 9535 9536 9537 9538 9539 9540 9541 9542 9543 9544 9545 |
* Read up to bufSize bytes.
*/
if ((csPtr->toRead == (Tcl_WideInt) -1)
|| (csPtr->toRead > (Tcl_WideInt) csPtr->bufSize)) {
sizeb = csPtr->bufSize;
} else {
sizeb = csPtr->toRead;
}
if (inBinary || sameEncoding) {
size = DoRead(inStatePtr->topChanPtr, csPtr->buffer, sizeb,
!GotFlag(inStatePtr, CHANNEL_NONBLOCKING));
} else {
size = DoReadChars(inStatePtr->topChanPtr, bufObj, sizeb,
0 /* No append */);
}
underflow = (size >= 0) && ((size_t)size < sizeb); /* Input underflow */
}
if (size < 0) {
readError:
if (interp) {
TclNewObj(errObj);
Tcl_AppendStringsToObj(errObj, "error reading \"",
|
| ︙ | ︙ | |||
9568 9569 9570 9571 9572 9573 9574 | * bytes or characters, and both EOL translation and encoding * conversion may have changed this number unpredictably in relation * to 'size' (It can be smaller or larger, in the latter case able to * drive toRead below -1, causing infinite looping). Completely * unsuitable for updating totals and toRead. */ | | | 9615 9616 9617 9618 9619 9620 9621 9622 9623 9624 9625 9626 9627 9628 9629 |
* bytes or characters, and both EOL translation and encoding
* conversion may have changed this number unpredictably in relation
* to 'size' (It can be smaller or larger, in the latter case able to
* drive toRead below -1, causing infinite looping). Completely
* unsuitable for updating totals and toRead.
*/
if (sizeb == TCL_AUTO_LENGTH) {
writeError:
if (interp) {
TclNewObj(errObj);
Tcl_AppendStringsToObj(errObj, "error writing \"",
Tcl_GetChannelName(outChan), "\": ", NULL);
if (msg != NULL) {
Tcl_AppendObjToObj(errObj, msg);
|
| ︙ | ︙ | |||
9736 9737 9738 9739 9740 9741 9742 |
*----------------------------------------------------------------------
*/
static int
DoRead(
Channel *chanPtr, /* The channel from which to read. */
char *dst, /* Where to store input read. */
| | < < | 9783 9784 9785 9786 9787 9788 9789 9790 9791 9792 9793 9794 9795 9796 9797 9798 9799 9800 9801 9802 |
*----------------------------------------------------------------------
*/
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) */
{
ChannelState *statePtr = chanPtr->state;
char *p = dst;
/*
* Early out when we know a read will get the eofchar.
*
* NOTE: This seems to be a bug. The special handling for
* a zero-char read request ought to come first. As coded
* the EOF due to eofchar has distinguishing behavior from
* the EOF due to reported EOF on the underlying device, and
|
| ︙ | ︙ | |||
9797 9798 9799 9800 9801 9802 9803 | /* * 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 */ | | | 9842 9843 9844 9845 9846 9847 9848 9849 9850 9851 9852 9853 9854 9855 9856 |
/*
* 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 */
int code;
moreData:
code = GetInput(chanPtr);
bufPtr = statePtr->inQueueHead;
|
| ︙ | ︙ | |||
10041 10042 10043 10044 10045 10046 10047 |
}
Tcl_DeleteChannelHandler(inChan, MBEvent, csPtr);
Tcl_DeleteChannelHandler(outChan, MBEvent, csPtr);
TclDecrRefCount(csPtr->cmdPtr);
}
inStatePtr->csPtrR = NULL;
outStatePtr->csPtrW = NULL;
| | | 10086 10087 10088 10089 10090 10091 10092 10093 10094 10095 10096 10097 10098 10099 10100 |
}
Tcl_DeleteChannelHandler(inChan, MBEvent, csPtr);
Tcl_DeleteChannelHandler(outChan, MBEvent, csPtr);
TclDecrRefCount(csPtr->cmdPtr);
}
inStatePtr->csPtrR = NULL;
outStatePtr->csPtrW = NULL;
Tcl_Free(csPtr);
}
/*
*----------------------------------------------------------------------
*
* StackSetBlockMode --
*
|
| ︙ | ︙ | |||
10343 10344 10345 10346 10347 10348 10349 |
int
Tcl_IsChannelShared(
Tcl_Channel chan) /* The channel to query */
{
ChannelState *statePtr = ((Channel *) chan)->state;
/* State of real channel structure. */
| | | 10388 10389 10390 10391 10392 10393 10394 10395 10396 10397 10398 10399 10400 10401 10402 |
int
Tcl_IsChannelShared(
Tcl_Channel chan) /* The channel to query */
{
ChannelState *statePtr = ((Channel *) chan)->state;
/* State of real channel structure. */
return ((statePtr->refCount + 1 > 2) ? 1 : 0);
}
/*
*----------------------------------------------------------------------
*
* Tcl_IsChannelExisting --
*
|
| ︙ | ︙ | |||
10387 10388 10389 10390 10391 10392 10393 |
} else if (statePtr->topChanPtr == (Channel *) tsdPtr->stderrChannel) {
name = "stderr";
} else {
name = statePtr->channelName;
}
if ((*chanName == *name) &&
| | | 10432 10433 10434 10435 10436 10437 10438 10439 10440 10441 10442 10443 10444 10445 10446 |
} else if (statePtr->topChanPtr == (Channel *) tsdPtr->stderrChannel) {
name = "stderr";
} else {
name = statePtr->channelName;
}
if ((*chanName == *name) &&
(memcmp(name, chanName, chanNameLen + 1) == 0)) {
return 1;
}
}
return 0;
}
|
| ︙ | ︙ | |||
11014 11015 11016 11017 11018 11019 11020 |
if (newlevel >= 0) {
lcn += 2;
}
if (newcode >= 0) {
lcn += 2;
}
| | | 11059 11060 11061 11062 11063 11064 11065 11066 11067 11068 11069 11070 11071 11072 11073 |
if (newlevel >= 0) {
lcn += 2;
}
if (newcode >= 0) {
lcn += 2;
}
lvn = Tcl_Alloc(lcn * sizeof(Tcl_Obj *));
/*
* New level/code information is spliced into the first occurence of
* -level, -code, further occurences are ignored. The options cannot be
* not present, we would not come here. Options which are ok are simply
* copied over.
*/
|
| ︙ | ︙ | |||
11067 11068 11069 11070 11071 11072 11073 |
if (explicitResult) {
lvn[j++] = lv[i];
}
msg = Tcl_NewListObj(j, lvn);
| | | 11112 11113 11114 11115 11116 11117 11118 11119 11120 11121 11122 11123 11124 11125 11126 |
if (explicitResult) {
lvn[j++] = lv[i];
}
msg = Tcl_NewListObj(j, lvn);
Tcl_Free(lvn);
return msg;
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetChannelErrorInterp --
|
| ︙ | ︙ | |||
11180 11181 11182 11183 11184 11185 11186 |
static void
DupChannelIntRep(
register Tcl_Obj *srcPtr, /* Object with internal rep to copy. Must have
* an internal rep of type "Channel". */
register Tcl_Obj *copyPtr) /* Object with internal rep to set. Must not
* currently have an internal rep.*/
{
| | > | < | | 11225 11226 11227 11228 11229 11230 11231 11232 11233 11234 11235 11236 11237 11238 11239 11240 11241 11242 11243 |
static void
DupChannelIntRep(
register Tcl_Obj *srcPtr, /* Object with internal rep to copy. Must have
* an internal rep of type "Channel". */
register Tcl_Obj *copyPtr) /* Object with internal rep to set. Must not
* currently have an internal rep.*/
{
ResolvedChanName *resPtr;
ChanGetIntRep(srcPtr, resPtr);
assert(resPtr);
ChanSetIntRep(copyPtr, resPtr);
}
/*
*----------------------------------------------------------------------
*
* FreeChannelIntRep --
*
|
| ︙ | ︙ | |||
11207 11208 11209 11210 11211 11212 11213 |
*----------------------------------------------------------------------
*/
static void
FreeChannelIntRep(
Tcl_Obj *objPtr) /* Object with internal rep to free. */
{
| | | > | | 11252 11253 11254 11255 11256 11257 11258 11259 11260 11261 11262 11263 11264 11265 11266 11267 11268 11269 11270 11271 11272 11273 11274 |
*----------------------------------------------------------------------
*/
static void
FreeChannelIntRep(
Tcl_Obj *objPtr) /* Object with internal rep to free. */
{
ResolvedChanName *resPtr;
ChanGetIntRep(objPtr, resPtr);
assert(resPtr);
if (resPtr->refCount-- > 1) {
return;
}
Tcl_Release(resPtr->statePtr);
Tcl_Free(resPtr);
}
#if 0
/*
* For future debugging work, a simple function to print the flags of a
* channel in semi-readable form.
*/
|
| ︙ | ︙ |
Changes to generic/tclIO.h.
| ︙ | ︙ | |||
32 33 34 35 36 37 38 |
/*
* struct ChannelBuffer:
*
* Buffers data being sent to or from a channel.
*/
typedef struct ChannelBuffer {
| | | | 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 |
/*
* struct ChannelBuffer:
*
* Buffers data being sent to or from a channel.
*/
typedef struct ChannelBuffer {
size_t 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[1]; /* Placeholder for real buffer. The real
* buffer occuppies this space + bufSize-1
* bytes. This must be the last field in the
* structure. */
} ChannelBuffer;
#define CHANNELBUFFER_HEADER_SIZE offsetof(ChannelBuffer, buf)
/*
* 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).
*/
|
| ︙ | ︙ | |||
92 93 94 95 96 97 98 |
* data specific to the channel but which belongs to the generic part of the
* Tcl channel mechanism, and it points at an instance specific (and type
* specific) instance data, and at a channel type structure.
*/
typedef struct Channel {
struct ChannelState *state; /* Split out state information */
| | | | 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 |
* data specific to the channel but which belongs to the generic part of the
* Tcl channel mechanism, and it points at an instance specific (and type
* specific) instance data, and at a channel type structure.
*/
typedef struct Channel {
struct ChannelState *state; /* Split out state information */
void *instanceData; /* Instance-specific data provided by creator
* of channel. */
const Tcl_ChannelType *typePtr; /* Pointer to channel type structure. */
struct Channel *downChanPtr;/* Refers to channel this one was stacked
* upon. This reference is NULL for normal
* channels. See Tcl_StackChannel. */
struct Channel *upChanPtr; /* Refers to the channel above stacked this
* one. NULL for the top most channel. */
/*
* Intermediate buffers to hold pre-read data for consumption by a newly
* stacked transformation. See 'Tcl_StackChannel'.
*/
ChannelBuffer *inQueueHead; /* Points at first buffer in input queue. */
ChannelBuffer *inQueueTail; /* Points at last buffer in input queue. */
size_t refCount;
} Channel;
/*
* struct ChannelState:
*
* One of these structures is allocated for each open channel. It contains
* data specific to the channel but which belongs to the generic part of the
|
| ︙ | ︙ | |||
159 160 161 162 163 164 165 |
int inEofChar; /* If nonzero, use this as a signal of EOF on
* input. */
int outEofChar; /* If nonzero, append this to the channel when
* it is closed if it is open for writing. */
int unreportedError; /* Non-zero if an error report was deferred
* because it happened in the background. The
* value is the POSIX error code. */
| | | 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 |
int inEofChar; /* If nonzero, use this as a signal of EOF on
* input. */
int outEofChar; /* If nonzero, append this to the channel when
* it is closed if it is open for writing. */
int unreportedError; /* Non-zero if an error report was deferred
* because it happened in the background. The
* value is the POSIX error code. */
size_t refCount; /* How many interpreters hold references to
* this IO channel? */
struct CloseCallback *closeCbPtr;
/* Callbacks registered to be called when the
* channel is closed. */
char *outputStage; /* Temporary staging buffer used when
* translating EOL before converting from
* UTF-8 to external form. */
|
| ︙ | ︙ |
Changes to generic/tclIOCmd.c.
| ︙ | ︙ | |||
164 165 166 167 168 169 170 |
"channel \"%s\" wasn't opened for writing",
TclGetString(chanObjPtr)));
return TCL_ERROR;
}
TclChannelPreserve(chan);
result = Tcl_WriteObj(chan, string);
| | | | 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 |
"channel \"%s\" wasn't opened for writing",
TclGetString(chanObjPtr)));
return TCL_ERROR;
}
TclChannelPreserve(chan);
result = Tcl_WriteObj(chan, string);
if (result == -1) {
goto error;
}
if (newline != 0) {
result = Tcl_WriteChars(chan, "\n", 1);
if (result == -1) {
goto error;
}
}
TclChannelRelease(chan);
return TCL_OK;
/*
|
| ︙ | ︙ | |||
458 459 460 461 462 463 464 |
/*
* If requested, remove the last newline in the channel if at EOF.
*/
if ((charactersRead > 0) && (newline != 0)) {
const char *result;
| | | 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 |
/*
* If requested, remove the last newline in the channel if at EOF.
*/
if ((charactersRead > 0) && (newline != 0)) {
const char *result;
size_t length;
result = TclGetStringFromObj(resultPtr, &length);
if (result[length - 1] == '\n') {
Tcl_SetObjLength(resultPtr, length - 1);
}
}
Tcl_SetObjResult(interp, resultPtr);
|
| ︙ | ︙ | |||
528 529 530 531 532 533 534 |
return TCL_ERROR;
}
mode = modeArray[optionIndex];
}
TclChannelPreserve(chan);
result = Tcl_Seek(chan, offset, mode);
| | | 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 |
return TCL_ERROR;
}
mode = modeArray[optionIndex];
}
TclChannelPreserve(chan);
result = Tcl_Seek(chan, offset, mode);
if (result == -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.
*/
|
| ︙ | ︙ | |||
704 705 706 707 708 709 710 | * messages produced by drivers during the closing of a channel, * because the Tcl convention is that such error messages do not have * a terminating newline. */ Tcl_Obj *resultPtr = Tcl_GetObjResult(interp); const char *string; | | | 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 |
* messages produced by drivers during the closing of a channel,
* because the Tcl convention is that such error messages do not have
* a terminating newline.
*/
Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
const char *string;
size_t len;
if (Tcl_IsShared(resultPtr)) {
resultPtr = Tcl_DuplicateObj(resultPtr);
Tcl_SetObjResult(interp, resultPtr);
}
string = TclGetStringFromObj(resultPtr, &len);
if ((len > 0) && (string[len - 1] == '\n')) {
|
| ︙ | ︙ | |||
866 867 868 869 870 871 872 |
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *resultPtr;
const char **argv; /* An array for the string arguments. Stored
* on the _Tcl_ stack. */
const char *string;
Tcl_Channel chan;
| | | | 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 |
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *resultPtr;
const char **argv; /* An array for the string arguments. Stored
* on the _Tcl_ stack. */
const char *string;
Tcl_Channel chan;
int argc, background, i, index, keepNewline, result, skip, ignoreStderr;
size_t length;
static const char *const options[] = {
"-ignorestderr", "-keepnewline", "--", NULL
};
enum options {
EXEC_IGNORESTDERR, EXEC_KEEPNEWLINE, EXEC_LAST
};
|
| ︙ | ︙ | |||
921 922 923 924 925 926 927 |
/*
* Create the string argument array "argv". Make sure argv is large enough
* to hold the argc arguments plus 1 extra for the zero end-of-argv word.
*/
argc = objc - skip;
| | | 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 |
/*
* 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 = TclStackAlloc(interp, (argc + 1) * sizeof(char *));
/*
* Copy the string conversions of each (post option) object into the
* argument vector.
*/
for (i = 0; i < argc; i++) {
|
| ︙ | ︙ | |||
960 961 962 963 964 965 966 |
return TCL_ERROR;
}
return TCL_OK;
}
resultPtr = Tcl_NewObj();
if (Tcl_GetChannelHandle(chan, TCL_READABLE, NULL) == TCL_OK) {
| | | 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 |
return TCL_ERROR;
}
return TCL_OK;
}
resultPtr = Tcl_NewObj();
if (Tcl_GetChannelHandle(chan, TCL_READABLE, NULL) == TCL_OK) {
if (Tcl_ReadChars(chan, resultPtr, -1, 0) == TCL_IO_FAILURE) {
/*
* TIP #219.
* Capture error messages put by the driver into the bypass area
* and put them into the regular interpreter result. Fall back to
* the regular message if nothing was found in the bypass.
*/
|
| ︙ | ︙ | |||
1161 1162 1163 1164 1165 1166 1167 |
break;
}
chan = Tcl_OpenCommandChannel(interp, cmdObjc, cmdArgv, flags);
if (binary && chan) {
Tcl_SetChannelOption(interp, chan, "-translation", "binary");
}
}
| | | 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 |
break;
}
chan = Tcl_OpenCommandChannel(interp, cmdObjc, cmdArgv, flags);
if (binary && chan) {
Tcl_SetChannelOption(interp, chan, "-translation", "binary");
}
}
Tcl_Free((void *)cmdArgv);
}
if (chan == NULL) {
return TCL_ERROR;
}
Tcl_RegisterChannel(interp, chan);
Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_GetChannelName(chan), -1));
return TCL_OK;
|
| ︙ | ︙ | |||
1210 1211 1212 1213 1214 1215 1216 |
for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch);
hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) {
AcceptCallback *acceptCallbackPtr = Tcl_GetHashValue(hPtr);
acceptCallbackPtr->interp = NULL;
}
Tcl_DeleteHashTable(hTblPtr);
| | | 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 |
for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch);
hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) {
AcceptCallback *acceptCallbackPtr = Tcl_GetHashValue(hPtr);
acceptCallbackPtr->interp = NULL;
}
Tcl_DeleteHashTable(hTblPtr);
Tcl_Free(hTblPtr);
}
/*
*----------------------------------------------------------------------
*
* RegisterTcpServerInterpCleanup --
*
|
| ︙ | ︙ | |||
1250 1251 1252 1253 1254 1255 1256 |
* deleted. */
Tcl_HashEntry *hPtr; /* Entry for this record. */
int isNew; /* Is the entry new? */
hTblPtr = Tcl_GetAssocData(interp, "tclTCPAcceptCallbacks", NULL);
if (hTblPtr == NULL) {
| | | 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 |
* deleted. */
Tcl_HashEntry *hPtr; /* Entry for this record. */
int isNew; /* Is the entry new? */
hTblPtr = Tcl_GetAssocData(interp, "tclTCPAcceptCallbacks", NULL);
if (hTblPtr == NULL) {
hTblPtr = Tcl_Alloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(hTblPtr, TCL_ONE_WORD_KEYS);
Tcl_SetAssocData(interp, "tclTCPAcceptCallbacks",
TcpAcceptCallbacksDeleteProc, hTblPtr);
}
hPtr = Tcl_CreateHashEntry(hTblPtr, acceptCallbackPtr, &isNew);
if (!isNew) {
|
| ︙ | ︙ | |||
1425 1426 1427 1428 1429 1430 1431 |
/* The actual data. */
if (acceptCallbackPtr->interp != NULL) {
UnregisterTcpServerInterpCleanupProc(acceptCallbackPtr->interp,
acceptCallbackPtr);
}
Tcl_DecrRefCount(acceptCallbackPtr->script);
| | | 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 |
/* The actual data. */
if (acceptCallbackPtr->interp != NULL) {
UnregisterTcpServerInterpCleanupProc(acceptCallbackPtr->interp,
acceptCallbackPtr);
}
Tcl_DecrRefCount(acceptCallbackPtr->script);
Tcl_Free(acceptCallbackPtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_SocketObjCmd --
*
|
| ︙ | ︙ | |||
1472 1473 1474 1475 1476 1477 1478 |
Tcl_Channel chan;
if (TclpHasSockets(interp) != TCL_OK) {
return TCL_ERROR;
}
for (a = 1; a < objc; a++) {
| | | 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 |
Tcl_Channel chan;
if (TclpHasSockets(interp) != TCL_OK) {
return TCL_ERROR;
}
for (a = 1; a < objc; a++) {
const char *arg = TclGetString(objv[a]);
if (arg[0] != '-') {
break;
}
if (Tcl_GetIndexFromObj(interp, objv[a], socketOptions, "option",
TCL_EXACT, &optionIndex) != TCL_OK) {
return TCL_ERROR;
|
| ︙ | ︙ | |||
1621 1622 1623 1624 1625 1626 1627 |
if (a != objc-1) {
goto wrongNumArgs;
}
port = TclGetString(objv[a]);
if (server) {
| | | | 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 |
if (a != objc-1) {
goto wrongNumArgs;
}
port = TclGetString(objv[a]);
if (server) {
AcceptCallback *acceptCallbackPtr = Tcl_Alloc(sizeof(AcceptCallback));
Tcl_IncrRefCount(script);
acceptCallbackPtr->script = script;
acceptCallbackPtr->interp = interp;
chan = Tcl_OpenTcpServerEx(interp, port, host, flags,
AcceptCallbackProc, acceptCallbackPtr);
if (chan == NULL) {
Tcl_DecrRefCount(script);
Tcl_Free(acceptCallbackPtr);
return TCL_ERROR;
}
/*
* Register with the interpreter to let us know when the interpreter
* is deleted (by having the callback set the interp field of the
* acceptCallbackPtr's structure to NULL). This is to avoid trying to
|
| ︙ | ︙ | |||
1882 1883 1884 1885 1886 1887 1888 |
}
} else {
/*
* User wants to truncate to the current file position.
*/
length = Tcl_Tell(chan);
| | | 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 |
}
} 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)));
return TCL_ERROR;
}
}
|
| ︙ | ︙ |
Changes to generic/tclIOGT.c.
| ︙ | ︙ | |||
226 227 228 229 230 231 232 |
TransformChannelData *dataPtr)
{
if (dataPtr->refCount-- > 1) {
return;
}
ResultClear(&dataPtr->result);
Tcl_DecrRefCount(dataPtr->command);
| | | 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 |
TransformChannelData *dataPtr)
{
if (dataPtr->refCount-- > 1) {
return;
}
ResultClear(&dataPtr->result);
Tcl_DecrRefCount(dataPtr->command);
Tcl_Free(dataPtr);
}
/*
*----------------------------------------------------------------------
*
* TclChannelTransform --
*
|
| ︙ | ︙ | |||
283 284 285 286 287 288 289 |
/*
* Now initialize the transformation state and stack it upon the specified
* channel. One of the necessary things to do is to retrieve the blocking
* regime of the underlying channel and to use the same for us too.
*/
| | | 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 |
/*
* 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 = Tcl_Alloc(sizeof(TransformChannelData));
dataPtr->refCount = 1;
Tcl_DStringInit(&ds);
Tcl_GetChannelOption(interp, chan, "-blocking", &ds);
dataPtr->readIsFlushed = 0;
dataPtr->eofPending = 0;
dataPtr->flags = 0;
|
| ︙ | ︙ | |||
374 375 376 377 378 379 380 |
* callback is sent to the underlying channel
* or not. */
int preserve) /* Flag. If true the procedure will preserve
* the result state of all accessed
* interpreters. */
{
Tcl_Obj *resObj; /* See below, switch (transmit). */
| | | 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 |
* callback is sent to the underlying channel
* or not. */
int preserve) /* Flag. If true the procedure will preserve
* the result state of all accessed
* interpreters. */
{
Tcl_Obj *resObj; /* See below, switch (transmit). */
size_t resLen = 0;
unsigned char *resBuf;
Tcl_InterpState state = NULL;
int res = TCL_OK;
Tcl_Obj *command = TclListObjCopy(NULL, dataPtr->command);
Tcl_Interp *eval = dataPtr->interp;
Tcl_Preserve(eval);
|
| ︙ | ︙ | |||
439 440 441 442 443 444 445 |
break;
case TRANSMIT_DOWN:
if (dataPtr->self == NULL) {
break;
}
resObj = Tcl_GetObjResult(eval);
| | | | | 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 |
break;
case TRANSMIT_DOWN:
if (dataPtr->self == NULL) {
break;
}
resObj = Tcl_GetObjResult(eval);
resBuf = TclGetByteArrayFromObj(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);
Tcl_WriteRaw(dataPtr->self, (char *) resBuf, resLen);
break;
case TRANSMIT_IBUF:
resObj = Tcl_GetObjResult(eval);
resBuf = TclGetByteArrayFromObj(resObj, &resLen);
ResultAdd(&dataPtr->result, resBuf, resLen);
break;
case TRANSMIT_NUM:
/*
* Interpret result as integer number.
*/
|
| ︙ | ︙ | |||
906 907 908 909 910 911 912 |
Tcl_Channel parent = Tcl_GetStackedChannel(dataPtr->self);
const Tcl_ChannelType *parentType = Tcl_GetChannelType(parent);
Tcl_DriverSeekProc *parentSeekProc = Tcl_ChannelSeekProc(parentType);
Tcl_DriverWideSeekProc *parentWideSeekProc =
Tcl_ChannelWideSeekProc(parentType);
ClientData parentData = Tcl_GetChannelInstanceData(parent);
| | | < | 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 |
Tcl_Channel parent = Tcl_GetStackedChannel(dataPtr->self);
const 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)) {
/*
* 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);
}
return 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
* request down, unchanged.
*/
|
| ︙ | ︙ | |||
957 958 959 960 961 962 963 |
* 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.
*/
| | | | | | 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 |
* 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 (offset<LONG_MIN || offset>LONG_MAX) {
*errorCodePtr = EOVERFLOW;
return -1;
}
return parentSeekProc(parentData, offset,
mode, errorCodePtr);
}
/*
*----------------------------------------------------------------------
*
* TransformSetOptionProc --
*
|
| ︙ | ︙ | |||
1269 1270 1271 1272 1273 1274 1275 |
static inline void
ResultClear(
ResultBuffer *r) /* Reference to the buffer to clear out. */
{
r->used = 0;
if (r->allocated) {
| | | 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 |
static inline void
ResultClear(
ResultBuffer *r) /* Reference to the buffer to clear out. */
{
r->used = 0;
if (r->allocated) {
Tcl_Free(r->buf);
r->buf = NULL;
r->allocated = 0;
}
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
1413 1414 1415 1416 1417 1418 1419 |
if (r->used + toWrite > r->allocated) {
/*
* Extension of the internal buffer is required.
*/
if (r->allocated == 0) {
r->allocated = toWrite + INCREMENT;
| | | | 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 |
if (r->used + toWrite > r->allocated) {
/*
* Extension of the internal buffer is required.
*/
if (r->allocated == 0) {
r->allocated = toWrite + INCREMENT;
r->buf = Tcl_Alloc(r->allocated);
} else {
r->allocated += toWrite + INCREMENT;
r->buf = Tcl_Realloc(r->buf, r->allocated);
}
}
/*
* Now we may copy the data.
*/
|
| ︙ | ︙ |
Changes to generic/tclIORChan.c.
| ︙ | ︙ | |||
35 36 37 38 39 40 41 | 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); | | > > | 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 |
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 = {
|
| ︙ | ︙ | |||
72 73 74 75 76 77 78 |
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 */
| | | > > > > > > > > > > > < < | < | > | 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 |
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 */
#if TCL_THREADS
ReflectThread, /* thread action, tracking owner */
#else
NULL, /* thread action */
#endif
NULL /* truncate */
};
/*
* Instance data for a reflected channel. ===========================
*/
typedef struct {
Tcl_Channel chan; /* Back reference to generic channel
* structure. */
Tcl_Interp *interp; /* Reference to the interpreter containing the
* Tcl level part of the channel. NULL here
* signals the channel is dead because the
* interpreter/thread containing its Tcl
* command is gone.
*/
#if TCL_THREADS
Tcl_ThreadId thread; /* Thread the 'interp' belongs to. == Handler thread */
Tcl_ThreadId owner; /* Thread owning the structure. == Channel thread */
#endif
Tcl_Obj *cmd; /* Callback command prefix */
Tcl_Obj *methods; /* Methods to append to command prefix */
Tcl_Obj *name; /* Name of the channel as created */
int mode; /* Mask of R/W mode */
int interest; /* Mask of events the channel is interested
* in. */
int dead; /* Boolean signal that some operations
* should no longer be attempted. */
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.
*/
} ReflectedChannel;
/*
* Structure of the table maping from channel handles to reflected
* channels. Each interpreter which has the handler command for one or more
* reflected channels records them in such a table, so that 'chan postevent'
|
| ︙ | ︙ | |||
197 198 199 200 201 202 203 | #define RANDW \ (TCL_READABLE | TCL_WRITABLE) #define IMPLIES(a,b) ((!(a)) || (b)) #define NEGIMPL(a,b) #define HAS(x,f) (x & FLAG(f)) | | | 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 | #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'. */ |
| ︙ | ︙ | |||
248 249 250 251 252 253 254 |
* ForwardParamBase. Where an operation does not need any special types, it
* has no "subtype" and just uses ForwardParamBase, as listed above.)
*/
struct ForwardParamInput {
ForwardParamBase base; /* "Supertype". MUST COME FIRST. */
char *buf; /* O: Where to store the read bytes */
| | | 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 |
* ForwardParamBase. Where an operation does not need any special types, it
* has no "subtype" and just uses ForwardParamBase, as listed above.)
*/
struct ForwardParamInput {
ForwardParamBase base; /* "Supertype". MUST COME FIRST. */
char *buf; /* O: Where to store the read bytes */
size_t toRead; /* I: #bytes to read,
* O: #bytes actually read */
};
struct ForwardParamOutput {
ForwardParamBase base; /* "Supertype". MUST COME FIRST. */
const char *buf; /* I: Where the bytes to write come from */
int toWrite; /* I: #bytes to write,
* O: #bytes actually written */
|
| ︙ | ︙ | |||
381 382 383 384 385 386 387 |
static void ForwardOpToHandlerThread(ReflectedChannel *rcPtr,
ForwardedOperation op, const void *param);
static int ForwardProc(Tcl_Event *evPtr, int mask);
static void SrcExitProc(ClientData clientData);
#define FreeReceivedError(p) \
if ((p)->base.mustFree) { \
| | | 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 |
static void ForwardOpToHandlerThread(ReflectedChannel *rcPtr,
ForwardedOperation op, const void *param);
static int ForwardProc(Tcl_Event *evPtr, int mask);
static void SrcExitProc(ClientData clientData);
#define FreeReceivedError(p) \
if ((p)->base.mustFree) { \
Tcl_Free((p)->base.msgStr); \
}
#define PassReceivedErrorInterp(i,p) \
if ((i) != NULL) { \
Tcl_SetChannelErrorInterp((i), \
Tcl_NewStringObj((p)->base.msgStr, -1)); \
} \
FreeReceivedError(p)
|
| ︙ | ︙ | |||
447 448 449 450 451 452 453 |
* list-quoting to keep the words of the message together. See also [x].
*/
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}";
| | | 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 |
* list-quoting to keep the words of the message together. See also [x].
*/
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
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}";
/*
* Main methods to plug into the 'chan' ensemble'. ==================
|
| ︙ | ︙ | |||
666 667 668 669 670 671 672 |
if ((methods & NULLABLE_METHODS) != NULLABLE_METHODS) {
/*
* Some of the nullable methods are not supported. We clone the
* channel type, null the associated C functions, and use the result
* as the actual channel type.
*/
| | | 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 |
if ((methods & NULLABLE_METHODS) != NULLABLE_METHODS) {
/*
* Some of the nullable methods are not supported. We clone the
* channel type, null the associated C functions, and use the result
* as the actual channel type.
*/
Tcl_ChannelType *clonePtr = Tcl_Alloc(sizeof(Tcl_ChannelType));
memcpy(clonePtr, &tclRChannelType, sizeof(Tcl_ChannelType));
if (!(methods & FLAG(METH_CONFIGURE))) {
clonePtr->setOptionProc = NULL;
}
|
| ︙ | ︙ | |||
702 703 704 705 706 707 708 |
rcmPtr = GetReflectedChannelMap(interp);
hPtr = Tcl_CreateHashEntry(&rcmPtr->map, chanPtr->state->channelName,
&isNew);
if (!isNew && chanPtr != Tcl_GetHashValue(hPtr)) {
Tcl_Panic("TclChanCreateObjCmd: duplicate channel names");
}
Tcl_SetHashValue(hPtr, chan);
| | | | 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 |
rcmPtr = GetReflectedChannelMap(interp);
hPtr = Tcl_CreateHashEntry(&rcmPtr->map, chanPtr->state->channelName,
&isNew);
if (!isNew && chanPtr != Tcl_GetHashValue(hPtr)) {
Tcl_Panic("TclChanCreateObjCmd: duplicate channel names");
}
Tcl_SetHashValue(hPtr, chan);
#if TCL_THREADS
rcmPtr = GetThreadReflectedChannelMap();
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));
return TCL_OK;
error:
Tcl_DecrRefCount(rcPtr->name);
Tcl_DecrRefCount(rcPtr->methods);
Tcl_DecrRefCount(rcPtr->cmd);
Tcl_Free(rcPtr);
return TCL_ERROR;
#undef MODE
#undef CMD
}
/*
|
| ︙ | ︙ | |||
746 747 748 749 750 751 752 | * Side effects: * Posts events to a reflected channel, invokes event handlers. The * latter implies that arbitrary side effects are possible. * *---------------------------------------------------------------------- */ | | | 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 |
* Side effects:
* Posts events to a reflected channel, invokes event handlers. The
* latter implies that arbitrary side effects are possible.
*
*----------------------------------------------------------------------
*/
#if TCL_THREADS
typedef struct {
Tcl_Event header;
ReflectedChannel *rcPtr;
int events;
} ReflectEvent;
static int
|
| ︙ | ︙ | |||
913 914 915 916 917 918 919 |
return TCL_ERROR;
}
/*
* We have the channel and the events to post.
*/
| | | > > > > > > > > > > > | | | 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 |
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 = 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
|
| ︙ | ︙ | |||
963 964 965 966 967 968 969 970 971 972 973 974 975 976 |
Tcl_ResetResult(interp);
return TCL_OK;
#undef CHAN
#undef EVENT
}
/*
* Channel error message marshalling utilities.
*/
static Tcl_Obj *
MarshallError(
| > > > > > > > > > > > > > > > > > > | 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 |
Tcl_ResetResult(interp);
return TCL_OK;
#undef CHAN
#undef EVENT
}
static void
TimerRunRead(
ClientData clientData)
{
ReflectedChannel *rcPtr = clientData;
rcPtr->readTimer = NULL;
Tcl_NotifyChannel(rcPtr->chan, TCL_READABLE);
}
static void
TimerRunWrite(
ClientData clientData)
{
ReflectedChannel *rcPtr = clientData;
rcPtr->writeTimer = NULL;
Tcl_NotifyChannel(rcPtr->chan, TCL_WRITABLE);
}
/*
* Channel error message marshalling utilities.
*/
static Tcl_Obj *
MarshallError(
|
| ︙ | ︙ | |||
1133 1134 1135 1136 1137 1138 1139 | * 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? */ | | | > > > > > > | | 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 |
* 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?
*/
#if TCL_THREADS
if (rcPtr->thread != Tcl_GetCurrentThread()) {
ForwardParam p;
ForwardOpToHandlerThread(rcPtr, ForwardedClose, &p);
result = p.base.code;
/*
* Now squash the pending reflection events for this channel.
*/
Tcl_DeleteEvents(ReflectEventDelete, rcPtr);
if (result != TCL_OK) {
FreeReceivedError(&p);
}
}
#endif
tctPtr = ((Channel *)rcPtr->chan)->typePtr;
if (tctPtr && tctPtr != &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);
return EOK;
}
/*
* Are we in the correct thread?
*/
#if TCL_THREADS
if (rcPtr->thread != Tcl_GetCurrentThread()) {
ForwardParam p;
ForwardOpToHandlerThread(rcPtr, ForwardedClose, &p);
result = p.base.code;
/*
|
| ︙ | ︙ | |||
1212 1213 1214 1215 1216 1217 1218 |
rcmPtr = GetReflectedChannelMap(rcPtr->interp);
hPtr = Tcl_FindHashEntry(&rcmPtr->map,
Tcl_GetChannelName(rcPtr->chan));
if (hPtr) {
Tcl_DeleteHashEntry(hPtr);
}
}
| | | > > > > > > | 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 |
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);
return (result == TCL_OK) ? EOK : EINVAL;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1255 1256 1257 1258 1259 1260 1261 |
ClientData clientData,
char *buf,
int toRead,
int *errorCodePtr)
{
ReflectedChannel *rcPtr = clientData;
Tcl_Obj *toReadObj;
| | | | | 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 |
ClientData clientData,
char *buf,
int toRead,
int *errorCodePtr)
{
ReflectedChannel *rcPtr = clientData;
Tcl_Obj *toReadObj;
size_t bytec = 0; /* Number of returned bytes */
unsigned char *bytev; /* Array of returned bytes */
Tcl_Obj *resObj; /* Result data for 'read' */
/*
* Are we in the correct thread?
*/
#if TCL_THREADS
if (rcPtr->thread != Tcl_GetCurrentThread()) {
ForwardParam p;
p.input.buf = buf;
p.input.toRead = toRead;
ForwardOpToHandlerThread(rcPtr, ForwardedInput, &p);
if (p.base.code != TCL_OK) {
if (p.base.code < 0) {
/*
* No error message, this is an errno signal.
*/
*errorCodePtr = -p.base.code;
} else {
PassReceivedError(rcPtr->chan, &p);
*errorCodePtr = EINVAL;
}
p.input.toRead = TCL_AUTO_LENGTH;
} else {
*errorCodePtr = EOK;
}
return p.input.toRead;
}
#endif
|
| ︙ | ︙ | |||
1312 1313 1314 1315 1316 1317 1318 |
goto error;
}
Tcl_SetChannelError(rcPtr->chan, resObj);
goto invalid;
}
| | | | | | | 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 |
goto error;
}
Tcl_SetChannelError(rcPtr->chan, resObj);
goto invalid;
}
bytev = TclGetByteArrayFromObj(resObj, &bytec);
if ((size_t)toRead < bytec) {
SetChannelErrorStr(rcPtr->chan, msg_read_toomuch);
goto invalid;
}
*errorCodePtr = EOK;
if (bytec + 1 > 1) {
memcpy(buf, bytev, bytec);
}
stop:
Tcl_DecrRefCount(toReadObj);
Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */
Tcl_Release(rcPtr);
return bytec;
|
| ︙ | ︙ | |||
1369 1370 1371 1372 1373 1374 1375 |
Tcl_Obj *resObj; /* Result data for 'write' */
int written;
/*
* Are we in the correct thread?
*/
| | | 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 |
Tcl_Obj *resObj; /* Result data for 'write' */
int written;
/*
* Are we in the correct thread?
*/
#if TCL_THREADS
if (rcPtr->thread != Tcl_GetCurrentThread()) {
ForwardParam p;
p.output.buf = buf;
p.output.toWrite = toWrite;
ForwardOpToHandlerThread(rcPtr, ForwardedOutput, &p);
|
| ︙ | ︙ | |||
1498 1499 1500 1501 1502 1503 1504 |
Tcl_Obj *resObj; /* Result for 'seek' */
Tcl_WideInt newLoc;
/*
* Are we in the correct thread?
*/
| | | 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 |
Tcl_Obj *resObj; /* Result for 'seek' */
Tcl_WideInt newLoc;
/*
* Are we in the correct thread?
*/
#if TCL_THREADS
if (rcPtr->thread != Tcl_GetCurrentThread()) {
ForwardParam p;
p.seek.seekMode = seekMode;
p.seek.offset = offset;
ForwardOpToHandlerThread(rcPtr, ForwardedSeek, &p);
|
| ︙ | ︙ | |||
1540 1541 1542 1543 1544 1545 1546 |
}
if (Tcl_GetWideIntFromObj(rcPtr->interp, resObj, &newLoc) != TCL_OK) {
Tcl_SetChannelError(rcPtr->chan, MarshallError(rcPtr->interp));
goto invalid;
}
| | | 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 |
}
if (Tcl_GetWideIntFromObj(rcPtr->interp, resObj, &newLoc) != TCL_OK) {
Tcl_SetChannelError(rcPtr->chan, MarshallError(rcPtr->interp));
goto invalid;
}
if (newLoc < 0) {
SetChannelErrorStr(rcPtr->chan, msg_seek_beforestart);
goto invalid;
}
*errorCodePtr = EOK;
stop:
Tcl_DecrRefCount(offObj);
|
| ︙ | ︙ | |||
1572 1573 1574 1575 1576 1577 1578 |
/*
* 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.
*/
| | | 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 |
/*
* This function can be invoked from a transformation which is based on
* standard seeking, i.e. non-wide. Because of this we have to implement
* it, a dummy is not enough. We simply delegate the call to the wide
* routine.
*/
return ReflectSeekWide(clientData, offset, seekMode,
errorCodePtr);
}
/*
*----------------------------------------------------------------------
*
* ReflectWatch --
|
| ︙ | ︙ | |||
1621 1622 1623 1624 1625 1626 1627 |
return;
}
/*
* Are we in the correct thread?
*/
| | | 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 |
return;
}
/*
* Are we in the correct thread?
*/
#if TCL_THREADS
if (rcPtr->thread != Tcl_GetCurrentThread()) {
ForwardParam p;
p.watch.mask = mask;
ForwardOpToHandlerThread(rcPtr, ForwardedWatch, &p);
/*
|
| ︙ | ︙ | |||
1679 1680 1681 1682 1683 1684 1685 |
int errorNum; /* EINVAL or EOK (success). */
Tcl_Obj *resObj; /* Result data for 'blocking' */
/*
* Are we in the correct thread?
*/
| | | 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 |
int errorNum; /* EINVAL or EOK (success). */
Tcl_Obj *resObj; /* Result data for 'blocking' */
/*
* Are we in the correct thread?
*/
#if TCL_THREADS
if (rcPtr->thread != Tcl_GetCurrentThread()) {
ForwardParam p;
p.block.nonblocking = nonblocking;
ForwardOpToHandlerThread(rcPtr, ForwardedBlock, &p);
|
| ︙ | ︙ | |||
1715 1716 1717 1718 1719 1720 1721 |
Tcl_DecrRefCount(blockObj);
Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */
Tcl_Release(rcPtr);
return errorNum;
}
| | | 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 |
Tcl_DecrRefCount(blockObj);
Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */
Tcl_Release(rcPtr);
return errorNum;
}
#if TCL_THREADS
/*
*----------------------------------------------------------------------
*
* ReflectThread --
*
* This function is invoked to tell the channel about thread movements.
*
|
| ︙ | ︙ | |||
1785 1786 1787 1788 1789 1790 1791 |
int result; /* Result code for 'configure' */
Tcl_Obj *resObj; /* Result data for 'configure' */
/*
* Are we in the correct thread?
*/
| | | 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 |
int result; /* Result code for 'configure' */
Tcl_Obj *resObj; /* Result data for 'configure' */
/*
* Are we in the correct thread?
*/
#if TCL_THREADS
if (rcPtr->thread != Tcl_GetCurrentThread()) {
ForwardParam p;
p.setOpt.name = optionName;
p.setOpt.value = newValue;
ForwardOpToHandlerThread(rcPtr, ForwardedSetOpt, &p);
|
| ︙ | ︙ | |||
1864 1865 1866 1867 1868 1869 1870 |
Tcl_Obj **listv;
MethodName method;
/*
* Are we in the correct thread?
*/
| | | 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 |
Tcl_Obj **listv;
MethodName method;
/*
* Are we in the correct thread?
*/
#if TCL_THREADS
if (rcPtr->thread != Tcl_GetCurrentThread()) {
int opcode;
ForwardParam p;
p.getOpt.name = optionName;
p.getOpt.value = dsPtr;
|
| ︙ | ︙ | |||
1953 1954 1955 1956 1957 1958 1959 |
Tcl_ResetResult(interp);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"Expected list with even number of "
"elements, got %d element%s instead", listc,
(listc == 1 ? "" : "s")));
goto error;
} else {
| | | 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 |
Tcl_ResetResult(interp);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"Expected list with even number of "
"elements, got %d element%s instead", listc,
(listc == 1 ? "" : "s")));
goto error;
} else {
size_t len;
const char *str = TclGetStringFromObj(resObj, &len);
if (len) {
TclDStringAppendLiteral(dsPtr, " ");
Tcl_DStringAppend(dsPtr, str, len);
}
goto ok;
|
| ︙ | ︙ | |||
2120 2121 2122 2123 2124 2125 2126 |
Tcl_Obj *cmdpfxObj,
int mode,
Tcl_Obj *handleObj)
{
ReflectedChannel *rcPtr;
MethodName mn = METH_BLOCKING;
| | > > | | 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 |
Tcl_Obj *cmdpfxObj,
int mode,
Tcl_Obj *handleObj)
{
ReflectedChannel *rcPtr;
MethodName mn = METH_BLOCKING;
rcPtr = Tcl_Alloc(sizeof(ReflectedChannel));
/* rcPtr->chan: Assigned by caller. Dummy data here. */
rcPtr->chan = NULL;
rcPtr->interp = interp;
rcPtr->dead = 0;
rcPtr->readTimer = 0;
rcPtr->writeTimer = 0;
#if TCL_THREADS
rcPtr->thread = Tcl_GetCurrentThread();
#endif
rcPtr->mode = mode;
rcPtr->interest = 0; /* Initially no interest registered */
/* ASSERT: cmdpfxObj is a Tcl List */
rcPtr->cmd = TclListObjCopy(NULL, cmdpfxObj);
|
| ︙ | ︙ | |||
2205 2206 2207 2208 2209 2210 2211 |
}
if (rcPtr->methods) {
Tcl_DecrRefCount(rcPtr->methods);
}
if (rcPtr->cmd) {
Tcl_DecrRefCount(rcPtr->cmd);
}
| | | 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 |
}
if (rcPtr->methods) {
Tcl_DecrRefCount(rcPtr->methods);
}
if (rcPtr->cmd) {
Tcl_DecrRefCount(rcPtr->cmd);
}
Tcl_Free(rcPtr);
}
/*
*----------------------------------------------------------------------
*
* InvokeTclMethod --
*
|
| ︙ | ︙ | |||
2326 2327 2328 2329 2330 2331 2332 |
* 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) {
| | | 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 |
* 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) {
size_t cmdLen;
const char *cmdString = TclGetStringFromObj(cmd, &cmdLen);
Tcl_IncrRefCount(cmd);
Tcl_ResetResult(rcPtr->interp);
Tcl_SetObjResult(rcPtr->interp, Tcl_ObjPrintf(
"chan handler returned bad code: %d", result));
Tcl_LogCommandInfo(rcPtr->interp, cmdString, cmdString,
|
| ︙ | ︙ | |||
2441 2442 2443 2444 2445 2446 2447 |
static ReflectedChannelMap *
GetReflectedChannelMap(
Tcl_Interp *interp)
{
ReflectedChannelMap *rcmPtr = Tcl_GetAssocData(interp, RCMKEY, NULL);
if (rcmPtr == NULL) {
| | | 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 |
static ReflectedChannelMap *
GetReflectedChannelMap(
Tcl_Interp *interp)
{
ReflectedChannelMap *rcmPtr = Tcl_GetAssocData(interp, RCMKEY, NULL);
if (rcmPtr == NULL) {
rcmPtr = Tcl_Alloc(sizeof(ReflectedChannelMap));
Tcl_InitHashTable(&rcmPtr->map, TCL_STRING_KEYS);
Tcl_SetAssocData(interp, RCMKEY,
(Tcl_InterpDeleteProc *) DeleteReflectedChannelMap, rcmPtr);
}
return rcmPtr;
}
|
| ︙ | ︙ | |||
2502 2503 2504 2505 2506 2507 2508 |
{
ReflectedChannelMap *rcmPtr = clientData;
/* The map */
Tcl_HashSearch hSearch; /* Search variable. */
Tcl_HashEntry *hPtr; /* Search variable. */
ReflectedChannel *rcPtr;
Tcl_Channel chan;
| | | 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 |
{
ReflectedChannelMap *rcmPtr = clientData;
/* The map */
Tcl_HashSearch hSearch; /* Search variable. */
Tcl_HashEntry *hPtr; /* Search variable. */
ReflectedChannel *rcPtr;
Tcl_Channel chan;
#if TCL_THREADS
ForwardingResult *resultPtr;
ForwardingEvent *evPtr;
ForwardParam *paramPtr;
#endif
/*
* Delete all entries. The channels may have been closed already, or will
|
| ︙ | ︙ | |||
2530 2531 2532 2533 2534 2535 2536 |
chan = Tcl_GetHashValue(hPtr);
rcPtr = Tcl_GetChannelInstanceData(chan);
MarkDead(rcPtr);
Tcl_DeleteHashEntry(hPtr);
}
Tcl_DeleteHashTable(&rcmPtr->map);
| | | | 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 |
chan = Tcl_GetHashValue(hPtr);
rcPtr = Tcl_GetChannelInstanceData(chan);
MarkDead(rcPtr);
Tcl_DeleteHashEntry(hPtr);
}
Tcl_DeleteHashTable(&rcmPtr->map);
Tcl_Free(&rcmPtr->map);
#if TCL_THREADS
/*
* The origin interpreter for one or more reflected channels is gone.
*/
/*
* 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
|
| ︙ | ︙ | |||
2618 2619 2620 2621 2622 2623 2624 |
MarkDead(rcPtr);
Tcl_DeleteHashEntry(hPtr);
}
#endif
}
| | | 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 |
MarkDead(rcPtr);
Tcl_DeleteHashEntry(hPtr);
}
#endif
}
#if TCL_THREADS
/*
*----------------------------------------------------------------------
*
* GetThreadReflectedChannelMap --
*
* Gets and potentially initializes the reflected channel map for a
* thread.
|
| ︙ | ︙ | |||
2642 2643 2644 2645 2646 2647 2648 |
static ReflectedChannelMap *
GetThreadReflectedChannelMap(void)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (!tsdPtr->rcmPtr) {
| | | 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 |
static ReflectedChannelMap *
GetThreadReflectedChannelMap(void)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (!tsdPtr->rcmPtr) {
tsdPtr->rcmPtr = Tcl_Alloc(sizeof(ReflectedChannelMap));
Tcl_InitHashTable(&tsdPtr->rcmPtr->map, TCL_STRING_KEYS);
Tcl_CreateThreadExitHandler(DeleteThreadReflectedChannelMap, NULL);
}
return tsdPtr->rcmPtr;
}
|
| ︙ | ︙ | |||
2765 2766 2767 2768 2769 2770 2771 |
hPtr = Tcl_FirstHashEntry(&rcmPtr->map, &hSearch)) {
Tcl_Channel chan = Tcl_GetHashValue(hPtr);
ReflectedChannel *rcPtr = Tcl_GetChannelInstanceData(chan);
MarkDead(rcPtr);
Tcl_DeleteHashEntry(hPtr);
}
| | | 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 |
hPtr = Tcl_FirstHashEntry(&rcmPtr->map, &hSearch)) {
Tcl_Channel chan = Tcl_GetHashValue(hPtr);
ReflectedChannel *rcPtr = Tcl_GetChannelInstanceData(chan);
MarkDead(rcPtr);
Tcl_DeleteHashEntry(hPtr);
}
Tcl_Free(rcmPtr);
}
static void
ForwardOpToHandlerThread(
ReflectedChannel *rcPtr, /* Channel instance */
ForwardedOperation op, /* Forwarded driver operation */
const void *param) /* Arguments */
|
| ︙ | ︙ | |||
2805 2806 2807 2808 2809 2810 2811 |
return;
}
/*
* Create and initialize the event and data structures.
*/
| | | | 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 |
return;
}
/*
* Create and initialize the event and data structures.
*/
evPtr = Tcl_Alloc(sizeof(ForwardingEvent));
resultPtr = Tcl_Alloc(sizeof(ForwardingResult));
evPtr->event.proc = ForwardProc;
evPtr->resultPtr = resultPtr;
evPtr->op = op;
evPtr->rcPtr = rcPtr;
evPtr->param = (ForwardParam *) param;
|
| ︙ | ︙ | |||
2888 2889 2890 2891 2892 2893 2894 |
* returning the success code.
*
* Note: The event structure has already been deleted.
*/
Tcl_DeleteThreadExitHandler(SrcExitProc, evPtr);
| | | 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 |
* returning the success code.
*
* Note: The event structure has already been deleted.
*/
Tcl_DeleteThreadExitHandler(SrcExitProc, evPtr);
Tcl_Free(resultPtr);
}
static int
ForwardProc(
Tcl_Event *evGPtr,
int mask)
{
|
| ︙ | ︙ | |||
2988 2989 2990 2991 2992 2993 2994 |
int code = ErrnoReturn(rcPtr, resObj);
if (code < 0) {
paramPtr->base.code = code;
} else {
ForwardSetObjError(paramPtr, resObj);
}
| | | | | | | | 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 |
int code = ErrnoReturn(rcPtr, resObj);
if (code < 0) {
paramPtr->base.code = code;
} else {
ForwardSetObjError(paramPtr, resObj);
}
paramPtr->input.toRead = TCL_IO_FAILURE;
} else {
/*
* Process a regular result.
*/
size_t bytec = 0; /* Number of returned bytes */
unsigned char *bytev; /* Array of returned bytes */
bytev = TclGetByteArrayFromObj(resObj, &bytec);
if (paramPtr->input.toRead < bytec) {
ForwardSetStaticError(paramPtr, msg_read_toomuch);
paramPtr->input.toRead = TCL_IO_FAILURE;
} else {
if (bytec + 1 > 1) {
memcpy(paramPtr->input.buf, bytev, bytec);
}
paramPtr->input.toRead = bytec;
}
}
Tcl_Release(rcPtr);
Tcl_DecrRefCount(toReadObj);
break;
|
| ︙ | ︙ | |||
3075 3076 3077 3078 3079 3080 3081 |
* Process a regular result. If the type is wrong this may change
* into an error.
*/
Tcl_WideInt newLoc;
if (Tcl_GetWideIntFromObj(interp, resObj, &newLoc) == TCL_OK) {
| | | 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 |
* Process a regular result. If the type is wrong this may change
* into an error.
*/
Tcl_WideInt newLoc;
if (Tcl_GetWideIntFromObj(interp, resObj, &newLoc) == TCL_OK) {
if (newLoc < 0) {
ForwardSetStaticError(paramPtr, msg_seek_beforestart);
paramPtr->seek.offset = -1;
} else {
paramPtr->seek.offset = newLoc;
}
} else {
Tcl_DecrRefCount(resObj);
|
| ︙ | ︙ | |||
3183 3184 3185 3186 3187 3188 3189 |
resObj = MarshallError(interp);
ForwardSetObjError(paramPtr, resObj);
} else if ((listc % 2) == 1) {
/*
* Odd number of elements is wrong. [x].
*/
| | | | 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 |
resObj = MarshallError(interp);
ForwardSetObjError(paramPtr, resObj);
} else if ((listc % 2) == 1) {
/*
* Odd number of elements is wrong. [x].
*/
char *buf = Tcl_Alloc(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);
if (len) {
TclDStringAppendLiteral(paramPtr->getOpt.value, " ");
Tcl_DStringAppend(paramPtr->getOpt.value, str, len);
}
}
|
| ︙ | ︙ | |||
3289 3290 3291 3292 3293 3294 3295 |
}
static void
ForwardSetObjError(
ForwardParam *paramPtr,
Tcl_Obj *obj)
{
| | | | | 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 |
}
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
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* tab-width: 8
* indent-tabs-mode: nil
* End:
*/
|
Changes to generic/tclIORTrans.c.
| ︙ | ︙ | |||
85 86 87 88 89 90 91 |
/*
* 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. */
| | | | 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 |
/*
* 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);
|
| ︙ | ︙ | |||
123 124 125 126 127 128 129 |
* 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. */
| | | 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 |
* 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
|
| ︙ | ︙ | |||
216 217 218 219 220 221 222 | #define RANDW \ (TCL_READABLE | TCL_WRITABLE) #define IMPLIES(a,b) ((!(a)) || (b)) #define NEGIMPL(a,b) #define HAS(x,f) (x & FLAG(f)) | | | 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 | #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'. */ |
| ︙ | ︙ | |||
266 267 268 269 270 271 272 |
* has no "subtype" and just uses ForwardParamBase, as listed above.)
*/
struct ForwardParamTransform {
ForwardParamBase base; /* "Supertype". MUST COME FIRST. */
char *buf; /* I: Bytes to transform,
* O: Bytes in transform result */
| | | 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 |
* 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 */
};
|
| ︙ | ︙ | |||
362 363 364 365 366 367 368 |
ForwardedOperation op, const void *param);
static int ForwardProc(Tcl_Event *evPtr, int mask);
static void SrcExitProc(ClientData clientData);
#define FreeReceivedError(p) \
do { \
if ((p)->base.mustFree) { \
| | | 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 |
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)); \
|
| ︙ | ︙ | |||
434 435 436 437 438 439 440 |
* 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}";
| | | 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 |
* 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}";
/*
|
| ︙ | ︙ | |||
616 617 618 619 620 621 622 |
methods = 0;
while (listc > 0) {
if (Tcl_GetIndexFromObj(interp, listv[listc-1], methodNames,
"method", TCL_EXACT, &methIndex) != TCL_OK) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"chan handler \"%s initialize\" returned %s",
TclGetString(cmdObj),
| | | 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 |
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--;
}
|
| ︙ | ︙ | |||
695 696 697 698 699 700 701 |
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);
| | | 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 |
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.
|
| ︙ | ︙ | |||
907 908 909 910 911 912 913 | * 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? */ | | | 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 |
* 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) {
|
| ︙ | ︙ | |||
934 935 936 937 938 939 940 |
* 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)) {
| | | | | 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 |
* 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);
|
| ︙ | ︙ | |||
1010 1011 1012 1013 1014 1015 1016 |
*
* NOTE: The channel may have been removed from the map already via
* the per-interp DeleteReflectedTransformMap exit-handler.
*/
if (!rtPtr->dead) {
rtmPtr = GetReflectedTransformMap(rtPtr->interp);
| | | | 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 |
*
* 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 */
}
|
| ︙ | ︙ | |||
1336 1337 1338 1339 1340 1341 1342 |
/*
* Fail if the parent channel is not seekable.
*/
if (seekProc == NULL) {
Tcl_SetErrno(EINVAL);
| | | 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 |
/*
* Fail if the parent channel is not seekable.
*/
if (seekProc == NULL) {
Tcl_SetErrno(EINVAL);
return -1;
}
/*
* 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.
|
| ︙ | ︙ | |||
1386 1387 1388 1389 1390 1391 1392 |
* non-NULL...
*/
if (HaveVersion(parent->typePtr, TCL_CHANNEL_VERSION_3) &&
parent->typePtr->wideSeekProc != NULL) {
curPos = parent->typePtr->wideSeekProc(parent->instanceData, offset,
seekMode, errorCodePtr);
| | < | | | | | | 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 |
* non-NULL...
*/
if (HaveVersion(parent->typePtr, TCL_CHANNEL_VERSION_3) &&
parent->typePtr->wideSeekProc != NULL) {
curPos = parent->typePtr->wideSeekProc(parent->instanceData, offset,
seekMode, errorCodePtr);
} else if (offset < LONG_MIN || offset > LONG_MAX) {
*errorCodePtr = EOVERFLOW;
curPos = -1;
} else {
curPos = parent->typePtr->seekProc(
parent->instanceData, offset, seekMode,
errorCodePtr);
}
if (curPos == -1) {
Tcl_SetErrno(*errorCodePtr);
}
*errorCodePtr = EOK;
Tcl_Release(rtPtr);
return curPos;
}
|
| ︙ | ︙ | |||
1418 1419 1420 1421 1422 1423 1424 |
/*
* 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.
*/
| | | 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 |
/*
* This function can be invoked from a transformation which is based on
* standard seeking, i.e. non-wide. Because of this we have to implement
* it, a dummy is not enough. We simply delegate the call to the wide
* routine.
*/
return ReflectSeekWide(clientData, offset, seekMode,
errorCodePtr);
}
/*
*----------------------------------------------------------------------
*
* ReflectWatch --
|
| ︙ | ︙ | |||
1756 1757 1758 1759 1760 1761 1762 |
Tcl_Channel parentChan)
{
ReflectedTransform *rtPtr;
int listc;
Tcl_Obj **listv;
int i;
| | | | 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 |
Tcl_Channel parentChan)
{
ReflectedTransform *rtPtr;
int listc;
Tcl_Obj **listv;
int i;
rtPtr = 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;
|
| ︙ | ︙ | |||
1803 1804 1805 1806 1807 1808 1809 |
*
* 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;
| | | 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 |
*
* 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_Alloc(sizeof(Tcl_Obj *) * (listc+4));
/*
* Duplicate object references.
*/
for (i=0; i<listc ; i++) {
Tcl_Obj *word = rtPtr->argv[i] = listv[i];
|
| ︙ | ︙ | |||
1911 1912 1913 1914 1915 1916 1917 |
ReflectedTransform *rtPtr)
{
TimerKill(rtPtr);
ResultClear(&rtPtr->result);
FreeReflectedTransformArgs(rtPtr);
| | | | 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 |
ReflectedTransform *rtPtr)
{
TimerKill(rtPtr);
ResultClear(&rtPtr->result);
FreeReflectedTransformArgs(rtPtr);
Tcl_Free(rtPtr->argv);
Tcl_Free(rtPtr);
}
/*
*----------------------------------------------------------------------
*
* InvokeTclMethod --
*
|
| ︙ | ︙ | |||
2038 2039 2040 2041 2042 2043 2044 |
* 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);
| | | 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 |
* 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);
|
| ︙ | ︙ | |||
2111 2112 2113 2114 2115 2116 2117 |
static ReflectedTransformMap *
GetReflectedTransformMap(
Tcl_Interp *interp)
{
ReflectedTransformMap *rtmPtr = Tcl_GetAssocData(interp, RTMKEY, NULL);
if (rtmPtr == NULL) {
| | | 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 |
static ReflectedTransformMap *
GetReflectedTransformMap(
Tcl_Interp *interp)
{
ReflectedTransformMap *rtmPtr = Tcl_GetAssocData(interp, RTMKEY, NULL);
if (rtmPtr == NULL) {
rtmPtr = Tcl_Alloc(sizeof(ReflectedTransformMap));
Tcl_InitHashTable(&rtmPtr->map, TCL_STRING_KEYS);
Tcl_SetAssocData(interp, RTMKEY,
(Tcl_InterpDeleteProc *) DeleteReflectedTransformMap, rtmPtr);
}
return rtmPtr;
}
|
| ︙ | ︙ | |||
2148 2149 2150 2151 2152 2153 2154 |
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;
| | | 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 |
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
|
| ︙ | ︙ | |||
2176 2177 2178 2179 2180 2181 2182 |
hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch)) {
rtPtr = Tcl_GetHashValue(hPtr);
rtPtr->dead = 1;
Tcl_DeleteHashEntry(hPtr);
}
Tcl_DeleteHashTable(&rtmPtr->map);
| | | | 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 |
hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch)) {
rtPtr = 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
|
| ︙ | ︙ | |||
2250 2251 2252 2253 2254 2255 2256 |
Tcl_ConditionNotify(&resultPtr->done);
}
Tcl_MutexUnlock(&rtForwardMutex);
#endif /* TCL_THREADS */
}
| | | 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 |
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.
|
| ︙ | ︙ | |||
2274 2275 2276 2277 2278 2279 2280 |
static ReflectedTransformMap *
GetThreadReflectedTransformMap(void)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (!tsdPtr->rtmPtr) {
| | | 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 |
static ReflectedTransformMap *
GetThreadReflectedTransformMap(void)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (!tsdPtr->rtmPtr) {
tsdPtr->rtmPtr = Tcl_Alloc(sizeof(ReflectedTransformMap));
Tcl_InitHashTable(&tsdPtr->rtmPtr->map, TCL_STRING_KEYS);
Tcl_CreateThreadExitHandler(DeleteThreadReflectedTransformMap, NULL);
}
return tsdPtr->rtmPtr;
}
|
| ︙ | ︙ | |||
2332 2333 2334 2335 2336 2337 2338 |
hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch)) {
ReflectedTransform *rtPtr = Tcl_GetHashValue(hPtr);
rtPtr->dead = 1;
FreeReflectedTransformArgs(rtPtr);
Tcl_DeleteHashEntry(hPtr);
}
| | | 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 |
hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch)) {
ReflectedTransform *rtPtr = 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.
*/
|
| ︙ | ︙ | |||
2409 2410 2411 2412 2413 2414 2415 |
return;
}
/*
* Create and initialize the event and data structures.
*/
| | | | 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 |
return;
}
/*
* Create and initialize the event and data structures.
*/
evPtr = Tcl_Alloc(sizeof(ForwardingEvent));
resultPtr = Tcl_Alloc(sizeof(ForwardingResult));
evPtr->event.proc = ForwardProc;
evPtr->resultPtr = resultPtr;
evPtr->op = op;
evPtr->rtPtr = rtPtr;
evPtr->param = (ForwardParam *) param;
|
| ︙ | ︙ | |||
2490 2491 2492 2493 2494 2495 2496 |
*
* Note: The event structure has already been deleted by the destination
* notifier, after it serviced the event.
*/
Tcl_DeleteThreadExitHandler(SrcExitProc, evPtr);
| | | 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 |
*
* 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,
int mask)
{
|
| ︙ | ︙ | |||
2587 2588 2589 2590 2591 2592 2593 |
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);
| | | | | | | | | | | | | | | | | | | | | | 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 |
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_AUTO_LENGTH;
} 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 = 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_AUTO_LENGTH;
} 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 = 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_AUTO_LENGTH;
} 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 = 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_AUTO_LENGTH;
} 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 = Tcl_Alloc(bytec);
memcpy(paramPtr->transform.buf, bytev, bytec);
} else {
paramPtr->transform.buf = NULL;
}
}
break;
case ForwardedClear:
|
| ︙ | ︙ | |||
2802 2803 2804 2805 2806 2807 2808 |
}
static void
ForwardSetObjError(
ForwardParam *paramPtr,
Tcl_Obj *obj)
{
| | | | | 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 |
}
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 --
|
| ︙ | ︙ | |||
2951 2952 2953 2954 2955 2956 2957 |
{
rPtr->used = 0;
if (!rPtr->allocated) {
return;
}
| | | 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 |
{
rPtr->used = 0;
if (!rPtr->allocated) {
return;
}
Tcl_Free(rPtr->buf);
rPtr->buf = NULL;
rPtr->allocated = 0;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
2986 2987 2988 2989 2990 2991 2992 |
/*
* Extension of the internal buffer is required.
* NOTE: Currently linear. Should be doubling to amortize.
*/
if (rPtr->allocated == 0) {
rPtr->allocated = toWrite + RB_INCREMENT;
| | | | 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 |
/*
* 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.
*/
|
| ︙ | ︙ | |||
3034 3035 3036 3037 3038 3039 3040 |
if (rPtr->used == 0) {
/*
* Nothing to copy in the case of an empty buffer.
*/
copied = 0;
| | | | 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 |
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);
|
| ︙ | ︙ | |||
3077 3078 3079 3080 3081 3082 3083 |
static int
TransformRead(
ReflectedTransform *rtPtr,
int *errorCodePtr,
Tcl_Obj *bufObj)
{
Tcl_Obj *resObj;
| | | | | | | | | | | | | | | | | | | 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 |
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 */
}
|
| ︙ | ︙ | |||
3311 3312 3313 3314 3315 3316 3317 |
TransformClear(
ReflectedTransform *rtPtr)
{
/*
* Are we in the correct thread?
*/
| | | 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 |
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 */
|
| ︙ | ︙ | |||
3343 3344 3345 3346 3347 3348 3349 |
Tcl_Obj *resObj;
Tcl_InterpState sr; /* State of handler interp */
/*
* Are we in the correct thread?
*/
| | | 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 |
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);
|
| ︙ | ︙ |
Changes to generic/tclIOSock.c.
1 2 3 4 5 6 7 8 9 10 11 12 13 | /* * tclIOSock.c -- * * Common routines used by all socket based channel types. * * Copyright (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" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
/*
* tclIOSock.c --
*
* Common routines used by all socket based channel types.
*
* 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"
#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 */
|
| ︙ | ︙ | |||
57 58 59 60 61 62 63 |
*
*---------------------------------------------------------------------------
*/
int
TclSockGetPort(
Tcl_Interp *interp,
| | | | 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 |
*
*---------------------------------------------------------------------------
*/
int
TclSockGetPort(
Tcl_Interp *interp,
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;
if (Tcl_GetInt(NULL, string, portPtr) != TCL_OK) {
|
| ︙ | ︙ | |||
155 156 157 158 159 160 161 | * Fills in the *sockaddrPtr structure. * *---------------------------------------------------------------------- */ int TclCreateSocketAddress( | | | | | | | | | | > | | | | | | | | | | | | | | 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 |
* 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
|
| ︙ | ︙ | |||
252 253 254 255 256 257 258 259 260 261 262 263 264 265 |
/*
* 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;
| > | 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 |
/*
* 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;
|
| ︙ | ︙ |
Changes to generic/tclIOUtil.c.
| ︙ | ︙ | |||
135 136 137 138 139 140 141 | Tcl_FSLstatProc TclpObjLstat; Tcl_FSCopyFileProc TclpObjCopyFile; Tcl_FSDeleteFileProc TclpObjDeleteFile; Tcl_FSRenameFileProc TclpObjRenameFile; Tcl_FSCreateDirectoryProc TclpObjCreateDirectory; Tcl_FSCopyDirectoryProc TclpObjCopyDirectory; Tcl_FSRemoveDirectoryProc TclpObjRemoveDirectory; | < | 135 136 137 138 139 140 141 142 143 144 145 146 147 148 | 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; /* * 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 |
| ︙ | ︙ | |||
272 273 274 275 276 277 278 |
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) \
| | | | 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 |
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)
# define OUT_OF_URANGE(x) \
(((Tcl_WideUInt)(x)) > ((Tcl_WideUInt)ULONG_MAX))
/*
* Perform the result-buffer overflow check manually.
*
* Note that ino_t/ino64_t is unsigned...
|
| ︙ | ︙ | |||
454 455 456 457 458 459 460 |
* Trash the filesystems cache.
*/
fsRecPtr = tsdPtr->filesystemList;
while (fsRecPtr != NULL) {
tmpFsRecPtr = fsRecPtr->nextPtr;
fsRecPtr->fsPtr = NULL;
| | | 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 |
* Trash the filesystems cache.
*/
fsRecPtr = tsdPtr->filesystemList;
while (fsRecPtr != NULL) {
tmpFsRecPtr = fsRecPtr->nextPtr;
fsRecPtr->fsPtr = NULL;
Tcl_Free(fsRecPtr);
fsRecPtr = tmpFsRecPtr;
}
tsdPtr->filesystemList = NULL;
tsdPtr->initialized = 0;
}
int
|
| ︙ | ︙ | |||
536 537 538 539 540 541 542 |
if (pathPtrPtr == NULL) {
return (tsdPtr->cwdPathPtr == NULL);
}
if (tsdPtr->cwdPathPtr == *pathPtrPtr) {
return 1;
} else {
| | | 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 |
if (pathPtrPtr == NULL) {
return (tsdPtr->cwdPathPtr == NULL);
}
if (tsdPtr->cwdPathPtr == *pathPtrPtr) {
return 1;
} else {
size_t len1, len2;
const char *str1, *str2;
str1 = TclGetStringFromObj(tsdPtr->cwdPathPtr, &len1);
str2 = TclGetStringFromObj(*pathPtrPtr, &len2);
if ((len1 == len2) && !memcmp(str1, str2, len1)) {
/*
* They are equal, but different objects. Update so they will be
|
| ︙ | ︙ | |||
593 594 595 596 597 598 599 |
/*
* Refill the cache honouring the order.
*/
list = NULL;
fsRecPtr = tmpFsRecPtr;
while (fsRecPtr != NULL) {
| | | | 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 |
/*
* Refill the cache honouring the order.
*/
list = NULL;
fsRecPtr = tmpFsRecPtr;
while (fsRecPtr != NULL) {
tmpFsRecPtr = Tcl_Alloc(sizeof(FilesystemRecord));
*tmpFsRecPtr = *fsRecPtr;
tmpFsRecPtr->nextPtr = list;
tmpFsRecPtr->prevPtr = NULL;
list = tmpFsRecPtr;
fsRecPtr = fsRecPtr->prevPtr;
}
tsdPtr->filesystemList = list;
tsdPtr->filesystemEpoch = theFilesystemEpoch;
Tcl_MutexUnlock(&filesystemMutex);
while (toFree) {
FilesystemRecord *next = toFree->nextPtr;
toFree->fsPtr = NULL;
Tcl_Free(toFree);
toFree = next;
}
/*
* Make sure the above gets released on thread exit.
*/
|
| ︙ | ︙ | |||
678 679 680 681 682 683 684 |
*/
static void
FsUpdateCwd(
Tcl_Obj *cwdObj,
ClientData clientData)
{
| | | 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 |
*/
static void
FsUpdateCwd(
Tcl_Obj *cwdObj,
ClientData clientData)
{
size_t len = 0;
const char *str = NULL;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey);
if (cwdObj != NULL) {
str = TclGetStringFromObj(cwdObj, &len);
}
|
| ︙ | ︙ | |||
784 785 786 787 788 789 790 |
FilesystemRecord *tmpFsRecPtr = fsRecPtr->nextPtr;
/*
* The native filesystem is static, so we don't free it.
*/
if (fsRecPtr != &nativeFilesystemRecord) {
| | | 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 |
FilesystemRecord *tmpFsRecPtr = fsRecPtr->nextPtr;
/*
* The native filesystem is static, so we don't free it.
*/
if (fsRecPtr != &nativeFilesystemRecord) {
Tcl_Free(fsRecPtr);
}
fsRecPtr = tmpFsRecPtr;
}
if (++theFilesystemEpoch == 0) {
++theFilesystemEpoch;
}
filesystemList = NULL;
|
| ︙ | ︙ | |||
869 870 871 872 873 874 875 |
{
FilesystemRecord *newFilesystemPtr;
if (fsPtr == NULL) {
return TCL_ERROR;
}
| | | 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 |
{
FilesystemRecord *newFilesystemPtr;
if (fsPtr == NULL) {
return TCL_ERROR;
}
newFilesystemPtr = Tcl_Alloc(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
|
| ︙ | ︙ | |||
972 973 974 975 976 977 978 |
* (which would of course lead to memory exceptions).
*/
if (++theFilesystemEpoch == 0) {
++theFilesystemEpoch;
}
| | | 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 |
* (which would of course lead to memory exceptions).
*/
if (++theFilesystemEpoch == 0) {
++theFilesystemEpoch;
}
Tcl_Free(fsRecPtr);
retVal = TCL_OK;
} else {
fsRecPtr = fsRecPtr->nextPtr;
}
}
|
| ︙ | ︙ | |||
1200 1201 1202 1203 1204 1205 1206 |
gLength--;
}
break; /* Break out of for loop. */
}
}
if (!found && dir) {
Tcl_Obj *norm;
| | | 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 |
gLength--;
}
break; /* Break out of for loop. */
}
}
if (!found && dir) {
Tcl_Obj *norm;
size_t len, mlen;
/*
* 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.
*/
|
| ︙ | ︙ | |||
1387 1388 1389 1390 1391 1392 1393 1394 |
TclFSNormalizeToUniquePath(
Tcl_Interp *interp, /* Used for error messages. */
Tcl_Obj *pathPtr, /* The path to normalize in place. */
int startAt) /* Start at this char-offset. */
{
FilesystemRecord *fsRecPtr, *firstFsRecPtr;
/*
| > > > > < < < > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | | | | | | | | > | 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 |
TclFSNormalizeToUniquePath(
Tcl_Interp *interp, /* Used for error messages. */
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;
char *path;
/*
* Paths starting with a UNC prefix whose final character is a colon
* are reserved for VFS use. These names can not conflict with real
* UNC paths 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 each of the "normalise path" functions in succession.
*/
firstFsRecPtr = FsGetFirstFilesystem();
Claim();
if (!isVfsPath) {
/*
* 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).
*/
for (fsRecPtr=firstFsRecPtr; fsRecPtr!=NULL; fsRecPtr=fsRecPtr->nextPtr) {
if (fsRecPtr->fsPtr != &tclNativeFilesystem) {
continue;
}
/*
* TODO: Assume that we always find the native file system; it should
* always be there...
*/
if (fsRecPtr->fsPtr->normalizePathProc != NULL) {
startAt = fsRecPtr->fsPtr->normalizePathProc(interp, pathPtr,
startAt);
}
break;
}
}
for (fsRecPtr=firstFsRecPtr; fsRecPtr!=NULL; fsRecPtr=fsRecPtr->nextPtr) {
/*
* Skip the native system next time through.
*/
|
| ︙ | ︙ | |||
1633 1634 1635 1636 1637 1638 1639 |
mode |= O_NOCTTY;
#else
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"access mode \"%s\" not supported by this system",
flag));
}
| | | | | | 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 |
mode |= O_NOCTTY;
#else
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"access mode \"%s\" not supported by this system",
flag));
}
Tcl_Free((void *)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_Free((void *)modeArgv);
return -1;
#endif
} else if ((c == 'T') && (strcmp(flag, "TRUNC") == 0)) {
mode |= O_TRUNC;
} else if ((c == 'B') && (strcmp(flag, "BINARY") == 0)) {
*binaryPtr = 1;
} else {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"invalid access mode \"%s\": must be RDONLY, WRONLY, "
"RDWR, APPEND, BINARY, CREAT, EXCL, NOCTTY, NONBLOCK,"
" or TRUNC", flag));
}
Tcl_Free((void *)modeArgv);
return -1;
}
}
Tcl_Free((void *)modeArgv);
if (!gotRW) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"access mode must include either RDONLY, WRONLY, or RDWR",
-1));
}
|
| ︙ | ︙ | |||
1718 1719 1720 1721 1722 1723 1724 |
Tcl_FSEvalFileEx(
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. */
{
| > | | | | 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 |
Tcl_FSEvalFileEx(
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. */
{
size_t length;
int result = TCL_ERROR;
Tcl_StatBuf statBuf;
Tcl_Obj *oldScriptFile;
Interp *iPtr;
const char *string;
Tcl_Channel chan;
Tcl_Obj *objPtr;
if (Tcl_FSGetNormalizedPath(interp, pathPtr) == NULL) {
return result;
}
if (Tcl_FSStat(pathPtr, &statBuf) == -1) {
Tcl_SetErrno(errno);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't read file \"%s\": %s",
TclGetString(pathPtr), Tcl_PosixError(interp)));
return result;
}
chan = Tcl_FSOpenFileChannel(interp, pathPtr, "r", 0644);
if (chan == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't read file \"%s\": %s",
TclGetString(pathPtr), Tcl_PosixError(interp)));
return result;
}
/*
* The eofchar is \32 (^Z). This is the usual on Windows, but we effect
* this cross-platform to allow for scripted documents. [Bug: 2040]
*/
|
| ︙ | ︙ | |||
1773 1774 1775 1776 1777 1778 1779 |
Tcl_IncrRefCount(objPtr);
/*
* Try to read first character of stream, so we can check for utf-8 BOM to
* be handled especially.
*/
| | | | | | | 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 |
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) == TCL_IO_FAILURE) {
Tcl_Close(interp, chan);
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_Close(interp, chan);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't read file \"%s\": %s",
TclGetString(pathPtr), Tcl_PosixError(interp)));
goto end;
}
if (Tcl_Close(interp, chan) != TCL_OK) {
goto end;
}
|
| ︙ | ︙ | |||
1832 1833 1834 1835 1836 1837 1838 |
result = TclUpdateReturnInfo(iPtr);
} else if (result == TCL_ERROR) {
/*
* Record information telling where the error occurred.
*/
const char *pathString = TclGetStringFromObj(pathPtr, &length);
| | | | 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 |
result = TclUpdateReturnInfo(iPtr);
} else if (result == TCL_ERROR) {
/*
* Record information telling 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;
}
|
| ︙ | ︙ | |||
1868 1869 1870 1871 1872 1873 1874 |
return TCL_ERROR;
}
if (Tcl_FSStat(pathPtr, &statBuf) == -1) {
Tcl_SetErrno(errno);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't read file \"%s\": %s",
| | | | | 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 |
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 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 {}");
|
| ︙ | ︙ | |||
1908 1909 1910 1911 1912 1913 1914 |
Tcl_IncrRefCount(objPtr);
/*
* Try to read first character of stream, so we can check for utf-8 BOM to
* be handled especially.
*/
| | | | | | | 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 |
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) == TCL_IO_FAILURE) {
Tcl_Close(interp, chan);
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_Close(interp, chan);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't read file \"%s\": %s",
TclGetString(pathPtr), Tcl_PosixError(interp)));
Tcl_DecrRefCount(objPtr);
return TCL_ERROR;
}
if (Tcl_Close(interp, chan) != TCL_OK) {
Tcl_DecrRefCount(objPtr);
return TCL_ERROR;
|
| ︙ | ︙ | |||
1982 1983 1984 1985 1986 1987 1988 |
if (result == TCL_RETURN) {
result = TclUpdateReturnInfo(iPtr);
} else if (result == TCL_ERROR) {
/*
* Record information telling where the error occurred.
*/
| | | | | 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 |
if (result == TCL_RETURN) {
result = TclUpdateReturnInfo(iPtr);
} else if (result == TCL_ERROR) {
/*
* Record information telling 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)));
}
Tcl_DecrRefCount(objPtr);
return result;
}
|
| ︙ | ︙ | |||
2266 2267 2268 2269 2270 2271 2272 |
*/
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",
| | | | 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 |
*/
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_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)));
}
return NULL;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
2833 2834 2835 2836 2837 2838 2839 | /* * 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. */ | | | 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 |
/*
* 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.
*/
size_t len1, len2;
const char *str1, *str2;
str1 = TclGetStringFromObj(tsdPtr->cwdPathPtr, &len1);
str2 = TclGetStringFromObj(norm, &len2);
if ((len1 == len2) && (strcmp(str1, str2) == 0)) {
/*
* If the paths were equal, we can be more efficient and
|
| ︙ | ︙ | |||
3150 3151 3152 3153 3154 3155 3156 | * 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. */ | | | | 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 |
* 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.
*/
static int
skipUnlink(
Tcl_Obj *shlibFile)
{
/*
* Order of testing:
* 1. On hpux we generally want to skip unlink in general
*
* Outside of hpux then:
|
| ︙ | ︙ | |||
3193 3194 3195 3196 3197 3198 3199 |
* http://mooon.googlecode.com/svn/trunk/linux_include/linux/aufs_type.h
* http://aufs.sourceforge.net/
* Better reference will be gladly taken.
*/
#ifndef AUFS_SUPER_MAGIC
#define AUFS_SUPER_MAGIC ('a' << 24 | 'u' << 16 | 'f' << 8 | 's')
#endif /* AUFS_SUPER_MAGIC */
| | | | 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 |
* http://mooon.googlecode.com/svn/trunk/linux_include/linux/aufs_type.h
* http://aufs.sourceforge.net/
* Better reference will be gladly taken.
*/
#ifndef AUFS_SUPER_MAGIC
#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)) {
return 1;
}
}
#endif /* ... NO_FSTATFS */
#endif /* ... TCL_TEMPLOAD_NO_UNLINK */
/*
|
| ︙ | ︙ | |||
3269 3270 3271 3272 3273 3274 3275 |
* 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",
| | | 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 |
* 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)));
}
return TCL_ERROR;
}
#ifdef TCL_LOAD_FROM_MEMORY
/*
* The platform supports loading code from memory, so ask for a buffer of
|
| ︙ | ︙ | |||
3409 3410 3411 3412 3413 3414 3415 |
}
/*
* Try to delete the file immediately - this is possible in some OSes, and
* avoids any worries about leaving the copy laying around on exit.
*/
| | | 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 |
}
/*
* 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)) {
Tcl_DecrRefCount(copyToPtr);
/*
* 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
|
| ︙ | ︙ | |||
3432 3433 3434 3435 3436 3437 3438 |
}
/*
* When we unload this file, we need to divert the unloading so we can
* unload and cleanup the temporary file correctly.
*/
| | | 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 |
}
/*
* When we unload this file, we need to divert the unloading so we can
* unload and cleanup the temporary file correctly.
*/
tvdlPtr = Tcl_Alloc(sizeof(FsDivertLoad));
/*
* Remember three pieces of information. This allows us to cleanup the
* diverted load completely, on platforms which allow proper unloading of
* code.
*/
|
| ︙ | ︙ | |||
3478 3479 3480 3481 3482 3483 3484 |
tvdlPtr->divertedFile = NULL;
tvdlPtr->divertedFilesystem = NULL;
Tcl_DecrRefCount(copyToPtr);
}
copyToPtr = NULL;
| | | 3509 3510 3511 3512 3513 3514 3515 3516 3517 3518 3519 3520 3521 3522 3523 |
tvdlPtr->divertedFile = NULL;
tvdlPtr->divertedFilesystem = NULL;
Tcl_DecrRefCount(copyToPtr);
}
copyToPtr = NULL;
divertedLoadHandle = Tcl_Alloc(sizeof(struct Tcl_LoadHandle_));
divertedLoadHandle->clientData = tvdlPtr;
divertedLoadHandle->findSymbolProcPtr = DivertFindSymbol;
divertedLoadHandle->unloadFileProcPtr = DivertUnloadFile;
*handlePtr = divertedLoadHandle;
if (interp) {
Tcl_ResetResult(interp);
|
| ︙ | ︙ | |||
3624 3625 3626 3627 3628 3629 3630 |
* 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);
}
| | | | 3655 3656 3657 3658 3659 3660 3661 3662 3663 3664 3665 3666 3667 3668 3669 3670 |
* 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);
}
Tcl_Free(tvdlPtr);
Tcl_Free(loadHandle);
}
/*
*----------------------------------------------------------------------
*
* Tcl_FindSymbol --
*
|
| ︙ | ︙ | |||
3678 3679 3680 3681 3682 3683 3684 |
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"cannot unload: filesystem does not support unloading",
-1));
}
return TCL_ERROR;
}
| < < < < < < < < < < < < < < < < < < < < < > | 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 |
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 --
*
|
| ︙ | ︙ | |||
3794 3795 3796 3797 3798 3799 3800 |
* 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);
}
| | | 3805 3806 3807 3808 3809 3810 3811 3812 3813 3814 3815 3816 3817 3818 3819 |
* 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);
}
Tcl_Free(tvdlPtr);
}
/*
*---------------------------------------------------------------------------
*
* Tcl_FSLink --
*
|
| ︙ | ︙ | |||
4019 4020 4021 4022 4023 4024 4025 |
*/
if (fsPtr->filesystemSeparatorProc != NULL) {
Tcl_Obj *sep = fsPtr->filesystemSeparatorProc(pathPtr);
if (sep != NULL) {
Tcl_IncrRefCount(sep);
| | | | 4030 4031 4032 4033 4034 4035 4036 4037 4038 4039 4040 4041 4042 4043 4044 4045 4046 4047 4048 4049 4050 4051 4052 4053 4054 4055 4056 |
*/
if (fsPtr->filesystemSeparatorProc != NULL) {
Tcl_Obj *sep = fsPtr->filesystemSeparatorProc(pathPtr);
if (sep != NULL) {
Tcl_IncrRefCount(sep);
separator = TclGetString(sep)[0];
Tcl_DecrRefCount(sep);
}
}
/*
* 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)
*/
result = Tcl_NewObj();
p = TclGetString(pathPtr);
Tcl_ListObjAppendElement(NULL, result,
Tcl_NewStringObj(p, driveNameLength));
p += driveNameLength;
/*
* Add the remaining path elements to the list.
*/
|
| ︙ | ︙ | |||
4108 4109 4110 4111 4112 4113 4114 |
* 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. */
{
| | | 4119 4120 4121 4122 4123 4124 4125 4126 4127 4128 4129 4130 4131 4132 4133 |
* 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. */
{
size_t pathLen;
const char *path = TclGetStringFromObj(pathPtr, &pathLen);
Tcl_PathType type;
type = TclFSNonnativePathType(path, pathLen, filesystemPtrPtr,
driveNameLengthPtr, driveNameRef);
if (type != TCL_PATH_ABSOLUTE) {
|
| ︙ | ︙ | |||
4216 4217 4218 4219 4220 4221 4222 |
* (but Tcl_Panic seems a bit excessive).
*/
numVolumes = -1;
}
while (numVolumes > 0) {
Tcl_Obj *vol;
| | | | | 4227 4228 4229 4230 4231 4232 4233 4234 4235 4236 4237 4238 4239 4240 4241 4242 4243 4244 4245 4246 4247 4248 4249 4250 |
* (but Tcl_Panic seems a bit excessive).
*/
numVolumes = -1;
}
while (numVolumes > 0) {
Tcl_Obj *vol;
size_t len;
const char *strVol;
numVolumes--;
Tcl_ListObjIndex(NULL, thisFsVolumes, numVolumes, &vol);
strVol = TclGetStringFromObj(vol,&len);
if ((size_t) pathLen < len) {
continue;
}
if (strncmp(strVol, path, len) == 0) {
type = TCL_PATH_ABSOLUTE;
if (filesystemPtrPtr != NULL) {
*filesystemPtrPtr = fsRecPtr->fsPtr;
}
if (driveNameLengthPtr != NULL) {
*driveNameLengthPtr = len;
}
|
| ︙ | ︙ | |||
4564 4565 4566 4567 4568 4569 4570 |
*/
if (recursive) {
Tcl_Obj *cwdPtr = Tcl_FSGetCwd(NULL);
if (cwdPtr != NULL) {
const char *cwdStr, *normPathStr;
| | | | 4575 4576 4577 4578 4579 4580 4581 4582 4583 4584 4585 4586 4587 4588 4589 4590 4591 4592 4593 4594 4595 4596 |
*/
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, so we perform a 'cd
* [file dirname $path]'.
*/
Tcl_Obj *dirPtr = TclPathPart(NULL, pathPtr,
TCL_PATH_DIRNAME);
|
| ︙ | ︙ | |||
4685 4686 4687 4688 4689 4690 4691 | /* *--------------------------------------------------------------------------- * * Tcl_FSGetNativePath -- * * This function is for use by the Win/Unix native filesystems, so that | | | 4696 4697 4698 4699 4700 4701 4702 4703 4704 4705 4706 4707 4708 4709 4710 | /* *--------------------------------------------------------------------------- * * Tcl_FSGetNativePath -- * * This function is for use by the Win/Unix native filesystems, so that * they can easily retrieve the native (char* or WCHAR*) 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. |
| ︙ | ︙ | |||
4735 4736 4737 4738 4739 4740 4741 |
*---------------------------------------------------------------------------
*/
static void
NativeFreeInternalRep(
ClientData clientData)
{
| | | 4746 4747 4748 4749 4750 4751 4752 4753 4754 4755 4756 4757 4758 4759 4760 |
*---------------------------------------------------------------------------
*/
static void
NativeFreeInternalRep(
ClientData clientData)
{
Tcl_Free(clientData);
}
/*
*---------------------------------------------------------------------------
*
* Tcl_FSFileSystemInfo --
*
|
| ︙ | ︙ |
Changes to generic/tclIndexObj.c.
| ︙ | ︙ | |||
57 58 59 60 61 62 63 |
* pointer to one of these structures.
*
* Keep this structure declaration in sync with tclTestObj.c
*/
typedef struct {
void *tablePtr; /* Pointer to the table of strings */
| | | | 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 |
* pointer to one of these structures.
*
* Keep this structure declaration in sync with tclTestObj.c
*/
typedef struct {
void *tablePtr; /* Pointer to the table of strings */
size_t offset; /* Offset between table entries */
size_t index; /* Selected index into table. */
} IndexRep;
/*
* The following macros greatly simplify moving through a table...
*/
#define STRING_AT(table, offset) \
|
| ︙ | ︙ | |||
127 128 129 130 131 132 133 |
return result;
}
/*
* Build a string table from the list.
*/
| | | | | | 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 |
return result;
}
/*
* Build a string table from the list.
*/
tablePtr = 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;
return TCL_OK;
}
tablePtr[t] = TclGetString(objv[t]);
}
tablePtr[objc] = NULL;
result = Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr,
sizeof(char *), msg, flags | INDEX_TEMP_TABLE, indexPtr);
Tcl_Free((void *)tablePtr);
return result;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
186 187 188 189 190 191 192 |
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr, /* Object containing the string to lookup. */
const void *tablePtr, /* The first string in the table. The second
* string will be at this address plus the
* offset, the third plus the offset again,
* etc. The last entry must be NULL and there
* must not be duplicate entries. */
| | > | | | > > | > | 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 |
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 */
const char *msg, /* Identifying word to use in error
* messages. */
int flags, /* 0 or TCL_EXACT */
int *indexPtr) /* Place to store resulting integer index. */
{
int index, idx, numAbbrev;
const char *key, *p1;
const char *p2;
const char *const *entryPtr;
Tcl_Obj *resultPtr;
IndexRep *indexRep;
const Tcl_ObjIntRep *irPtr;
/* Protect against invalid values, like -1 or 0. */
if (offset+1 <= sizeof(char *)) {
offset = sizeof(char *);
}
/*
* See if there is a valid cached result from a previous lookup.
*/
if (!(flags & INDEX_TEMP_TABLE)) {
irPtr = TclFetchIntRep(objPtr, &indexType);
if (irPtr) {
indexRep = irPtr->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.
*/
|
| ︙ | ︙ | |||
269 270 271 272 273 274 275 |
/*
* 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 & INDEX_TEMP_TABLE)) {
| | > | | > | | | | | | | | | 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 |
/*
* 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 & INDEX_TEMP_TABLE)) {
irPtr = TclFetchIntRep(objPtr, &indexType);
if (irPtr) {
indexRep = irPtr->twoPtrValue.ptr1;
} else {
Tcl_ObjIntRep ir;
indexRep = Tcl_Alloc(sizeof(IndexRep));
ir.twoPtrValue.ptr1 = indexRep;
Tcl_StoreIntRep(objPtr, &indexType, &ir);
}
indexRep->tablePtr = (void *) tablePtr;
indexRep->offset = offset;
indexRep->index = index;
}
*indexPtr = index;
return TCL_OK;
error:
if (interp != NULL) {
|
| ︙ | ︙ | |||
378 379 380 381 382 383 384 |
*----------------------------------------------------------------------
*/
static void
UpdateStringOfIndex(
Tcl_Obj *objPtr)
{
| | < < | < < < < | 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 |
*----------------------------------------------------------------------
*/
static void
UpdateStringOfIndex(
Tcl_Obj *objPtr)
{
IndexRep *indexRep = TclFetchIntRep(objPtr, &indexType)->twoPtrValue.ptr1;
register const char *indexStr = EXPAND_OF(indexRep);
Tcl_InitStringRep(objPtr, indexStr, strlen(indexStr));
}
/*
*----------------------------------------------------------------------
*
* DupIndex --
*
|
| ︙ | ︙ | |||
413 414 415 416 417 418 419 |
*/
static void
DupIndex(
Tcl_Obj *srcPtr,
Tcl_Obj *dupPtr)
{
| | | > | > | | | 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 |
*/
static void
DupIndex(
Tcl_Obj *srcPtr,
Tcl_Obj *dupPtr)
{
Tcl_ObjIntRep ir;
IndexRep *dupIndexRep = Tcl_Alloc(sizeof(IndexRep));
memcpy(dupIndexRep, TclFetchIntRep(srcPtr, &indexType)->twoPtrValue.ptr1,
sizeof(IndexRep));
ir.twoPtrValue.ptr1 = dupIndexRep;
Tcl_StoreIntRep(dupPtr, &indexType, &ir);
}
/*
*----------------------------------------------------------------------
*
* FreeIndex --
*
|
| ︙ | ︙ | |||
442 443 444 445 446 447 448 |
*----------------------------------------------------------------------
*/
static void
FreeIndex(
Tcl_Obj *objPtr)
{
| | | 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 |
*----------------------------------------------------------------------
*/
static void
FreeIndex(
Tcl_Obj *objPtr)
{
Tcl_Free(TclFetchIntRep(objPtr, &indexType)->twoPtrValue.ptr1);
objPtr->typePtr = NULL;
}
/*
*----------------------------------------------------------------------
*
* TclInitPrefixCmd --
|
| ︙ | ︙ | |||
538 539 540 541 542 543 544 |
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++;
| | | 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 |
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;
|
| ︙ | ︙ | |||
628 629 630 631 632 633 634 |
static int
PrefixAllObjCmd(
ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
| | > | 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 |
static int
PrefixAllObjCmd(
ClientData clientData, /* Not used. */
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;
}
|
| ︙ | ︙ | |||
685 686 687 688 689 690 691 |
static int
PrefixLongestObjCmd(
ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
| | > | 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 |
static int
PrefixLongestObjCmd(
ClientData clientData, /* Not used. */
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;
}
|
| ︙ | ︙ | |||
808 809 810 811 812 813 814 |
Tcl_Obj *const objv[], /* Initial argument objects, which should be
* included in the error message. */
const char *message) /* Error message to print after the leading
* objects in objv. The message may be
* NULL. */
{
Tcl_Obj *objPtr;
| > | | | | > | | < | < | < | 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 |
Tcl_Obj *const objv[], /* Initial argument objects, which should be
* included in the error message. */
const char *message) /* Error message to print after the leading
* objects in objv. The message may be
* NULL. */
{
Tcl_Obj *objPtr;
int i;
size_t len, elemLen;
char flags;
Interp *iPtr = (Interp *) interp;
const char *elementStr;
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);
}
/*
* Check to see if we are processing an ensemble implementation, and if so
* rewrite the results in terms of how the ensemble was invoked.
*/
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...
*/
if (objc < toSkip) {
goto addNormalArgumentsToMessage;
}
/*
* Strip out the actual arguments that the ensemble inserted.
*/
objv += toSkip;
objc -= toSkip;
/*
* We assume no object is of index type.
*/
for (i=0 ; i<toPrint ; i++) {
/*
* Add the element, quoting it if necessary.
*/
const Tcl_ObjIntRep *irPtr;
if ((irPtr = TclFetchIntRep(origObjv[i], &indexType))) {
register IndexRep *indexRep = irPtr->twoPtrValue.ptr1;
elementStr = EXPAND_OF(indexRep);
elemLen = strlen(elementStr);
} else {
elementStr = TclGetStringFromObj(origObjv[i], &elemLen);
}
flags = 0;
len = TclScanElement(elementStr, elemLen, &flags);
if (len != elemLen) {
char *quotedElementStr = TclStackAlloc(interp, len + 1);
len = TclConvertElement(elementStr, elemLen,
quotedElementStr, flags);
Tcl_AppendToObj(objPtr, quotedElementStr, len);
TclStackFree(interp, quotedElementStr);
} else {
Tcl_AppendToObj(objPtr, elementStr, elemLen);
|
| ︙ | ︙ | |||
909 910 911 912 913 914 915 |
/*
* Now add the arguments (other than those rewritten) that the caller took
* from its calling context.
*/
addNormalArgumentsToMessage:
| | > | | | < | < | | 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 |
/*
* Now add the arguments (other than those rewritten) that the caller took
* from its calling context.
*/
addNormalArgumentsToMessage:
for (i = 0; i < objc; i++) {
/*
* 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))) {
register IndexRep *indexRep = irPtr->twoPtrValue.ptr1;
Tcl_AppendStringsToObj(objPtr, EXPAND_OF(indexRep), NULL);
} else {
/*
* Quote the argument if it contains spaces (Bug 942757).
*/
elementStr = TclGetStringFromObj(objv[i], &elemLen);
flags = 0;
len = TclScanElement(elementStr, elemLen, &flags);
if (len != elemLen) {
char *quotedElementStr = TclStackAlloc(interp, len + 1);
len = TclConvertElement(elementStr, elemLen,
quotedElementStr, flags);
Tcl_AppendToObj(objPtr, quotedElementStr, len);
TclStackFree(interp, quotedElementStr);
} else {
Tcl_AppendToObj(objPtr, elementStr, elemLen);
}
}
/*
* Append a space character (" ") if there is more text to follow
* (either another element from objv, or the message string).
*/
if (i<objc-1 || message!=NULL) {
Tcl_AppendStringsToObj(objPtr, " ", NULL);
}
}
/*
* Add any trailing message bits and set the resulting string as the
* interpreter result. Caller is responsible for reporting this as an
|
| ︙ | ︙ | |||
1023 1024 1025 1026 1027 1028 1029 |
* '-'). */
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. */
| | | | 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 |
* '-'). */
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_Alloc((1 + *objcPtr) * sizeof(Tcl_Obj *));
leftovers[0] = objv[0];
} else {
nrem = 0;
leftovers = NULL;
}
/*
|
| ︙ | ︙ | |||
1120 1121 1122 1123 1124 1125 1126 |
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\"",
| | | | 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 |
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.
|
| ︙ | ︙ | |||
1153 1154 1155 1156 1157 1158 1159 |
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\"",
| | | 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 |
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 *)
|
| ︙ | ︙ | |||
1218 1219 1220 1221 1222 1223 1224 |
if (objc > 0) {
memcpy(leftovers+nrem, objv+srcIndex, objc*sizeof(Tcl_Obj *));
nrem += objc;
}
leftovers[nrem] = NULL;
*objcPtr = nrem++;
| | | | 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 |
if (objc > 0) {
memcpy(leftovers+nrem, objv+srcIndex, objc*sizeof(Tcl_Obj *));
nrem += objc;
}
leftovers[nrem] = NULL;
*objcPtr = nrem++;
*remObjv = 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;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1275 1276 1277 1278 1279 1280 1281 |
/*
* 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++) {
| | | | 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 |
/*
* 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.
*/
|
| ︙ | ︙ | |||
1361 1362 1363 1364 1365 1366 1367 |
Tcl_Obj *value,
int *codePtr) /* Argument objects. */
{
static const char *const returnCodes[] = {
"ok", "error", "return", "break", "continue", NULL
};
| | | 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 |
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;
}
|
| ︙ | ︙ |
Changes to generic/tclInt.decls.
| ︙ | ︙ | |||
44 45 46 47 48 49 50 |
int TclCleanupChildren(Tcl_Interp *interp, int numPids, Tcl_Pid *pidPtr,
Tcl_Channel errorChan)
}
declare 6 {
void TclCleanupCommand(Command *cmdPtr)
}
declare 7 {
| | | 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 |
int TclCleanupChildren(Tcl_Interp *interp, int numPids, Tcl_Pid *pidPtr,
Tcl_Channel errorChan)
}
declare 6 {
void TclCleanupCommand(Command *cmdPtr)
}
declare 7 {
size_t TclCopyAndCollapse(size_t 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)
#}
|
| ︙ | ︙ | |||
76 77 78 79 80 81 82 |
}
# Removed in 8.5:
#declare 13 {
# int TclDoGlob(Tcl_Interp *interp, char *separators,
# Tcl_DString *headPtr, char *tail, Tcl_GlobTypeData *types)
#}
declare 14 {
| | | 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 |
}
# Removed in 8.5:
#declare 13 {
# int TclDoGlob(Tcl_Interp *interp, char *separators,
# Tcl_DString *headPtr, char *tail, Tcl_GlobTypeData *types)
#}
declare 14 {
int TclDumpMemoryInfo(void *clientData, int flags)
}
# Removed in 8.1:
# declare 15 {
# void TclExpandParseValue(ParseValue *pvPtr, int needed)
# }
declare 16 {
void TclExprFloatError(Tcl_Interp *interp, double value)
|
| ︙ | ︙ | |||
104 105 106 107 108 109 110 |
#}
#declare 21 {
# int TclFileRenameCmd(Tcl_Interp *interp, int argc, char **argv)
#}
declare 22 {
int TclFindElement(Tcl_Interp *interp, const char *listStr,
int listLength, const char **elementPtr, const char **nextPtr,
| | | | 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 |
#}
#declare 21 {
# int TclFileRenameCmd(Tcl_Interp *interp, int argc, char **argv)
#}
declare 22 {
int TclFindElement(Tcl_Interp *interp, const char *listStr,
int listLength, const char **elementPtr, const char **nextPtr,
size_t *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)
}
declare 25 {
void TclFreePackageInfo(Interp *iPtr)
}
# Removed in 8.1:
# declare 26 {
# char *TclGetCwd(Tcl_Interp *interp)
|
| ︙ | ︙ | |||
148 149 150 151 152 153 154 |
int TclGetFrame(Tcl_Interp *interp, const char *str,
CallFrame **framePtrPtr)
}
# Removed in 8.5:
#declare 33 {
# TclCmdProcType TclGetInterpProc(void)
#}
| > | | | < > | 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 |
int TclGetFrame(Tcl_Interp *interp, const char *str,
CallFrame **framePtrPtr)
}
# 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)
#}
# Removed in 8.4b2:
#declare 35 {
# Tcl_Obj *TclGetIndexedScalar(Tcl_Interp *interp, int localIndex,
# int flags)
#}
# Removed in 8.6a2:
#declare 36 {
|
| ︙ | ︙ | |||
223 224 225 226 227 228 229 |
}
# Removed in 8.5a2:
#declare 52 {
# int TclInvoke(Tcl_Interp *interp, int argc, const char **argv,
# int flags)
#}
declare 53 {
| | | | 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 |
}
# 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)
}
declare 54 {
int TclInvokeStringCommand(void *clientData, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[])
}
declare 55 {
Proc *TclIsProc(Command *cmdPtr)
}
# Replaced with TclpLoadFile in 8.1:
# declare 56 {
|
| ︙ | ︙ | |||
263 264 265 266 267 268 269 |
declare 61 {
Tcl_Obj *TclNewProcBodyObj(Proc *procPtr)
}
declare 62 {
int TclObjCommandComplete(Tcl_Obj *cmdPtr)
}
declare 63 {
| | | 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 |
declare 61 {
Tcl_Obj *TclNewProcBodyObj(Proc *procPtr)
}
declare 62 {
int TclObjCommandComplete(Tcl_Obj *cmdPtr)
}
declare 63 {
int TclObjInterpProc(void *clientData, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[])
}
declare 64 {
int TclObjInvoke(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[],
int flags)
}
# Removed in 8.5a2:
|
| ︙ | ︙ | |||
286 287 288 289 290 291 292 |
# int TclOpenFileChannelInsertProc(TclOpenFileChannelProc_ *proc)
#}
# Replaced by Tcl_FSAccess in 8.4:
#declare 68 {
# int TclpAccess(const char *path, int mode)
#}
declare 69 {
| | | | | | | 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 |
# int TclOpenFileChannelInsertProc(TclOpenFileChannelProc_ *proc)
#}
# Replaced by Tcl_FSAccess in 8.4:
#declare 68 {
# int TclpAccess(const char *path, int mode)
#}
declare 69 {
void *TclpAlloc(size_t size)
}
#declare 70 {
# int TclpCopyFile(const char *source, const char *dest)
#}
#declare 71 {
# int TclpCopyDirectory(const char *source, const char *dest,
# Tcl_DString *errorPtr)
#}
#declare 72 {
# int TclpCreateDirectory(const char *path)
#}
#declare 73 {
# int TclpDeleteFile(const char *path)
#}
declare 74 {
void TclpFree(void *ptr)
}
declare 75 {
Tcl_WideUInt TclpGetClicks(void)
}
declare 76 {
Tcl_WideUInt TclpGetSeconds(void)
}
# Removed in 9.0:
#declare 77 {
# void TclpGetTime(Tcl_Time *time)
#}
# Removed in 8.6:
#declare 78 {
# int TclpGetTimeZone(unsigned long time)
#}
# Replaced by Tcl_FSListVolumes in 8.4:
#declare 79 {
# int TclpListVolumes(Tcl_Interp *interp)
#}
# Replaced by Tcl_FSOpenFileChannel in 8.4:
#declare 80 {
# Tcl_Channel TclpOpenFileChannel(Tcl_Interp *interp, char *fileName,
# char *modeString, int permissions)
#}
declare 81 {
void *TclpRealloc(void *ptr, size_t size)
}
#declare 82 {
# int TclpRemoveDirectory(const char *path, int recursive,
# Tcl_DString *errorPtr)
#}
#declare 83 {
# int TclpRenameFile(const char *source, const char *dest)
|
| ︙ | ︙ | |||
356 357 358 359 360 361 362 |
# int flags, char **termPtr, ParseValue *pvPtr)
# }
# declare 87 {
# void TclPlatformInit(Tcl_Interp *interp)
# }
# Removed in 9.0:
#declare 88 {
| | | | | 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 |
# 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 89 {
int TclPreventAliasLoop(Tcl_Interp *interp, Tcl_Interp *cmdInterp,
Tcl_Command cmd)
}
# Removed in 8.1 (only available if compiled with TCL_COMPILE_DEBUG):
# declare 90 {
# void TclPrintByteCodeObj(Tcl_Interp *interp, Tcl_Obj *objPtr)
# }
declare 91 {
void TclProcCleanupProc(Proc *procPtr)
}
declare 92 {
int TclProcCompileProc(Tcl_Interp *interp, Proc *procPtr,
Tcl_Obj *bodyPtr, Namespace *nsPtr, const char *description,
const char *procName)
}
declare 93 {
void TclProcDeleteProc(void *clientData)
}
# Removed in 8.5:
#declare 94 {
# int TclProcInterpProc(void *clientData, Tcl_Interp *interp,
# int argc, const char **argv)
#}
# Replaced by Tcl_FSStat in 8.4:
#declare 95 {
# int TclpStat(const char *path, Tcl_StatBuf *buf)
#}
declare 96 {
|
| ︙ | ︙ | |||
461 462 463 464 465 466 467 |
#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,
| | | 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 |
#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 {
|
| ︙ | ︙ | |||
567 568 569 570 571 572 573 |
#}
declare 138 {
const char *TclGetEnv(const char *name, Tcl_DString *valuePtr)
}
#declare 139 {
# int TclpLoadFile(Tcl_Interp *interp, char *fileName, char *sym1,
# char *sym2, Tcl_PackageInitProc **proc1Ptr,
| | | | 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 |
#}
declare 138 {
const 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)
#}
#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)
}
declare 142 {
int TclSetByteCodeFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr,
CompileHookProc *hookProc, void *clientData)
}
declare 143 {
int TclAddLiteralObj(struct CompileEnv *envPtr, Tcl_Obj *objPtr,
LiteralEntry **litPtrPtr)
}
declare 144 {
void TclHideLiteral(Tcl_Interp *interp, struct CompileEnv *envPtr,
|
| ︙ | ︙ | |||
610 611 612 613 614 615 616 |
# Added for Tcl 8.2
declare 150 {
int TclRegAbout(Tcl_Interp *interp, Tcl_RegExp re)
}
declare 151 {
| | | | | | 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 |
# Added for Tcl 8.2
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)
}
declare 152 {
void TclSetLibraryPath(Tcl_Obj *pathPtr)
}
declare 153 {
Tcl_Obj *TclGetLibraryPath(void)
}
# moved to tclTest.c (static) in 8.3.2/8.4a2
#declare 154 {
# int TclTestChannelCmd(void *clientData,
# Tcl_Interp *interp, int argc, char **argv)
#}
#declare 155 {
# int TclTestChannelEventCmd(void *clientData,
# Tcl_Interp *interp, int argc, char **argv)
#}
declare 156 {
void TclRegError(Tcl_Interp *interp, const char *msg,
int status)
}
|
| ︙ | ︙ | |||
657 658 659 660 661 662 663 |
# new in 8.3.2/8.4a2
declare 161 {
int TclChannelTransform(Tcl_Interp *interp, Tcl_Channel chan,
Tcl_Obj *cmdObjPtr)
}
declare 162 {
| | | 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 |
# new in 8.3.2/8.4a2
declare 161 {
int TclChannelTransform(Tcl_Interp *interp, Tcl_Channel chan,
Tcl_Obj *cmdObjPtr)
}
declare 162 {
void TclChannelEventScriptInvoker(void *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.
|
| ︙ | ︙ | |||
699 700 701 702 703 704 705 |
#}
# REMOVED - use public Tcl_GetStartupScript()
#declare 168 {
# Tcl_Obj *TclGetStartupScriptPath(void)
#}
# variant of Tcl_UtfNCmp that takes n as bytes, not chars
declare 169 {
| | | | | | | 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 |
#}
# REMOVED - use public Tcl_GetStartupScript()
#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)
}
declare 170 {
int TclCheckInterpTraces(Tcl_Interp *interp, const char *command,
size_t 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 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)
}
# added for 8.4.3
#declare 174 {
# Tcl_Obj *TclIncrWideVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr,
# Tcl_Obj *part2Ptr, Tcl_WideInt wideIncrAmount, int part1NotParsed)
|
| ︙ | ︙ | |||
882 883 884 885 886 887 888 |
declare 213 {
Tcl_Obj *TclGetObjNameOfExecutable(void)
}
declare 214 {
void TclSetObjNameOfExecutable(Tcl_Obj *name, Tcl_Encoding encoding)
}
declare 215 {
| | | 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 |
declare 213 {
Tcl_Obj *TclGetObjNameOfExecutable(void)
}
declare 214 {
void TclSetObjNameOfExecutable(Tcl_Obj *name, Tcl_Encoding encoding)
}
declare 215 {
void *TclStackAlloc(Tcl_Interp *interp, size_t numBytes)
}
declare 216 {
void TclStackFree(Tcl_Interp *interp, void *freePtr)
}
declare 217 {
int TclPushStackFrame(Tcl_Interp *interp, Tcl_CallFrame **framePtrPtr,
Tcl_Namespace *namespacePtr, int isProcCallFrame)
|
| ︙ | ︙ | |||
909 910 911 912 913 914 915 |
Tcl_Obj *TclTraceDictPath(Tcl_Interp *interp, Tcl_Obj *rootPtr,
int keyc, Tcl_Obj *const keyv[], int flags)
}
declare 226 {
int TclObjBeingDeleted(Tcl_Obj *objPtr)
}
declare 227 {
| | | 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 |
Tcl_Obj *TclTraceDictPath(Tcl_Interp *interp, Tcl_Obj *rootPtr,
int keyc, Tcl_Obj *const keyv[], int flags)
}
declare 226 {
int TclObjBeingDeleted(Tcl_Obj *objPtr)
}
declare 227 {
void TclSetNsPath(Namespace *nsPtr, size_t 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(register Tcl_Interp *interp, Tcl_Obj *procNameObj,
# int skip, ProcErrorProc *errorProc)
|
| ︙ | ︙ | |||
964 965 966 967 968 969 970 |
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 {
| | | 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 |
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 {
|
| ︙ | ︙ | |||
1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 |
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)
}
##############################################################################
# Define the platform specific internal Tcl interface. These functions are
# only available on the designated platform.
interface tclIntPlat
| > > > > > > > > > > | 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 |
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)
}
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)
}
##############################################################################
# Define the platform specific internal Tcl interface. These functions are
# only available on the designated platform.
interface tclIntPlat
|
| ︙ | ︙ | |||
1098 1099 1100 1101 1102 1103 1104 |
#}
# Removed in 9.0:
#declare 7 win {
# int TclWinSetSockOpt(SOCKET s, int level, int optname,
# const char *optval, int optlen)
#}
declare 8 win {
| | | | 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 |
#}
# Removed in 9.0:
#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):
#declare 10 win {
# int TclWinSynchSpawn(void *args, int type, void **trans, Tcl_Pid *pidPtr)
#}
# Pipe channel functions
|
| ︙ | ︙ | |||
1156 1157 1158 1159 1160 1161 1162 |
declare 18 win {
TclFile TclpMakeFile(Tcl_Channel channel, int direction)
}
declare 19 win {
TclFile TclpOpenFile(const char *fname, int mode)
}
declare 20 win {
| | | 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 |
declare 18 win {
TclFile TclpMakeFile(Tcl_Channel channel, int direction)
}
declare 19 win {
TclFile TclpOpenFile(const char *fname, int mode)
}
declare 20 win {
void TclWinAddProcess(HANDLE hProcess, size_t id)
}
# Removed in 9.0:
#declare 21 win {
# char *TclpInetNtoa(struct in_addr addr)
#}
# removed permanently for 8.4
#declare 21 win {
|
| ︙ | ︙ | |||
1247 1248 1249 1250 1251 1252 1253 |
TclFile TclpCreateTempFile(const char *contents)
}
# Added in 8.4:
# Removed in 9.0:
#declare 10 unix {
| | | 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 |
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 {
|
| ︙ | ︙ |
Changes to generic/tclInt.h.
| ︙ | ︙ | |||
21 22 23 24 25 26 27 28 29 30 31 32 33 34 | /* * Some numerics configuration options. */ #undef ACCEPT_NAN /* * 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. */ | > > > > > > > > > > > > > > | 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 | /* * Some numerics configuration options. */ #undef ACCEPT_NAN /* * Used to tag functions that are only to be visible within the module being * built and not outside it (where this is supported by the linker). * Also used in the platform-specific *Port.h files. */ #ifndef MODULE_SCOPE # ifdef __cplusplus # define MODULE_SCOPE extern "C" # else # define MODULE_SCOPE extern # endif #endif /* * Common include files needed by most of the Tcl source files are included * here, so that system-dependent personalizations for the include files only * have to be made in once place. This results in a few extra includes, but * greater modularity. The order of the three groups of #includes is * important. For example, stdio.h is needed by tcl.h. */ |
| ︙ | ︙ | |||
46 47 48 49 50 51 52 | #endif #ifdef NO_STRING_H #include "../compat/string.h" #else #include <string.h> #endif #if defined(STDC_HEADERS) || defined(__STDC__) || defined(__C99__FUNC__) \ | | | 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 |
#endif
#ifdef NO_STRING_H
#include "../compat/string.h"
#else
#include <string.h>
#endif
#if defined(STDC_HEADERS) || defined(__STDC__) || defined(__C99__FUNC__) \
|| defined(__cplusplus) || defined(_MSC_VER) || defined(__ICC)
#include <stddef.h>
#else
typedef int ptrdiff_t;
#endif
/*
* Ensure WORDS_BIGENDIAN is defined correctly:
|
| ︙ | ︙ | |||
78 79 80 81 82 83 84 | # ifdef LITTLE_ENDIAN # if BYTE_ORDER == LITTLE_ENDIAN # undef WORDS_BIGENDIAN # endif # endif #endif | < < < < < < < < < < < < < | | | | > > > > > > > > > > > > > > > > > > > > | 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 | # ifdef LITTLE_ENDIAN # if BYTE_ORDER == LITTLE_ENDIAN # undef WORDS_BIGENDIAN # endif # endif #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)) # else # define INT2PTR(p) ((void *)(p)) # define PTR2INT(p) ((long)(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)) # else # define UINT2PTR(p) ((void *)(p)) # define PTR2UINT(p) ((unsigned long)(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. */ struct Tcl_ResolvedVarInfo; |
| ︙ | ︙ | |||
229 230 231 232 233 234 235 |
typedef struct Namespace {
char *name; /* The namespace's simple (unqualified) name.
* This contains no ::'s. The name of the
* global namespace is "" although "::" is an
* synonym. */
char *fullName; /* The namespace's fully qualified name. This
* starts with ::. */
| | | | | 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 |
typedef struct Namespace {
char *name; /* The namespace's simple (unqualified) name.
* This contains no ::'s. The name of the
* global namespace is "" although "::" is an
* synonym. */
char *fullName; /* The namespace's fully qualified name. This
* starts with ::. */
void *clientData; /* An arbitrary value associated with this
* namespace. */
Tcl_NamespaceDeleteProc *deleteProc;
/* Procedure invoked when deleting the
* namespace to, e.g., free clientData. */
struct Namespace *parentPtr;/* Points to the namespace that contains this
* one. NULL if this is the global
* namespace. */
#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
* 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
* 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
* objects. The namespace can't be freed until
* refCount becomes zero. */
Tcl_HashTable cmdTable; /* Contains all the commands currently
|
| ︙ | ︙ | |||
278 279 280 281 282 283 284 |
* 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
* registered using "namespace export". */
| | | 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 |
* 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
* registered using "namespace export". */
size_t maxExportPatterns; /* Number of export patterns for which space
* is currently allocated. */
size_t 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
|
| ︙ | ︙ | |||
323 324 325 326 327 328 329 |
* validated efficiently. */
Tcl_Ensemble *ensembles; /* List of structures that contain the details
* of the ensembles that are implemented on
* top of this namespace. */
Tcl_Obj *unknownHandlerPtr; /* A script fragment to be used when command
* resolution in this namespace fails. TIP
* 181. */
| | | 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 |
* validated efficiently. */
Tcl_Ensemble *ensembles; /* List of structures that contain the details
* of the ensembles that are implemented on
* top of this namespace. */
Tcl_Obj *unknownHandlerPtr; /* A script fragment to be used when command
* resolution in this namespace fails. TIP
* 181. */
size_t 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;
|
| ︙ | ︙ | |||
500 501 502 503 504 505 506 |
* specific C procedure whenever certain operations are performed on a
* variable.
*/
typedef struct VarTrace {
Tcl_VarTraceProc *traceProc;/* Procedure to call when operations given by
* flags are performed on variable. */
| | | | | 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 |
* specific C procedure whenever certain operations are performed on a
* variable.
*/
typedef struct VarTrace {
Tcl_VarTraceProc *traceProc;/* Procedure to call when operations given by
* flags are performed on variable. */
void *clientData; /* Argument to pass to proc. */
int flags; /* What events the trace procedure is
* interested in: OR-ed combination of
* TCL_TRACE_READS, TCL_TRACE_WRITES,
* TCL_TRACE_UNSETS and TCL_TRACE_ARRAY. */
struct VarTrace *nextPtr; /* Next in list of traces associated with a
* particular variable. */
} VarTrace;
/*
* The following structure defines a command trace, which is used to invoke a
* specific C procedure whenever certain operations are performed on a
* command.
*/
typedef struct CommandTrace {
Tcl_CommandTraceProc *traceProc;
/* Procedure to call when operations given by
* flags are performed on command. */
void *clientData; /* Argument to pass to proc. */
int flags; /* What events the trace procedure is
* interested in: OR-ed combination of
* TCL_TRACE_RENAME, TCL_TRACE_DELETE. */
struct CommandTrace *nextPtr;
/* Next in list of traces associated with a
* particular command. */
size_t refCount; /* Used to ensure this structure is not
* deleted too early. Keeps track of how many
* pieces of code have a pointer to this
* structure. */
} CommandTrace;
/*
* When a command trace is active (i.e. its associated procedure is executing)
|
| ︙ | ︙ | |||
589 590 591 592 593 594 595 |
* variable. See below for definitions. */
union {
Tcl_Obj *objPtr; /* The variable's object value. Used for
* scalar variables and array elements. */
TclVarHashTable *tablePtr;/* For array variables, this points to
* information about the hash table used to
* implement the associative array. Points to
| | | 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 |
* variable. See below for definitions. */
union {
Tcl_Obj *objPtr; /* The variable's object value. Used for
* scalar variables and array elements. */
TclVarHashTable *tablePtr;/* For array variables, this points to
* information about the hash table used to
* implement the associative array. Points to
* Tcl_Alloc-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;
|
| ︙ | ︙ | |||
896 897 898 899 900 901 902 |
*/
typedef struct CompiledLocal {
struct CompiledLocal *nextPtr;
/* Next compiler-recognized local variable for
* this procedure, or NULL if this is the last
* local. */
| | | < | | 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 |
*/
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 frameIndex; /* Index in the array of compiler-assigned
* variables in the procedure call frame. */
int flags; /* Flag bits for the local variable. Same as
* the flags for the Var structure above,
* although only VAR_ARGUMENT, VAR_TEMPORARY,
* and VAR_RESOLVED make sense. */
Tcl_Obj *defValuePtr; /* Pointer to the default value of an
* argument, if any. NULL if not an argument
* or, if an argument, no default value. */
Tcl_ResolvedVarInfo *resolveInfo;
/* Customized variable resolution info
* supplied by the Tcl_ResolveCompiledVarProc
* associated with a namespace. Each variable
* is marked by a unique tag during
* compilation, and that same tag is used to
* find the variable at runtime. */
char name[1]; /* 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! */
|
| ︙ | ︙ | |||
973 974 975 976 977 978 979 |
* clients to find out whenever a command is about to be executed.
*/
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. */
| | | 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 |
* clients to find out whenever a command is about to be executed.
*/
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. */
struct Trace *nextPtr; /* Next in list of traces for this interp. */
int flags; /* Flags governing the trace - see
* Tcl_CreateObjTrace for details. */
Tcl_CmdObjTraceDeleteProc *delProc;
/* Procedure to call when trace is deleted. */
} Trace;
|
| ︙ | ︙ | |||
1025 1026 1027 1028 1029 1030 1031 |
* associated with an interpreter. The entry contains a pointer to a function
* to call when the interpreter is deleted, and a pointer to a user-defined
* piece of data.
*/
typedef struct AssocData {
Tcl_InterpDeleteProc *proc; /* Proc to call when deleting. */
| | | 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 |
* associated with an interpreter. The entry contains a pointer to a function
* to call when the interpreter is deleted, and a pointer to a user-defined
* piece of data.
*/
typedef struct AssocData {
Tcl_InterpDeleteProc *proc; /* Proc to call when deleting. */
void *clientData; /* Value to pass to proc. */
} AssocData;
/*
* The structure below defines a call frame. A call frame defines a naming
* context for a procedure call: its local naming scope (for local variables)
* and its global naming scope (a namespace, perhaps the global :: namespace).
* A call frame can also define the naming context for a namespace eval or
|
| ︙ | ︙ | |||
1103 1104 1105 1106 1107 1108 1109 |
* Initially NULL and created if needed. */
int numCompiledLocals; /* Count of local variables recognized by the
* compiler including arguments. */
Var *compiledLocals; /* Points to the array of local variables
* recognized by the compiler. The compiler
* emits code that refers to these variables
* using an index into this array. */
| | | 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 |
* Initially NULL and created if needed. */
int numCompiledLocals; /* Count of local variables recognized by the
* compiler including arguments. */
Var *compiledLocals; /* Points to the array of local variables
* recognized by the compiler. The compiler
* emits code that refers to these variables
* using an index into this array. */
void *clientData; /* Pointer to some context that is used by
* object systems. The meaning of the contents
* of this field is defined by the code that
* sets it, and it should only ever be set by
* the code that is pushing the frame. In that
* case, the code that sets it should also
* have some means of discovering what the
* meaning of the value is, which we do not
|
| ︙ | ︙ | |||
1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 | * 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. */ /* * TIP #280 * The structure below defines a command frame. A command frame provides * location information for all commands executing a tcl script (source, eval, * uplevel, procedure bodies, ...). The runtime structure essentially contains * the stack trace as it would be if the currently executing command were to | > > > > | 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 | * 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, * uplevel, procedure bodies, ...). The runtime structure essentially contains * the stack trace as it would be if the currently executing command were to |
| ︙ | ︙ | |||
1199 1200 1201 1202 1203 1204 1205 |
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... */
| | | | 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 |
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. */
} 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
* stack. */
} CFWord;
typedef struct CFWordBC {
CmdFrame *framePtr; /* CmdFrame to access. */
size_t 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 */
|
| ︙ | ︙ | |||
1287 1288 1289 1290 1291 1292 1293 | /* * 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. */ | | | | | 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 |
/*
* 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 struct {
const char *name; /* Name of this field. */
GetFrameInfoValueProc *proc; /* Function to generate a Tcl_Obj* from the
* clientData, or just use the clientData
* directly (after casting) if NULL. */
void *clientData; /* Context for above function, or Tcl_Obj* if
* proc field is NULL. */
} ExtraFrameInfoField;
typedef struct {
size_t length; /* Length of array. */
ExtraFrameInfoField fields[2];
/* Really as long as necessary, but this is
* long enough for nearly anything. */
} ExtraFrameInfo;
/*
*----------------------------------------------------------------
|
| ︙ | ︙ | |||
1386 1387 1388 1389 1390 1391 1392 | /* * The type of procedure called from the compilation hook point in * SetByteCodeFromAny. */ typedef int (CompileHookProc)(Tcl_Interp *interp, | | | 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 |
/*
* The type of procedure called from the compilation hook point in
* SetByteCodeFromAny.
*/
typedef int (CompileHookProc)(Tcl_Interp *interp,
struct CompileEnv *compEnvPtr, void *clientData);
/*
* The data structure for a (linked list of) execution stacks.
*/
typedef struct ExecStack {
struct ExecStack *prevPtr;
|
| ︙ | ︙ | |||
1477 1478 1479 1480 1481 1482 1483 |
* 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
* table, the number of ByteCode structures
* that share the literal object; the literal
* entry can be freed when refCount drops to
| | | 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 |
* 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
* 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_AUTO_LENGTH. */
Namespace *nsPtr; /* Namespace in which this literal is used. We
* try to avoid sharing literal non-FQ command
* names among different namespaces to reduce
* shimmering. */
} LiteralEntry;
typedef struct LiteralTable {
|
| ︙ | ︙ | |||
1508 1509 1510 1511 1512 1513 1514 |
* The following structure defines for each Tcl interpreter various
* statistics-related information about the bytecode compiler and
* interpreter's operation in that interpreter.
*/
#ifdef TCL_COMPILE_STATS
typedef struct ByteCodeStats {
| | | | | | | | | | | | 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 |
* The following structure defines for each Tcl interpreter various
* statistics-related information about the bytecode compiler and
* interpreter's operation in that interpreter.
*/
#ifdef TCL_COMPILE_STATS
typedef struct ByteCodeStats {
size_t numExecutions; /* Number of ByteCodes executed. */
size_t numCompilations; /* Number of ByteCodes created. */
size_t numByteCodesFreed; /* Number of ByteCodes destroyed. */
size_t instructionCount[256]; /* Number of times each instruction was
* executed. */
double totalSrcBytes; /* Total source bytes ever compiled. */
double totalByteCodeBytes; /* Total bytes for all ByteCodes. */
double currentSrcBytes; /* Src bytes for all current ByteCodes. */
double currentByteCodeBytes;/* Code bytes in all current ByteCodes. */
size_t srcCount[32]; /* Source size distribution: # of srcs of
* size [2**(n-1)..2**n), n in [0..32). */
size_t byteCodeCount[32]; /* ByteCode size distribution. */
size_t lifetimeCount[32]; /* ByteCode lifetime distribution (ms). */
double currentInstBytes; /* Instruction bytes-current ByteCodes. */
double currentLitBytes; /* Current literal bytes. */
double currentExceptBytes; /* Current exception table bytes. */
double currentAuxBytes; /* Current auxiliary information bytes. */
double currentCmdMapBytes; /* Current src<->code map bytes. */
size_t 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. */
} ByteCodeStats;
#endif /* TCL_COMPILE_STATS */
/*
* Structure used in implementation of those core ensembles which are
* partially compiled. Used as an array of these, with a terminating field
* whose 'name' is NULL.
*/
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.
|
| ︙ | ︙ | |||
1626 1627 1628 1629 1630 1631 1632 |
* freed when refCount becomes zero. */
size_t 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. */
| | | | | 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 |
* freed when refCount becomes zero. */
size_t cmdEpoch; /* Incremented to invalidate any references
* that point to this command when it is
* renamed, deleted, hidden, or exposed. */
CompileProc *compileProc; /* Procedure called to compile command. NULL
* if no compile proc exists for command. */
Tcl_ObjCmdProc *objProc; /* Object-based command procedure. */
void *objClientData; /* Arbitrary value passed to object proc. */
Tcl_CmdProc *proc; /* String-based command procedure. */
void *clientData; /* Arbitrary value passed to string proc. */
Tcl_CmdDeleteProc *deleteProc;
/* Procedure invoked when deleting command to,
* e.g., free all client data. */
void *deleteData; /* Arbitrary value passed to deleteProc. */
int flags; /* Miscellaneous bits of information about
* command. See below for definitions. */
ImportRef *importRefPtr; /* List of each imported Command created in
* another namespace when this command is
* imported. These imported commands redirect
* invocations back to this command. The list
* is used to remove all those imported
|
| ︙ | ︙ | |||
1740 1741 1742 1743 1744 1745 1746 |
*----------------------------------------------------------------
*/
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. */
| | < | 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 |
*----------------------------------------------------------------
*/
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
* tclBasic.c, but almost every Tcl source file uses something in here.
*----------------------------------------------------------------
*/
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
|
| ︙ | ︙ | |||
1789 1790 1791 1792 1793 1794 1795 |
* 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. */
| | | 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 |
* interp is deleted. */
Namespace *globalNsPtr; /* The interpreter's global namespace. */
Tcl_HashTable *hiddenCmdTablePtr;
/* Hash table used by tclBasic.c to keep track
* of hidden commands on a per-interp
* basis. */
void *interpInfo; /* Information used by tclInterp.c to keep
* track of master/slave interps on a
* per-interp basis. */
void (*optimizer)(void *envPtr);
/*
* Information related to procedures and variables. See tclProc.c and
* tclVar.c for usage.
*/
|
| ︙ | ︙ | |||
1837 1838 1839 1840 1841 1842 1843 |
* commands for packages that aren't described
* in packageTable. Ckalloc'ed, may be
* NULL. */
/*
* Miscellaneous information:
*/
| | | 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 |
* commands for packages that aren't described
* in packageTable. Ckalloc'ed, may be
* NULL. */
/*
* Miscellaneous information:
*/
size_t 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. */
size_t compileEpoch; /* Holds the current "compilation epoch" for
* this interpreter. This is incremented to
|
| ︙ | ︙ | |||
1917 1918 1919 1920 1921 1922 1923 | * set. */ int granularityTicker; /* Counter used to determine how often to * check the limits. */ int exceeded; /* Which limits have been exceeded, described * as flag values the same as the 'active' * field. */ | | | 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 | * set. */ int granularityTicker; /* Counter used to determine how often to * check the limits. */ int exceeded; /* Which limits have been exceeded, described * as flag values the same as the 'active' * field. */ size_t cmdCount; /* Limit for how many commands to execute in * the interpreter. */ LimitHandler *cmdHandlers; /* Handlers to execute when the limit is * reached. */ int cmdGranularity; /* Mod factor used to determine how often to * evaluate the limit check. */ |
| ︙ | ︙ | |||
2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 |
* This macro is only used by tclCompile.c in the core (Bug 926445). It
* however not be made file static, as extensions that touch bytecodes
* (notably tbcload) require it.
*/
#define TCL_ALIGN(x) (((int)(x) + 7) & ~7)
/*
* The following enum values are used to specify the runtime platform setting
* of the tclPlatform variable.
*/
typedef enum {
TCL_PLATFORM_UNIX = 0, /* Any Unix-like OS. */
| > > > > > > > | 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 |
* This macro is only used by tclCompile.c in the core (Bug 926445). It
* however not be made file static, as extensions that touch bytecodes
* (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.
*/
typedef enum {
TCL_PLATFORM_UNIX = 0, /* Any Unix-like OS. */
|
| ︙ | ︙ | |||
2331 2332 2333 2334 2335 2336 2337 |
Tcl_Obj *elements; /* First list element; the struct is grown to
* accommodate all elements. */
} List;
#define LIST_MAX \
(1 + (int)(((size_t)UINT_MAX - sizeof(List))/sizeof(Tcl_Obj *)))
#define LIST_SIZE(numElems) \
| | < < < < < < | 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 |
Tcl_Obj *elements; /* First list element; the struct is grown to
* accommodate all elements. */
} List;
#define LIST_MAX \
(1 + (int)(((size_t)UINT_MAX - sizeof(List))/sizeof(Tcl_Obj *)))
#define LIST_SIZE(numElems) \
(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 ListObjGetElements(listPtr, objc, objv) \
((objv) = &(ListRepPtr(listPtr)->elements), \
(objc) = ListRepPtr(listPtr)->elemCount)
#define ListObjLength(listPtr, len) \
((len) = ListRepPtr(listPtr)->elemCount)
|
| ︙ | ︙ | |||
2380 2381 2382 2383 2384 2385 2386 | #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 | | | | | | | | | | | | 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 |
#define TCL_EACH_KEEP_NONE 0 /* Discard iteration result like [foreach] */
#define TCL_EACH_COLLECT 1 /* Collect iteration result like [lmap] */
/*
* Macros providing a faster path to booleans and integers:
* Tcl_GetBooleanFromObj, Tcl_GetLongFromObj, Tcl_GetIntFromObj
* and Tcl_GetIntForIndex.
*
* WARNING: these macros eval their args more than once.
*/
#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) \
: Tcl_GetIntFromObj((interp), (objPtr), (intPtr)))
#define TclGetIntForIndexM(interp, objPtr, endValue, idxPtr) \
(((objPtr)->typePtr == &tclIntType \
&& (objPtr)->internalRep.wideValue <= (Tcl_WideInt)(INT_MAX)) \
? ((*(idxPtr) = ((objPtr)->internalRep.wideValue >= 0) \
? (size_t)(objPtr)->internalRep.wideValue : TCL_INDEX_NONE), 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)))
/*
* Flag values for TclTraceDictPath().
*
* DICT_PATH_READ indicates that all entries on the path must exist but no
|
| ︙ | ︙ | |||
2473 2474 2475 2476 2477 2478 2479 | * been thoroughly tested and investigated a new public filesystem interface * will be released. The aim is more versatile virtual filesystem interfaces, * more efficiency in 'path' manipulation and usage, and cleaner filesystem * code internally. */ #define TCL_FILESYSTEM_VERSION_2 ((Tcl_FSVersion) 0x2) | | | 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 | * been thoroughly tested and investigated a new public filesystem interface * will be released. The aim is more versatile virtual filesystem interfaces, * more efficiency in 'path' manipulation and usage, and cleaner filesystem * code internally. */ #define TCL_FILESYSTEM_VERSION_2 ((Tcl_FSVersion) 0x2) typedef void *(TclFSGetCwdProc2)(void *clientData); typedef int (Tcl_FSLoadFileProc2) (Tcl_Interp *interp, Tcl_Obj *pathPtr, Tcl_LoadHandle *handlePtr, Tcl_FSUnloadFileProc **unloadProcPtr, int flags); /* * The following types are used for getting and storing platform-specific file * attributes in tclFCmd.c and the various platform-versions of that file. * This is done to have as much common code as possible in the file attributes |
| ︙ | ︙ | |||
2601 2602 2603 2604 2605 2606 2607 | /* *---------------------------------------------------------------------- * Type values TclGetNumberFromObj *---------------------------------------------------------------------- */ | | < | 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 | /* *---------------------------------------------------------------------- * Type values TclGetNumberFromObj *---------------------------------------------------------------------- */ #define TCL_NUMBER_INT 2 #define TCL_NUMBER_BIG 3 #define TCL_NUMBER_DOUBLE 4 #define TCL_NUMBER_NAN 5 /* *---------------------------------------------------------------- * Variables shared among Tcl modules but not used by the outside world. |
| ︙ | ︙ | |||
2628 2629 2630 2631 2632 2633 2634 | /* * TIP #233 (Virtualized Time) * Data for the time hooks, if any. */ MODULE_SCOPE Tcl_GetTimeProc *tclGetTimeProcPtr; MODULE_SCOPE Tcl_ScaleTimeProc *tclScaleTimeProcPtr; | | < < | 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 | /* * TIP #233 (Virtualized Time) * Data for the time hooks, if any. */ MODULE_SCOPE Tcl_GetTimeProc *tclGetTimeProcPtr; MODULE_SCOPE Tcl_ScaleTimeProc *tclScaleTimeProcPtr; MODULE_SCOPE void *tclTimeClientData; /* * Variables denoting the Tcl object types defined in the core. */ MODULE_SCOPE const Tcl_ObjType tclBignumType; MODULE_SCOPE const Tcl_ObjType tclBooleanType; MODULE_SCOPE const Tcl_ObjType 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; /* * Variables denoting the hash key types defined in the core. */ |
| ︙ | ︙ | |||
2667 2668 2669 2670 2671 2672 2673 | * 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 | | | | > > > > | 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 |
* 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;
#define TCL_MAX_SHARED_OBJ_STATS 5
MODULE_SCOPE size_t 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 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.
*----------------------------------------------------------------
*/
|
| ︙ | ︙ | |||
2747 2748 2749 2750 2751 2752 2753 |
/* 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_ {
| | < < < < < < | | < < | | > > > | | < | < | < | < < | | < | | > | | | | | 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 |
/* 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_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_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 */
/*
*----------------------------------------------------------------
* 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 char *end);
MODULE_SCOPE void TclArgumentEnter(Tcl_Interp *interp,
Tcl_Obj *objv[], int objc, CmdFrame *cf);
MODULE_SCOPE void TclArgumentRelease(Tcl_Interp *interp,
Tcl_Obj *objv[], int objc);
MODULE_SCOPE void TclArgumentBCEnter(Tcl_Interp *interp,
Tcl_Obj *objv[], int objc,
void *codePtr, CmdFrame *cfPtr, int cmd, 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 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 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 TclChanCaughtErrorBypass(Tcl_Interp *interp,
Tcl_Channel chan);
MODULE_SCOPE Tcl_ObjCmdProc TclChannelNamesCmd;
MODULE_SCOPE Tcl_NRPostProc TclClearRootEnsemble;
MODULE_SCOPE int TclCompareTwoNumbers(Tcl_Obj *valuePtr,
Tcl_Obj *value2Ptr);
MODULE_SCOPE ContLineLoc *TclContinuationsEnter(Tcl_Obj *objPtr, int num,
int *loc);
MODULE_SCOPE void TclContinuationsEnterDerived(Tcl_Obj *objPtr,
int start, int *clNext);
MODULE_SCOPE ContLineLoc *TclContinuationsGet(Tcl_Obj *objPtr);
MODULE_SCOPE void TclContinuationsCopy(Tcl_Obj *objPtr,
Tcl_Obj *originObjPtr);
MODULE_SCOPE size_t TclConvertElement(const char *src, size_t 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. */
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;
MODULE_SCOPE void TclCreateLateExitHandler(Tcl_ExitProc *proc,
void *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);
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);
|
| ︙ | ︙ | |||
2903 2904 2905 2906 2907 2908 2909 | MODULE_SCOPE void TclFinalizeThreadAllocThread(void); MODULE_SCOPE void TclFinalizeThreadData(int quick); MODULE_SCOPE void TclFinalizeThreadObjects(void); MODULE_SCOPE double TclFloor(const mp_int *a); MODULE_SCOPE void TclFormatNaN(double value, char *buffer); MODULE_SCOPE int TclFSFileAttrIndex(Tcl_Obj *pathPtr, const char *attributeName, int *indexPtr); | | < | < | < | < > > | | > > | | | | | < | | | > > > | > | | | | | | | | | | 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 | MODULE_SCOPE void TclFinalizeThreadAllocThread(void); MODULE_SCOPE void TclFinalizeThreadData(int quick); MODULE_SCOPE void TclFinalizeThreadObjects(void); MODULE_SCOPE double TclFloor(const 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, int *typePtr); MODULE_SCOPE int TclGetOpenModeEx(Tcl_Interp *interp, const char *modeString, int *seekFlagPtr, int *binaryPtr); MODULE_SCOPE Tcl_Obj * TclGetProcessGlobalValue(ProcessGlobalValue *pgvPtr); MODULE_SCOPE Tcl_Obj * TclGetSourceFromFrame(CmdFrame *cfPtr, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE char * TclGetStringStorage(Tcl_Obj *objPtr, 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 *); 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, 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, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int TclInfoLocalsCmd(void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int TclInfoVarsCmd(void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE void TclInitAlloc(void); MODULE_SCOPE void TclInitBignumFromWideInt(mp_int *, Tcl_WideInt); MODULE_SCOPE void TclInitBignumFromWideUInt(mp_int *, Tcl_WideUInt); MODULE_SCOPE void TclInitDbCkalloc(void); MODULE_SCOPE void TclInitDoubleConversion(void); MODULE_SCOPE void TclInitEmbeddedConfigurationInformation( Tcl_Interp *interp); MODULE_SCOPE void TclInitEncodingSubsystem(void); MODULE_SCOPE void TclInitIOSubsystem(void); MODULE_SCOPE void TclInitLimitSupport(Tcl_Interp *interp); MODULE_SCOPE void TclInitNamespaceSubsystem(void); MODULE_SCOPE void TclInitNotifier(void); MODULE_SCOPE void TclInitObjSubsystem(void); MODULE_SCOPE void TclInitSubsystems(void); MODULE_SCOPE int TclInterpReady(Tcl_Interp *interp); MODULE_SCOPE int TclIsSpaceProc(int byte); MODULE_SCOPE int TclIsBareword(int byte); MODULE_SCOPE Tcl_Obj * TclJoinPath(int elements, Tcl_Obj * const objv[], int forceRelative); MODULE_SCOPE int TclJoinThread(Tcl_ThreadId id, int *result); MODULE_SCOPE void TclLimitRemoveAllHandlers(Tcl_Interp *interp); MODULE_SCOPE Tcl_Obj * TclLindexList(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *argPtr); MODULE_SCOPE Tcl_Obj * TclLindexFlat(Tcl_Interp *interp, Tcl_Obj *listPtr, 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, int fromIdx, int toIdx); 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 TclMergeReturnOptions(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], Tcl_Obj **optionsPtrPtr, int *codePtr, int *levelPtr); MODULE_SCOPE Tcl_Obj * TclNoErrorStack(Tcl_Interp *interp, Tcl_Obj *options); MODULE_SCOPE int TclNokia770Doubles(void); MODULE_SCOPE void TclNsDecrRefCount(Namespace *nsPtr); MODULE_SCOPE int TclNamespaceDeleted(Namespace *nsPtr); MODULE_SCOPE void TclObjVarErrMsg(Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const char *operation, const char *reason, int index); MODULE_SCOPE int TclObjInvokeNamespace(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], Tcl_Namespace *nsPtr, int flags); MODULE_SCOPE int TclObjUnsetVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags); MODULE_SCOPE int TclParseBackslash(const char *src, size_t numBytes, size_t *readPtr, char *dst); MODULE_SCOPE int TclParseHex(const char *src, size_t numBytes, int *resultPtr); MODULE_SCOPE int TclParseNumber(Tcl_Interp *interp, Tcl_Obj *objPtr, const char *expected, const char *bytes, size_t 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); MODULE_SCOPE int TclProcessReturn(Tcl_Interp *interp, int code, int level, Tcl_Obj *returnOpts); MODULE_SCOPE int TclpObjLstat(Tcl_Obj *pathPtr, Tcl_StatBuf *buf); MODULE_SCOPE Tcl_Obj * TclpTempFileName(void); MODULE_SCOPE Tcl_Obj * TclpTempFileNameForLibrary(Tcl_Interp *interp, Tcl_Obj* pathPtr); MODULE_SCOPE Tcl_Obj * TclNewFSPathObj(Tcl_Obj *dirPtr, const char *addStrRep, size_t len); MODULE_SCOPE int TclpDeleteFile(const void *path); MODULE_SCOPE void TclpFinalizeCondition(Tcl_Condition *condPtr); MODULE_SCOPE void TclpFinalizeMutex(Tcl_Mutex *mutexPtr); MODULE_SCOPE void TclpFinalizePipes(void); MODULE_SCOPE void TclpFinalizeSockets(void); MODULE_SCOPE int TclCreateSocketAddress(Tcl_Interp *interp, struct addrinfo **addrlist, const char *host, int port, int willBind, const char **errorMsgPtr); MODULE_SCOPE int TclpThreadCreate(Tcl_ThreadId *idPtr, Tcl_ThreadCreateProc *proc, void *clientData, size_t stackSize, int flags); MODULE_SCOPE size_t TclpFindVariable(const char *name, size_t *lengthPtr); MODULE_SCOPE void TclpInitLibraryPath(char **valuePtr, size_t *lengthPtr, Tcl_Encoding *encodingPtr); MODULE_SCOPE void TclpInitLock(void); MODULE_SCOPE void TclpInitPlatform(void); MODULE_SCOPE void TclpInitUnlock(void); MODULE_SCOPE Tcl_Obj * TclpObjListVolumes(void); MODULE_SCOPE void TclpMasterLock(void); |
| ︙ | ︙ | |||
3055 3056 3057 3058 3059 3060 3061 | MODULE_SCOPE Tcl_PathType TclpGetNativePathType(Tcl_Obj *pathPtr, int *driveNameLengthPtr, Tcl_Obj **driveNameRef); MODULE_SCOPE int TclCrossFilesystemCopy(Tcl_Interp *interp, Tcl_Obj *source, Tcl_Obj *target); MODULE_SCOPE int TclpMatchInDirectory(Tcl_Interp *interp, Tcl_Obj *resultPtr, Tcl_Obj *pathPtr, const char *pattern, Tcl_GlobTypeData *types); | | | 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 | MODULE_SCOPE Tcl_PathType TclpGetNativePathType(Tcl_Obj *pathPtr, int *driveNameLengthPtr, Tcl_Obj **driveNameRef); MODULE_SCOPE int TclCrossFilesystemCopy(Tcl_Interp *interp, Tcl_Obj *source, Tcl_Obj *target); MODULE_SCOPE int TclpMatchInDirectory(Tcl_Interp *interp, Tcl_Obj *resultPtr, Tcl_Obj *pathPtr, const char *pattern, Tcl_GlobTypeData *types); MODULE_SCOPE void *TclpGetNativeCwd(void *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); |
| ︙ | ︙ | |||
3079 3080 3081 3082 3083 3084 3085 | void *data); MODULE_SCOPE TCL_NORETURN void TclpThreadExit(int status); MODULE_SCOPE void TclRememberCondition(Tcl_Condition *mutex); MODULE_SCOPE void TclRememberJoinableThread(Tcl_ThreadId id); MODULE_SCOPE void TclRememberMutex(Tcl_Mutex *mutex); MODULE_SCOPE void TclRemoveScriptLimitCallbacks(Tcl_Interp *interp); MODULE_SCOPE int TclReToGlob(Tcl_Interp *interp, const char *reStr, | | | | > | > > > > > > | | | | | | | | | > > > > > > > > > > > > > > > | | > > > > > > > > > > > > > > > > < | | | | | | | | | | | | | | | | | | | < | | | | | | | | | < | | | | | | | | | | | | | | | | | | | > > > | | > > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > > | | | | | | | | | | | 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 3505 3506 3507 3508 3509 3510 3511 | void *data); MODULE_SCOPE TCL_NORETURN void TclpThreadExit(int status); MODULE_SCOPE void TclRememberCondition(Tcl_Condition *mutex); MODULE_SCOPE void TclRememberJoinableThread(Tcl_ThreadId id); MODULE_SCOPE void TclRememberMutex(Tcl_Mutex *mutex); MODULE_SCOPE void TclRemoveScriptLimitCallbacks(Tcl_Interp *interp); MODULE_SCOPE int TclReToGlob(Tcl_Interp *interp, const char *reStr, size_t reStrLen, Tcl_DString *dsPtr, int *flagsPtr, int *quantifiersFoundPtr); MODULE_SCOPE size_t TclScanElement(const char *string, size_t length, char *flagPtr); MODULE_SCOPE void TclSetBgErrorHandler(Tcl_Interp *interp, Tcl_Obj *cmdPrefix); MODULE_SCOPE void TclSetBignumIntRep(Tcl_Obj *objPtr, mp_int *bignumValue); MODULE_SCOPE int TclSetBooleanFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); MODULE_SCOPE void TclSetCmdNameObj(Tcl_Interp *interp, Tcl_Obj *objPtr, Command *cmdPtr); MODULE_SCOPE void TclSetDuplicateObj(Tcl_Obj *dupPtr, Tcl_Obj *objPtr); MODULE_SCOPE void TclSetProcessGlobalValue(ProcessGlobalValue *pgvPtr, Tcl_Obj *newValue, Tcl_Encoding encoding); MODULE_SCOPE void TclSignalExitThread(Tcl_ThreadId id, int result); MODULE_SCOPE void TclSpellFix(Tcl_Interp *interp, Tcl_Obj *const *objv, int objc, 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, 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 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); #if (TCL_UTF_MAX > 4) && (defined(__CYGWIN__) || defined(_WIN32)) MODULE_SCOPE int TclUtfToWChar(const char *src, WCHAR *chPtr); MODULE_SCOPE char * TclWCharToUtfDString(const WCHAR *uniStr, int uniLength, Tcl_DString *dsPtr); MODULE_SCOPE WCHAR * TclUtfToWCharDString(const char *src, int length, Tcl_DString *dsPtr); #else # define TclUtfToWChar TclUtfToUniChar # define TclWCharToUtfDString Tcl_UniCharToUtfDString # define TclUtfToWCharDString Tcl_UtfToUniCharDString #endif 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); MODULE_SCOPE Tcl_Obj * TclpNativeToNormalized(void *clientData); MODULE_SCOPE Tcl_Obj * TclpFilesystemPathType(Tcl_Obj *pathPtr); MODULE_SCOPE int TclpDlopen(Tcl_Interp *interp, Tcl_Obj *pathPtr, Tcl_LoadHandle *loadHandle, Tcl_FSUnloadFileProc **unloadProcPtr, int flags); MODULE_SCOPE int TclpUtime(Tcl_Obj *pathPtr, struct utimbuf *tval); #ifdef TCL_LOAD_FROM_MEMORY MODULE_SCOPE void * TclpLoadMemoryGetBuffer(Tcl_Interp *interp, int size); MODULE_SCOPE int TclpLoadMemory(Tcl_Interp *interp, void *buffer, int size, int codeSize, Tcl_LoadHandle *loadHandle, Tcl_FSUnloadFileProc **unloadProcPtr, int flags); #endif MODULE_SCOPE void TclInitThreadStorage(void); MODULE_SCOPE void TclFinalizeThreadDataThread(void); MODULE_SCOPE void TclFinalizeThreadStorage(void); #ifdef TCL_WIDE_CLICKS MODULE_SCOPE Tcl_WideInt TclpGetWideClicks(void); MODULE_SCOPE double TclpWideClicksToNanoseconds(Tcl_WideInt clicks); MODULE_SCOPE double TclpWideClickInMicrosec(void); #else # ifdef _WIN32 # define TCL_WIDE_CLICKS 1 MODULE_SCOPE Tcl_WideInt TclpGetWideClicks(void); MODULE_SCOPE double TclpWideClickInMicrosec(void); # define TclpWideClicksToNanoseconds(clicks) \ ((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 TclpThreadSetMasterTSD(void *tsdKeyPtr, void *ptr); MODULE_SCOPE void * TclpThreadGetMasterTSD(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); /* *---------------------------------------------------------------- * 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, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE Tcl_Command TclInitChanCmd(Tcl_Interp *interp); MODULE_SCOPE int TclChanCreateObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int TclChanPostEventObjCmd(void *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, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_CloseObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_ConcatObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_ContinueObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE Tcl_TimerToken TclCreateAbsoluteTimerHandler( Tcl_Time *timePtr, Tcl_TimerProc *proc, void *clientData); MODULE_SCOPE int TclDefaultBgErrorHandlerObjCmd( void *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, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_FconfigureObjCmd( void *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, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE Tcl_Command TclInitInfoCmd(Tcl_Interp *interp); MODULE_SCOPE int Tcl_InterpObjCmd(void *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, 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, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* *---------------------------------------------------------------- * Compilation procedures for commands in the generic core: *---------------------------------------------------------------- |
| ︙ | ︙ | |||
3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 | 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 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); | > > > | 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 | 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); |
| ︙ | ︙ | |||
3651 3652 3653 3654 3655 3656 3657 3658 3659 3660 3661 3662 3663 3664 | 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 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); | > > > | 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 3729 3730 3731 3732 | 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); |
| ︙ | ︙ | |||
3761 3762 3763 3764 3765 3766 3767 | 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); | | | | | | | | | | | | | | | | | | < < < < < < < < < < < < < < < < < < | | | | | | | 3829 3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 3846 3847 3848 3849 3850 3851 3852 3853 3854 3855 3856 3857 3858 3859 3860 3861 3862 3863 3864 3865 3866 3867 3868 3869 3870 3871 3872 3873 3874 3875 3876 3877 3878 3879 3880 3881 3882 3883 3884 3885 3886 3887 3888 3889 3890 3891 3892 3893 3894 3895 3896 3897 3898 3899 3900 3901 3902 3903 3904 3905 3906 3907 3908 3909 3910 3911 3912 3913 3914 3915 3916 3917 3918 3919 3920 3921 3922 3923 3924 3925 3926 3927 3928 3929 3930 3931 3932 3933 3934 3935 3936 3937 3938 3939 3940 3941 3942 3943 3944 3945 3946 3947 3948 3949 3950 3951 3952 3953 3954 3955 3956 3957 3958 3959 3960 3961 3962 3963 3964 3965 3966 3967 3968 3969 3970 3971 3972 3973 3974 3975 3976 3977 3978 3979 3980 3981 3982 | 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, 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, 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, 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, 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, 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, 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, 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, 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, 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, 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, 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, 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, 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, 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, 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, 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, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int TclCompileDivOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileLessOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileLeqOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileGreaterOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileGeqOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileEqOpCmd(Tcl_Interp *interp, 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 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 size_t TclStringFirst(Tcl_Obj *needle, Tcl_Obj *haystack, size_t start); MODULE_SCOPE size_t 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) |
| ︙ | ︙ | |||
3977 3978 3979 3980 3981 3982 3983 3984 3985 3986 3987 3988 3989 3990 3991 3992 3993 3994 3995 3996 3997 3998 3999 4000 4001 4002 |
int flags, int leaveErrMsg, int index);
/*
* So tclObj.c and tclDictObj.c can share these implementations.
*/
MODULE_SCOPE int TclCompareObjKeys(void *keyPtr, Tcl_HashEntry *hPtr);
MODULE_SCOPE void TclFreeObjEntry(Tcl_HashEntry *hPtr);
MODULE_SCOPE TCL_HASH_TYPE TclHashObjKey(Tcl_HashTable *tablePtr, void *keyPtr);
MODULE_SCOPE int TclFullFinalizationRequested(void);
/*
* 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. */
| > > > > > > > > > > > > > > | > > > > > > > | | | < | < | 4027 4028 4029 4030 4031 4032 4033 4034 4035 4036 4037 4038 4039 4040 4041 4042 4043 4044 4045 4046 4047 4048 4049 4050 4051 4052 4053 4054 4055 4056 4057 4058 4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 4070 4071 4072 4073 4074 4075 4076 4077 4078 4079 4080 4081 4082 4083 4084 4085 4086 4087 4088 4089 4090 4091 4092 4093 4094 4095 4096 4097 4098 4099 4100 4101 4102 |
int flags, int leaveErrMsg, int index);
/*
* So tclObj.c and tclDictObj.c can share these implementations.
*/
MODULE_SCOPE int TclCompareObjKeys(void *keyPtr, Tcl_HashEntry *hPtr);
MODULE_SCOPE void TclFreeObj(Tcl_Obj *objPtr);
MODULE_SCOPE void TclFreeObjEntry(Tcl_HashEntry *hPtr);
MODULE_SCOPE TCL_HASH_TYPE TclHashObjKey(Tcl_HashTable *tablePtr, void *keyPtr);
MODULE_SCOPE int TclFullFinalizationRequested(void);
/*
* Just for the purposes of command-type registration.
*/
MODULE_SCOPE Tcl_ObjCmdProc TclEnsembleImplementationCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclAliasObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclLocalAliasObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclSlaveObjCmd;
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);
/*
* 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)
/*
*----------------------------------------------------------------
* Macros used by the Tcl core to create and release Tcl objects.
* TclNewObj(objPtr) creates a new object denoting an empty string.
* TclDecrRefCount(objPtr) decrements the object's reference count, and frees
* the object if its reference count is zero. These macros are inline versions
|
| ︙ | ︙ | |||
4087 4088 4089 4090 4091 4092 4093 |
(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
| | | < < < < | | | | | | | | | | | | | > | > > | | | | | 4156 4157 4158 4159 4160 4161 4162 4163 4164 4165 4166 4167 4168 4169 4170 4171 4172 4173 4174 4175 4176 4177 4178 4179 4180 4181 4182 4183 4184 4185 4186 4187 4188 4189 4190 4191 4192 4193 4194 4195 4196 4197 4198 4199 4200 4201 4202 4203 4204 4205 4206 4207 4208 4209 4210 4211 |
(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_AUTO_LENGTH'.
* Use empty 'if ; else' to handle use in unbraced outer if/else conditions.
*/
# define TclDecrRefCount(objPtr) \
if ((objPtr)->refCount-- > 1) ; else { \
if (!(objPtr)->typePtr || !(objPtr)->typePtr->freeIntRepProc) { \
TCL_DTRACE_OBJ_FREE(objPtr); \
if ((objPtr)->bytes \
&& ((objPtr)->bytes != &tclEmptyString)) { \
Tcl_Free((objPtr)->bytes); \
} \
(objPtr)->length = TCL_AUTO_LENGTH; \
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) \
(objPtr) = (Tcl_Obj *) Tcl_Alloc(sizeof(Tcl_Obj))
# define TclFreeObjStorageEx(interp, objPtr) \
Tcl_Free(objPtr)
#undef USE_THREAD_ALLOC
#undef USE_TCLALLOC
#elif TCL_THREADS && defined(USE_THREAD_ALLOC)
/*
* The TCL_THREADS mode is like the regular mode but allocates Tcl_Obj's from
* per-thread caches.
*/
MODULE_SCOPE Tcl_Obj * TclThreadAllocObj(void);
|
| ︙ | ︙ | |||
4194 4195 4196 4197 4198 4199 4200 |
#if defined(USE_TCLALLOC) && USE_TCLALLOC
MODULE_SCOPE void TclFinalizeAllocSubsystem();
MODULE_SCOPE void TclInitAlloc();
#else
# define USE_TCLALLOC 0
#endif
| | | 4262 4263 4264 4265 4266 4267 4268 4269 4270 4271 4272 4273 4274 4275 4276 |
#if defined(USE_TCLALLOC) && USE_TCLALLOC
MODULE_SCOPE void TclFinalizeAllocSubsystem();
MODULE_SCOPE void TclInitAlloc();
#else
# define USE_TCLALLOC 0
#endif
#if TCL_THREADS
/* declared in tclObj.c */
MODULE_SCOPE Tcl_Mutex tclObjMutex;
#endif
# define TclAllocObjStorageEx(interp, objPtr) \
do { \
Tcl_MutexLock(&tclObjMutex); \
|
| ︙ | ︙ | |||
4265 4266 4267 4268 4269 4270 4271 |
*/
#define TclInitStringRep(objPtr, bytePtr, len) \
if ((len) == 0) { \
(objPtr)->bytes = &tclEmptyString; \
(objPtr)->length = 0; \
} else { \
| | | > > > > > > > > > > > > > > > > > > > | > | > > > | > > > > > | 4333 4334 4335 4336 4337 4338 4339 4340 4341 4342 4343 4344 4345 4346 4347 4348 4349 4350 4351 4352 4353 4354 4355 4356 4357 4358 4359 4360 4361 4362 4363 4364 4365 4366 4367 4368 4369 4370 4371 4372 4373 4374 4375 4376 4377 4378 4379 4380 4381 4382 4383 4384 4385 4386 4387 4388 4389 4390 4391 4392 4393 4394 4395 4396 4397 4398 4399 |
*/
#define TclInitStringRep(objPtr, bytePtr, len) \
if ((len) == 0) { \
(objPtr)->bytes = &tclEmptyString; \
(objPtr)->length = 0; \
} else { \
(objPtr)->bytes = Tcl_Alloc((len) + 1); \
memcpy((objPtr)->bytes, (bytePtr) ? (bytePtr) : &tclEmptyString, (len)); \
(objPtr)->bytes[len] = '\0'; \
(objPtr)->length = (len); \
}
/*
*----------------------------------------------------------------
* Macro used by the Tcl core to get the string representation's byte array
* pointer from a Tcl_Obj. This is an inline version of Tcl_GetString(). The
* macro's expression result is the string rep's byte pointer which might be
* NULL. The bytes referenced by this pointer must not be modified by the
* caller. The ANSI C "prototype" for this macro is:
*
* MODULE_SCOPE char * TclGetString(Tcl_Obj *objPtr);
*----------------------------------------------------------------
*/
#define TclGetString(objPtr) \
((objPtr)->bytes? (objPtr)->bytes : Tcl_GetString(objPtr))
#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);
}
return response;
}
#else
#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), \
(unsigned char *)(((size_t *) (objPtr)->internalRep.twoPtrValue.ptr1) + 2)) : NULL)
#endif
/*
*----------------------------------------------------------------
* Macro used by the Tcl core to clean out an object's internal
* representation. Does not actually reset the rep's bytes. The ANSI C
* "prototype" for this macro is:
*
|
| ︙ | ︙ | |||
4321 4322 4323 4324 4325 4326 4327 |
* MODULE_SCOPE void TclInvalidateStringRep(Tcl_Obj *objPtr);
*----------------------------------------------------------------
*/
#define TclInvalidateStringRep(objPtr) \
if ((objPtr)->bytes != NULL) { \
if ((objPtr)->bytes != &tclEmptyString) { \
| | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 4417 4418 4419 4420 4421 4422 4423 4424 4425 4426 4427 4428 4429 4430 4431 4432 4433 4434 4435 4436 4437 4438 4439 4440 4441 4442 4443 4444 4445 4446 4447 4448 4449 4450 4451 4452 4453 4454 4455 4456 4457 4458 4459 4460 4461 4462 4463 4464 4465 4466 4467 4468 4469 4470 4471 4472 |
* MODULE_SCOPE void TclInvalidateStringRep(Tcl_Obj *objPtr);
*----------------------------------------------------------------
*/
#define TclInvalidateStringRep(objPtr) \
if ((objPtr)->bytes != NULL) { \
if ((objPtr)->bytes != &tclEmptyString) { \
Tcl_Free((objPtr)->bytes); \
} \
(objPtr)->bytes = NULL; \
}
/*
*----------------------------------------------------------------
* 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 { \
register Tcl_Obj *bignumObj = (objPtr); \
register int bignumPayload = \
PTR2INT(bignumObj->internalRep.twoPtrValue.ptr2); \
if (bignumPayload == -1) { \
(bignum) = *((mp_int *) bignumObj->internalRep.twoPtrValue.ptr1); \
} else { \
(bignum).dp = bignumObj->internalRep.twoPtrValue.ptr1; \
(bignum).sign = bignumPayload >> 30; \
(bignum).alloc = (bignumPayload >> 15) & 0x7fff; \
(bignum).used = bignumPayload & 0x7fff; \
} \
} while (0)
/*
*----------------------------------------------------------------
* Macros used by the Tcl core to grow Tcl_Token arrays. They use the same
* growth algorithm as used in tclStringObj.c for growing strings. The ANSI C
* "prototype" for this macro is:
*
* MODULE_SCOPE void TclGrowTokenArray(Tcl_Token *tokenPtr, int used,
|
| ︙ | ︙ | |||
4373 4374 4375 4376 4377 4378 4379 |
Tcl_Token *newPtr; \
if (oldPtr == (staticPtr)) { \
oldPtr = NULL; \
} \
if (allocated > TCL_MAX_TOKENS) { \
allocated = TCL_MAX_TOKENS; \
} \
| | | | | | | 4506 4507 4508 4509 4510 4511 4512 4513 4514 4515 4516 4517 4518 4519 4520 4521 4522 4523 4524 4525 4526 4527 4528 4529 4530 4531 4532 4533 |
Tcl_Token *newPtr; \
if (oldPtr == (staticPtr)) { \
oldPtr = NULL; \
} \
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)
#define TclGrowParseTokenArray(parsePtr, append) \
TclGrowTokenArray((parsePtr)->tokenPtr, (parsePtr)->numTokens, \
|
| ︙ | ︙ | |||
4422 4423 4424 4425 4426 4427 4428 | *---------------------------------------------------------------- * 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, | | | 4555 4556 4557 4558 4559 4560 4561 4562 4563 4564 4565 4566 4567 4568 4569 |
*----------------------------------------------------------------
* 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); \
|
| ︙ | ︙ | |||
4454 4455 4456 4457 4458 4459 4460 4461 4462 4463 4464 4465 4466 4467 | * The ANSI C "prototype" for this macro is: * * MODULE_SCOPE int TclIsPureByteArray(Tcl_Obj *objPtr); *---------------------------------------------------------------- */ MODULE_SCOPE int TclIsPureByteArray(Tcl_Obj *objPtr); /* *---------------------------------------------------------------- * 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 * lexically correct on little-endian systems. The ANSI C "prototype" for * this macro is: | > > > > > > > | 4587 4588 4589 4590 4591 4592 4593 4594 4595 4596 4597 4598 4599 4600 4601 4602 4603 4604 4605 4606 4607 | * The ANSI C "prototype" for this macro is: * * MODULE_SCOPE int TclIsPureByteArray(Tcl_Obj *objPtr); *---------------------------------------------------------------- */ MODULE_SCOPE int TclIsPureByteArray(Tcl_Obj *objPtr); #define TclIsPureDict(objPtr) \ (((objPtr)->bytes==NULL) && ((objPtr)->typePtr==&tclDictType)) #define TclHasIntRep(objPtr, type) \ ((objPtr)->typePtr == (type)) #define TclFetchIntRep(objPtr, type) \ (TclHasIntRep((objPtr), (type)) ? &((objPtr)->internalRep) : 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 * lexically correct on little-endian systems. The ANSI C "prototype" for * this macro is: |
| ︙ | ︙ | |||
4542 4543 4544 4545 4546 4547 4548 4549 |
* MODULE_SCOPE void TclSetIntObj(Tcl_Obj *objPtr, Tcl_WideInt w);
* MODULE_SCOPE void TclSetDoubleObj(Tcl_Obj *objPtr, double d);
*----------------------------------------------------------------
*/
#define TclSetIntObj(objPtr, i) \
do { \
TclInvalidateStringRep(objPtr); \
| > > | < < | > > | | < < | 4682 4683 4684 4685 4686 4687 4688 4689 4690 4691 4692 4693 4694 4695 4696 4697 4698 4699 4700 4701 4702 4703 4704 4705 4706 4707 |
* MODULE_SCOPE void TclSetIntObj(Tcl_Obj *objPtr, Tcl_WideInt w);
* MODULE_SCOPE void TclSetDoubleObj(Tcl_Obj *objPtr, double d);
*----------------------------------------------------------------
*/
#define TclSetIntObj(objPtr, i) \
do { \
Tcl_ObjIntRep ir; \
ir.wideValue = (Tcl_WideInt) i; \
TclInvalidateStringRep(objPtr); \
Tcl_StoreIntRep(objPtr, &tclIntType, &ir); \
} while (0)
#define TclSetDoubleObj(objPtr, d) \
do { \
Tcl_ObjIntRep ir; \
ir.doubleValue = (double) d; \
TclInvalidateStringRep(objPtr); \
Tcl_StoreIntRep(objPtr, &tclDoubleType, &ir); \
} while (0)
/*
*----------------------------------------------------------------
* Macros used by the Tcl core to create and initialise objects of standard
* types, avoiding the corresponding function calls in time critical parts of
* the core. The ANSI C "prototypes" for these macros are:
|
| ︙ | ︙ | |||
4632 4633 4634 4635 4636 4637 4638 | * * MODULE_SCOPE char * TclDStringAppendLiteral(Tcl_DString *dsPtr, * const char *sLiteral); * MODULE_SCOPE void TclDStringClear(Tcl_DString *dsPtr); */ #define TclDStringAppendLiteral(dsPtr, sLiteral) \ | | | 4772 4773 4774 4775 4776 4777 4778 4779 4780 4781 4782 4783 4784 4785 4786 |
*
* 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)
/*
*----------------------------------------------------------------
* Macros used by the Tcl core to test for some special double values.
* The ANSI C "prototypes" for these macros are:
|
| ︙ | ︙ | |||
4657 4658 4659 4660 4661 4662 4663 | # ifdef NO_ISNAN # define TclIsNaN(d) ((d) != (d)) # else # define TclIsNaN(d) (isnan(d)) # endif #endif | < < < < < | | < < | | 4797 4798 4799 4800 4801 4802 4803 4804 4805 4806 4807 4808 4809 4810 4811 4812 4813 | # ifdef NO_ISNAN # define TclIsNaN(d) ((d) != (d)) # else # define TclIsNaN(d) (isnan(d)) # endif #endif /* Workaround for platforms missing offsetof(), e.g. VC++ 6.0 */ #ifndef offsetof # define offsetof(type, field) ((size_t) ((char *) &((type *) 0)->field)) #endif /* *---------------------------------------------------------------- * Inline version of Tcl_GetCurrentNamespace and Tcl_GetGlobalNamespace. */ |
| ︙ | ︙ | |||
4688 4689 4690 4691 4692 4693 4694 |
*----------------------------------------------------------------
* Inline version of TclCleanupCommand; still need the function as it is in
* the internal stubs, but the core can use the macro instead.
*/
#define TclCleanupCommandMacro(cmdPtr) \
if ((cmdPtr)->refCount-- <= 1) { \
| | | 4821 4822 4823 4824 4825 4826 4827 4828 4829 4830 4831 4832 4833 4834 4835 |
*----------------------------------------------------------------
* Inline version of TclCleanupCommand; still need the function as it is in
* the internal stubs, but the core can use the macro instead.
*/
#define TclCleanupCommandMacro(cmdPtr) \
if ((cmdPtr)->refCount-- <= 1) { \
Tcl_Free(cmdPtr);\
}
/*
*----------------------------------------------------------------
* Inline versions of Tcl_LimitReady() and Tcl_LimitExceeded to limit number
* of calls out of the critical path. Note that this code isn't particularly
* readable; the non-inline version (in tclInterp.c) is much easier to
|
| ︙ | ︙ | |||
4751 4752 4753 4754 4755 4756 4757 |
#ifndef TCL_MEM_DEBUG
#define TclSmallAllocEx(interp, nbytes, memPtr) \
do { \
Tcl_Obj *_objPtr; \
TCL_CT_ASSERT((nbytes)<=sizeof(Tcl_Obj)); \
TclIncrObjsAllocated(); \
| | | | | > > > > > > > > > > > > > > > | 4884 4885 4886 4887 4888 4889 4890 4891 4892 4893 4894 4895 4896 4897 4898 4899 4900 4901 4902 4903 4904 4905 4906 4907 4908 4909 4910 4911 4912 4913 4914 4915 4916 4917 4918 4919 4920 4921 4922 4923 4924 4925 4926 4927 4928 4929 4930 4931 4932 4933 4934 4935 4936 4937 4938 4939 4940 4941 |
#ifndef TCL_MEM_DEBUG
#define TclSmallAllocEx(interp, nbytes, memPtr) \
do { \
Tcl_Obj *_objPtr; \
TCL_CT_ASSERT((nbytes)<=sizeof(Tcl_Obj)); \
TclIncrObjsAllocated(); \
TclAllocObjStorageEx((interp), _objPtr); \
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); \
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 */
/*
* Macros to convert size_t to wide-int (and wide-int object) considering
* platform-related negative value ((size_t)-1), if wide-int and size_t
* have different dimensions (e. g. 32-bit platform).
*/
#if (!defined(TCL_WIDE_INT_IS_LONG) || (LONG_MAX > UINT_MAX)) && (SIZE_MAX <= UINT_MAX)
# define TclWideIntFromSize(value) (((Tcl_WideInt)(((size_t)(value))+1))-1)
# define TclNewWideIntObjFromSize(value) \
Tcl_NewWideIntObj(TclWideIntFromSize(value))
#else
# define TclWideIntFromSize(value) ((Tcl_WideInt)(value))
# define TclNewWideIntObjFromSize Tcl_NewWideIntObj
#endif
/*
* Support for Clang Static Analyzer <http://clang-analyzer.llvm.org>
*/
#if defined(PURIFY) && defined(__clang__)
#if __has_feature(attribute_analyzer_noreturn) && \
!defined(Tcl_Panic) && defined(Tcl_Panic_TCL_DECLARED)
|
| ︙ | ︙ | |||
4816 4817 4818 4819 4820 4821 4822 |
* 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;
| | | | | | | | | | | | 4964 4965 4966 4967 4968 4969 4970 4971 4972 4973 4974 4975 4976 4977 4978 4979 4980 4981 4982 4983 4984 4985 4986 4987 4988 4989 4990 4991 4992 4993 4994 4995 4996 4997 4998 4999 5000 5001 5002 5003 5004 5005 5006 5007 5008 5009 5010 5011 5012 5013 5014 5015 5016 5017 5018 5019 5020 5021 5022 5023 5024 5025 5026 5027 5028 |
* 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"
#include "tclTomMathDecls.h"
#if !defined(USE_TCL_STUBS) && !defined(TCL_MEM_DEBUG)
#define Tcl_AttemptAlloc TclpAlloc
#define Tcl_AttemptRealloc TclpRealloc
#define Tcl_Free TclpFree
#endif
#endif /* _TCLINT */
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclIntDecls.h.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 | * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #ifndef _TCLINTDECLS #define _TCLINTDECLS | < | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #ifndef _TCLINTDECLS #define _TCLINTDECLS /* * 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. */ |
| ︙ | ︙ | |||
41 42 43 44 45 46 47 | /* Slot 4 is reserved */ /* 5 */ TCLAPI int TclCleanupChildren(Tcl_Interp *interp, int numPids, Tcl_Pid *pidPtr, Tcl_Channel errorChan); /* 6 */ TCLAPI void TclCleanupCommand(Command *cmdPtr); /* 7 */ | | | | | | < < | 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 | /* Slot 4 is reserved */ /* 5 */ TCLAPI int TclCleanupChildren(Tcl_Interp *interp, int numPids, Tcl_Pid *pidPtr, Tcl_Channel errorChan); /* 6 */ TCLAPI void TclCleanupCommand(Command *cmdPtr); /* 7 */ TCLAPI size_t TclCopyAndCollapse(size_t count, const char *src, char *dst); /* Slot 8 is reserved */ /* 9 */ TCLAPI int TclCreatePipeline(Tcl_Interp *interp, int argc, const char **argv, Tcl_Pid **pidArrayPtr, TclFile *inPipePtr, TclFile *outPipePtr, TclFile *errFilePtr); /* 10 */ TCLAPI int TclCreateProc(Tcl_Interp *interp, Namespace *nsPtr, const char *procName, Tcl_Obj *argsPtr, Tcl_Obj *bodyPtr, Proc **procPtrPtr); /* 11 */ TCLAPI void TclDeleteCompiledLocalVars(Interp *iPtr, CallFrame *framePtr); /* 12 */ TCLAPI void TclDeleteVars(Interp *iPtr, TclVarHashTable *tablePtr); /* Slot 13 is reserved */ /* 14 */ TCLAPI int TclDumpMemoryInfo(void *clientData, int flags); /* Slot 15 is reserved */ /* 16 */ TCLAPI void TclExprFloatError(Tcl_Interp *interp, double value); /* Slot 17 is reserved */ /* Slot 18 is reserved */ /* Slot 19 is reserved */ /* Slot 20 is reserved */ /* Slot 21 is reserved */ /* 22 */ TCLAPI int TclFindElement(Tcl_Interp *interp, const char *listStr, int listLength, const char **elementPtr, const char **nextPtr, size_t *sizePtr, int *bracePtr); /* 23 */ TCLAPI Proc * TclFindProc(Interp *iPtr, const char *procName); /* 24 */ TCLAPI size_t TclFormatInt(char *buffer, Tcl_WideInt n); /* 25 */ TCLAPI void TclFreePackageInfo(Interp *iPtr); /* Slot 26 is reserved */ /* Slot 27 is reserved */ /* 28 */ TCLAPI Tcl_Channel TclpGetDefaultStdChannel(int type); /* Slot 29 is reserved */ /* Slot 30 is reserved */ /* 31 */ TCLAPI const char * TclGetExtension(const char *name); /* 32 */ TCLAPI int TclGetFrame(Tcl_Interp *interp, const char *str, CallFrame **framePtrPtr); /* Slot 33 is reserved */ /* Slot 34 is reserved */ /* Slot 35 is reserved */ /* Slot 36 is reserved */ /* 37 */ TCLAPI int TclGetLoadedPackages(Tcl_Interp *interp, const char *targetName); /* 38 */ TCLAPI int TclGetNamespaceForQualName(Tcl_Interp *interp, |
| ︙ | ︙ | |||
137 138 139 140 141 142 143 | /* 50 */ TCLAPI void TclInitCompiledLocals(Tcl_Interp *interp, CallFrame *framePtr, Namespace *nsPtr); /* 51 */ TCLAPI int TclInterpInit(Tcl_Interp *interp); /* Slot 52 is reserved */ /* 53 */ | | | | | | | | | | | 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 | /* 50 */ TCLAPI void TclInitCompiledLocals(Tcl_Interp *interp, CallFrame *framePtr, Namespace *nsPtr); /* 51 */ TCLAPI int TclInterpInit(Tcl_Interp *interp); /* Slot 52 is reserved */ /* 53 */ TCLAPI int TclInvokeObjectCommand(void *clientData, Tcl_Interp *interp, int argc, const char **argv); /* 54 */ TCLAPI int TclInvokeStringCommand(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 55 */ TCLAPI Proc * TclIsProc(Command *cmdPtr); /* Slot 56 is reserved */ /* Slot 57 is reserved */ /* 58 */ TCLAPI Var * TclLookupVar(Tcl_Interp *interp, const char *part1, const char *part2, int flags, const char *msg, int createPart1, int createPart2, Var **arrayPtrPtr); /* Slot 59 is reserved */ /* 60 */ TCLAPI int TclNeedSpace(const char *start, const char *end); /* 61 */ TCLAPI Tcl_Obj * TclNewProcBodyObj(Proc *procPtr); /* 62 */ TCLAPI int TclObjCommandComplete(Tcl_Obj *cmdPtr); /* 63 */ TCLAPI int TclObjInterpProc(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 64 */ TCLAPI int TclObjInvoke(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int flags); /* Slot 65 is reserved */ /* Slot 66 is reserved */ /* Slot 67 is reserved */ /* Slot 68 is reserved */ /* 69 */ TCLAPI void * TclpAlloc(size_t size); /* Slot 70 is reserved */ /* Slot 71 is reserved */ /* Slot 72 is reserved */ /* Slot 73 is reserved */ /* 74 */ TCLAPI void TclpFree(void *ptr); /* 75 */ TCLAPI Tcl_WideUInt TclpGetClicks(void); /* 76 */ TCLAPI Tcl_WideUInt TclpGetSeconds(void); /* Slot 77 is reserved */ /* Slot 78 is reserved */ /* Slot 79 is reserved */ /* Slot 80 is reserved */ /* 81 */ TCLAPI void * TclpRealloc(void *ptr, size_t size); /* Slot 82 is reserved */ /* Slot 83 is reserved */ /* Slot 84 is reserved */ /* Slot 85 is reserved */ /* Slot 86 is reserved */ /* Slot 87 is reserved */ /* Slot 88 is reserved */ /* 89 */ TCLAPI int TclPreventAliasLoop(Tcl_Interp *interp, Tcl_Interp *cmdInterp, Tcl_Command cmd); /* Slot 90 is reserved */ /* 91 */ TCLAPI void TclProcCleanupProc(Proc *procPtr); /* 92 */ TCLAPI int TclProcCompileProc(Tcl_Interp *interp, Proc *procPtr, Tcl_Obj *bodyPtr, Namespace *nsPtr, const char *description, const char *procName); /* 93 */ TCLAPI void TclProcDeleteProc(void *clientData); /* Slot 94 is reserved */ /* Slot 95 is reserved */ /* 96 */ TCLAPI int TclRenameCommand(Tcl_Interp *interp, const char *oldName, const char *newName); /* 97 */ TCLAPI void TclResetShadowedCmdRefs(Tcl_Interp *interp, |
| ︙ | ︙ | |||
301 302 303 304 305 306 307 | /* Slot 139 is reserved */ /* Slot 140 is reserved */ /* 141 */ TCLAPI const char * TclpGetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr); /* 142 */ TCLAPI int TclSetByteCodeFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr, CompileHookProc *hookProc, | | | | | | | | | | | 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 | /* Slot 139 is reserved */ /* Slot 140 is reserved */ /* 141 */ TCLAPI const char * TclpGetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr); /* 142 */ TCLAPI int TclSetByteCodeFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr, CompileHookProc *hookProc, void *clientData); /* 143 */ TCLAPI int TclAddLiteralObj(struct CompileEnv *envPtr, Tcl_Obj *objPtr, LiteralEntry **litPtrPtr); /* 144 */ TCLAPI void TclHideLiteral(Tcl_Interp *interp, struct CompileEnv *envPtr, int index); /* 145 */ TCLAPI const struct AuxDataType * TclGetAuxDataType(const char *typeName); /* 146 */ TCLAPI TclHandle TclHandleCreate(void *ptr); /* 147 */ TCLAPI void TclHandleFree(TclHandle handle); /* 148 */ TCLAPI TclHandle TclHandlePreserve(TclHandle handle); /* 149 */ TCLAPI void TclHandleRelease(TclHandle handle); /* 150 */ TCLAPI int TclRegAbout(Tcl_Interp *interp, Tcl_RegExp re); /* 151 */ TCLAPI void TclRegExpRangeUniChar(Tcl_RegExp re, size_t index, size_t *startPtr, size_t *endPtr); /* 152 */ TCLAPI void TclSetLibraryPath(Tcl_Obj *pathPtr); /* 153 */ TCLAPI Tcl_Obj * TclGetLibraryPath(void); /* Slot 154 is reserved */ /* Slot 155 is reserved */ /* 156 */ TCLAPI void TclRegError(Tcl_Interp *interp, const char *msg, int status); /* 157 */ TCLAPI Var * TclVarTraceExists(Tcl_Interp *interp, const char *varName); /* Slot 158 is reserved */ /* Slot 159 is reserved */ /* Slot 160 is reserved */ /* 161 */ TCLAPI int TclChannelTransform(Tcl_Interp *interp, Tcl_Channel chan, Tcl_Obj *cmdObjPtr); /* 162 */ TCLAPI void TclChannelEventScriptInvoker(void *clientData, int flags); /* 163 */ TCLAPI const void * TclGetInstructionTable(void); /* 164 */ TCLAPI void TclExpandCodeArray(void *envPtr); /* 165 */ TCLAPI void TclpSetInitialEncodings(void); /* 166 */ TCLAPI int TclListObjSetElement(Tcl_Interp *interp, Tcl_Obj *listPtr, int index, Tcl_Obj *valuePtr); /* Slot 167 is reserved */ /* Slot 168 is reserved */ /* 169 */ TCLAPI int TclpUtfNcmp2(const char *s1, const char *s2, size_t n); /* 170 */ TCLAPI int TclCheckInterpTraces(Tcl_Interp *interp, const char *command, size_t numChars, Command *cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *const objv[]); /* 171 */ TCLAPI int TclCheckExecutionTraces(Tcl_Interp *interp, const char *command, size_t numChars, Command *cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *const objv[]); /* 172 */ TCLAPI int TclInThreadExit(void); /* 173 */ TCLAPI int TclUniCharMatch(const Tcl_UniChar *string, size_t strLen, const Tcl_UniChar *pattern, size_t ptnLen, int flags); /* Slot 174 is reserved */ /* 175 */ TCLAPI int TclCallVarTraces(Interp *iPtr, Var *arrayPtr, Var *varPtr, const char *part1, const char *part2, int flags, int leaveErrMsg); /* 176 */ |
| ︙ | ︙ | |||
445 446 447 448 449 450 451 | TCLAPI void TclpFindExecutable(const char *argv0); /* 213 */ TCLAPI Tcl_Obj * TclGetObjNameOfExecutable(void); /* 214 */ TCLAPI void TclSetObjNameOfExecutable(Tcl_Obj *name, Tcl_Encoding encoding); /* 215 */ | | | 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 | TCLAPI void TclpFindExecutable(const char *argv0); /* 213 */ TCLAPI Tcl_Obj * TclGetObjNameOfExecutable(void); /* 214 */ TCLAPI void TclSetObjNameOfExecutable(Tcl_Obj *name, Tcl_Encoding encoding); /* 215 */ TCLAPI void * TclStackAlloc(Tcl_Interp *interp, size_t numBytes); /* 216 */ TCLAPI void TclStackFree(Tcl_Interp *interp, void *freePtr); /* 217 */ TCLAPI int TclPushStackFrame(Tcl_Interp *interp, Tcl_CallFrame **framePtrPtr, Tcl_Namespace *namespacePtr, int isProcCallFrame); |
| ︙ | ︙ | |||
469 470 471 472 473 474 475 | /* 225 */ TCLAPI Tcl_Obj * TclTraceDictPath(Tcl_Interp *interp, Tcl_Obj *rootPtr, int keyc, Tcl_Obj *const keyv[], int flags); /* 226 */ TCLAPI int TclObjBeingDeleted(Tcl_Obj *objPtr); /* 227 */ | | | 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 | /* 225 */ TCLAPI Tcl_Obj * TclTraceDictPath(Tcl_Interp *interp, Tcl_Obj *rootPtr, int keyc, Tcl_Obj *const keyv[], int flags); /* 226 */ TCLAPI int TclObjBeingDeleted(Tcl_Obj *objPtr); /* 227 */ TCLAPI void TclSetNsPath(Namespace *nsPtr, size_t pathLength, Tcl_Namespace *pathAry[]); /* Slot 228 is reserved */ /* 229 */ TCLAPI int TclPtrMakeUpvar(Tcl_Interp *interp, Var *otherP1Ptr, const char *myName, int myFlags, int index); /* 230 */ TCLAPI Var * TclObjLookupVar(Tcl_Interp *interp, |
| ︙ | ︙ | |||
499 500 501 502 503 504 505 | /* 235 */ TCLAPI void TclInitVarHashTable(TclVarHashTable *tablePtr, Namespace *nsPtr); /* Slot 236 is reserved */ /* 237 */ TCLAPI int TclResetCancellation(Tcl_Interp *interp, int force); /* 238 */ | | < | | 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 | /* 235 */ TCLAPI void TclInitVarHashTable(TclVarHashTable *tablePtr, Namespace *nsPtr); /* Slot 236 is reserved */ /* 237 */ TCLAPI int TclResetCancellation(Tcl_Interp *interp, int force); /* 238 */ TCLAPI int TclNRInterpProc(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 239 */ TCLAPI int TclNRInterpProcCore(Tcl_Interp *interp, Tcl_Obj *procNameObj, int skip, ProcErrorProc *errorProc); /* 240 */ TCLAPI int TclNRRunCallbacks(Tcl_Interp *interp, int result, struct NRE_callback *rootPtr); |
| ︙ | ︙ | |||
564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 |
TCLAPI int TclPtrObjMakeUpvar(Tcl_Interp *interp,
Tcl_Var otherPtr, Tcl_Obj *myNamePtr,
int myFlags);
/* 256 */
TCLAPI int TclPtrUnsetVar(Tcl_Interp *interp, Tcl_Var varPtr,
Tcl_Var arrayPtr, Tcl_Obj *part1Ptr,
Tcl_Obj *part2Ptr, const int flags);
typedef struct TclIntStubs {
int magic;
void *hooks;
void (*reserved0)(void);
void (*reserved1)(void);
void (*reserved2)(void);
void (*tclAllocateFreeObjects) (void); /* 3 */
void (*reserved4)(void);
int (*tclCleanupChildren) (Tcl_Interp *interp, int numPids, Tcl_Pid *pidPtr, Tcl_Channel errorChan); /* 5 */
void (*tclCleanupCommand) (Command *cmdPtr); /* 6 */
| > > > > > > > > | | | | | | | | | | | | | | | 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 |
TCLAPI int TclPtrObjMakeUpvar(Tcl_Interp *interp,
Tcl_Var otherPtr, Tcl_Obj *myNamePtr,
int myFlags);
/* 256 */
TCLAPI int TclPtrUnsetVar(Tcl_Interp *interp, Tcl_Var varPtr,
Tcl_Var arrayPtr, Tcl_Obj *part1Ptr,
Tcl_Obj *part2Ptr, const int flags);
/* 257 */
TCLAPI void TclStaticPackage(Tcl_Interp *interp,
const char *pkgName,
Tcl_PackageInitProc *initProc,
Tcl_PackageInitProc *safeInitProc);
/* 258 */
TCLAPI Tcl_Obj * TclpCreateTemporaryDirectory(Tcl_Obj *dirObj,
Tcl_Obj *basenameObj);
typedef struct TclIntStubs {
int magic;
void *hooks;
void (*reserved0)(void);
void (*reserved1)(void);
void (*reserved2)(void);
void (*tclAllocateFreeObjects) (void); /* 3 */
void (*reserved4)(void);
int (*tclCleanupChildren) (Tcl_Interp *interp, int numPids, Tcl_Pid *pidPtr, Tcl_Channel errorChan); /* 5 */
void (*tclCleanupCommand) (Command *cmdPtr); /* 6 */
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 */
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 (*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 (*tclFreePackageInfo) (Interp *iPtr); /* 25 */
void (*reserved26)(void);
void (*reserved27)(void);
Tcl_Channel (*tclpGetDefaultStdChannel) (int type); /* 28 */
void (*reserved29)(void);
void (*reserved30)(void);
const char * (*tclGetExtension) (const char *name); /* 31 */
int (*tclGetFrame) (Tcl_Interp *interp, const char *str, CallFrame **framePtrPtr); /* 32 */
void (*reserved33)(void);
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 */
TclObjCmdProcType (*tclGetObjInterpProc) (void); /* 39 */
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 */
int (*tclHideUnsafeCommands) (Tcl_Interp *interp); /* 45 */
int (*tclInExit) (void); /* 46 */
void (*reserved47)(void);
void (*reserved48)(void);
void (*reserved49)(void);
void (*tclInitCompiledLocals) (Tcl_Interp *interp, CallFrame *framePtr, Namespace *nsPtr); /* 50 */
int (*tclInterpInit) (Tcl_Interp *interp); /* 51 */
void (*reserved52)(void);
int (*tclInvokeObjectCommand) (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 */
Proc * (*tclIsProc) (Command *cmdPtr); /* 55 */
void (*reserved56)(void);
void (*reserved57)(void);
Var * (*tclLookupVar) (Tcl_Interp *interp, const char *part1, const char *part2, int flags, const char *msg, int createPart1, int createPart2, Var **arrayPtrPtr); /* 58 */
void (*reserved59)(void);
int (*tclNeedSpace) (const char *start, const char *end); /* 60 */
Tcl_Obj * (*tclNewProcBodyObj) (Proc *procPtr); /* 61 */
int (*tclObjCommandComplete) (Tcl_Obj *cmdPtr); /* 62 */
int (*tclObjInterpProc) (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 (*tclPreventAliasLoop) (Tcl_Interp *interp, Tcl_Interp *cmdInterp, Tcl_Command cmd); /* 89 */
void (*reserved90)(void);
void (*tclProcCleanupProc) (Proc *procPtr); /* 91 */
int (*tclProcCompileProc) (Tcl_Interp *interp, Proc *procPtr, Tcl_Obj *bodyPtr, Namespace *nsPtr, const char *description, const char *procName); /* 92 */
void (*tclProcDeleteProc) (void *clientData); /* 93 */
void (*reserved94)(void);
void (*reserved95)(void);
int (*tclRenameCommand) (Tcl_Interp *interp, const char *oldName, const char *newName); /* 96 */
void (*tclResetShadowedCmdRefs) (Tcl_Interp *interp, Command *newCmdPtr); /* 97 */
int (*tclServiceIdle) (void); /* 98 */
void (*reserved99)(void);
void (*reserved100)(void);
|
| ︙ | ︙ | |||
711 712 713 714 715 716 717 |
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 */
| | | | | | | | | 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 |
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 */
int (*tclAddLiteralObj) (struct CompileEnv *envPtr, Tcl_Obj *objPtr, LiteralEntry **litPtrPtr); /* 143 */
void (*tclHideLiteral) (Tcl_Interp *interp, struct CompileEnv *envPtr, int index); /* 144 */
const struct AuxDataType * (*tclGetAuxDataType) (const char *typeName); /* 145 */
TclHandle (*tclHandleCreate) (void *ptr); /* 146 */
void (*tclHandleFree) (TclHandle handle); /* 147 */
TclHandle (*tclHandlePreserve) (TclHandle handle); /* 148 */
void (*tclHandleRelease) (TclHandle handle); /* 149 */
int (*tclRegAbout) (Tcl_Interp *interp, Tcl_RegExp re); /* 150 */
void (*tclRegExpRangeUniChar) (Tcl_RegExp re, size_t index, size_t *startPtr, size_t *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);
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 (*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 */
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 */
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);
|
| ︙ | ︙ | |||
784 785 786 787 788 789 790 |
Tcl_Channel (*tclpOpenFileChannel) (Tcl_Interp *interp, Tcl_Obj *pathPtr, int mode, int permissions); /* 208 */
void (*reserved209)(void);
void (*reserved210)(void);
void (*reserved211)(void);
void (*tclpFindExecutable) (const char *argv0); /* 212 */
Tcl_Obj * (*tclGetObjNameOfExecutable) (void); /* 213 */
void (*tclSetObjNameOfExecutable) (Tcl_Obj *name, Tcl_Encoding encoding); /* 214 */
| | | | > > | 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 |
Tcl_Channel (*tclpOpenFileChannel) (Tcl_Interp *interp, Tcl_Obj *pathPtr, int mode, int permissions); /* 208 */
void (*reserved209)(void);
void (*reserved210)(void);
void (*reserved211)(void);
void (*tclpFindExecutable) (const char *argv0); /* 212 */
Tcl_Obj * (*tclGetObjNameOfExecutable) (void); /* 213 */
void (*tclSetObjNameOfExecutable) (Tcl_Obj *name, Tcl_Encoding encoding); /* 214 */
void * (*tclStackAlloc) (Tcl_Interp *interp, size_t numBytes); /* 215 */
void (*tclStackFree) (Tcl_Interp *interp, void *freePtr); /* 216 */
int (*tclPushStackFrame) (Tcl_Interp *interp, Tcl_CallFrame **framePtrPtr, Tcl_Namespace *namespacePtr, int isProcCallFrame); /* 217 */
void (*tclPopStackFrame) (Tcl_Interp *interp); /* 218 */
void (*reserved219)(void);
void (*reserved220)(void);
void (*reserved221)(void);
void (*reserved222)(void);
void (*reserved223)(void);
TclPlatformType * (*tclGetPlatform) (void); /* 224 */
Tcl_Obj * (*tclTraceDictPath) (Tcl_Interp *interp, Tcl_Obj *rootPtr, int keyc, Tcl_Obj *const keyv[], int flags); /* 225 */
int (*tclObjBeingDeleted) (Tcl_Obj *objPtr); /* 226 */
void (*tclSetNsPath) (Namespace *nsPtr, 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 */
int (*tclGetNamespaceFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Namespace **nsPtrPtr); /* 231 */
int (*tclEvalObjEx) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags, const CmdFrame *invoker, int word); /* 232 */
void (*tclGetSrcInfoForPc) (CmdFrame *contextPtr); /* 233 */
Var * (*tclVarHashCreateVar) (TclVarHashTable *tablePtr, const char *key, int *newPtr); /* 234 */
void (*tclInitVarHashTable) (TclVarHashTable *tablePtr, Namespace *nsPtr); /* 235 */
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 (*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 */
char * (*tclDoubleDigits) (double dv, int ndigits, int flags, int *decpt, int *signum, char **endPtr); /* 249 */
void (*tclSetSlaveCancelFlags) (Tcl_Interp *interp, int flags, int force); /* 250 */
int (*tclRegisterLiteral) (void *envPtr, const char *bytes, 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 */
} TclIntStubs;
extern const TclIntStubs *tclIntStubsPtr;
#ifdef __cplusplus
}
#endif
|
| ︙ | ︙ | |||
891 892 893 894 895 896 897 | /* Slot 29 is reserved */ /* Slot 30 is reserved */ #define TclGetExtension \ (tclIntStubsPtr->tclGetExtension) /* 31 */ #define TclGetFrame \ (tclIntStubsPtr->tclGetFrame) /* 32 */ /* Slot 33 is reserved */ | | < | 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 | /* Slot 29 is reserved */ /* Slot 30 is reserved */ #define TclGetExtension \ (tclIntStubsPtr->tclGetExtension) /* 31 */ #define TclGetFrame \ (tclIntStubsPtr->tclGetFrame) /* 32 */ /* Slot 33 is reserved */ /* Slot 34 is reserved */ /* Slot 35 is reserved */ /* Slot 36 is reserved */ #define TclGetLoadedPackages \ (tclIntStubsPtr->tclGetLoadedPackages) /* 37 */ #define TclGetNamespaceForQualName \ (tclIntStubsPtr->tclGetNamespaceForQualName) /* 38 */ #define TclGetObjInterpProc \ |
| ︙ | ︙ | |||
1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 | (tclIntStubsPtr->tclPtrSetVar) /* 253 */ #define TclPtrIncrObjVar \ (tclIntStubsPtr->tclPtrIncrObjVar) /* 254 */ #define TclPtrObjMakeUpvar \ (tclIntStubsPtr->tclPtrObjMakeUpvar) /* 255 */ #define TclPtrUnsetVar \ (tclIntStubsPtr->tclPtrUnsetVar) /* 256 */ #endif /* defined(USE_TCL_STUBS) */ /* !END!: Do not edit above this line. */ #endif /* _TCLINTDECLS */ | > > > > > > > > > > | 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 | (tclIntStubsPtr->tclPtrSetVar) /* 253 */ #define TclPtrIncrObjVar \ (tclIntStubsPtr->tclPtrIncrObjVar) /* 254 */ #define TclPtrObjMakeUpvar \ (tclIntStubsPtr->tclPtrObjMakeUpvar) /* 255 */ #define TclPtrUnsetVar \ (tclIntStubsPtr->tclPtrUnsetVar) /* 256 */ #define TclStaticPackage \ (tclIntStubsPtr->tclStaticPackage) /* 257 */ #define TclpCreateTemporaryDirectory \ (tclIntStubsPtr->tclpCreateTemporaryDirectory) /* 258 */ #endif /* defined(USE_TCL_STUBS) */ /* !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) */ #endif /* _TCLINTDECLS */ |
Changes to generic/tclIntPlatDecls.h.
| ︙ | ︙ | |||
93 94 95 96 97 98 99 | /* 4 */ TCLAPI HINSTANCE TclWinGetTclInstance(void); /* 5 */ TCLAPI int TclUnixWaitForFile(int fd, int mask, int timeout); /* Slot 6 is reserved */ /* Slot 7 is reserved */ /* 8 */ | | | 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 | /* 4 */ TCLAPI HINSTANCE TclWinGetTclInstance(void); /* 5 */ TCLAPI int TclUnixWaitForFile(int fd, int mask, int timeout); /* Slot 6 is reserved */ /* Slot 7 is reserved */ /* 8 */ TCLAPI size_t TclpGetPid(Tcl_Pid pid); /* Slot 9 is reserved */ /* Slot 10 is reserved */ /* 11 */ TCLAPI void TclGetAndDetachPids(Tcl_Interp *interp, Tcl_Channel chan); /* 12 */ TCLAPI int TclpCloseFile(TclFile file); |
| ︙ | ︙ | |||
123 124 125 126 127 128 129 | const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 18 */ TCLAPI TclFile TclpMakeFile(Tcl_Channel channel, int direction); /* 19 */ TCLAPI TclFile TclpOpenFile(const char *fname, int mode); /* 20 */ | | | 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 | const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 18 */ TCLAPI TclFile TclpMakeFile(Tcl_Channel channel, int direction); /* 19 */ TCLAPI TclFile TclpOpenFile(const char *fname, int mode); /* 20 */ TCLAPI void TclWinAddProcess(HANDLE hProcess, size_t id); /* Slot 21 is reserved */ /* 22 */ TCLAPI TclFile TclpCreateTempFile(const char *contents); /* Slot 23 is reserved */ /* 24 */ TCLAPI char * TclWinNoBackslash(char *path); /* Slot 25 is reserved */ |
| ︙ | ︙ | |||
259 260 261 262 263 264 265 |
void (*reserved1)(void);
void (*reserved2)(void);
void (*reserved3)(void);
HINSTANCE (*tclWinGetTclInstance) (void); /* 4 */
int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 5 */
void (*reserved6)(void);
void (*reserved7)(void);
| | | | 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 |
void (*reserved1)(void);
void (*reserved2)(void);
void (*reserved3)(void);
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);
void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 11 */
int (*tclpCloseFile) (TclFile file); /* 12 */
Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 13 */
int (*tclpCreatePipe) (TclFile *readPipe, TclFile *writePipe); /* 14 */
int (*tclpCreateProcess) (Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 15 */
int (*tclpIsAtty) (int fd); /* 16 */
int (*tclUnixCopyFile) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 17 */
TclFile (*tclpMakeFile) (Tcl_Channel channel, int direction); /* 18 */
TclFile (*tclpOpenFile) (const char *fname, int mode); /* 19 */
void (*tclWinAddProcess) (HANDLE hProcess, size_t id); /* 20 */
void (*reserved21)(void);
TclFile (*tclpCreateTempFile) (const char *contents); /* 22 */
void (*reserved23)(void);
char * (*tclWinNoBackslash) (char *path); /* 24 */
void (*reserved25)(void);
void (*reserved26)(void);
void (*tclWinFlushDirtyChannels) (void); /* 27 */
|
| ︙ | ︙ | |||
484 485 486 487 488 489 490 | #endif /* defined(USE_TCL_STUBS) */ /* !END!: Do not edit above this line. */ #if !defined(_WIN32) # undef TclpGetPid | | | 484 485 486 487 488 489 490 491 492 493 494 | #endif /* defined(USE_TCL_STUBS) */ /* !END!: Do not edit above this line. */ #if !defined(_WIN32) # undef TclpGetPid # define TclpGetPid(pid) ((size_t) (pid)) #endif #endif /* _TCLINTPLATDECLS */ |
Changes to generic/tclInterp.c.
| ︙ | ︙ | |||
80 81 82 83 84 85 86 |
* slave interpreter. Used to find this
* record, and used when deleting the slave
* interpreter to delete it from the master's
* table. */
Tcl_Interp *slaveInterp; /* The slave interpreter. */
Tcl_Command interpCmd; /* Interpreter object command. */
Tcl_HashTable aliasTable; /* Table which maps from names of commands in
| | | 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 |
* slave interpreter. Used to find this
* record, and used when deleting the slave
* interpreter to delete it from the master's
* table. */
Tcl_Interp *slaveInterp; /* The slave interpreter. */
Tcl_Command interpCmd; /* Interpreter object command. */
Tcl_HashTable aliasTable; /* Table which maps from names of commands in
* slave interpreter to struct Alias defined
* below. */
} Slave;
/*
* struct Target:
*
* Maps from master interpreter commands back to the source commands in slave
|
| ︙ | ︙ | |||
218 219 220 221 222 223 224 | Tcl_Obj *namePtr, Tcl_Obj *targetPtr, int objc, Tcl_Obj *const objv[]); static int AliasDelete(Tcl_Interp *interp, Tcl_Interp *slaveInterp, Tcl_Obj *namePtr); static int AliasDescribe(Tcl_Interp *interp, Tcl_Interp *slaveInterp, Tcl_Obj *objPtr); static int AliasList(Tcl_Interp *interp, Tcl_Interp *slaveInterp); | < < < | 218 219 220 221 222 223 224 225 226 227 228 229 230 231 | Tcl_Obj *namePtr, Tcl_Obj *targetPtr, int objc, Tcl_Obj *const objv[]); static int AliasDelete(Tcl_Interp *interp, Tcl_Interp *slaveInterp, Tcl_Obj *namePtr); static int AliasDescribe(Tcl_Interp *interp, Tcl_Interp *slaveInterp, Tcl_Obj *objPtr); static int AliasList(Tcl_Interp *interp, Tcl_Interp *slaveInterp); static int AliasNRCmd(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[]); |
| ︙ | ︙ | |||
253 254 255 256 257 258 259 | Tcl_Interp *slaveInterp); static int SlaveInvokeHidden(Tcl_Interp *interp, Tcl_Interp *slaveInterp, const char *namespaceName, int objc, Tcl_Obj *const objv[]); static int SlaveMarkTrusted(Tcl_Interp *interp, Tcl_Interp *slaveInterp); | < < | 250 251 252 253 254 255 256 257 258 259 260 261 262 263 | Tcl_Interp *slaveInterp); static int SlaveInvokeHidden(Tcl_Interp *interp, Tcl_Interp *slaveInterp, const char *namespaceName, int objc, Tcl_Obj *const objv[]); static int SlaveMarkTrusted(Tcl_Interp *interp, Tcl_Interp *slaveInterp); static void SlaveObjCmdDeleteProc(ClientData clientData); static int SlaveRecursionLimit(Tcl_Interp *interp, Tcl_Interp *slaveInterp, int objc, Tcl_Obj *const objv[]); static int SlaveCommandLimitCmd(Tcl_Interp *interp, Tcl_Interp *slaveInterp, int consumedObjc, int objc, Tcl_Obj *const objv[]); |
| ︙ | ︙ | |||
410 411 412 413 414 415 416 417 418 419 420 421 422 423 |
"file join [file dirname $env(TCL_LIBRARY)] tcl[info tclversion]}\n"
" }\n"
" if {[info exists tclDefaultLibrary]} {\n"
" lappend scripts {set tclDefaultLibrary}\n"
" } else {\n"
" lappend scripts {::tcl::pkgconfig get scriptdir,runtime}\n"
" }\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"
| > | 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 |
"file join [file dirname $env(TCL_LIBRARY)] tcl[info tclversion]}\n"
" }\n"
" 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"
|
| ︙ | ︙ | |||
485 486 487 488 489 490 491 |
TclInterpInit(
Tcl_Interp *interp) /* Interpreter to initialize. */
{
InterpInfo *interpInfoPtr;
Master *masterPtr;
Slave *slavePtr;
| | | 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 |
TclInterpInit(
Tcl_Interp *interp) /* Interpreter to initialize. */
{
InterpInfo *interpInfoPtr;
Master *masterPtr;
Slave *slavePtr;
interpInfoPtr = Tcl_Alloc(sizeof(InterpInfo));
((Interp *) interp)->interpInfo = interpInfoPtr;
masterPtr = &interpInfoPtr->master;
Tcl_InitHashTable(&masterPtr->slaveTable, TCL_STRING_KEYS);
masterPtr->targetsPtr = NULL;
slavePtr = &interpInfoPtr->slave;
|
| ︙ | ︙ | |||
582 583 584 585 586 587 588 |
*/
if (slavePtr->aliasTable.numEntries != 0) {
Tcl_Panic("InterpInfoDeleteProc: still exist aliases");
}
Tcl_DeleteHashTable(&slavePtr->aliasTable);
| | | 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 |
*/
if (slavePtr->aliasTable.numEntries != 0) {
Tcl_Panic("InterpInfoDeleteProc: still exist aliases");
}
Tcl_DeleteHashTable(&slavePtr->aliasTable);
Tcl_Free(interpInfoPtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_InterpObjCmd --
*
|
| ︙ | ︙ | |||
786 787 788 789 790 791 792 |
/*
* Weird historical rules: "-safe" is accepted at the end, too.
*/
slavePtr = NULL;
last = 0;
for (i = 2; i < objc; i++) {
| | | 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 |
/*
* Weird historical rules: "-safe" is accepted at the end, too.
*/
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) {
return TCL_ERROR;
}
if (index == OPT_SAFE) {
safe = 1;
continue;
|
| ︙ | ︙ | |||
1100 1101 1102 1103 1104 1105 1106 |
aliasName = TclGetString(objv[3]);
iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo;
hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName);
if (hPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"alias \"%s\" in path \"%s\" not found",
| | | | 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 |
aliasName = TclGetString(objv[3]);
iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo;
hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName);
if (hPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"alias \"%s\" in path \"%s\" not found",
aliasName, TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS", aliasName,
NULL);
return TCL_ERROR;
}
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);
return TCL_ERROR;
}
return TCL_OK;
}
}
|
| ︙ | ︙ | |||
1188 1189 1190 1191 1192 1193 1194 |
const char *const *argv) /* These are the additional args. */
{
Tcl_Obj *slaveObjPtr, *targetObjPtr;
Tcl_Obj **objv;
int i;
int result;
| | | 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 |
const char *const *argv) /* These are the additional args. */
{
Tcl_Obj *slaveObjPtr, *targetObjPtr;
Tcl_Obj **objv;
int i;
int result;
objv = TclStackAlloc(slaveInterp, sizeof(Tcl_Obj *) * argc);
for (i = 0; i < argc; i++) {
objv[i] = Tcl_NewStringObj(argv[i], -1);
Tcl_IncrRefCount(objv[i]);
}
slaveObjPtr = Tcl_NewStringObj(slaveCmd, -1);
Tcl_IncrRefCount(slaveObjPtr);
|
| ︙ | ︙ | |||
1309 1310 1311 1312 1313 1314 1315 |
*targetNamePtr = TclGetString(objv[0]);
}
if (argcPtr != NULL) {
*argcPtr = objc - 1;
}
if (argvPtr != NULL) {
*argvPtr = (const char **)
| | | 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 |
*targetNamePtr = TclGetString(objv[0]);
}
if (argcPtr != NULL) {
*argcPtr = objc - 1;
}
if (argvPtr != NULL) {
*argvPtr = (const char **)
Tcl_Alloc(sizeof(const char *) * (objc - 1));
for (i = 1; i < objc; i++) {
(*argvPtr)[i - 1] = TclGetString(objv[i]);
}
}
return TCL_OK;
}
|
| ︙ | ︙ | |||
1414 1415 1416 1417 1418 1419 1420 |
Command *aliasCmdPtr;
/*
* If we are not creating or renaming an alias, then it is always OK to
* create or rename the command.
*/
| | > | 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 |
Command *aliasCmdPtr;
/*
* 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) {
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.
|
| ︙ | ︙ | |||
1469 1470 1471 1472 1473 1474 1475 | /* * 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. */ | | > | 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 |
/*
* Otherwise, follow the chain one step further. See if the target
* command is an alias - if so, follow the loop to its target command.
* Otherwise we do not have a loop.
*/
if (aliasCmdPtr->objProc != TclAliasObjCmd
&& aliasCmdPtr->objProc != TclLocalAliasObjCmd) {
return TCL_OK;
}
nextAliasPtr = aliasCmdPtr->objClientData;
}
/* NOTREACHED */
}
|
| ︙ | ︙ | |||
1515 1516 1517 1518 1519 1520 1521 |
Tcl_HashEntry *hPtr;
Target *targetPtr;
Slave *slavePtr;
Master *masterPtr;
Tcl_Obj **prefv;
int isNew, i;
| | | | | | | | 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 |
Tcl_HashEntry *hPtr;
Target *targetPtr;
Slave *slavePtr;
Master *masterPtr;
Tcl_Obj **prefv;
int isNew, i;
aliasPtr = Tcl_Alloc(sizeof(Alias) + objc * sizeof(Tcl_Obj *));
aliasPtr->token = namePtr;
Tcl_IncrRefCount(aliasPtr->token);
aliasPtr->targetInterp = masterInterp;
aliasPtr->objc = objc + 1;
prefv = &aliasPtr->objPtr;
*prefv = targetNamePtr;
Tcl_IncrRefCount(targetNamePtr);
for (i = 0; i < objc; i++) {
*(++prefv) = objv[i];
Tcl_IncrRefCount(objv[i]);
}
Tcl_Preserve(slaveInterp);
Tcl_Preserve(masterInterp);
if (slaveInterp == masterInterp) {
aliasPtr->slaveCmd = Tcl_NRCreateCommand(slaveInterp,
TclGetString(namePtr), TclLocalAliasObjCmd, AliasNRCmd,
aliasPtr, AliasObjCmdDeleteProc);
} else {
aliasPtr->slaveCmd = Tcl_CreateObjCommand(slaveInterp,
TclGetString(namePtr), TclAliasObjCmd, 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
|
| ︙ | ︙ | |||
1566 1567 1568 1569 1570 1571 1572 | cmdPtr = (Command *) aliasPtr->slaveCmd; cmdPtr->clientData = NULL; cmdPtr->deleteProc = NULL; cmdPtr->deleteData = NULL; Tcl_DeleteCommandFromToken(slaveInterp, aliasPtr->slaveCmd); | | | 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 | cmdPtr = (Command *) aliasPtr->slaveCmd; cmdPtr->clientData = NULL; cmdPtr->deleteProc = NULL; cmdPtr->deleteData = NULL; Tcl_DeleteCommandFromToken(slaveInterp, aliasPtr->slaveCmd); Tcl_Free(aliasPtr); /* * The result was already set by TclPreventAliasLoop. */ Tcl_Release(slaveInterp); Tcl_Release(masterInterp); |
| ︙ | ︙ | |||
1623 1624 1625 1626 1627 1628 1629 |
* because the alias may be pointing at a renamed alias, as in:
*
* interp alias {} foo {} bar # Create an alias "foo"
* rename foo zop # Now rename the alias
* interp alias {} foo {} zop # Now recreate "foo"...
*/
| | | 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 |
* because the alias may be pointing at a renamed alias, as in:
*
* interp alias {} foo {} bar # Create an alias "foo"
* rename foo zop # Now rename the alias
* interp alias {} foo {} zop # Now recreate "foo"...
*/
targetPtr = Tcl_Alloc(sizeof(Target));
targetPtr->slaveCmd = aliasPtr->slaveCmd;
targetPtr->slaveInterp = slaveInterp;
masterPtr = &((InterpInfo*) ((Interp*) masterInterp)->interpInfo)->master;
targetPtr->nextPtr = masterPtr->targetsPtr;
targetPtr->prevPtr = NULL;
if (masterPtr->targetsPtr != NULL) {
|
| ︙ | ︙ | |||
1725 1726 1727 1728 1729 1730 1731 |
/*
* If the alias has been renamed in the slave, the master can still use
* the original name (with which it was created) to find the alias to
* describe it.
*/
slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave;
| | | 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 |
/*
* If the alias has been renamed in the slave, the master can still use
* the original name (with which it was created) to find the alias to
* describe it.
*/
slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave;
hPtr = Tcl_FindHashEntry(&slavePtr->aliasTable, TclGetString(namePtr));
if (hPtr == NULL) {
return TCL_OK;
}
aliasPtr = Tcl_GetHashValue(hPtr);
prefixPtr = Tcl_NewListObj(aliasPtr->objc, &aliasPtr->objPtr);
Tcl_SetObjResult(interp, prefixPtr);
return TCL_OK;
|
| ︙ | ︙ | |||
1776 1777 1778 1779 1780 1781 1782 |
Tcl_SetObjResult(interp, resultPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
| | > > > > > | 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 |
Tcl_SetObjResult(interp, resultPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclAliasObjCmd, TclLocalAliasObjCmd --
*
* 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
* 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
* occur as a result of invoking the command to which the invocation is
|
| ︙ | ︙ | |||
1819 1820 1821 1822 1823 1824 1825 |
*/
prefc = aliasPtr->objc;
prefv = &aliasPtr->objPtr;
cmdc = prefc + objc - 1;
listPtr = Tcl_NewListObj(cmdc, NULL);
| | | | | | | 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 |
*/
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; i<cmdc; i++) {
Tcl_IncrRefCount(cmdv[i]);
}
/*
* Use the ensemble rewriting machinery to ensure correct error messages:
* only the source command should show, not the full target prefix.
*/
if (TclInitRewriteEnsemble(interp, 1, prefc, objv)) {
TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL);
}
TclSkipTailcall(interp);
return Tcl_NREvalObj(interp, listPtr, flags);
}
int
TclAliasObjCmd(
ClientData clientData, /* Alias record. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument vector. */
{
#define ALIAS_CMDV_PREALLOC 10
Alias *aliasPtr = clientData;
|
| ︙ | ︙ | |||
1873 1874 1875 1876 1877 1878 1879 |
cmdc = prefc + objc - 1;
if (cmdc <= ALIAS_CMDV_PREALLOC) {
cmdv = cmdArr;
} else {
cmdv = TclStackAlloc(interp, cmdc * sizeof(Tcl_Obj *));
}
| | | | 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 |
cmdc = prefc + objc - 1;
if (cmdc <= ALIAS_CMDV_PREALLOC) {
cmdv = cmdArr;
} else {
cmdv = TclStackAlloc(interp, cmdc * sizeof(Tcl_Obj *));
}
memcpy(cmdv, prefv, prefc * sizeof(Tcl_Obj *));
memcpy(cmdv+prefc, objv+1, (objc-1) * sizeof(Tcl_Obj *));
Tcl_ResetResult(targetInterp);
for (i=0; i<cmdc; i++) {
Tcl_IncrRefCount(cmdv[i]);
}
|
| ︙ | ︙ | |||
1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 |
* on the target interpreter.
*/
if (targetInterp != interp) {
Tcl_TransferResult(targetInterp, result, interp);
Tcl_Release(targetInterp);
}
for (i=0; i<cmdc; i++) {
Tcl_DecrRefCount(cmdv[i]);
}
if (cmdv != cmdArr) {
TclStackFree(interp, cmdv);
}
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 |
* on the target interpreter.
*/
if (targetInterp != interp) {
Tcl_TransferResult(targetInterp, result, interp);
Tcl_Release(targetInterp);
}
for (i=0; i<cmdc; i++) {
Tcl_DecrRefCount(cmdv[i]);
}
if (cmdv != cmdArr) {
TclStackFree(interp, cmdv);
}
return result;
#undef ALIAS_CMDV_PREALLOC
}
int
TclLocalAliasObjCmd(
ClientData clientData, /* Alias record. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument vector. */
{
#define ALIAS_CMDV_PREALLOC 10
Alias *aliasPtr = clientData;
int result, prefc, cmdc, i;
Tcl_Obj **prefv, **cmdv;
Tcl_Obj *cmdArr[ALIAS_CMDV_PREALLOC];
Interp *iPtr = (Interp *) interp;
int isRootEnsemble;
/*
* Append the arguments to the command prefix and invoke the command in
* the global namespace.
*/
prefc = aliasPtr->objc;
prefv = &aliasPtr->objPtr;
cmdc = prefc + objc - 1;
if (cmdc <= ALIAS_CMDV_PREALLOC) {
cmdv = cmdArr;
} else {
cmdv = TclStackAlloc(interp, cmdc * sizeof(Tcl_Obj *));
}
memcpy(cmdv, prefv, prefc * sizeof(Tcl_Obj *));
memcpy(cmdv+prefc, objv+1, (objc-1) * sizeof(Tcl_Obj *));
for (i=0; i<cmdc; i++) {
Tcl_IncrRefCount(cmdv[i]);
}
/*
* Use the ensemble rewriting machinery to ensure correct error messages:
* only the source command should show, not the full target prefix.
*/
isRootEnsemble = TclInitRewriteEnsemble((Tcl_Interp *)iPtr, 1, prefc, objv);
/*
* Execute the target command in the target interpreter.
*/
result = Tcl_EvalObjv(interp, cmdc, cmdv, TCL_EVAL_INVOKE);
/*
* Clean up the ensemble rewrite info if we set it in the first place.
*/
if (isRootEnsemble) {
TclResetRewriteEnsemble((Tcl_Interp *)iPtr, 1);
}
for (i=0; i<cmdc; i++) {
Tcl_DecrRefCount(cmdv[i]);
}
if (cmdv != cmdArr) {
TclStackFree(interp, cmdv);
}
|
| ︙ | ︙ | |||
1985 1986 1987 1988 1989 1990 1991 |
masterPtr->targetsPtr = targetPtr->nextPtr;
}
if (targetPtr->nextPtr != NULL) {
targetPtr->nextPtr->prevPtr = targetPtr->prevPtr;
}
| | | | 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 |
masterPtr->targetsPtr = targetPtr->nextPtr;
}
if (targetPtr->nextPtr != NULL) {
targetPtr->nextPtr->prevPtr = targetPtr->prevPtr;
}
Tcl_Free(targetPtr);
Tcl_Free(aliasPtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_CreateSlave --
*
|
| ︙ | ︙ | |||
2372 2373 2374 2375 2376 2377 2378 |
slaveInterp = Tcl_CreateInterp();
slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave;
slavePtr->masterInterp = masterInterp;
slavePtr->slaveEntryPtr = hPtr;
slavePtr->slaveInterp = slaveInterp;
slavePtr->interpCmd = Tcl_NRCreateCommand(masterInterp, path,
| | | 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 |
slaveInterp = Tcl_CreateInterp();
slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave;
slavePtr->masterInterp = masterInterp;
slavePtr->slaveEntryPtr = hPtr;
slavePtr->slaveInterp = slaveInterp;
slavePtr->interpCmd = Tcl_NRCreateCommand(masterInterp, path,
TclSlaveObjCmd, NRSlaveCmd, slaveInterp, SlaveObjCmdDeleteProc);
Tcl_InitHashTable(&slavePtr->aliasTable, TCL_STRING_KEYS);
Tcl_SetHashValue(hPtr, slavePtr);
Tcl_SetVar2(slaveInterp, "tcl_interactive", NULL, "0", TCL_GLOBAL_ONLY);
/*
* Inherit the recursion limit.
*/
|
| ︙ | ︙ | |||
2440 2441 2442 2443 2444 2445 2446 |
return NULL;
}
/*
*----------------------------------------------------------------------
*
| | | | | 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 |
return NULL;
}
/*
*----------------------------------------------------------------------
*
* TclSlaveObjCmd --
*
* Command to manipulate an interpreter, e.g. to send commands to it to
* be evaluated. One such command exists for each slave interpreter.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See user documentation for details.
*
*----------------------------------------------------------------------
*/
int
TclSlaveObjCmd(
ClientData clientData, /* Slave interpreter. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
return Tcl_NRCallObjProc(interp, NRSlaveCmd, clientData, objc, objv);
}
|
| ︙ | ︙ | |||
2487 2488 2489 2490 2491 2492 2493 |
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) {
| | | 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 |
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("TclSlaveObjCmd: interpreter has been deleted");
}
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "cmd ?arg ...?");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0,
|
| ︙ | ︙ | |||
2933 2934 2935 2936 2937 2938 2939 |
Tcl_SetErrorCode(interp, "TCL", "RECURSION", NULL);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, objv[0]);
return TCL_OK;
} else {
limit = Tcl_SetRecursionLimit(slaveInterp, 0);
| | | 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 |
Tcl_SetErrorCode(interp, "TCL", "RECURSION", NULL);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, objv[0]);
return TCL_OK;
} else {
limit = Tcl_SetRecursionLimit(slaveInterp, 0);
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(limit));
return TCL_OK;
}
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
3486 3487 3488 3489 3490 3491 3492 |
* LIMIT_HANDLER_DELETED flag.
*/
if (handlerPtr->flags & LIMIT_HANDLER_DELETED) {
if (handlerPtr->deleteProc != NULL) {
handlerPtr->deleteProc(handlerPtr->clientData);
}
| | | 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 3570 |
* LIMIT_HANDLER_DELETED flag.
*/
if (handlerPtr->flags & LIMIT_HANDLER_DELETED) {
if (handlerPtr->deleteProc != NULL) {
handlerPtr->deleteProc(handlerPtr->clientData);
}
Tcl_Free(handlerPtr);
}
}
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
3523 3524 3525 3526 3527 3528 3529 |
LimitHandler *handlerPtr;
/*
* Convert everything into a real deletion callback.
*/
if (deleteProc == (Tcl_LimitHandlerDeleteProc *) TCL_DYNAMIC) {
| | | | 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 |
LimitHandler *handlerPtr;
/*
* Convert everything into a real deletion callback.
*/
if (deleteProc == (Tcl_LimitHandlerDeleteProc *) TCL_DYNAMIC) {
deleteProc = (Tcl_LimitHandlerDeleteProc *) TclpFree;
}
/*
* Allocate a handler record.
*/
handlerPtr = Tcl_Alloc(sizeof(LimitHandler));
handlerPtr->flags = 0;
handlerPtr->handlerProc = handlerProc;
handlerPtr->clientData = clientData;
handlerPtr->deleteProc = deleteProc;
handlerPtr->prevPtr = NULL;
/*
|
| ︙ | ︙ | |||
3649 3650 3651 3652 3653 3654 3655 |
* go away when the handler returns.
*/
if (!(handlerPtr->flags & LIMIT_HANDLER_ACTIVE)) {
if (handlerPtr->deleteProc != NULL) {
handlerPtr->deleteProc(handlerPtr->clientData);
}
| | | 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 3729 3730 3731 3732 3733 |
* go away when the handler returns.
*/
if (!(handlerPtr->flags & LIMIT_HANDLER_ACTIVE)) {
if (handlerPtr->deleteProc != NULL) {
handlerPtr->deleteProc(handlerPtr->clientData);
}
Tcl_Free(handlerPtr);
}
return;
}
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
3709 3710 3711 3712 3713 3714 3715 |
* go away when the handler returns.
*/
if (!(handlerPtr->flags & LIMIT_HANDLER_ACTIVE)) {
if (handlerPtr->deleteProc != NULL) {
handlerPtr->deleteProc(handlerPtr->clientData);
}
| | | 3779 3780 3781 3782 3783 3784 3785 3786 3787 3788 3789 3790 3791 3792 3793 |
* go away when the handler returns.
*/
if (!(handlerPtr->flags & LIMIT_HANDLER_ACTIVE)) {
if (handlerPtr->deleteProc != NULL) {
handlerPtr->deleteProc(handlerPtr->clientData);
}
Tcl_Free(handlerPtr);
}
}
/*
* Delete all time-limit handlers.
*/
|
| ︙ | ︙ | |||
3742 3743 3744 3745 3746 3747 3748 |
* go away when the handler returns.
*/
if (!(handlerPtr->flags & LIMIT_HANDLER_ACTIVE)) {
if (handlerPtr->deleteProc != NULL) {
handlerPtr->deleteProc(handlerPtr->clientData);
}
| | | 3812 3813 3814 3815 3816 3817 3818 3819 3820 3821 3822 3823 3824 3825 3826 |
* go away when the handler returns.
*/
if (!(handlerPtr->flags & LIMIT_HANDLER_ACTIVE)) {
if (handlerPtr->deleteProc != NULL) {
handlerPtr->deleteProc(handlerPtr->clientData);
}
Tcl_Free(handlerPtr);
}
}
/*
* Delete the timer callback that is used to trap limits that occur in
* [vwait]s...
*/
|
| ︙ | ︙ | |||
4137 4138 4139 4140 4141 4142 4143 |
{
ScriptLimitCallback *limitCBPtr = clientData;
Tcl_DecrRefCount(limitCBPtr->scriptObj);
if (limitCBPtr->entryPtr != NULL) {
Tcl_DeleteHashEntry(limitCBPtr->entryPtr);
}
| | | 4207 4208 4209 4210 4211 4212 4213 4214 4215 4216 4217 4218 4219 4220 4221 |
{
ScriptLimitCallback *limitCBPtr = clientData;
Tcl_DecrRefCount(limitCBPtr->scriptObj);
if (limitCBPtr->entryPtr != NULL) {
Tcl_DeleteHashEntry(limitCBPtr->entryPtr);
}
Tcl_Free(limitCBPtr);
}
/*
*----------------------------------------------------------------------
*
* CallScriptLimitCallback --
*
|
| ︙ | ︙ | |||
4237 4238 4239 4240 4241 4242 4243 |
if (!isNew) {
limitCBPtr = Tcl_GetHashValue(hashPtr);
limitCBPtr->entryPtr = NULL;
Tcl_LimitRemoveHandler(targetInterp, type, CallScriptLimitCallback,
limitCBPtr);
}
| | | 4307 4308 4309 4310 4311 4312 4313 4314 4315 4316 4317 4318 4319 4320 4321 |
if (!isNew) {
limitCBPtr = Tcl_GetHashValue(hashPtr);
limitCBPtr->entryPtr = NULL;
Tcl_LimitRemoveHandler(targetInterp, type, CallScriptLimitCallback,
limitCBPtr);
}
limitCBPtr = Tcl_Alloc(sizeof(ScriptLimitCallback));
limitCBPtr->interp = interp;
limitCBPtr->scriptObj = scriptObj;
limitCBPtr->entryPtr = hashPtr;
limitCBPtr->type = type;
Tcl_IncrRefCount(scriptObj);
Tcl_LimitAddHandler(targetInterp, type, CallScriptLimitCallback,
|
| ︙ | ︙ | |||
4442 4443 4444 4445 4446 4447 4448 | putEmptyCommandInDict: TclNewObj(empty); Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[0], -1), empty); } Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[1], -1), | | | | 4512 4513 4514 4515 4516 4517 4518 4519 4520 4521 4522 4523 4524 4525 4526 4527 4528 4529 4530 4531 |
putEmptyCommandInDict:
TclNewObj(empty);
Tcl_DictObjPut(NULL, dictPtr,
Tcl_NewStringObj(options[0], -1), empty);
}
Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[1], -1),
Tcl_NewWideIntObj(Tcl_LimitGetGranularity(slaveInterp,
TCL_LIMIT_COMMANDS)));
if (Tcl_LimitTypeEnabled(slaveInterp, TCL_LIMIT_COMMANDS)) {
Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[2], -1),
Tcl_NewWideIntObj(Tcl_LimitGetCommands(slaveInterp)));
} else {
Tcl_Obj *empty;
TclNewObj(empty);
Tcl_DictObjPut(NULL, dictPtr,
Tcl_NewStringObj(options[2], -1), empty);
}
|
| ︙ | ︙ | |||
4475 4476 4477 4478 4479 4480 4481 |
limitCBPtr = Tcl_GetHashValue(hPtr);
if (limitCBPtr != NULL && limitCBPtr->scriptObj != NULL) {
Tcl_SetObjResult(interp, limitCBPtr->scriptObj);
}
}
break;
case OPT_GRAN:
| | | > | | 4545 4546 4547 4548 4549 4550 4551 4552 4553 4554 4555 4556 4557 4558 4559 4560 4561 4562 4563 4564 4565 4566 4567 4568 4569 4570 4571 4572 4573 4574 4575 |
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(slaveInterp, TCL_LIMIT_COMMANDS)));
break;
case OPT_VAL:
if (Tcl_LimitTypeEnabled(slaveInterp, TCL_LIMIT_COMMANDS)) {
Tcl_SetObjResult(interp,
Tcl_NewWideIntObj(Tcl_LimitGetCommands(slaveInterp)));
}
break;
}
return TCL_OK;
} else if ((objc-consumedObjc) & 1 /* isOdd(objc-consumedObjc) */) {
Tcl_WrongNumArgs(interp, consumedObjc, objv, "?-option value ...?");
return TCL_ERROR;
} else {
int i;
size_t scriptLen = 0, limitLen = 0;
Tcl_Obj *scriptObj = NULL, *granObj = NULL, *limitObj = NULL;
int gran = 0, limit = 0;
for (i=consumedObjc ; i<objc ; i+=2) {
if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0,
&index) != TCL_OK) {
return TCL_ERROR;
|
| ︙ | ︙ | |||
4629 4630 4631 4632 4633 4634 4635 | Tcl_Obj *empty; putEmptyCommandInDict: TclNewObj(empty); Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[0], -1), empty); } Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[1], -1), | | | | | 4700 4701 4702 4703 4704 4705 4706 4707 4708 4709 4710 4711 4712 4713 4714 4715 4716 4717 4718 4719 4720 4721 4722 4723 4724 |
Tcl_Obj *empty;
putEmptyCommandInDict:
TclNewObj(empty);
Tcl_DictObjPut(NULL, dictPtr,
Tcl_NewStringObj(options[0], -1), empty);
}
Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[1], -1),
Tcl_NewWideIntObj(Tcl_LimitGetGranularity(slaveInterp,
TCL_LIMIT_TIME)));
if (Tcl_LimitTypeEnabled(slaveInterp, TCL_LIMIT_TIME)) {
Tcl_Time limitMoment;
Tcl_LimitGetTime(slaveInterp, &limitMoment);
Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[2], -1),
Tcl_NewWideIntObj(limitMoment.usec/1000));
Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[3], -1),
Tcl_NewWideIntObj(limitMoment.sec));
} else {
Tcl_Obj *empty;
TclNewObj(empty);
Tcl_DictObjPut(NULL, dictPtr,
Tcl_NewStringObj(options[2], -1), empty);
Tcl_DictObjPut(NULL, dictPtr,
|
| ︙ | ︙ | |||
4669 4670 4671 4672 4673 4674 4675 |
limitCBPtr = Tcl_GetHashValue(hPtr);
if (limitCBPtr != NULL && limitCBPtr->scriptObj != NULL) {
Tcl_SetObjResult(interp, limitCBPtr->scriptObj);
}
}
break;
case OPT_GRAN:
| | | | > | | 4740 4741 4742 4743 4744 4745 4746 4747 4748 4749 4750 4751 4752 4753 4754 4755 4756 4757 4758 4759 4760 4761 4762 4763 4764 4765 4766 4767 4768 4769 4770 4771 4772 4773 4774 4775 4776 4777 4778 4779 4780 4781 |
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(slaveInterp, TCL_LIMIT_TIME)));
break;
case OPT_MILLI:
if (Tcl_LimitTypeEnabled(slaveInterp, TCL_LIMIT_TIME)) {
Tcl_Time limitMoment;
Tcl_LimitGetTime(slaveInterp, &limitMoment);
Tcl_SetObjResult(interp,
Tcl_NewWideIntObj(limitMoment.usec/1000));
}
break;
case OPT_SEC:
if (Tcl_LimitTypeEnabled(slaveInterp, TCL_LIMIT_TIME)) {
Tcl_Time limitMoment;
Tcl_LimitGetTime(slaveInterp, &limitMoment);
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(limitMoment.sec));
}
break;
}
return TCL_OK;
} else if ((objc-consumedObjc) & 1 /* isOdd(objc-consumedObjc) */) {
Tcl_WrongNumArgs(interp, consumedObjc, objv, "?-option value ...?");
return TCL_ERROR;
} else {
int i;
size_t scriptLen = 0, milliLen = 0, secLen = 0;
Tcl_Obj *scriptObj = NULL, *granObj = NULL;
Tcl_Obj *milliObj = NULL, *secObj = NULL;
int gran = 0;
Tcl_Time limitMoment;
int tmp;
Tcl_LimitGetTime(slaveInterp, &limitMoment);
|
| ︙ | ︙ |
Changes to generic/tclLink.c.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 |
/*
* tclLink.c --
*
* This file implements linked variables (a C variable that is tied to a
* Tcl variable). The idea of linked variables was first suggested by
* Andreas Stolcke and this implementation is based heavily on a
* prototype implementation provided by him.
*
* Copyright (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.
*/
#include "tclInt.h"
/*
* For each linked variable there is a data structure of the following type,
* which describes the link and is the clientData for the trace set on the Tcl
* variable.
*/
typedef struct {
Tcl_Interp *interp; /* Interpreter 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. */
| > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > < | > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 |
/*
* tclLink.c --
*
* This file implements linked variables (a C variable that is tied to a
* Tcl variable). The idea of linked variables was first suggested by
* Andreas Stolcke and this implementation is based heavily on a
* prototype implementation provided by him.
*
* Copyright (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 "tommath.h"
#include <math.h>
/*
* For each linked variable there is a data structure of the following type,
* which describes the link and is the clientData for the trace set on the Tcl
* variable.
*/
typedef struct {
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. */
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;
/*
* Definitions for flag bits:
* 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);
static Tcl_Obj * ObjValue(Link *linkPtr);
static void LinkFree(Link *linkPtr);
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 */
};
/*
* Convenience macro for accessing the value of the C variable pointed to by a
* link. Note that this macro produces something that may be regarded as an
* lvalue or rvalue; it may be assigned to as well as read. Also note that
* this macro assumes the name of the variable being accessed (linkPtr); this
* is not strictly a good thing, but it keeps the code much shorter and
|
| ︙ | ︙ | |||
104 105 106 107 108 109 110 |
*----------------------------------------------------------------------
*/
int
Tcl_LinkVar(
Tcl_Interp *interp, /* Interpreter in which varName exists. */
const char *varName, /* Name of a global variable in interp. */
| | > > | > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 |
*----------------------------------------------------------------------
*/
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
* varName. */
int type) /* Type of C variable: TCL_LINK_INT, etc. Also
* may have TCL_LINK_READ_ONLY OR'ed in. */
{
Tcl_Obj *objPtr;
Link *linkPtr;
Namespace *dummy;
const char *name;
int code;
linkPtr = (Link *) Tcl_VarTraceInfo2(interp, varName, NULL,
TCL_GLOBAL_ONLY, LinkTraceProc, (ClientData) NULL);
if (linkPtr != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"variable '%s' is already linked", varName));
return TCL_ERROR;
}
linkPtr = Tcl_Alloc(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 (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);
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 = Tcl_Alloc(sizeof(Link));
linkPtr->type = type & ~TCL_LINK_READ_ONLY;
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);
}
return code;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
182 183 184 185 186 187 188 |
if (linkPtr == NULL) {
return;
}
Tcl_UntraceVar2(interp, varName, NULL,
TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
LinkTraceProc, linkPtr);
Tcl_DecrRefCount(linkPtr->varName);
| | | 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 |
if (linkPtr == NULL) {
return;
}
Tcl_UntraceVar2(interp, varName, NULL,
TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
LinkTraceProc, linkPtr);
Tcl_DecrRefCount(linkPtr->varName);
LinkFree(linkPtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_UpdateLinkedVar --
*
|
| ︙ | ︙ | |||
233 234 235 236 237 238 239 240 241 242 243 244 245 246 |
linkPtr->flags = (linkPtr->flags & ~LINK_BEING_UPDATED) | savedFlag;
}
}
/*
*----------------------------------------------------------------------
*
* LinkTraceProc --
*
* This function is invoked when a linked Tcl variable is read, written,
* or unset from Tcl. It's responsible for keeping the C variable in sync
* with the Tcl variable.
*
* Results:
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 |
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 = clientData;
Tcl_WideUInt value = 0;
union {
Tcl_WideUInt value;
unsigned char bytes[sizeof(Tcl_WideUInt)];
} scratch;
unsigned long numBytes = sizeof(Tcl_WideUInt);
unsigned char *bytes = scratch.bytes;
if (numPtr->sign || (MP_OKAY != mp_to_unsigned_bin_n(numPtr,
bytes, &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_Interp *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 --
*
* This function is invoked when a linked Tcl variable is read, written,
* or unset from Tcl. It's responsible for keeping the C variable in sync
* with the Tcl variable.
*
* Results:
|
| ︙ | ︙ | |||
261 262 263 264 265 266 267 |
Tcl_Interp *interp, /* Interpreter containing Tcl variable. */
const char *name1, /* First part of variable name. */
const char *name2, /* Second part of variable name. */
int flags) /* Miscellaneous additional information. */
{
Link *linkPtr = clientData;
int changed;
| | > > > > | | | | 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 |
Tcl_Interp *interp, /* Interpreter containing Tcl variable. */
const char *name1, /* First part of variable name. */
const char *name2, /* Second part of variable name. */
int flags) /* Miscellaneous additional information. */
{
Link *linkPtr = clientData;
int changed;
size_t valueLength = 0;
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);
} 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_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES
|TCL_TRACE_UNSETS, LinkTraceProc, linkPtr);
}
return NULL;
}
/*
|
| ︙ | ︙ | |||
304 305 306 307 308 309 310 |
/*
* 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) {
| > > > > > > > > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > | | | > | > | 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 |
/*
* 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"; */
}
}
if (changed) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
}
return NULL;
}
|
| ︙ | ︙ | |||
379 380 381 382 383 384 385 386 387 388 |
if (valueObj == NULL) {
/*
* This shouldn't ever happen.
*/
return (char *) "internal error: linked variable couldn't be read";
}
switch (linkPtr->type) {
case TCL_LINK_INT:
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > | > > | | | | | > > > | > > > > > > > > > | > > | | | | | > | < < < > | | | | < > | | > > > > | | > > > > > > > > > > > > > > | | | | | | > > > | > > > > > > > > | | | | | | | > > > | > > > > > > > > > | | | | | | | > > > > | > > > > > > > > | | | | | | | > > > | > > > > > > > > > | | | | | | | > > > > | > > > > > > > > > | | | | | | | > > > > | > > > > > > > > | | | | | | | > > > | > > > > > > > > > | | | | | | | > > < > | > > > | > > | > > | | | | | | > > > | | | | | | | | < | | | > | | > > | < | > > > > > | 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 |
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 = 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, (size_t) valueLength);
memcpy(linkPtr->addr, value, (size_t) valueLength);
} else {
linkPtr->lastValue.c = '\0';
LinkedVar(char) = linkPtr->lastValue.c;
}
return NULL;
case TCL_LINK_BINARY:
value = (char *) 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, (size_t) valueLength);
memcpy(linkPtr->addr, value, (size_t) 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";
}
}
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;
}
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;
}
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;
}
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;
}
break;
case TCL_LINK_CHAR:
if (linkPtr->flags & LINK_ALLOC_LAST) {
for (i=0; i < objc; i++) {
if (GetInt(objv[i], &valueInt)
|| !InRange(SCHAR_MIN, valueInt, SCHAR_MAX)) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
ObjValue(linkPtr), TCL_GLOBAL_ONLY);
return (char *) "variable array must have char value";
}
linkPtr->lastValue.cPtr[i] = (char) valueInt;
}
} else {
if (GetInt(valueObj, &valueInt)
|| !InRange(SCHAR_MIN, valueInt, SCHAR_MAX)) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
ObjValue(linkPtr), TCL_GLOBAL_ONLY);
return (char *) "variable must have char value";
}
LinkedVar(char) = linkPtr->lastValue.c = (char) valueInt;
}
break;
case TCL_LINK_UCHAR:
if (linkPtr->flags & LINK_ALLOC_LAST) {
for (i=0; i < objc; i++) {
if (GetInt(objv[i], &valueInt)
|| !InRange(0, valueInt, 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;
}
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;
}
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;
}
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;
}
break;
case TCL_LINK_ULONG:
if (linkPtr->flags & LINK_ALLOC_LAST) {
for (i=0; i < objc; i++) {
if (GetUWide(objv[i], &valueUWide)
|| !InRange(0, valueUWide, ULONG_MAX)) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
ObjValue(linkPtr), TCL_GLOBAL_ONLY);
return (char *)
"variable array must have unsigned long value";
}
linkPtr->lastValue.ulPtr[i] = (unsigned long) valueUWide;
}
} else {
if (GetUWide(valueObj, &valueUWide)
|| !InRange(0, 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
case TCL_LINK_WIDE_UINT:
if (linkPtr->flags & LINK_ALLOC_LAST) {
for (i=0; i < objc; i++) {
if (GetUWide(objv[i], &valueUWide)) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
ObjValue(linkPtr), TCL_GLOBAL_ONLY);
return (char *)
"variable array must have unsigned wide int value";
}
linkPtr->lastValue.uwPtr[i] = valueUWide;
}
} else {
if (GetUWide(valueObj, &valueUWide)) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
ObjValue(linkPtr), TCL_GLOBAL_ONLY);
return (char *) "variable must have unsigned wide int value";
}
LinkedVar(Tcl_WideUInt) = linkPtr->lastValue.uw = valueUWide;
}
break;
case TCL_LINK_FLOAT:
if (linkPtr->flags & LINK_ALLOC_LAST) {
for (i=0; i < objc; i++) {
if (GetDouble(objv[i], &valueDouble)
&& !InRange(FLT_MIN, fabs(valueDouble), FLT_MAX)
&& !IsSpecial(valueDouble)) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
ObjValue(linkPtr), TCL_GLOBAL_ONLY);
return (char *) "variable array must have float value";
}
linkPtr->lastValue.fPtr[i] = (float) valueDouble;
}
} else {
if (GetDouble(valueObj, &valueDouble)
&& !InRange(FLT_MIN, fabs(valueDouble), FLT_MAX)
&& !IsSpecial(valueDouble)) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
ObjValue(linkPtr), TCL_GLOBAL_ONLY);
return (char *) "variable must have float value";
}
LinkedVar(float) = linkPtr->lastValue.f = (float) valueDouble;
}
break;
default:
return (char *) "internal error: bad linked variable type";
}
if (linkPtr->flags & LINK_ALLOC_LAST) {
memcpy(linkPtr->addr, linkPtr->lastValue.aryPtr, linkPtr->bytes);
}
return NULL;
}
/*
*----------------------------------------------------------------------
*
* ObjValue --
|
| ︙ | ︙ | |||
569 570 571 572 573 574 575 |
*/
static Tcl_Obj *
ObjValue(
Link *linkPtr) /* Structure describing linked variable. */
{
char *p;
| | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > < < < > > > > > > > > > > > > > > > > > > > > | < > > | < < | < < < < | < < < < > | < < < < < < < < < < < < < < < < | < < | < < < < < | > > | < < < < < > < < | < | < < | < < < < < < < | < < | | < < | | | | < < < < < < < < < < | < < < | < < < < < < < < | 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 |
*/
static Tcl_Obj *
ObjValue(
Link *linkPtr) /* Structure describing linked variable. */
{
char *p;
Tcl_Obj *resultObj, **objv;
size_t i;
switch (linkPtr->type) {
case TCL_LINK_INT:
if (linkPtr->flags & LINK_ALLOC_LAST) {
memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
objv = Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *));
for (i=0; i < linkPtr->numElems; i++) {
objv[i] = Tcl_NewIntObj(linkPtr->lastValue.iPtr[i]);
}
resultObj = Tcl_NewListObj(linkPtr->numElems, objv);
Tcl_Free(objv);
return resultObj;
}
linkPtr->lastValue.i = LinkedVar(int);
return Tcl_NewIntObj(linkPtr->lastValue.i);
case TCL_LINK_WIDE_INT:
if (linkPtr->flags & LINK_ALLOC_LAST) {
memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
objv = Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *));
for (i=0; i < linkPtr->numElems; i++) {
objv[i] = Tcl_NewWideIntObj(linkPtr->lastValue.wPtr[i]);
}
resultObj = Tcl_NewListObj(linkPtr->numElems, objv);
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_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_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);
case TCL_LINK_CHAR:
if (linkPtr->flags & LINK_ALLOC_LAST) {
memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
objv = Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *));
for (i=0; i < linkPtr->numElems; i++) {
objv[i] = Tcl_NewIntObj(linkPtr->lastValue.cPtr[i]);
}
resultObj = Tcl_NewListObj(linkPtr->numElems, objv);
Tcl_Free(objv);
return resultObj;
}
linkPtr->lastValue.c = LinkedVar(char);
return Tcl_NewIntObj(linkPtr->lastValue.c);
case TCL_LINK_UCHAR:
if (linkPtr->flags & LINK_ALLOC_LAST) {
memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
objv = Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *));
for (i=0; i < linkPtr->numElems; i++) {
objv[i] = Tcl_NewIntObj(linkPtr->lastValue.ucPtr[i]);
}
resultObj = Tcl_NewListObj(linkPtr->numElems, objv);
Tcl_Free(objv);
return resultObj;
}
linkPtr->lastValue.uc = LinkedVar(unsigned char);
return Tcl_NewIntObj(linkPtr->lastValue.uc);
case TCL_LINK_SHORT:
if (linkPtr->flags & LINK_ALLOC_LAST) {
memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
objv = Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *));
for (i=0; i < linkPtr->numElems; i++) {
objv[i] = Tcl_NewIntObj(linkPtr->lastValue.sPtr[i]);
}
resultObj = Tcl_NewListObj(linkPtr->numElems, objv);
Tcl_Free(objv);
return resultObj;
}
linkPtr->lastValue.s = LinkedVar(short);
return Tcl_NewIntObj(linkPtr->lastValue.s);
case TCL_LINK_USHORT:
if (linkPtr->flags & LINK_ALLOC_LAST) {
memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
objv = Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *));
for (i=0; i < linkPtr->numElems; i++) {
objv[i] = Tcl_NewIntObj(linkPtr->lastValue.usPtr[i]);
}
resultObj = Tcl_NewListObj(linkPtr->numElems, objv);
Tcl_Free(objv);
return resultObj;
}
linkPtr->lastValue.us = LinkedVar(unsigned short);
return Tcl_NewIntObj(linkPtr->lastValue.us);
case TCL_LINK_UINT:
if (linkPtr->flags & LINK_ALLOC_LAST) {
memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
objv = Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *));
for (i=0; i < linkPtr->numElems; i++) {
objv[i] = Tcl_NewWideIntObj(linkPtr->lastValue.uiPtr[i]);
}
resultObj = Tcl_NewListObj(linkPtr->numElems, objv);
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_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *));
for (i=0; i < linkPtr->numElems; i++) {
objv[i] = Tcl_NewWideIntObj(linkPtr->lastValue.lPtr[i]);
}
resultObj = Tcl_NewListObj(linkPtr->numElems, objv);
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_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *));
for (i=0; i < linkPtr->numElems; i++) {
objv[i] = Tcl_NewWideIntObj(linkPtr->lastValue.ulPtr[i]);
}
resultObj = Tcl_NewListObj(linkPtr->numElems, objv);
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_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_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *));
for (i=0; i < linkPtr->numElems; i++) {
objv[i] = Tcl_NewWideIntObj((Tcl_WideInt)
linkPtr->lastValue.uwPtr[i]);
}
resultObj = Tcl_NewListObj(linkPtr->numElems, objv);
Tcl_Free(objv);
return resultObj;
}
linkPtr->lastValue.uw = LinkedVar(Tcl_WideUInt);
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).
*/
default:
TclNewLiteralStringObj(resultObj, "??");
return resultObj;
}
}
/*
*----------------------------------------------------------------------
*
* LinkFree --
*
* Free's allocated space of given link and link structure.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
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);
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclListObj.c.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 15 16 17 18 19 20 21 | * 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. */ #include "tclInt.h" /* * Prototypes for functions defined later in this file: */ static List * AttemptNewList(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); | > | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | * 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. */ #include "tclInt.h" #include <assert.h> /* * Prototypes for functions defined later in this file: */ static List * AttemptNewList(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); |
| ︙ | ︙ | |||
42 43 44 45 46 47 48 49 50 51 52 53 54 55 |
"list", /* name */
FreeListInternalRep, /* freeIntRepProc */
DupListInternalRep, /* dupIntRepProc */
UpdateStringOfList, /* updateStringProc */
SetListFromAny /* setFromAnyProc */
};
#ifndef TCL_MIN_ELEMENT_GROWTH
#define TCL_MIN_ELEMENT_GROWTH TCL_MIN_GROWTH/sizeof(Tcl_Obj *)
#endif
/*
*----------------------------------------------------------------------
*
| > > > > > > > > > > > > > > > > > > > > > | 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 |
"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 ? 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
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
98 99 100 101 102 103 104 |
if (p) {
Tcl_Panic("max length of a Tcl list (%d elements) exceeded",
LIST_MAX);
}
return NULL;
}
| | | | 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 |
if (p) {
Tcl_Panic("max length of a Tcl list (%d elements) exceeded",
LIST_MAX);
}
return NULL;
}
listRepPtr = Tcl_AttemptAlloc(LIST_SIZE(objc));
if (listRepPtr == NULL) {
if (p) {
Tcl_Panic("list creation failed: unable to alloc %" TCL_Z_MODIFIER "u bytes",
LIST_SIZE(objc));
}
return NULL;
}
listRepPtr->canonicalFlag = 0;
listRepPtr->refCount = 0;
|
| ︙ | ︙ | |||
152 153 154 155 156 157 158 |
if (interp != NULL && listRepPtr == NULL) {
if (objc > LIST_MAX) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"max length of a Tcl list (%d elements) exceeded",
LIST_MAX));
} else {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
| | | 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 |
if (interp != NULL && listRepPtr == NULL) {
if (objc > LIST_MAX) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"max length of a Tcl list (%d elements) exceeded",
LIST_MAX));
} else {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"list creation failed: unable to alloc %" TCL_Z_MODIFIER "u bytes",
LIST_SIZE(objc)));
}
Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
}
return listRepPtr;
}
|
| ︙ | ︙ | |||
332 333 334 335 336 337 338 |
* object an empty string rep and a NULL type.
*/
if (objc > 0) {
listRepPtr = NewListIntRep(objc, objv, 1);
ListSetIntRep(objPtr, listRepPtr);
} else {
| < | | 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 |
* object an empty string rep and a NULL type.
*/
if (objc > 0) {
listRepPtr = NewListIntRep(objc, objv, 1);
ListSetIntRep(objPtr, listRepPtr);
} else {
Tcl_InitStringRep(objPtr, NULL, 0);
}
}
/*
*----------------------------------------------------------------------
*
* TclListObjCopy --
|
| ︙ | ︙ | |||
367 368 369 370 371 372 373 374 |
Tcl_Obj *
TclListObjCopy(
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;
| > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 |
Tcl_Obj *
TclListObjCopy(
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 (SetListFromAny(interp, listPtr) != TCL_OK) {
return NULL;
}
}
TclNewObj(copyPtr);
TclInvalidateStringRep(copyPtr);
DupListInternalRep(listPtr, copyPtr);
return copyPtr;
}
/*
*----------------------------------------------------------------------
*
* TclListObjRange --
*
* Makes a slice of a list value.
* *listPtr must be known to be a valid list.
*
* Results:
* Returns a pointer to the sliced list.
* This may be a new object or the same object if not shared.
*
* 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. */
int fromIdx, /* Index of first element to include. */
int toIdx) /* Index of last element to include. */
{
Tcl_Obj **elemPtrs;
int listLen, i, newLen;
List *listRepPtr;
TclListObjGetElements(NULL, listPtr, &listLen, &elemPtrs);
if (fromIdx < 0) {
fromIdx = 0;
}
if (toIdx >= listLen) {
toIdx = listLen-1;
}
if (fromIdx > toIdx) {
return Tcl_NewObj();
}
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 < 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'.
|
| ︙ | ︙ | |||
425 426 427 428 429 430 431 |
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. */
{
register List *listRepPtr;
| > | > > | > > < | 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 |
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. */
{
register List *listRepPtr;
ListGetIntRep(listPtr, listRepPtr);
if (listRepPtr == NULL) {
int result;
size_t length;
(void) TclGetStringFromObj(listPtr, &length);
if (length == 0) {
*objcPtr = 0;
*objvPtr = NULL;
return TCL_OK;
}
result = SetListFromAny(interp, listPtr);
if (result != TCL_OK) {
return result;
}
ListGetIntRep(listPtr, listRepPtr);
}
*objcPtr = listRepPtr->elemCount;
*objvPtr = &listRepPtr->elements;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
545 546 547 548 549 550 551 |
{
register List *listRepPtr, *newPtr = NULL;
int numElems, numRequired, needGrow, isShared, attempt;
if (Tcl_IsShared(listPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_ListObjAppendElement");
}
| | > > > | > > < | 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 |
{
register List *listRepPtr, *newPtr = NULL;
int numElems, numRequired, needGrow, isShared, attempt;
if (Tcl_IsShared(listPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_ListObjAppendElement");
}
ListGetIntRep(listPtr, listRepPtr);
if (listRepPtr == NULL) {
int result;
size_t length;
(void) TclGetStringFromObj(listPtr, &length);
if (length == 0) {
Tcl_SetListObj(listPtr, 1, &objPtr);
return TCL_OK;
}
result = SetListFromAny(interp, listPtr);
if (result != TCL_OK) {
return result;
}
ListGetIntRep(listPtr, listRepPtr);
}
numElems = listRepPtr->elemCount;
numRequired = numElems + 1 ;
needGrow = (numRequired > listRepPtr->maxElemCount);
isShared = (listRepPtr->refCount > 1);
if (numRequired > LIST_MAX) {
if (interp != NULL) {
|
| ︙ | ︙ | |||
581 582 583 584 585 586 587 |
if (needGrow && !isShared) {
/*
* Need to grow + unshared intrep => try to realloc
*/
attempt = 2 * numRequired;
if (attempt <= LIST_MAX) {
| | | | | 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 |
if (needGrow && !isShared) {
/*
* Need to grow + unshared intrep => try to realloc
*/
attempt = 2 * numRequired;
if (attempt <= LIST_MAX) {
newPtr = Tcl_AttemptRealloc(listRepPtr, LIST_SIZE(attempt));
}
if (newPtr == NULL) {
attempt = numRequired + 1 + TCL_MIN_ELEMENT_GROWTH;
if (attempt > LIST_MAX) {
attempt = LIST_MAX;
}
newPtr = Tcl_AttemptRealloc(listRepPtr, LIST_SIZE(attempt));
}
if (newPtr == NULL) {
attempt = numRequired;
newPtr = Tcl_AttemptRealloc(listRepPtr, LIST_SIZE(attempt));
}
if (newPtr) {
listRepPtr = newPtr;
listRepPtr->maxElemCount = attempt;
needGrow = 0;
}
}
|
| ︙ | ︙ | |||
649 650 651 652 653 654 655 |
}
listRepPtr->refCount--;
} else {
/*
* Old intrep to be freed, re-use refCounts.
*/
| | | > | > > > | 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 |
}
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--;
/*
* 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;
|
| ︙ | ︙ | |||
713 714 715 716 717 718 719 |
Tcl_Interp *interp, /* Used to report errors if not NULL. */
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. */
{
register List *listRepPtr;
| > | > | > > < | 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 |
Tcl_Interp *interp, /* Used to report errors if not NULL. */
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. */
{
register List *listRepPtr;
ListGetIntRep(listPtr, listRepPtr);
if (listRepPtr == NULL) {
int result;
size_t length;
(void) TclGetStringFromObj(listPtr, &length);
if (length == 0) {
*objPtrPtr = NULL;
return TCL_OK;
}
result = SetListFromAny(interp, listPtr);
if (result != TCL_OK) {
return result;
}
ListGetIntRep(listPtr, listRepPtr);
}
if ((index < 0) || (index >= listRepPtr->elemCount)) {
*objPtrPtr = NULL;
} else {
*objPtrPtr = (&listRepPtr->elements)[index];
}
return TCL_OK;
|
| ︙ | ︙ | |||
767 768 769 770 771 772 773 |
Tcl_ListObjLength(
Tcl_Interp *interp, /* Used to report errors if not NULL. */
register Tcl_Obj *listPtr, /* List object whose #elements to return. */
register int *intPtr) /* The resulting int is stored here. */
{
register List *listRepPtr;
| > | > | > > < | 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 |
Tcl_ListObjLength(
Tcl_Interp *interp, /* Used to report errors if not NULL. */
register Tcl_Obj *listPtr, /* List object whose #elements to return. */
register int *intPtr) /* The resulting int is stored here. */
{
register List *listRepPtr;
ListGetIntRep(listPtr, listRepPtr);
if (listRepPtr == NULL) {
int result;
size_t length;
(void) TclGetStringFromObj(listPtr, &length);
if (length == 0) {
*intPtr = 0;
return TCL_OK;
}
result = SetListFromAny(interp, listPtr);
if (result != TCL_OK) {
return result;
}
ListGetIntRep(listPtr, listRepPtr);
}
*intPtr = listRepPtr->elemCount;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
841 842 843 844 845 846 847 |
List *listRepPtr;
register Tcl_Obj **elemPtrs;
int needGrow, numElems, numRequired, numAfterLast, start, i, j, isShared;
if (Tcl_IsShared(listPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_ListObjReplace");
}
| | > > > | > > | > < | 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 |
List *listRepPtr;
register Tcl_Obj **elemPtrs;
int needGrow, numElems, numRequired, numAfterLast, start, i, j, isShared;
if (Tcl_IsShared(listPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_ListObjReplace");
}
ListGetIntRep(listPtr, listRepPtr);
if (listRepPtr == NULL) {
size_t length;
(void) TclGetStringFromObj(listPtr, &length);
if (length == 0) {
if (objc == 0) {
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
* 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.
*/
elemPtrs = &listRepPtr->elements;
numElems = listRepPtr->elemCount;
if (first < 0) {
first = 0;
}
if (first >= numElems) {
|
| ︙ | ︙ | |||
903 904 905 906 907 908 909 |
}
if (needGrow && !isShared) {
/* Try to use realloc */
List *newPtr = NULL;
int attempt = 2 * numRequired;
if (attempt <= LIST_MAX) {
| | | | | | 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 |
}
if (needGrow && !isShared) {
/* Try to use realloc */
List *newPtr = NULL;
int attempt = 2 * numRequired;
if (attempt <= LIST_MAX) {
newPtr = Tcl_AttemptRealloc(listRepPtr, LIST_SIZE(attempt));
}
if (newPtr == NULL) {
attempt = numRequired + 1 + TCL_MIN_ELEMENT_GROWTH;
if (attempt > LIST_MAX) {
attempt = LIST_MAX;
}
newPtr = Tcl_AttemptRealloc(listRepPtr, LIST_SIZE(attempt));
}
if (newPtr == NULL) {
attempt = numRequired;
newPtr = 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) {
int shift;
|
| ︙ | ︙ | |||
949 950 951 952 953 954 955 |
start = first + count;
numAfterLast = numElems - start;
shift = objc - count; /* numNewElems - numDeleted */
if ((numAfterLast > 0) && (shift != 0)) {
Tcl_Obj **src = elemPtrs + start;
| | | | 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 |
start = first + count;
numAfterLast = numElems - start;
shift = objc - count; /* numNewElems - numDeleted */
if ((numAfterLast > 0) && (shift != 0)) {
Tcl_Obj **src = elemPtrs + start;
memmove(src+shift, src, numAfterLast * sizeof(Tcl_Obj*));
}
} else {
/*
* Cannot use the current List struct; it is shared, too small, or
* both. Allocate a new struct and insert elements into it.
*/
List *oldListRepPtr = listRepPtr;
Tcl_Obj **oldPtrs = elemPtrs;
int newMax;
if (needGrow) {
newMax = 2 * numRequired;
} else {
newMax = listRepPtr->maxElemCount;
}
listRepPtr = AttemptNewList(NULL, newMax, NULL);
if (listRepPtr == NULL) {
|
| ︙ | ︙ | |||
987 988 989 990 991 992 993 | Tcl_DecrRefCount(objv[i]); } return TCL_ERROR; } } } | | | 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 |
Tcl_DecrRefCount(objv[i]);
}
return TCL_ERROR;
}
}
}
ListResetIntRep(listPtr, listRepPtr);
listRepPtr->refCount++;
elemPtrs = &listRepPtr->elements;
if (isShared) {
/*
* The old struct will remain in place; need new refCounts for the
|
| ︙ | ︙ | |||
1016 1017 1018 1019 1020 1021 1022 |
oldListRepPtr->refCount--;
} else {
/*
* The old struct will be removed; use its inherited refCounts.
*/
if (first > 0) {
| | | 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 |
oldListRepPtr->refCount--;
} else {
/*
* The old struct will be removed; use its inherited refCounts.
*/
if (first > 0) {
memcpy(elemPtrs, oldPtrs, first * sizeof(Tcl_Obj *));
}
/*
* "Delete" count elements starting at first.
*/
for (j = first; j < first + count; j++) {
|
| ︙ | ︙ | |||
1041 1042 1043 1044 1045 1046 1047 |
start = first + count;
numAfterLast = numElems - start;
if (numAfterLast > 0) {
memcpy(elemPtrs + first + objc, oldPtrs + start,
(size_t) numAfterLast * sizeof(Tcl_Obj *));
}
| | | | > > > > > | 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 |
start = first + count;
numAfterLast = numElems - start;
if (numAfterLast > 0) {
memcpy(elemPtrs + first + objc, oldPtrs + start,
(size_t) numAfterLast * sizeof(Tcl_Obj *));
}
Tcl_Free(oldListRepPtr);
}
}
/*
* Insert the new elements into elemPtrs before "first".
*/
for (i=0,j=first ; i<objc ; i++,j++) {
elemPtrs[j] = objv[i];
}
/*
* Update the count of elements.
*/
listRepPtr->elemCount = numRequired;
/*
* Invalidate and free any old representations that may not agree
* with the revised list's internal representation.
*/
listRepPtr->refCount++;
TclFreeIntRep(listPtr);
ListSetIntRep(listPtr, listRepPtr);
listRepPtr->refCount--;
TclInvalidateStringRep(listPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
1097 1098 1099 1100 1101 1102 1103 |
Tcl_Obj *
TclLindexList(
Tcl_Interp *interp, /* Tcl interpreter. */
Tcl_Obj *listPtr, /* List being unpacked. */
Tcl_Obj *argPtr) /* Index or index list. */
{
| | > | > | | 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 |
Tcl_Obj *
TclLindexList(
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. */
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, TCL_INDEX_START, &index) == TCL_OK) {
/*
* argPtr designates a single index.
*/
return TclLindexFlat(interp, listPtr, 1, &argPtr);
}
|
| ︙ | ︙ | |||
1137 1138 1139 1140 1141 1142 1143 |
* argPtr designates something that is neither an index nor a
* well-formed list. Report the error via TclLindexFlat.
*/
return TclLindexFlat(interp, listPtr, 1, &argPtr);
}
| > | < | < | < > | 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 |
* argPtr designates something that is neither an index nor a
* well-formed list. Report the error via TclLindexFlat.
*/
return TclLindexFlat(interp, listPtr, 1, &argPtr);
}
ListGetIntRep(indexListCopy, listRepPtr);
assert(listRepPtr != NULL);
listPtr = TclLindexFlat(interp, listPtr, listRepPtr->elemCount,
&listRepPtr->elements);
Tcl_DecrRefCount(indexListCopy);
return listPtr;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1182 1183 1184 1185 1186 1187 1188 |
* represent the indices in the list. */
{
int i;
Tcl_IncrRefCount(listPtr);
for (i=0 ; i<indexCount && listPtr ; i++) {
| > | | 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 |
* represent the indices in the list. */
{
int i;
Tcl_IncrRefCount(listPtr);
for (i=0 ; i<indexCount && listPtr ; i++) {
size_t index;
int listLen = 0;
Tcl_Obj **elemPtrs = NULL, *sublistCopy;
/*
* Here we make a private copy of the current sublist, so we avoid any
* shimmering issues that might invalidate the elemPtr array below
* while we are still using it. See test lindex-8.4.
*/
|
| ︙ | ︙ | |||
1206 1207 1208 1209 1210 1211 1212 |
break;
}
TclListObjGetElements(NULL, sublistCopy, &listLen, &elemPtrs);
if (TclGetIntForIndexM(interp, indexArray[i], /*endValue*/ listLen-1,
&index) == TCL_OK) {
| | | | 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 |
break;
}
TclListObjGetElements(NULL, sublistCopy, &listLen, &elemPtrs);
if (TclGetIntForIndexM(interp, indexArray[i], /*endValue*/ listLen-1,
&index) == TCL_OK) {
if (index >= (size_t)listLen) {
/*
* Index is out of range. Break out of loop with empty result.
* First check remaining indices for validity
*/
while (++i < indexCount) {
if (TclGetIntForIndexM(interp, indexArray[i], TCL_INDEX_NONE, &index)
!= TCL_OK) {
Tcl_DecrRefCount(sublistCopy);
return NULL;
}
}
listPtr = Tcl_NewObj();
} else {
|
| ︙ | ︙ | |||
1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 |
/*
*----------------------------------------------------------------------
*
* TclLsetList --
*
* The core of [lset] when objc == 4. Objv[2] may be either a
* scalar index or a list of indices.
*
* 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.
*
*----------------------------------------------------------------------
*/
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'. */
| > | | > | > | | 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 |
/*
*----------------------------------------------------------------------
*
* TclLsetList --
*
* The core of [lset] 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.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclLsetList(
Tcl_Interp *interp, /* Tcl interpreter. */
Tcl_Obj *listPtr, /* Pointer to the list being modified. */
Tcl_Obj *indexArgPtr, /* Index or index-list arg to 'lset'. */
Tcl_Obj *valuePtr) /* Value arg to 'lset' or NULL to 'lpop'. */
{
int indexCount = 0; /* Number of indices in the index list. */
Tcl_Obj **indices = NULL; /* Vector of indices in the index list. */
Tcl_Obj *retValuePtr; /* Pointer to the list to be returned. */
size_t 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, TCL_INDEX_START, &index) == TCL_OK) {
/*
* indexArgPtr designates a single index.
*/
return TclLsetFlat(interp, listPtr, 1, &indexArgPtr, valuePtr);
}
|
| ︙ | ︙ | |||
1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 | /* *---------------------------------------------------------------------- * * TclLsetFlat -- * * Core engine of the 'lset' command. * * Value * * The resulting list * * The 'refCount' of 'valuePtr' is incremented. If 'listPtr' was not * duplicated, its 'refCount' is incremented. The reference count of | > | 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 | /* *---------------------------------------------------------------------- * * 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 |
| ︙ | ︙ | |||
1357 1358 1359 1360 1361 1362 1363 |
Tcl_Obj *
TclLsetFlat(
Tcl_Interp *interp, /* Tcl interpreter. */
Tcl_Obj *listPtr, /* Pointer to the list being modified. */
int indexCount, /* Number of index args. */
Tcl_Obj *const indexArray[],
/* Index args. */
| | > | > > > | > | 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 |
Tcl_Obj *
TclLsetFlat(
Tcl_Interp *interp, /* Tcl interpreter. */
Tcl_Obj *listPtr, /* Pointer to the list being modified. */
int indexCount, /* Number of index args. */
Tcl_Obj *const indexArray[],
/* Index args. */
Tcl_Obj *valuePtr) /* Value arg to 'lset' or NULL to 'lpop'. */
{
size_t index;
int result, len;
Tcl_Obj *subListPtr, *retValuePtr, *chainPtr;
Tcl_ObjIntRep *irPtr;
/*
* If there are no indices, simply return the new value. (Without
* indices, [lset] is a synonym for [set].
* [lpop] does not use this but protect for NULL valuePtr just in case.
*/
if (indexCount == 0) {
if (valuePtr != NULL) {
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
|
| ︙ | ︙ | |||
1428 1429 1430 1431 1432 1433 1434 | /* ...the index we're trying to use isn't an index at all. */ result = TCL_ERROR; indexArray++; break; } indexArray++; | | > | > | | | 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 |
/* ...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)) {
/* ...the index points outside the sublist. */
if (interp != NULL) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("list index out of range", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION",
valuePtr == NULL ? "LPOP" : "LSET",
"BADINDEX", NULL);
}
result = TCL_ERROR;
break;
}
/*
* No error conditions. As long as we're not yet on the last index,
* determine the next sublist for the next pass through the loop, and
* take steps to make sure it is an unshared copy, as we intend to
* modify it.
*/
if (--indexCount) {
parentList = subListPtr;
if (index == (size_t)elemCount) {
subListPtr = Tcl_NewObj();
} else {
subListPtr = elemPtrs[index];
}
if (Tcl_IsShared(subListPtr)) {
subListPtr = Tcl_DuplicateObj(subListPtr);
}
/*
* Replace the original elemPtr[index] in parentList with a copy
* we know to be unshared. This call will also deal with the
* situation where parentList shares its intrep with other
* Tcl_Obj's. Dealing with the shared intrep case can cause
* subListPtr to become shared again, so detect that case and make
* and store another copy.
*/
if (index == (size_t)elemCount) {
Tcl_ListObjAppendElement(NULL, parentList, subListPtr);
} else {
TclListObjSetElement(NULL, parentList, index, subListPtr);
}
if (Tcl_IsShared(subListPtr)) {
subListPtr = Tcl_DuplicateObj(subListPtr);
TclListObjSetElement(NULL, parentList, index, subListPtr);
|
| ︙ | ︙ | |||
1491 1492 1493 1494 1495 1496 1497 | * 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. */ | > | | < < < < < < < < > > | > > > > > > > > > > > > > > > | > | 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 |
* 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;
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.
*/
while (chainPtr) {
Tcl_Obj *objPtr = chainPtr;
List *listRepPtr;
/*
* Clear away our intrep surgery mess.
*/
irPtr = TclFetchIntRep(objPtr, &tclListType);
listRepPtr = irPtr->twoPtrValue.ptr1;
chainPtr = irPtr->twoPtrValue.ptr2;
if (result == TCL_OK) {
/*
* 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;
}
}
if (result != TCL_OK) {
/*
* Error return; message is already in interp. Clean up any excess
* memory.
*/
|
| ︙ | ︙ | |||
1543 1544 1545 1546 1547 1548 1549 |
* 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);
| > > | < | > | 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 |
* 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);
}
Tcl_IncrRefCount(retValuePtr);
return retValuePtr;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1616 1617 1618 1619 1620 1621 1622 |
/*
* Ensure that the listPtr parameter designates an unshared list.
*/
if (Tcl_IsShared(listPtr)) {
Tcl_Panic("%s called with shared object", "TclListObjSetElement");
}
| | > > > | > > < | 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 |
/*
* Ensure that the listPtr parameter designates an unshared list.
*/
if (Tcl_IsShared(listPtr)) {
Tcl_Panic("%s called with shared object", "TclListObjSetElement");
}
ListGetIntRep(listPtr, listRepPtr);
if (listRepPtr == NULL) {
int result;
size_t length;
(void) TclGetStringFromObj(listPtr, &length);
if (length == 0) {
if (interp != NULL) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("list index out of range", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSET",
"BADINDEX", NULL);
}
return TCL_ERROR;
}
result = SetListFromAny(interp, listPtr);
if (result != TCL_OK) {
return result;
}
ListGetIntRep(listPtr, listRepPtr);
}
elemCount = listRepPtr->elemCount;
/*
* Ensure that the index is in bounds.
*/
if (index<0 || index>=elemCount) {
|
| ︙ | ︙ | |||
1677 1678 1679 1680 1681 1682 1683 |
while (elemCount--) {
*dst = *src++;
Tcl_IncrRefCount(*dst++);
}
listRepPtr->refCount--;
| | > | 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 |
while (elemCount--) {
*dst = *src++;
Tcl_IncrRefCount(*dst++);
}
listRepPtr->refCount--;
listRepPtr = newPtr;
ListResetIntRep(listPtr, listRepPtr);
}
elemPtrs = &listRepPtr->elements;
/*
* Add a reference to the new list element.
*/
|
| ︙ | ︙ | |||
1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 |
/*
* Stash the new object in the list.
*/
elemPtrs[index] = valuePtr;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* FreeListInternalRep --
*
* Deallocate the storage associated with the internal representation of a
* a list object.
*
* Effect
*
| > > > > > > > > > > > > | < | | > > > | < < | 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 |
/*
* 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.
*
* Effect
*
* Frees listPtr's List* internal representation, if no longer shared.
* May decrement the ref counts of element objects, which may free them.
*
*----------------------------------------------------------------------
*/
static void
FreeListInternalRep(
Tcl_Obj *listPtr) /* List object with internal rep to free. */
{
List *listRepPtr;
ListGetIntRep(listPtr, listRepPtr);
assert(listRepPtr != NULL);
if (listRepPtr->refCount-- <= 1) {
Tcl_Obj **elemPtrs = &listRepPtr->elements;
int i, numElems = listRepPtr->elemCount;
for (i = 0; i < numElems; i++) {
Tcl_DecrRefCount(elemPtrs[i]);
}
Tcl_Free(listRepPtr);
}
}
/*
*----------------------------------------------------------------------
*
* DupListInternalRep --
*
|
| ︙ | ︙ | |||
1758 1759 1760 1761 1762 1763 1764 |
*/
static void
DupListInternalRep(
Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
Tcl_Obj *copyPtr) /* Object with internal rep to set. */
{
| | > > | 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 |
*/
static void
DupListInternalRep(
Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
Tcl_Obj *copyPtr) /* Object with internal rep to set. */
{
List *listRepPtr;
ListGetIntRep(srcPtr, listRepPtr);
assert(listRepPtr != NULL);
ListSetIntRep(copyPtr, listRepPtr);
}
/*
*----------------------------------------------------------------------
*
* SetListFromAny --
|
| ︙ | ︙ | |||
1802 1803 1804 1805 1806 1807 1808 |
* Dictionaries are a special case; they have a string representation such
* that *all* valid dictionaries are valid lists. Hence we can convert
* 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).
*/
| | | 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 |
* Dictionaries are a special case; they have a string representation such
* that *all* valid dictionaries are valid lists. Hence we can convert
* 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)) {
Tcl_Obj *keyPtr, *valuePtr;
Tcl_DictSearch search;
int done, size;
/*
* Create the new list representation. Note that we do not need to do
* anything with the string representation as the transformation (and
|
| ︙ | ︙ | |||
1837 1838 1839 1840 1841 1842 1843 |
*elemPtrs++ = keyPtr;
*elemPtrs++ = valuePtr;
Tcl_IncrRefCount(keyPtr);
Tcl_IncrRefCount(valuePtr);
Tcl_DictObjNext(&search, &keyPtr, &valuePtr, &done);
}
} else {
| | > | 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 |
*elemPtrs++ = keyPtr;
*elemPtrs++ = valuePtr;
Tcl_IncrRefCount(keyPtr);
Tcl_IncrRefCount(valuePtr);
Tcl_DictObjNext(&search, &keyPtr, &valuePtr, &done);
}
} else {
int estCount;
size_t length;
const char *limit, *nextElem = TclGetStringFromObj(objPtr, &length);
/*
* Allocate enough space to hold a (Tcl_Obj *) for each
* (possible) list element.
*/
|
| ︙ | ︙ | |||
1860 1861 1862 1863 1864 1865 1866 |
/*
* Each iteration, parse and store a list element.
*/
while (nextElem < limit) {
const char *elemStart;
| > > | > | < < < < | | > > > > > > > > > > > > | < | | < | 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 |
/*
* Each iteration, parse and store a list element.
*/
while (nextElem < limit) {
const char *elemStart;
char *check;
size_t elemSize;
int literal;
if (TCL_OK != TclFindElement(interp, nextElem, limit - nextElem,
&elemStart, &nextElem, &elemSize, &literal)) {
fail:
while (--elemPtrs >= &listRepPtr->elements) {
Tcl_DecrRefCount(*elemPtrs);
}
Tcl_Free(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));
}
Tcl_IncrRefCount(*elemPtrs++);/* Since list now holds ref to it. */
}
listRepPtr->elemCount = elemPtrs - &listRepPtr->elements;
}
/*
* Store the new internalRep. We do this as late
* as possible to allow the conversion code, in particular
* Tcl_GetStringFromObj, to use the old internalRep.
*/
ListSetIntRep(objPtr, listRepPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1926 1927 1928 1929 1930 1931 1932 |
static void
UpdateStringOfList(
Tcl_Obj *listPtr) /* List object with string rep to update. */
{
# define LOCAL_SIZE 64
char localFlags[LOCAL_SIZE], *flagPtr = NULL;
| < | | | > > > > > > > < | | < < | < < < < | | | < | > > | | 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 |
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;
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.
*/
if (numElems == 0) {
Tcl_InitStringRep(listPtr, NULL, 0);
return;
}
/*
* Pass 1: estimate space, gather flags.
*/
if (numElems <= LOCAL_SIZE) {
flagPtr = localFlags;
} else {
/*
* We know numElems <= LIST_MAX, so this is safe.
*/
flagPtr = Tcl_Alloc(numElems);
}
elemPtrs = &listRepPtr->elements;
for (i = 0; i < numElems; i++) {
flagPtr[i] = (i ? TCL_DONT_QUOTE_HASH : 0);
elem = TclGetStringFromObj(elemPtrs[i], &length);
bytesNeeded += TclScanElement(elem, length, flagPtr+i);
}
bytesNeeded += numElems - 1;
/*
* Pass 2: copy into string rep buffer.
*/
start = dst = Tcl_InitStringRep(listPtr, NULL, bytesNeeded);
TclOOM(dst, bytesNeeded);
for (i = 0; i < numElems; i++) {
flagPtr[i] |= (i ? TCL_DONT_QUOTE_HASH : 0);
elem = TclGetStringFromObj(elemPtrs[i], &length);
dst += TclConvertElement(elem, length, dst, flagPtr[i]);
*dst++ = ' ';
}
/* Set the string length to what was actually written, the safe choice */
(void) Tcl_InitStringRep(listPtr, NULL, dst - 1 - start);
if (flagPtr != localFlags) {
Tcl_Free(flagPtr);
}
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclLiteral.c.
| ︙ | ︙ | |||
127 128 129 130 131 132 133 |
for (i=0 ; i<tablePtr->numBuckets ; i++) {
entryPtr = tablePtr->buckets[i];
while (entryPtr != NULL) {
objPtr = entryPtr->objPtr;
TclDecrRefCount(objPtr);
nextPtr = entryPtr->nextPtr;
| | | | 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 |
for (i=0 ; i<tablePtr->numBuckets ; i++) {
entryPtr = tablePtr->buckets[i];
while (entryPtr != NULL) {
objPtr = entryPtr->objPtr;
TclDecrRefCount(objPtr);
nextPtr = entryPtr->nextPtr;
Tcl_Free(entryPtr);
entryPtr = nextPtr;
}
}
/*
* Free up the table's bucket array if it was dynamically allocated.
*/
if (tablePtr->buckets != tablePtr->staticBuckets) {
Tcl_Free(tablePtr->buckets);
}
}
/*
*----------------------------------------------------------------------
*
* TclCreateLiteral --
|
| ︙ | ︙ | |||
170 171 172 173 174 175 176 |
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclCreateLiteral(
Interp *iPtr,
| | | | 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 |
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclCreateLiteral(
Interp *iPtr,
const 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
* computed here. */
int *newPtr,
Namespace *nsPtr,
int flags,
LiteralEntry **globalPtrPtr)
{
Tcl_Obj *objPtr;
if (!newPtr) {
if ((flags & LITERAL_ON_HEAP)) {
Tcl_Free((void *)bytes);
}
return NULL;
}
TclNewObj(objPtr);
if (flags & LITERAL_ON_HEAP) {
objPtr->bytes = (char *) bytes;
|
| ︙ | ︙ | |||
280 281 282 283 284 285 286 |
LiteralTable *localTablePtr = &envPtr->localLitTable;
LiteralEntry *localPtr;
Tcl_Obj *objPtr;
size_t hash, localHash, objIndex;
int new;
Namespace *nsPtr;
| | | | | 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 |
LiteralTable *localTablePtr = &envPtr->localLitTable;
LiteralEntry *localPtr;
Tcl_Obj *objPtr;
size_t hash, localHash, objIndex;
int new;
Namespace *nsPtr;
if (length == TCL_AUTO_LENGTH) {
length = (bytes ? strlen(bytes) : 0);
}
hash = HashString(bytes, length);
/*
* Is the literal already in the CompileEnv's local literal array? If so,
* just return its index.
*/
localHash = (hash & localTablePtr->mask);
for (localPtr=localTablePtr->buckets[localHash] ; localPtr!=NULL;
localPtr = localPtr->nextPtr) {
objPtr = localPtr->objPtr;
if ((objPtr->length == length) && ((length == 0)
|| ((objPtr->bytes[0] == bytes[0])
&& (memcmp(objPtr->bytes, bytes, length) == 0)))) {
if ((flags & LITERAL_ON_HEAP)) {
Tcl_Free((void *)bytes);
}
objIndex = (localPtr - envPtr->literalArrayPtr);
#ifdef TCL_COMPILE_DEBUG
TclVerifyLocalLiteralTable(envPtr);
#endif /*TCL_COMPILE_DEBUG*/
return objIndex;
|
| ︙ | ︙ | |||
419 420 421 422 423 424 425 |
*/
newObjPtr = Tcl_DuplicateObj(lPtr->objPtr);
Tcl_IncrRefCount(newObjPtr);
TclReleaseLiteral(interp, lPtr->objPtr);
lPtr->objPtr = newObjPtr;
| | < | 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 |
*/
newObjPtr = Tcl_DuplicateObj(lPtr->objPtr);
Tcl_IncrRefCount(newObjPtr);
TclReleaseLiteral(interp, lPtr->objPtr);
lPtr->objPtr = newObjPtr;
bytes = TclGetStringFromObj(newObjPtr, &length);
localHash = HashString(bytes, length) & localTablePtr->mask;
nextPtrPtr = &localTablePtr->buckets[localHash];
for (entryPtr=*nextPtrPtr ; entryPtr!=NULL ; entryPtr=*nextPtrPtr) {
if (entryPtr == lPtr) {
*nextPtrPtr = lPtr->nextPtr;
lPtr->nextPtr = NULL;
|
| ︙ | ︙ | |||
477 478 479 480 481 482 483 |
}
objIndex = envPtr->literalArrayNext;
envPtr->literalArrayNext++;
lPtr = &envPtr->literalArrayPtr[objIndex];
lPtr->objPtr = objPtr;
Tcl_IncrRefCount(objPtr);
| | | 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 |
}
objIndex = envPtr->literalArrayNext;
envPtr->literalArrayNext++;
lPtr = &envPtr->literalArrayPtr[objIndex];
lPtr->objPtr = objPtr;
Tcl_IncrRefCount(objPtr);
lPtr->refCount = TCL_AUTO_LENGTH; /* i.e., unused */
lPtr->nextPtr = NULL;
if (litPtrPtr) {
*litPtrPtr = lPtr;
}
return objIndex;
|
| ︙ | ︙ | |||
553 554 555 556 557 558 559 |
if (localPtr->objPtr == objPtr) {
found = 1;
}
}
}
if (!found) {
| | < | 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 |
if (localPtr->objPtr == objPtr) {
found = 1;
}
}
}
if (!found) {
bytes = TclGetStringFromObj(objPtr, &length);
Tcl_Panic("%s: literal \"%.*s\" wasn't found locally",
"AddLocalLiteralEntry", (length>60? 60 : (int)length), bytes);
}
}
#endif /*TCL_COMPILE_DEBUG*/
return objIndex;
|
| ︙ | ︙ | |||
603 604 605 606 607 608 609 |
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;
if (currBytes == newSize) {
| | | | | | | | 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 |
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;
if (currBytes == newSize) {
Tcl_Panic("max size of Tcl literal array (%" TCL_Z_MODIFIER "u literals) exceeded",
currElems);
}
if (envPtr->mallocedLiteralArray) {
newArrayPtr = Tcl_Realloc(currArrayPtr, newSize);
} else {
/*
* envPtr->literalArrayPtr isn't a Tcl_Alloc'd pointer, so we must
* code a Tcl_Realloc equivalent for ourselves.
*/
newArrayPtr = Tcl_Alloc(newSize);
memcpy(newArrayPtr, currArrayPtr, currBytes);
envPtr->mallocedLiteralArray = 1;
}
/*
* Update the local literal table's bucket array.
*/
|
| ︙ | ︙ | |||
684 685 686 687 688 689 690 |
size_t length, index;
if (iPtr == NULL) {
goto done;
}
globalTablePtr = &iPtr->literalTable;
| | < | | | 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 |
size_t length, index;
if (iPtr == NULL) {
goto done;
}
globalTablePtr = &iPtr->literalTable;
bytes = TclGetStringFromObj(objPtr, &length);
index = HashString(bytes, length) & globalTablePtr->mask;
/*
* Check to see if the object is in the global literal table and remove
* this reference. The object may not be in the table if it is a hidden
* local literal.
*/
for (prevPtr=NULL, entryPtr=globalTablePtr->buckets[index];
entryPtr!=NULL ; prevPtr=entryPtr, entryPtr=entryPtr->nextPtr) {
if (entryPtr->objPtr == objPtr) {
/*
* If the literal is no longer being used by any ByteCode, delete
* the entry then remove the reference corresponding to the global
* literal table entry (decrement the ref count of the object).
*/
if ((entryPtr->refCount != TCL_AUTO_LENGTH) && (entryPtr->refCount-- <= 1)) {
if (prevPtr == NULL) {
globalTablePtr->buckets[index] = entryPtr->nextPtr;
} else {
prevPtr->nextPtr = entryPtr->nextPtr;
}
Tcl_Free(entryPtr);
globalTablePtr->numEntries--;
TclDecrRefCount(objPtr);
#ifdef TCL_COMPILE_STATS
iPtr->stats.currentLitStringBytes -= (double) (length + 1);
#endif /*TCL_COMPILE_STATS*/
|
| ︙ | ︙ | |||
842 843 844 845 846 847 848 |
* with what we have.
*/
return;
}
tablePtr->numBuckets *= 4;
| | | < | | 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 |
* with what we have.
*/
return;
}
tablePtr->numBuckets *= 4;
tablePtr->buckets = Tcl_Alloc(tablePtr->numBuckets * sizeof(LiteralEntry*));
for (count=tablePtr->numBuckets, newChainPtr=tablePtr->buckets;
count>0 ; count--, newChainPtr++) {
*newChainPtr = NULL;
}
tablePtr->rebuildSize *= 4;
tablePtr->mask = (tablePtr->mask << 2) + 3;
/*
* Rehash all of the existing entries into the new bucket array.
*/
for (oldChainPtr=oldBuckets ; oldSize>0 ; oldSize--,oldChainPtr++) {
for (entryPtr=*oldChainPtr ; entryPtr!=NULL ; entryPtr=*oldChainPtr) {
bytes = TclGetStringFromObj(entryPtr->objPtr, &length);
index = (HashString(bytes, length) & tablePtr->mask);
*oldChainPtr = entryPtr->nextPtr;
bucketPtr = &tablePtr->buckets[index];
entryPtr->nextPtr = *bucketPtr;
*bucketPtr = entryPtr;
}
}
/*
* Free up the old bucket array, if it was dynamically allocated.
*/
if (oldBuckets != tablePtr->staticBuckets) {
Tcl_Free(oldBuckets);
}
}
/*
*----------------------------------------------------------------------
*
* TclInvalidateCmdLiteral --
|
| ︙ | ︙ | |||
912 913 914 915 916 917 918 |
* invalidate a cmd literal. */
{
Interp *iPtr = (Interp *) interp;
Tcl_Obj *literalObjPtr = TclCreateLiteral(iPtr, name,
strlen(name), -1, NULL, nsPtr, 0, NULL);
if (literalObjPtr != NULL) {
| | | 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 |
* 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);
}
}
|
| ︙ | ︙ | |||
945 946 947 948 949 950 951 |
*/
char *
TclLiteralStats(
LiteralTable *tablePtr) /* Table for which to produce stats. */
{
#define NUM_COUNTERS 10
| | | 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 |
*/
char *
TclLiteralStats(
LiteralTable *tablePtr) /* Table for which to produce stats. */
{
#define NUM_COUNTERS 10
size_t count[NUM_COUNTERS], overflow, i, j;
double average, tmp;
register LiteralEntry *entryPtr;
char *result, *p;
/*
* Compute a histogram of bucket usage. For each bucket chain i, j is the
* number of entries in the chain.
|
| ︙ | ︙ | |||
979 980 981 982 983 984 985 |
average += (tmp+1.0)*(tmp/tablePtr->numEntries)/2.0;
}
/*
* Print out the histogram and a few other pieces of information.
*/
| | | | | | | 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 |
average += (tmp+1.0)*(tmp/tablePtr->numEntries)/2.0;
}
/*
* Print out the histogram and a few other pieces of information.
*/
result = Tcl_Alloc(NUM_COUNTERS*60 + 300);
sprintf(result, "%" TCL_Z_MODIFIER "u entries in table, %" TCL_Z_MODIFIER "u buckets\n",
tablePtr->numEntries, tablePtr->numBuckets);
p = result + strlen(result);
for (i=0 ; i<NUM_COUNTERS ; i++) {
sprintf(p, "number of buckets with %" TCL_Z_MODIFIER "u entries: %" TCL_Z_MODIFIER "u\n",
i, count[i]);
p += strlen(p);
}
sprintf(p, "number of buckets with %d or more entries: %" TCL_Z_MODIFIER "u\n",
NUM_COUNTERS, overflow);
p += strlen(p);
sprintf(p, "average search distance for entry: %.1f", average);
return result;
}
#endif /*TCL_COMPILE_STATS*/
|
| ︙ | ︙ | |||
1027 1028 1029 1030 1031 1032 1033 |
char *bytes;
size_t i, length, count = 0;
for (i=0 ; i<localTablePtr->numBuckets ; i++) {
for (localPtr=localTablePtr->buckets[i] ; localPtr!=NULL;
localPtr=localPtr->nextPtr) {
count++;
| | | < | | | | 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 |
char *bytes;
size_t i, length, count = 0;
for (i=0 ; i<localTablePtr->numBuckets ; i++) {
for (localPtr=localTablePtr->buckets[i] ; localPtr!=NULL;
localPtr=localPtr->nextPtr) {
count++;
if (localPtr->refCount != TCL_AUTO_LENGTH) {
bytes = TclGetStringFromObj(localPtr->objPtr, &length);
Tcl_Panic("%s: local literal \"%.*s\" had bad refCount %" TCL_Z_MODIFIER "u",
"TclVerifyLocalLiteralTable",
(length>60? 60 : (int) length), bytes, localPtr->refCount);
}
if (localPtr->objPtr->bytes == NULL) {
Tcl_Panic("%s: literal has NULL string rep",
"TclVerifyLocalLiteralTable");
}
}
}
if (count != localTablePtr->numEntries) {
Tcl_Panic("%s: local literal table had %" TCL_Z_MODIFIER "u entries, should be %" TCL_Z_MODIFIER "u",
"TclVerifyLocalLiteralTable", count,
localTablePtr->numEntries);
}
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
1078 1079 1080 1081 1082 1083 1084 |
char *bytes;
size_t i, length, count = 0;
for (i=0 ; i<globalTablePtr->numBuckets ; i++) {
for (globalPtr=globalTablePtr->buckets[i] ; globalPtr!=NULL;
globalPtr=globalPtr->nextPtr) {
count++;
| | | < | | | 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 |
char *bytes;
size_t i, length, count = 0;
for (i=0 ; i<globalTablePtr->numBuckets ; i++) {
for (globalPtr=globalTablePtr->buckets[i] ; globalPtr!=NULL;
globalPtr=globalPtr->nextPtr) {
count++;
if (globalPtr->refCount + 1 < 2) {
bytes = TclGetStringFromObj(globalPtr->objPtr, &length);
Tcl_Panic("%s: global literal \"%.*s\" had bad refCount %" TCL_Z_MODIFIER "u",
"TclVerifyGlobalLiteralTable",
(length>60? 60 : (int)length), bytes, globalPtr->refCount);
}
if (globalPtr->objPtr->bytes == NULL) {
Tcl_Panic("%s: literal has NULL string rep",
"TclVerifyGlobalLiteralTable");
}
}
}
if (count != globalTablePtr->numEntries) {
Tcl_Panic("%s: global literal table had %" TCL_Z_MODIFIER "u entries, should be %" TCL_Z_MODIFIER "u",
"TclVerifyGlobalLiteralTable", count,
globalTablePtr->numEntries);
}
#else
#endif
}
#endif /*TCL_COMPILE_DEBUG*/
|
| ︙ | ︙ |
Changes to generic/tclLoad.c.
| ︙ | ︙ | |||
127 128 129 130 131 132 133 |
InterpPackage *ipFirstPtr, *ipPtr;
int code, namesMatch, filesMatch, offset;
const char *symbols[2];
Tcl_PackageInitProc *initProc;
const char *p, *fullFileName, *packageName;
Tcl_LoadHandle loadHandle;
Tcl_UniChar ch = 0;
| | | 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 |
InterpPackage *ipFirstPtr, *ipPtr;
int code, namesMatch, filesMatch, offset;
const char *symbols[2];
Tcl_PackageInitProc *initProc;
const char *p, *fullFileName, *packageName;
Tcl_LoadHandle loadHandle;
Tcl_UniChar ch = 0;
size_t len;
int index, flags = 0;
Tcl_Obj *const *savedobjv = objv;
static const char *const options[] = {
"-global", "-lazy", "--", NULL
};
enum options {
LOAD_GLOBAL, LOAD_LAZY, LOAD_LAST
|
| ︙ | ︙ | |||
161 162 163 164 165 166 167 |
if ((objc < 2) || (objc > 4)) {
Tcl_WrongNumArgs(interp, 1, savedobjv, "?-global? ?-lazy? ?--? fileName ?packageName? ?interp?");
return TCL_ERROR;
}
if (Tcl_FSConvertToPathType(interp, objv[1]) != TCL_OK) {
return TCL_ERROR;
}
| | | | | 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 |
if ((objc < 2) || (objc > 4)) {
Tcl_WrongNumArgs(interp, 1, savedobjv, "?-global? ?-lazy? ?--? fileName ?packageName? ?interp?");
return TCL_ERROR;
}
if (Tcl_FSConvertToPathType(interp, objv[1]) != TCL_OK) {
return TCL_ERROR;
}
fullFileName = TclGetString(objv[1]);
Tcl_DStringInit(&pkgName);
Tcl_DStringInit(&initName);
Tcl_DStringInit(&safeInitName);
Tcl_DStringInit(&unloadName);
Tcl_DStringInit(&safeUnloadName);
Tcl_DStringInit(&tmp);
packageName = NULL;
if (objc >= 3) {
packageName = TclGetString(objv[2]);
if (packageName[0] == '\0') {
packageName = NULL;
}
}
if ((fullFileName[0] == 0) && (packageName == NULL)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"must specify either file name or package name", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "NOLIBRARY",
NULL);
code = TCL_ERROR;
goto done;
}
/*
* Figure out which interpreter we're going to load the package into.
*/
target = interp;
if (objc == 4) {
const char *slaveIntName = TclGetString(objv[3]);
target = Tcl_GetSlave(interp, slaveIntName);
if (target == NULL) {
code = TCL_ERROR;
goto done;
}
}
|
| ︙ | ︙ | |||
320 321 322 323 324 325 326 | * name, stripping off any leading "lib", and then using all * of the alphabetic and underline characters that follow * that. */ splitPtr = Tcl_FSSplitPath(objv[1], &pElements); Tcl_ListObjIndex(NULL, splitPtr, pElements -1, &pkgGuessPtr); | | | 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 |
* name, stripping off any leading "lib", and then using all
* of the alphabetic and underline characters that follow
* that.
*/
splitPtr = Tcl_FSSplitPath(objv[1], &pElements);
Tcl_ListObjIndex(NULL, splitPtr, pElements -1, &pkgGuessPtr);
pkgGuess = TclGetString(pkgGuessPtr);
if ((pkgGuess[0] == 'l') && (pkgGuess[1] == 'i')
&& (pkgGuess[2] == 'b')) {
pkgGuess += 3;
}
#ifdef __CYGWIN__
if ((pkgGuess[0] == 'c') && (pkgGuess[1] == 'y')
&& (pkgGuess[2] == 'g')) {
|
| ︙ | ︙ | |||
397 398 399 400 401 402 403 | goto done; } /* * Create a new record to describe this package. */ | | | | | | 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 | goto done; } /* * Create a new record to describe this package. */ pkgPtr = Tcl_Alloc(sizeof(LoadedPackage)); len = strlen(fullFileName) + 1; pkgPtr->fileName = Tcl_Alloc(len); memcpy(pkgPtr->fileName, fullFileName, len); len = Tcl_DStringLength(&pkgName) + 1; pkgPtr->packageName = Tcl_Alloc(len); memcpy(pkgPtr->packageName, Tcl_DStringValue(&pkgName), len); pkgPtr->loadHandle = loadHandle; pkgPtr->initProc = initProc; pkgPtr->safeInitProc = (Tcl_PackageInitProc *) Tcl_FindSymbol(interp, loadHandle, Tcl_DStringValue(&safeInitName)); pkgPtr->unloadProc = (Tcl_PackageUnloadProc *) |
| ︙ | ︙ | |||
502 503 504 505 506 507 508 |
/*
* Refetch ipFirstPtr: loading the package may have introduced additional
* static packages at the head of the linked list!
*/
ipFirstPtr = Tcl_GetAssocData(target, "tclLoad", NULL);
| | | 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 |
/*
* Refetch ipFirstPtr: loading the package may have introduced additional
* static packages at the head of the linked list!
*/
ipFirstPtr = Tcl_GetAssocData(target, "tclLoad", NULL);
ipPtr = Tcl_Alloc(sizeof(InterpPackage));
ipPtr->pkgPtr = pkgPtr;
ipPtr->nextPtr = ipFirstPtr;
Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc, ipPtr);
done:
Tcl_DStringFree(&pkgName);
Tcl_DStringFree(&initName);
|
| ︙ | ︙ | |||
560 561 562 563 564 565 566 |
enum options {
UNLOAD_NOCOMPLAIN, UNLOAD_KEEPLIB, UNLOAD_LAST
};
for (i = 1; i < objc; i++) {
if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0,
&index) != TCL_OK) {
| | | 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 |
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]);
if (fullFileName[0] == '-') {
/*
* It looks like the command contains an option so signal an
* error
*/
return TCL_ERROR;
|
| ︙ | ︙ | |||
600 601 602 603 604 605 606 |
"?-switch ...? fileName ?packageName? ?interp?");
return TCL_ERROR;
}
if (Tcl_FSConvertToPathType(interp, objv[i]) != TCL_OK) {
return TCL_ERROR;
}
| | | | | 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 |
"?-switch ...? fileName ?packageName? ?interp?");
return TCL_ERROR;
}
if (Tcl_FSConvertToPathType(interp, objv[i]) != TCL_OK) {
return TCL_ERROR;
}
fullFileName = TclGetString(objv[i]);
Tcl_DStringInit(&pkgName);
Tcl_DStringInit(&tmp);
packageName = NULL;
if (objc - i >= 2) {
packageName = TclGetString(objv[i+1]);
if (packageName[0] == '\0') {
packageName = NULL;
}
}
if ((fullFileName[0] == 0) && (packageName == NULL)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"must specify either file name or package name", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "NOLIBRARY",
NULL);
code = TCL_ERROR;
goto done;
}
/*
* Figure out which interpreter we're going to load the package into.
*/
target = interp;
if (objc - i == 3) {
const char *slaveIntName = TclGetString(objv[i + 2]);
target = Tcl_GetSlave(interp, slaveIntName);
if (target == NULL) {
return TCL_ERROR;
}
}
|
| ︙ | ︙ | |||
886 887 888 889 890 891 892 | ipPrevPtr->nextPtr = ipPtr->nextPtr; break; } } } Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc, ipFirstPtr); | | | | | | 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 |
ipPrevPtr->nextPtr = ipPtr->nextPtr;
break;
}
}
}
Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc,
ipFirstPtr);
Tcl_Free(defaultPtr->fileName);
Tcl_Free(defaultPtr->packageName);
Tcl_Free(defaultPtr);
Tcl_Free(ipPtr);
Tcl_MutexUnlock(&packageMutex);
} else {
code = TCL_ERROR;
}
}
#else
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
|
| ︙ | ︙ | |||
976 977 978 979 980 981 982 |
/*
* If the package is not yet recorded as being loaded statically, add it
* to the list now.
*/
if (pkgPtr == NULL) {
| | | | | 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 |
/*
* If the package is not yet recorded as being loaded statically, add it
* to the list now.
*/
if (pkgPtr == NULL) {
pkgPtr = Tcl_Alloc(sizeof(LoadedPackage));
pkgPtr->fileName = Tcl_Alloc(1);
pkgPtr->fileName[0] = 0;
pkgPtr->packageName = Tcl_Alloc(strlen(pkgName) + 1);
strcpy(pkgPtr->packageName, pkgName);
pkgPtr->loadHandle = NULL;
pkgPtr->initProc = initProc;
pkgPtr->safeInitProc = safeInitProc;
Tcl_MutexLock(&packageMutex);
pkgPtr->nextPtr = firstPackagePtr;
firstPackagePtr = pkgPtr;
|
| ︙ | ︙ | |||
1009 1010 1011 1012 1013 1014 1015 | } /* * Package isn't loaded in the current interp yet. Mark it as now being * loaded. */ | | | 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 |
}
/*
* Package isn't loaded in the current interp yet. Mark it as now being
* loaded.
*/
ipPtr = Tcl_Alloc(sizeof(InterpPackage));
ipPtr->pkgPtr = pkgPtr;
ipPtr->nextPtr = ipFirstPtr;
Tcl_SetAssocData(interp, "tclLoad", LoadCleanupProc, ipPtr);
}
}
/*
|
| ︙ | ︙ | |||
1153 1154 1155 1156 1157 1158 1159 |
Tcl_Interp *interp) /* Interpreter that is being deleted. */
{
InterpPackage *ipPtr, *nextPtr;
ipPtr = clientData;
while (ipPtr != NULL) {
nextPtr = ipPtr->nextPtr;
| | | 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 |
Tcl_Interp *interp) /* Interpreter that is being deleted. */
{
InterpPackage *ipPtr, *nextPtr;
ipPtr = clientData;
while (ipPtr != NULL) {
nextPtr = ipPtr->nextPtr;
Tcl_Free(ipPtr);
ipPtr = nextPtr;
}
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1204 1205 1206 1207 1208 1209 1210 |
*/
if (pkgPtr->fileName[0] != '\0') {
Tcl_FSUnloadFile(NULL, pkgPtr->loadHandle);
}
#endif
| | | | | 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 |
*/
if (pkgPtr->fileName[0] != '\0') {
Tcl_FSUnloadFile(NULL, pkgPtr->loadHandle);
}
#endif
Tcl_Free(pkgPtr->fileName);
Tcl_Free(pkgPtr->packageName);
Tcl_Free(pkgPtr);
}
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclMain.c.
| ︙ | ︙ | |||
14 15 16 17 18 19 20 | * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * On Windows, this file needs to be compiled twice, once with TCL_ASCII_MAIN | | | 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 | * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * On Windows, this file needs to be compiled twice, once with TCL_ASCII_MAIN * defined. This way both Tcl_MainEx and Tcl_MainExW can be implemented, sharing * the same source code. */ #if defined(TCL_ASCII_MAIN) # ifdef UNICODE # undef UNICODE # undef _UNICODE |
| ︙ | ︙ | |||
55 56 57 58 59 60 61 | /* * Further on, in UNICODE mode we just use Tcl_NewUnicodeObj, otherwise * NewNativeObj is needed (which provides proper conversion from native * encoding to UTF-8). */ | | | | | > > > > > > | > | | 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 |
/*
* Further on, in UNICODE mode we just use Tcl_NewUnicodeObj, otherwise
* NewNativeObj is needed (which provides proper conversion from native
* encoding to UTF-8).
*/
#if defined(UNICODE) && (TCL_UTF_MAX <= 4)
# define NewNativeObj Tcl_NewUnicodeObj
#else /* !UNICODE || (TCL_UTF_MAX > 4) */
static inline Tcl_Obj *
NewNativeObj(
TCHAR *string,
size_t length)
{
Tcl_DString ds;
#ifdef UNICODE
if (length > 0) {
length *= sizeof(WCHAR);
}
Tcl_WinTCharToUtf(string, length, &ds);
#else
Tcl_ExternalToUtfDString(NULL, (char *) string, length, &ds);
#endif
return TclDStringToObj(&ds);
}
#endif /* !UNICODE || (TCL_UTF_MAX > 4) */
/*
* 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).
*/
|
| ︙ | ︙ | |||
211 212 213 214 215 216 217 |
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (encodingPtr != NULL) {
if (tsdPtr->encoding == NULL) {
*encodingPtr = NULL;
} else {
| | | 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 |
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (encodingPtr != NULL) {
if (tsdPtr->encoding == NULL) {
*encodingPtr = NULL;
} else {
*encodingPtr = TclGetString(tsdPtr->encoding);
}
}
return tsdPtr->path;
}
/*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
295 296 297 298 299 300 301 | * This function initializes the Tcl world and then starts interpreting * commands; almost anything could happen, depending on the script being * interpreted. * *---------------------------------------------------------------------- */ | | | 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 |
* This function initializes the Tcl world and then starts interpreting
* commands; almost anything could happen, depending on the script being
* interpreted.
*
*----------------------------------------------------------------------
*/
TCL_NORETURN void
Tcl_MainEx(
int argc, /* Number of arguments. */
TCHAR **argv, /* Array of argument strings. */
Tcl_AppInitProc *appInitProc,
/* Application-specific initialization
* function to call after most initialization
* but before starting to execute commands. */
|
| ︙ | ︙ | |||
339 340 341 342 343 344 345 |
* FILENAME
*/
if ((argc > 3) && (0 == _tcscmp(TEXT("-encoding"), argv[1]))
&& ('-' != argv[3][0])) {
Tcl_Obj *value = NewNativeObj(argv[2], -1);
Tcl_SetStartupScript(NewNativeObj(argv[3], -1),
| | | 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 |
* FILENAME
*/
if ((argc > 3) && (0 == _tcscmp(TEXT("-encoding"), argv[1]))
&& ('-' != argv[3][0])) {
Tcl_Obj *value = NewNativeObj(argv[2], -1);
Tcl_SetStartupScript(NewNativeObj(argv[3], -1),
TclGetString(value));
Tcl_DecrRefCount(value);
argc -= 3;
argv += 3;
} else if ((argc > 1) && ('-' != argv[1][0])) {
Tcl_SetStartupScript(NewNativeObj(argv[1], -1), NULL);
argc--;
argv++;
|
| ︙ | ︙ | |||
463 464 465 466 467 468 469 |
*/
Tcl_LinkVar(interp, "tcl_interactive", (char *) &is.tty, TCL_LINK_BOOLEAN);
is.input = Tcl_GetStdChannel(TCL_STDIN);
while ((is.input != NULL) && !Tcl_InterpDeleted(interp)) {
mainLoopProc = TclGetMainLoop();
if (mainLoopProc == NULL) {
| | | | 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 |
*/
Tcl_LinkVar(interp, "tcl_interactive", (char *) &is.tty, TCL_LINK_BOOLEAN);
is.input = Tcl_GetStdChannel(TCL_STDIN);
while ((is.input != NULL) && !Tcl_InterpDeleted(interp)) {
mainLoopProc = TclGetMainLoop();
if (mainLoopProc == NULL) {
size_t length;
if (is.tty) {
Prompt(interp, &is);
if (Tcl_InterpDeleted(interp)) {
break;
}
if (Tcl_LimitExceeded(interp)) {
break;
}
is.input = Tcl_GetStdChannel(TCL_STDIN);
if (is.input == NULL) {
break;
}
}
if (Tcl_IsShared(is.commandPtr)) {
Tcl_DecrRefCount(is.commandPtr);
is.commandPtr = Tcl_DuplicateObj(is.commandPtr);
Tcl_IncrRefCount(is.commandPtr);
}
length = Tcl_GetsObj(is.input, is.commandPtr);
if (length == TCL_AUTO_LENGTH) {
if (Tcl_InputBlocked(is.input)) {
/*
* This can only happen if stdin has been set to
* non-blocking. In that case cycle back and try again.
* This sets up a tight polling loop (since we have no
* event loop running). If this causes bad CPU hogging, we
* might try toggling the blocking on stdin instead.
|
| ︙ | ︙ | |||
528 529 530 531 532 533 534 | is.prompt = PROMPT_START; /* * The final newline is syntactically redundant, and causes some * error messages troubles deeper in, so lop it back off. */ | | | | 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 |
is.prompt = PROMPT_START;
/*
* 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);
is.commandPtr = Tcl_NewObj();
Tcl_IncrRefCount(is.commandPtr);
if (code != TCL_OK) {
chan = Tcl_GetStdChannel(TCL_STDERR);
if (chan) {
Tcl_WriteObj(chan, Tcl_GetObjResult(interp));
Tcl_WriteChars(chan, "\n", 1);
}
} else if (is.tty) {
resultPtr = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(resultPtr);
(void)TclGetStringFromObj(resultPtr, &length);
chan = Tcl_GetStdChannel(TCL_STDOUT);
if ((length > 0) && chan) {
Tcl_WriteObj(chan, resultPtr);
Tcl_WriteChars(chan, "\n", 1);
}
Tcl_DecrRefCount(resultPtr);
}
|
| ︙ | ︙ | |||
749 750 751 752 753 754 755 |
/* ARGSUSED */
static void
StdinProc(
ClientData clientData, /* The state of interactive cmd line */
int mask) /* Not used. */
{
| | > | | 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 |
/* ARGSUSED */
static void
StdinProc(
ClientData clientData, /* The state of interactive cmd line */
int mask) /* Not used. */
{
int code;
size_t length;
InteractiveState *isPtr = clientData;
Tcl_Channel chan = isPtr->input;
Tcl_Obj *commandPtr = isPtr->commandPtr;
Tcl_Interp *interp = isPtr->interp;
if (Tcl_IsShared(commandPtr)) {
Tcl_DecrRefCount(commandPtr);
commandPtr = Tcl_DuplicateObj(commandPtr);
Tcl_IncrRefCount(commandPtr);
}
length = Tcl_GetsObj(chan, commandPtr);
if (length == TCL_AUTO_LENGTH) {
if (Tcl_InputBlocked(chan)) {
return;
}
if (isPtr->tty) {
/*
* Would be better to find a way to exit the mainLoop? Or perhaps
* evaluate [exit]? Leaving as is for now due to compatibility
|
| ︙ | ︙ | |||
789 790 791 792 793 794 795 |
}
Tcl_AppendToObj(commandPtr, "\n", 1);
if (!TclObjCommandComplete(commandPtr)) {
isPtr->prompt = PROMPT_CONTINUE;
goto prompt;
}
isPtr->prompt = PROMPT_START;
| | | 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 |
}
Tcl_AppendToObj(commandPtr, "\n", 1);
if (!TclObjCommandComplete(commandPtr)) {
isPtr->prompt = PROMPT_CONTINUE;
goto prompt;
}
isPtr->prompt = PROMPT_START;
(void)TclGetStringFromObj(commandPtr, &length);
Tcl_SetObjLength(commandPtr, --length);
/*
* Disable the stdin channel handler while evaluating the command;
* otherwise if the command re-enters the event loop we might process
* commands from stdin before the current command is finished. Among other
* things, this will trash the text of the command being evaluated.
|
| ︙ | ︙ | |||
820 821 822 823 824 825 826 |
Tcl_WriteChars(chan, "\n", 1);
}
} else if (isPtr->tty) {
Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
chan = Tcl_GetStdChannel(TCL_STDOUT);
Tcl_IncrRefCount(resultPtr);
| | | 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 |
Tcl_WriteChars(chan, "\n", 1);
}
} else if (isPtr->tty) {
Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
chan = 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_DecrRefCount(resultPtr);
}
|
| ︙ | ︙ |
Changes to generic/tclNamesp.c.
| ︙ | ︙ | |||
21 22 23 24 25 26 27 28 29 30 31 32 33 34 |
*
* 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 */
/*
* Thread-local storage used to avoid having a global lock on data that is not
* limited to a single interpreter.
*/
typedef struct {
| > | 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 |
*
* 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 <assert.h>
/*
* Thread-local storage used to avoid having a global lock on data that is not
* limited to a single interpreter.
*/
typedef struct {
|
| ︙ | ︙ | |||
85 86 87 88 89 90 91 | const char *name2, int flags); static char * EstablishErrorInfoTraces(ClientData clientData, Tcl_Interp *interp, const char *name1, const char *name2, int flags); static void FreeNsNameInternalRep(Tcl_Obj *objPtr); static int GetNamespaceFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Namespace **nsPtrPtr); | < < | 86 87 88 89 90 91 92 93 94 95 96 97 98 99 | const char *name2, int flags); static char * EstablishErrorInfoTraces(ClientData clientData, Tcl_Interp *interp, const char *name1, const char *name2, int flags); static void FreeNsNameInternalRep(Tcl_Obj *objPtr); static int GetNamespaceFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Namespace **nsPtrPtr); static int InvokeImportedNRCmd(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, |
| ︙ | ︙ | |||
149 150 151 152 153 154 155 156 157 158 159 160 161 162 |
static const Tcl_ObjType nsNameType = {
"nsName", /* the type's name */
FreeNsNameInternalRep, /* freeIntRepProc */
DupNsNameInternalRep, /* dupIntRepProc */
NULL, /* updateStringProc */
SetNsNameFromAny /* setFromAnyProc */
};
/*
* Array of values describing how to implement each standard subcommand of the
* "namespace" command.
*/
static const EnsembleImplMap defaultNamespaceMap[] = {
| > > > > > > > > > > > > > > > > | 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 |
static const 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 ? irPtr->twoPtrValue.ptr1 : NULL; \
} while (0)
/*
* Array of values describing how to implement each standard subcommand of the
* "namespace" command.
*/
static const EnsembleImplMap defaultNamespaceMap[] = {
|
| ︙ | ︙ | |||
377 378 379 380 381 382 383 384 385 386 |
void
Tcl_PopCallFrame(
Tcl_Interp *interp) /* Interpreter with call frame to pop. */
{
register Interp *iPtr = (Interp *) interp;
register CallFrame *framePtr = iPtr->framePtr;
Namespace *nsPtr;
if (framePtr->varTablePtr != NULL) {
TclDeleteVars(iPtr, framePtr->varTablePtr);
| > > > > > > > > > > > > > | | | < < < < < < < < | 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 |
void
Tcl_PopCallFrame(
Tcl_Interp *interp) /* Interpreter with call frame to pop. */
{
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
* the variable deletion don't see the partially-deleted frame.
*/
if (framePtr->callerPtr) {
iPtr->framePtr = framePtr->callerPtr;
iPtr->varFramePtr = framePtr->callerVarPtr;
} else {
/* Tcl_PopCallFrame: trying to pop rootCallFrame! */
}
if (framePtr->varTablePtr != NULL) {
TclDeleteVars(iPtr, framePtr->varTablePtr);
Tcl_Free(framePtr->varTablePtr);
framePtr->varTablePtr = NULL;
}
if (framePtr->numCompiledLocals > 0) {
TclDeleteCompiledLocalVars(iPtr, framePtr);
if (framePtr->localCachePtr->refCount-- <= 1) {
TclFreeLocalCache(interp, framePtr->localCachePtr);
}
framePtr->localCachePtr = NULL;
}
/*
* Decrement the namespace's count of active call frames. If the namespace
* is "dying" and there are no more active call frames, call
* Tcl_DeleteNamespace to destroy it.
*/
nsPtr = framePtr->nsPtr;
if ((--nsPtr->activationCount <= (nsPtr == iPtr->globalNsPtr))
&& (nsPtr->flags & NS_DYING)) {
Tcl_DeleteNamespace((Tcl_Namespace *) nsPtr);
}
framePtr->nsPtr = NULL;
if (framePtr->tailcallPtr) {
TclSetTailcall(interp, framePtr->tailcallPtr);
}
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
661 662 663 664 665 666 667 |
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;
| | > | 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 |
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;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
const char *nameStr;
Tcl_DString tmpBuffer;
Tcl_DStringInit(&tmpBuffer);
/*
|
| ︙ | ︙ | |||
760 761 762 763 764 765 766 |
/*
* Create the new namespace and root it in its parent. Increment the count
* of namespaces created.
*/
doCreate:
| | | | 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 |
/*
* Create the new namespace and root it in its parent. Increment the count
* of namespaces created.
*/
doCreate:
nsPtr = Tcl_Alloc(sizeof(Namespace));
nameLen = strlen(simpleName) + 1;
nsPtr->name = Tcl_Alloc(nameLen);
memcpy(nsPtr->name, simpleName, nameLen);
nsPtr->fullName = NULL; /* Set below. */
nsPtr->clientData = clientData;
nsPtr->deleteProc = deleteProc;
nsPtr->parentPtr = parentPtr;
#ifndef BREAK_NAMESPACE_COMPAT
Tcl_InitHashTable(&nsPtr->childTable, TCL_STRING_KEYS);
|
| ︙ | ︙ | |||
850 851 852 853 854 855 856 |
namePtr = buffPtr;
buffPtr = tempPtr;
}
}
name = Tcl_DStringValue(namePtr);
nameLen = Tcl_DStringLength(namePtr);
| | | | 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 |
namePtr = buffPtr;
buffPtr = tempPtr;
}
}
name = Tcl_DStringValue(namePtr);
nameLen = Tcl_DStringLength(namePtr);
nsPtr->fullName = Tcl_Alloc(nameLen + 1);
memcpy(nsPtr->fullName, name, nameLen + 1);
Tcl_DStringFree(&buffer1);
Tcl_DStringFree(&buffer2);
Tcl_DStringFree(&tmpBuffer);
/*
* If compilation of commands originating from the parent NS is
|
| ︙ | ︙ | |||
998 999 1000 1001 1002 1003 1004 |
* namespace's commands and variables are deleted but the structure isn't
* freed. Instead, NS_DEAD is OR'd into the structure's flags to allow the
* namespace resolution code to recognize that the namespace is "deleted".
* The structure's storage is freed by FreeNsNameInternalRep when its
* refCount reaches 0.
*/
| | | 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 |
* namespace's commands and variables are deleted but the structure isn't
* freed. Instead, NS_DEAD is OR'd into the structure's flags to allow the
* namespace resolution code to recognize that the namespace is "deleted".
* The structure's storage is freed by FreeNsNameInternalRep when its
* refCount reaches 0.
*/
if (nsPtr->activationCount > (nsPtr == globalNsPtr)) {
nsPtr->flags |= NS_DYING;
if (nsPtr->parentPtr != NULL) {
entryPtr = Tcl_FindHashEntry(
TclGetNamespaceChildTable((Tcl_Namespace *)
nsPtr->parentPtr), nsPtr->name);
if (entryPtr != NULL) {
Tcl_DeleteHashEntry(entryPtr);
|
| ︙ | ︙ | |||
1037 1038 1039 1040 1041 1042 1043 |
TclDeleteNamespaceVars(nsPtr);
#ifndef BREAK_NAMESPACE_COMPAT
Tcl_DeleteHashTable(&nsPtr->childTable);
#else
if (nsPtr->childTablePtr != NULL) {
Tcl_DeleteHashTable(nsPtr->childTablePtr);
| | | 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 |
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;
} else {
/*
|
| ︙ | ︙ | |||
1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 |
*/
nsPtr->flags &= ~(NS_DYING|NS_KILLED);
}
}
TclNsDecrRefCount(nsPtr);
}
/*
*----------------------------------------------------------------------
*
* TclTeardownNamespace --
*
* Used internally to dismantle and unlink a namespace when it is
| > > > > > > > | 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 |
*/
nsPtr->flags &= ~(NS_DYING|NS_KILLED);
}
}
TclNsDecrRefCount(nsPtr);
}
int
TclNamespaceDeleted(
Namespace *nsPtr)
{
return (nsPtr->flags & NS_DYING) ? 1 : 0;
}
/*
*----------------------------------------------------------------------
*
* TclTeardownNamespace --
*
* Used internally to dismantle and unlink a namespace when it is
|
| ︙ | ︙ | |||
1206 1207 1208 1209 1210 1211 1212 |
TclNsDecrRefCount(children[i]);
}
TclStackFree((Tcl_Interp *) iPtr, children);
}
#else
if (nsPtr->childTablePtr != NULL) {
while (nsPtr->childTablePtr->numEntries > 0) {
| | | 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 |
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 = TclStackAlloc((Tcl_Interp *) iPtr,
sizeof(Namespace *) * length);
i = 0;
for (entryPtr = Tcl_FirstHashEntry(nsPtr->childTablePtr, &search);
entryPtr != NULL;
entryPtr = Tcl_NextHashEntry(&search)) {
|
| ︙ | ︙ | |||
1233 1234 1235 1236 1237 1238 1239 |
/*
* Free the namespace's export pattern array.
*/
if (nsPtr->exportArrayPtr != NULL) {
for (i = 0; i < nsPtr->numExportPatterns; i++) {
| | | | 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 |
/*
* Free the namespace's export pattern array.
*/
if (nsPtr->exportArrayPtr != NULL) {
for (i = 0; i < nsPtr->numExportPatterns; i++) {
Tcl_Free(nsPtr->exportArrayPtr[i]);
}
Tcl_Free(nsPtr->exportArrayPtr);
nsPtr->exportArrayPtr = NULL;
nsPtr->numExportPatterns = 0;
nsPtr->maxExportPatterns = 0;
}
/*
* Free any client data associated with the namespace.
|
| ︙ | ︙ | |||
1287 1288 1289 1290 1291 1292 1293 |
{
/*
* 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.
*/
| | | | | 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 |
{
/*
* 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);
}
/*
*----------------------------------------------------------------------
*
* TclNsDecrRefCount --
*
|
| ︙ | ︙ | |||
1378 1379 1380 1381 1382 1383 1384 |
* If resetListFirst is true (nonzero), clear the namespace's export
* pattern list.
*/
if (resetListFirst) {
if (nsPtr->exportArrayPtr != NULL) {
for (i = 0; i < nsPtr->numExportPatterns; i++) {
| | | | 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 |
* If resetListFirst is true (nonzero), clear the namespace's export
* pattern list.
*/
if (resetListFirst) {
if (nsPtr->exportArrayPtr != NULL) {
for (i = 0; i < nsPtr->numExportPatterns; i++) {
Tcl_Free(nsPtr->exportArrayPtr[i]);
}
Tcl_Free(nsPtr->exportArrayPtr);
nsPtr->exportArrayPtr = NULL;
TclInvalidateNsCmdLookup(nsPtr);
nsPtr->numExportPatterns = 0;
nsPtr->maxExportPatterns = 0;
}
}
|
| ︙ | ︙ | |||
1427 1428 1429 1430 1431 1432 1433 |
* pattern.
*/
neededElems = nsPtr->numExportPatterns + 1;
if (neededElems > nsPtr->maxExportPatterns) {
nsPtr->maxExportPatterns = nsPtr->maxExportPatterns ?
2 * nsPtr->maxExportPatterns : INIT_EXPORT_PATTERNS;
| | | | | 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 |
* pattern.
*/
neededElems = nsPtr->numExportPatterns + 1;
if (neededElems > nsPtr->maxExportPatterns) {
nsPtr->maxExportPatterns = nsPtr->maxExportPatterns ?
2 * nsPtr->maxExportPatterns : INIT_EXPORT_PATTERNS;
nsPtr->exportArrayPtr = Tcl_Realloc(nsPtr->exportArrayPtr,
sizeof(char *) * nsPtr->maxExportPatterns);
}
/*
* Add the pattern to the namespace's array of export patterns.
*/
len = strlen(pattern);
patternCpy = Tcl_Alloc(len + 1);
memcpy(patternCpy, pattern, len + 1);
nsPtr->exportArrayPtr[nsPtr->numExportPatterns] = patternCpy;
nsPtr->numExportPatterns++;
/*
* The list of commands actually exported from the namespace might have
* changed (probably will have!) However, we do not need to recompute this
|
| ︙ | ︙ | |||
1755 1756 1757 1758 1759 1760 1761 | Tcl_DStringFree(&ds); Tcl_SetErrorCode(interp, "TCL", "IMPORT", "LOOP", NULL); return TCL_ERROR; } } } | | | | | 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 |
Tcl_DStringFree(&ds);
Tcl_SetErrorCode(interp, "TCL", "IMPORT", "LOOP", NULL);
return TCL_ERROR;
}
}
}
dataPtr = Tcl_Alloc(sizeof(ImportedCmdData));
importedCmd = Tcl_NRCreateCommand(interp, Tcl_DStringValue(&ds),
TclInvokeImportedCmd, InvokeImportedNRCmd, dataPtr,
DeleteImportedCmd);
dataPtr->realCmdPtr = cmdPtr;
dataPtr->selfPtr = (Command *) importedCmd;
dataPtr->selfPtr->compileProc = cmdPtr->compileProc;
Tcl_DStringFree(&ds);
/*
* Create an ImportRef structure describing this new import command
* and add it to the import ref list in the "real" command.
*/
refPtr = Tcl_Alloc(sizeof(ImportRef));
refPtr->importedCmdPtr = (Command *) importedCmd;
refPtr->nextPtr = cmdPtr->importRefPtr;
cmdPtr->importRefPtr = refPtr;
} else {
Command *overwrite = Tcl_GetHashValue(found);
if (overwrite->deleteProc == DeleteImportedCmd) {
|
| ︙ | ︙ | |||
1978 1979 1980 1981 1982 1983 1984 |
}
return (Tcl_Command) cmdPtr;
}
/*
*----------------------------------------------------------------------
*
| | | 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 |
}
return (Tcl_Command) cmdPtr;
}
/*
*----------------------------------------------------------------------
*
* TclInvokeImportedCmd --
*
* 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.
*
* Results:
* Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
|
| ︙ | ︙ | |||
2009 2010 2011 2012 2013 2014 2015 |
ImportedCmdData *dataPtr = clientData;
Command *realCmdPtr = dataPtr->realCmdPtr;
TclSkipTailcall(interp);
return TclNREvalObjv(interp, objc, objv, TCL_EVAL_NOERR, realCmdPtr);
}
| | | | 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 |
ImportedCmdData *dataPtr = 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,
|
| ︙ | ︙ | |||
2066 2067 2068 2069 2070 2071 2072 |
*/
if (prevPtr == NULL) { /* refPtr is first in list. */
realCmdPtr->importRefPtr = refPtr->nextPtr;
} else {
prevPtr->nextPtr = refPtr->nextPtr;
}
| | | | 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 |
*/
if (prevPtr == NULL) { /* refPtr is first in list. */
realCmdPtr->importRefPtr = refPtr->nextPtr;
} else {
prevPtr->nextPtr = refPtr->nextPtr;
}
Tcl_Free(refPtr);
Tcl_Free(dataPtr);
return;
}
prevPtr = refPtr;
}
Tcl_Panic("DeleteImportedCmd: did not find cmd in real cmd's list of import references");
}
|
| ︙ | ︙ | |||
2597 2598 2599 2600 2601 2602 2603 |
/*
* Find the namespace(s) that contain the command.
*/
cmdPtr = NULL;
if (cxtNsPtr->commandPathLength!=0 && strncmp(name, "::", 2)
&& !(flags & TCL_NAMESPACE_ONLY)) {
| | | 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 |
/*
* Find the namespace(s) that contain the command.
*/
cmdPtr = NULL;
if (cxtNsPtr->commandPathLength!=0 && strncmp(name, "::", 2)
&& !(flags & TCL_NAMESPACE_ONLY)) {
size_t i;
Namespace *pathNsPtr, *realNsPtr, *dummyNsPtr;
(void) TclGetNamespaceForQualName(interp, name, cxtNsPtr,
TCL_NAMESPACE_ONLY, &realNsPtr, &dummyNsPtr, &dummyNsPtr,
&simpleName);
if ((realNsPtr != NULL) && (simpleName != NULL)) {
if ((cxtNsPtr == realNsPtr)
|
| ︙ | ︙ | |||
2891 2892 2893 2894 2895 2896 2897 |
GetNamespaceFromObj(
Tcl_Interp *interp, /* The current interpreter. */
Tcl_Obj *objPtr, /* The object to be resolved as the name of a
* namespace. */
Tcl_Namespace **nsPtrPtr) /* Result namespace pointer goes here. */
{
ResolvedNsName *resNamePtr;
| > > > | < < > > | | 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 |
GetNamespaceFromObj(
Tcl_Interp *interp, /* The current interpreter. */
Tcl_Obj *objPtr, /* The object to be resolved as the name of a
* namespace. */
Tcl_Namespace **nsPtrPtr) /* Result namespace pointer goes here. */
{
ResolvedNsName *resNamePtr;
NsNameGetIntRep(objPtr, resNamePtr);
if (resNamePtr) {
Namespace *nsPtr, *refNsPtr;
/*
* Check that the ResolvedNsName is still valid; avoid letting the ref
* cross interps.
*/
nsPtr = resNamePtr->nsPtr;
refNsPtr = resNamePtr->refNsPtr;
if (!(nsPtr->flags & NS_DYING) && (interp == nsPtr->interp)
&& (!refNsPtr || (refNsPtr ==
(Namespace *) TclGetCurrentNamespace(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);
*nsPtrPtr = (Tcl_Namespace *) resNamePtr->nsPtr;
return TCL_OK;
}
return TCL_ERROR;
}
/*
|
| ︙ | ︙ | |||
3021 3022 3023 3024 3025 3026 3027 |
/*
* Create a list containing the full names of all child namespaces whose
* names match the specified pattern, if any.
*/
listPtr = Tcl_NewListObj(0, NULL);
if ((pattern != NULL) && TclMatchIsTrivial(pattern)) {
| | | 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 |
/*
* Create a list containing the full names of all child namespaces whose
* names match the specified pattern, if any.
*/
listPtr = Tcl_NewListObj(0, NULL);
if ((pattern != NULL) && TclMatchIsTrivial(pattern)) {
size_t 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
|
| ︙ | ︙ | |||
3101 3102 3103 3104 3105 3106 3107 |
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Namespace *currNsPtr;
Tcl_Obj *listPtr, *objPtr;
register const char *arg;
| | | 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 |
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Namespace *currNsPtr;
Tcl_Obj *listPtr, *objPtr;
register const char *arg;
size_t length;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "arg");
return TCL_ERROR;
}
/*
|
| ︙ | ︙ | |||
3414 3415 3416 3417 3418 3419 3420 |
ClientData data[],
Tcl_Interp *interp,
int result)
{
Tcl_Namespace *namespacePtr = data[0];
if (result == TCL_ERROR) {
| | | | | 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 |
ClientData data[],
Tcl_Interp *interp,
int result)
{
Tcl_Namespace *namespacePtr = data[0];
if (result == TCL_ERROR) {
size_t length = strlen(namespacePtr->fullName);
unsigned limit = 200;
int overflow = (length > limit);
char *cmd = 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)));
}
/*
* Restore the previous "current" namespace.
*/
|
| ︙ | ︙ | |||
3469 3470 3471 3472 3473 3474 3475 |
Tcl_Namespace *namespacePtr;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "name");
return TCL_ERROR;
}
| | | 3500 3501 3502 3503 3504 3505 3506 3507 3508 3509 3510 3511 3512 3513 3514 |
Tcl_Namespace *namespacePtr;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "name");
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(
GetNamespaceFromObj(interp, objv[1], &namespacePtr) == TCL_OK));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
3542 3543 3544 3545 3546 3547 3548 |
}
/*
* Process the optional "-clear" argument.
*/
firstArg = 1;
| | | | 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 3590 3591 3592 3593 3594 3595 3596 3597 3598 |
}
/*
* Process the optional "-clear" argument.
*/
firstArg = 1;
if (strcmp("-clear", TclGetString(objv[firstArg])) == 0) {
Tcl_Export(interp, NULL, "::", 1);
Tcl_ResetResult(interp);
firstArg++;
}
/*
* Add each pattern to the namespace's export pattern list.
*/
for (i = firstArg; i < objc; i++) {
int result = Tcl_Export(interp, NULL, TclGetString(objv[i]), 0);
if (result != TCL_OK) {
return result;
}
}
return TCL_OK;
}
|
| ︙ | ︙ | |||
3995 3996 3997 3998 3999 4000 4001 |
NamespacePathCmd(
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);
| > | | 4026 4027 4028 4029 4030 4031 4032 4033 4034 4035 4036 4037 4038 4039 4040 4041 |
NamespacePathCmd(
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;
Tcl_Obj **nsObjv;
Tcl_Namespace **namespaceList = NULL;
if (objc > 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?pathList?");
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
4032 4033 4034 4035 4036 4037 4038 |
if (TclListObjGetElements(interp, objv[1], &nsObjc, &nsObjv) != TCL_OK) {
goto badNamespace;
}
if (nsObjc != 0) {
namespaceList = TclStackAlloc(interp,
sizeof(Tcl_Namespace *) * nsObjc);
| | | 4064 4065 4066 4067 4068 4069 4070 4071 4072 4073 4074 4075 4076 4077 4078 |
if (TclListObjGetElements(interp, objv[1], &nsObjc, &nsObjv) != TCL_OK) {
goto badNamespace;
}
if (nsObjc != 0) {
namespaceList = TclStackAlloc(interp,
sizeof(Tcl_Namespace *) * nsObjc);
for (i=0 ; i<(size_t)nsObjc ; i++) {
if (TclGetNamespaceFromObj(interp, nsObjv[i],
&namespaceList[i]) != TCL_OK) {
goto badNamespace;
}
}
}
|
| ︙ | ︙ | |||
4077 4078 4079 4080 4081 4082 4083 |
*
*----------------------------------------------------------------------
*/
void
TclSetNsPath(
Namespace *nsPtr, /* Namespace whose path is to be set. */
| | | | | 4109 4110 4111 4112 4113 4114 4115 4116 4117 4118 4119 4120 4121 4122 4123 4124 4125 4126 4127 4128 4129 |
*
*----------------------------------------------------------------------
*/
void
TclSetNsPath(
Namespace *nsPtr, /* Namespace whose path is to be set. */
size_t pathLength, /* Length of pathAry. */
Tcl_Namespace *pathAry[]) /* Array of namespaces that are the path. */
{
if (pathLength != 0) {
NamespacePathEntry *tmpPathArray =
Tcl_Alloc(sizeof(NamespacePathEntry) * pathLength);
size_t i;
for (i=0 ; i<pathLength ; i++) {
tmpPathArray[i].nsPtr = (Namespace *) pathAry[i];
tmpPathArray[i].creatorNsPtr = nsPtr;
tmpPathArray[i].prevPtr = NULL;
tmpPathArray[i].nextPtr =
tmpPathArray[i].nsPtr->commandPathSourceList;
|
| ︙ | ︙ | |||
4134 4135 4136 4137 4138 4139 4140 |
*----------------------------------------------------------------------
*/
static void
UnlinkNsPath(
Namespace *nsPtr)
{
| | | | 4166 4167 4168 4169 4170 4171 4172 4173 4174 4175 4176 4177 4178 4179 4180 4181 4182 4183 4184 4185 4186 4187 4188 4189 4190 4191 4192 4193 4194 4195 4196 |
*----------------------------------------------------------------------
*/
static void
UnlinkNsPath(
Namespace *nsPtr)
{
size_t i;
for (i=0 ; i<nsPtr->commandPathLength ; i++) {
NamespacePathEntry *nsPathPtr = &nsPtr->commandPathArray[i];
if (nsPathPtr->prevPtr != NULL) {
nsPathPtr->prevPtr->nextPtr = nsPathPtr->nextPtr;
}
if (nsPathPtr->nextPtr != NULL) {
nsPathPtr->nextPtr->prevPtr = nsPathPtr->prevPtr;
}
if (nsPathPtr->nsPtr != NULL) {
if (nsPathPtr->nsPtr->commandPathSourceList == nsPathPtr) {
nsPathPtr->nsPtr->commandPathSourceList = nsPathPtr->nextPtr;
}
}
}
Tcl_Free(nsPtr->commandPathArray);
}
/*
*----------------------------------------------------------------------
*
* TclInvalidateNsPath --
*
|
| ︙ | ︙ | |||
4220 4221 4222 4223 4224 4225 4226 |
NamespaceQualifiersCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
register const char *name, *p;
| | | 4252 4253 4254 4255 4256 4257 4258 4259 4260 4261 4262 4263 4264 4265 4266 |
NamespaceQualifiersCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
register const char *name, *p;
size_t length;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "string");
return TCL_ERROR;
}
/*
|
| ︙ | ︙ | |||
4621 4622 4623 4624 4625 4626 4627 |
Tcl_WrongNumArgs(interp, 1, objv, "?-command? ?-variable? name");
return TCL_ERROR;
} else if (objc == 3) {
/*
* Look for a flag controlling the lookup.
*/
| | | | 4653 4654 4655 4656 4657 4658 4659 4660 4661 4662 4663 4664 4665 4666 4667 4668 |
Tcl_WrongNumArgs(interp, 1, objv, "?-command? ?-variable? name");
return TCL_ERROR;
} else if (objc == 3) {
/*
* Look for a flag controlling the lookup.
*/
if (Tcl_GetIndexFromObj(interp, objv[1], opts, "option", 0,
&lookupType) != TCL_OK) {
/*
* Preserve old style of error message!
*/
Tcl_ResetResult(interp);
goto badArgs;
}
|
| ︙ | ︙ | |||
4680 4681 4682 4683 4684 4685 4686 |
*/
static void
FreeNsNameInternalRep(
register Tcl_Obj *objPtr) /* nsName object with internal representation
* to free. */
{
| | > > > | < | 4712 4713 4714 4715 4716 4717 4718 4719 4720 4721 4722 4723 4724 4725 4726 4727 4728 4729 4730 4731 4732 4733 4734 4735 4736 4737 4738 4739 4740 4741 4742 4743 4744 4745 |
*/
static void
FreeNsNameInternalRep(
register Tcl_Obj *objPtr) /* nsName object with internal representation
* to free. */
{
ResolvedNsName *resNamePtr;
NsNameGetIntRep(objPtr, resNamePtr);
assert(resNamePtr != NULL);
/*
* Decrement the reference count of the namespace. If there are no more
* references, free it up.
*/
if (resNamePtr->refCount-- <= 1) {
/*
* Decrement the reference count for the cached namespace. If the
* namespace is dead, and there are no more references to it, free
* it.
*/
TclNsDecrRefCount(resNamePtr->nsPtr);
Tcl_Free(resNamePtr);
}
}
/*
*----------------------------------------------------------------------
*
* DupNsNameInternalRep --
*
|
| ︙ | ︙ | |||
4724 4725 4726 4727 4728 4729 4730 |
*/
static void
DupNsNameInternalRep(
Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
register Tcl_Obj *copyPtr) /* Object with internal rep to set. */
{
| | | | | | 4758 4759 4760 4761 4762 4763 4764 4765 4766 4767 4768 4769 4770 4771 4772 4773 4774 4775 4776 |
*/
static void
DupNsNameInternalRep(
Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
register Tcl_Obj *copyPtr) /* Object with internal rep to set. */
{
ResolvedNsName *resNamePtr;
NsNameGetIntRep(srcPtr, resNamePtr);
assert(resNamePtr != NULL);
NsNameSetIntRep(copyPtr, resNamePtr);
}
/*
*----------------------------------------------------------------------
*
* SetNsNameFromAny --
*
|
| ︙ | ︙ | |||
4772 4773 4774 4775 4776 4777 4778 4779 4780 4781 4782 4783 4784 |
if (interp == NULL) {
return TCL_ERROR;
}
name = TclGetString(objPtr);
TclGetNamespaceForQualName(interp, name, NULL, TCL_FIND_ONLY_NS,
&nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy);
/*
* If we found a namespace, then create a new ResolvedNsName structure
* that holds a reference to it.
*/
| > > > > < < < < < < < < < < < < < | | | < < | 4806 4807 4808 4809 4810 4811 4812 4813 4814 4815 4816 4817 4818 4819 4820 4821 4822 4823 4824 4825 4826 4827 4828 4829 4830 4831 4832 4833 4834 4835 4836 4837 4838 4839 |
if (interp == NULL) {
return TCL_ERROR;
}
name = TclGetString(objPtr);
TclGetNamespaceForQualName(interp, name, NULL, TCL_FIND_ONLY_NS,
&nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy);
if ((nsPtr == NULL) || (nsPtr->flags & NS_DYING)) {
return TCL_ERROR;
}
/*
* If we found a namespace, then create a new ResolvedNsName structure
* that holds a reference to it.
*/
nsPtr->refCount++;
resNamePtr = Tcl_Alloc(sizeof(ResolvedNsName));
resNamePtr->nsPtr = nsPtr;
if ((name[0] == ':') && (name[1] == ':')) {
resNamePtr->refNsPtr = NULL;
} else {
resNamePtr->refNsPtr = (Namespace *) TclGetCurrentNamespace(interp);
}
resNamePtr->refCount = 0;
NsNameSetIntRep(objPtr, resNamePtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclGetNamespaceCommandTable --
|
| ︙ | ︙ | |||
4854 4855 4856 4857 4858 4859 4860 |
Tcl_Namespace *nsPtr)
{
Namespace *nPtr = (Namespace *) nsPtr;
#ifndef BREAK_NAMESPACE_COMPAT
return &nPtr->childTable;
#else
if (nPtr->childTablePtr == NULL) {
| | | 4877 4878 4879 4880 4881 4882 4883 4884 4885 4886 4887 4888 4889 4890 4891 |
Tcl_Namespace *nsPtr)
{
Namespace *nPtr = (Namespace *) nsPtr;
#ifndef BREAK_NAMESPACE_COMPAT
return &nPtr->childTable;
#else
if (nPtr->childTablePtr == NULL) {
nPtr->childTablePtr = Tcl_Alloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(nPtr->childTablePtr, TCL_STRING_KEYS);
}
return nPtr->childTablePtr;
#endif
}
/*
|
| ︙ | ︙ | |||
4890 4891 4892 4893 4894 4895 4896 |
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. */
| | | | 4913 4914 4915 4916 4917 4918 4919 4920 4921 4922 4923 4924 4925 4926 4927 4928 |
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 */
{
register const char *p;
Interp *iPtr = (Interp *) interp;
int overflow, limit = 150;
|
| ︙ | ︙ | |||
4922 4923 4924 4925 4926 4927 4928 |
iPtr->errorLine = 1;
for (p = script; p != command; p++) {
if (*p == '\n') {
iPtr->errorLine++;
}
}
| | | | | 4945 4946 4947 4948 4949 4950 4951 4952 4953 4954 4955 4956 4957 4958 4959 4960 4961 4962 4963 4964 4965 4966 |
iPtr->errorLine = 1;
for (p = script; p != command; p++) {
if (*p == '\n') {
iPtr->errorLine++;
}
}
if (length == TCL_AUTO_LENGTH) {
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.
|
| ︙ | ︙ | |||
5012 5013 5014 5015 5016 5017 5018 |
*/
} else if (iPtr->varFramePtr != iPtr->framePtr) {
/*
* uplevel case, [lappend errorstack UP $relativelevel]
*/
Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->upLiteral);
| | | 5035 5036 5037 5038 5039 5040 5041 5042 5043 5044 5045 5046 5047 5048 5049 |
*/
} 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_NewIntObj(
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);
|
| ︙ | ︙ | |||
5047 5048 5049 5050 5051 5052 5053 |
*----------------------------------------------------------------------
*/
void
TclErrorStackResetIf(
Tcl_Interp *interp,
const char *msg,
| | | 5070 5071 5072 5073 5074 5075 5076 5077 5078 5079 5080 5081 5082 5083 5084 |
*----------------------------------------------------------------------
*/
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);
|
| ︙ | ︙ | |||
5102 5103 5104 5105 5106 5107 5108 |
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. */
| | | 5125 5126 5127 5128 5129 5130 5131 5132 5133 5134 5135 5136 5137 5138 5139 |
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);
}
/*
|
| ︙ | ︙ |
Changes to generic/tclNotify.c.
| ︙ | ︙ | |||
177 178 179 180 181 182 183 |
return; /* Notifier not initialized for the current thread */
}
Tcl_MutexLock(&(tsdPtr->queueMutex));
for (evPtr = tsdPtr->firstEventPtr; evPtr != NULL; ) {
hold = evPtr;
evPtr = evPtr->nextPtr;
| | | 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 |
return; /* Notifier not initialized for the current thread */
}
Tcl_MutexLock(&(tsdPtr->queueMutex));
for (evPtr = tsdPtr->firstEventPtr; evPtr != NULL; ) {
hold = evPtr;
evPtr = evPtr->nextPtr;
Tcl_Free(hold);
}
tsdPtr->firstEventPtr = NULL;
tsdPtr->lastEventPtr = NULL;
Tcl_MutexUnlock(&(tsdPtr->queueMutex));
Tcl_MutexLock(&listLock);
|
| ︙ | ︙ | |||
272 273 274 275 276 277 278 |
Tcl_EventCheckProc *checkProc,
/* Function to call after waiting to see what
* happened. */
ClientData clientData) /* One-word argument to pass to setupProc and
* checkProc. */
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
| | | 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 |
Tcl_EventCheckProc *checkProc,
/* Function to call after waiting to see what
* happened. */
ClientData clientData) /* One-word argument to pass to setupProc and
* checkProc. */
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
EventSource *sourcePtr = Tcl_Alloc(sizeof(EventSource));
sourcePtr->setupProc = setupProc;
sourcePtr->checkProc = checkProc;
sourcePtr->clientData = clientData;
sourcePtr->nextPtr = tsdPtr->firstEventSourcePtr;
tsdPtr->firstEventSourcePtr = sourcePtr;
}
|
| ︙ | ︙ | |||
326 327 328 329 330 331 332 |
continue;
}
if (prevPtr == NULL) {
tsdPtr->firstEventSourcePtr = sourcePtr->nextPtr;
} else {
prevPtr->nextPtr = sourcePtr->nextPtr;
}
| | | 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 |
continue;
}
if (prevPtr == NULL) {
tsdPtr->firstEventSourcePtr = sourcePtr->nextPtr;
} else {
prevPtr->nextPtr = sourcePtr->nextPtr;
}
Tcl_Free(sourcePtr);
return;
}
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
351 352 353 354 355 356 357 |
*----------------------------------------------------------------------
*/
void
Tcl_QueueEvent(
Tcl_Event *evPtr, /* Event to add to queue. The storage space
* must have been allocated the caller with
| | | 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 |
*----------------------------------------------------------------------
*/
void
Tcl_QueueEvent(
Tcl_Event *evPtr, /* Event to add to queue. The storage space
* must have been allocated the caller with
* malloc (Tcl_Alloc), and it becomes the
* property of the event queue. It will be
* freed after the event has been handled. */
Tcl_QueuePosition position) /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD,
* TCL_QUEUE_MARK. */
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
|
| ︙ | ︙ | |||
383 384 385 386 387 388 389 |
*/
void
Tcl_ThreadQueueEvent(
Tcl_ThreadId threadId, /* Identifier for thread to use. */
Tcl_Event *evPtr, /* Event to add to queue. The storage space
* must have been allocated the caller with
| | | 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 |
*/
void
Tcl_ThreadQueueEvent(
Tcl_ThreadId threadId, /* Identifier for thread to use. */
Tcl_Event *evPtr, /* Event to add to queue. The storage space
* must have been allocated the caller with
* malloc (Tcl_Alloc), and it becomes the
* property of the event queue. It will be
* freed after the event has been handled. */
Tcl_QueuePosition position) /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD,
* TCL_QUEUE_MARK. */
{
ThreadSpecificData *tsdPtr;
|
| ︙ | ︙ | |||
408 409 410 411 412 413 414 |
/*
* Queue the event if there was a notifier associated with the thread.
*/
if (tsdPtr) {
QueueEvent(tsdPtr, evPtr, position);
} else {
| | | 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 |
/*
* Queue the event if there was a notifier associated with the thread.
*/
if (tsdPtr) {
QueueEvent(tsdPtr, evPtr, position);
} else {
Tcl_Free(evPtr);
}
Tcl_MutexUnlock(&listLock);
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
440 441 442 443 444 445 446 |
static void
QueueEvent(
ThreadSpecificData *tsdPtr, /* Handle to thread local data that indicates
* which event queue to use. */
Tcl_Event *evPtr, /* Event to add to queue. The storage space
* must have been allocated the caller with
| | | 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 |
static void
QueueEvent(
ThreadSpecificData *tsdPtr, /* Handle to thread local data that indicates
* which event queue to use. */
Tcl_Event *evPtr, /* Event to add to queue. The storage space
* must have been allocated the caller with
* malloc (Tcl_Alloc), and it becomes the
* property of the event queue. It will be
* freed after the event has been handled. */
Tcl_QueuePosition position) /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD,
* TCL_QUEUE_MARK. */
{
Tcl_MutexLock(&(tsdPtr->queueMutex));
if (position == TCL_QUEUE_TAIL) {
|
| ︙ | ︙ | |||
559 560 561 562 563 564 565 | /* * Delete the event data structure. */ hold = evPtr; evPtr = evPtr->nextPtr; | | | 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 |
/*
* Delete the event data structure.
*/
hold = evPtr;
evPtr = evPtr->nextPtr;
Tcl_Free(hold);
} else {
/*
* Event is to be retained.
*/
prevPtr = evPtr;
evPtr = evPtr->nextPtr;
|
| ︙ | ︙ | |||
698 699 700 701 702 703 704 |
tsdPtr->markerEventPtr = prevPtr;
}
} else {
evPtr = NULL;
}
}
if (evPtr) {
| | | 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 |
tsdPtr->markerEventPtr = prevPtr;
}
} else {
evPtr = NULL;
}
}
if (evPtr) {
Tcl_Free(evPtr);
}
Tcl_MutexUnlock(&(tsdPtr->queueMutex));
return 1;
} else {
/*
* The event wasn't actually handled, so we have to restore the
* proc field to allow the event to be attempted again.
|
| ︙ | ︙ |
Changes to generic/tclOO.c.
| ︙ | ︙ | |||
22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 |
static const struct {
const char *name;
Tcl_ObjCmdProc *objProc;
int flag;
} defineCmds[] = {
{"constructor", TclOODefineConstructorObjCmd, 0},
{"deletemethod", TclOODefineDeleteMethodObjCmd, 0},
{"destructor", TclOODefineDestructorObjCmd, 0},
{"export", TclOODefineExportObjCmd, 0},
{"forward", TclOODefineForwardObjCmd, 0},
{"method", TclOODefineMethodObjCmd, 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},
{"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.
*/
| > > > < | 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 |
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);
|
| ︙ | ︙ | |||
78 79 80 81 82 83 84 | static void KillFoundation(ClientData clientData, Tcl_Interp *interp); static void MyDeleted(ClientData clientData); static void ObjectNamespaceDeleted(ClientData clientData); static void ObjectRenamedTrace(ClientData clientData, Tcl_Interp *interp, const char *oldName, const char *newName, int flags); | < < < < < < < < > > > > | 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 | static void KillFoundation(ClientData clientData, Tcl_Interp *interp); static void MyDeleted(ClientData clientData); static void ObjectNamespaceDeleted(ClientData clientData); static void ObjectRenamedTrace(ClientData clientData, Tcl_Interp *interp, const char *oldName, const char *newName, int flags); 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. |
| ︙ | ︙ | |||
146 147 148 149 150 151 152 |
"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;"; */
/*
| | < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < | 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 |
"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;
|
| ︙ | ︙ | |||
353 354 355 356 357 358 359 |
static int
InitFoundation(
Tcl_Interp *interp)
{
static Tcl_ThreadDataKey tsdKey;
ThreadLocalData *tsdPtr =
Tcl_GetThreadData(&tsdKey, sizeof(ThreadLocalData));
| | | | 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 |
static int
InitFoundation(
Tcl_Interp *interp)
{
static Tcl_ThreadDataKey tsdKey;
ThreadLocalData *tsdPtr =
Tcl_GetThreadData(&tsdKey, sizeof(ThreadLocalData));
Foundation *fPtr = 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,
|
| ︙ | ︙ | |||
376 377 378 379 380 381 382 |
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);
| | | 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 |
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, "<constructor>");
TclNewLiteralStringObj(fPtr->destructorName, "<destructor>");
TclNewLiteralStringObj(fPtr->clonedName, "<cloned>");
TclNewLiteralStringObj(fPtr->defineName, "::oo::define");
Tcl_IncrRefCount(fPtr->unknownMethodNameObj);
|
| ︙ | ︙ | |||
399 400 401 402 403 404 405 |
Tcl_SetNamespaceUnknownHandler(interp, fPtr->objdefNs, namePtr);
/*
* Create the subcommands in the oo::define and oo::objdefine spaces.
*/
Tcl_DStringInit(&buffer);
| | | | | < < < < < < < < < < < < | | 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 |
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.
*/
|
| ︙ | ︙ | |||
485 486 487 488 489 490 491 |
/*
* Now make the class of slots.
*/
if (TclOODefineSlots(fPtr) != TCL_OK) {
return TCL_ERROR;
}
| > > > > > | > | | > | | > > | > | > > > > > | > | > > > > > | 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 |
/*
* 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.
|
| ︙ | ︙ | |||
628 629 630 631 632 633 634 |
TclDecrRefCount(fPtr->constructorName);
TclDecrRefCount(fPtr->destructorName);
TclDecrRefCount(fPtr->clonedName);
TclDecrRefCount(fPtr->defineName);
TclOODecrRefCount(fPtr->objectCls->thisPtr);
TclOODecrRefCount(fPtr->classCls->thisPtr);
| | | 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 |
TclDecrRefCount(fPtr->constructorName);
TclDecrRefCount(fPtr->destructorName);
TclDecrRefCount(fPtr->clonedName);
TclDecrRefCount(fPtr->defineName);
TclOODecrRefCount(fPtr->objectCls->thisPtr);
TclOODecrRefCount(fPtr->classCls->thisPtr);
Tcl_Free(fPtr);
}
/*
* ----------------------------------------------------------------------
*
* AllocObject --
*
|
| ︙ | ︙ | |||
668 669 670 671 672 673 674 |
{
Foundation *fPtr = GetFoundation(interp);
Object *oPtr;
Command *cmdPtr;
CommandTrace *tracePtr;
size_t creationEpoch;
| | | 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 |
{
Foundation *fPtr = GetFoundation(interp);
Object *oPtr;
Command *cmdPtr;
CommandTrace *tracePtr;
size_t creationEpoch;
oPtr = 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).
|
| ︙ | ︙ | |||
695 696 697 698 699 700 701 |
}
Tcl_ResetResult(interp);
}
while (1) {
char objName[10 + TCL_INTEGER_SPACE];
| | < < | | 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 |
}
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) {
|
| ︙ | ︙ | |||
770 771 772 773 774 775 776 |
if (!nameStr) {
nameStr = oPtr->namespacePtr->name;
nsPtr = (Namespace *)oPtr->namespacePtr;
if (nsPtr->parentPtr != NULL) {
nsPtr = nsPtr->parentPtr;
}
| | < | | | > > > | 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 |
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 = 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 --
|
| ︙ | ︙ | |||
818 819 820 821 822 823 824 |
oPtr->cachedNameObj = NULL;
}
}
/*
* ----------------------------------------------------------------------
*
| | | | > | < > > > > > > > > | 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 |
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. */
{
register Object *oPtr = clientData;
oPtr->myCommand = NULL;
}
static void
MyClassDeleted(
ClientData clientData)
{
Object *oPtr = clientData;
oPtr->myclassCommand = NULL;
}
/*
* ----------------------------------------------------------------------
*
* ObjectRenamedTrace --
*
* This callback is triggered when the object is deleted by any
|
| ︙ | ︙ | |||
887 888 889 890 891 892 893 |
TclOODecrRefCount(oPtr);
return;
}
/*
* ----------------------------------------------------------------------
*
| | | | > | > > | > | > | | | > | > | | > | > | | | | > > > | > | > | > > > | > > > | | | | | | > > > > > > > > | 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 |
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 (!Deleted(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 (!Deleted(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 (!Deleted(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 (!Deleted(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) && !Deleted(fPtr->objectCls->thisPtr)) {
Tcl_DeleteCommandFromToken(interp, fPtr->objectCls->thisPtr->command);
}
}
|
| ︙ | ︙ | |||
1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 |
{
Object *oPtr = clientData;
Foundation *fPtr = oPtr->fPtr;
FOREACH_HASH_DECLS;
Class *mixinPtr;
Method *mPtr;
Tcl_Obj *filterObj, *variableObj;
Tcl_Interp *interp = oPtr->fPtr->interp;
int i;
if (Deleted(oPtr)) {
/*
| > | | > | > > | | < > | | | | > > > < | < < > | > | | | > > > > > > > > | | | | | 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 |
{
Object *oPtr = 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 (Deleted(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_DELETED;
/*
* 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_IS_DELETED) {
/*
* 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) && !Deleted(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);
|
| ︙ | ︙ | |||
1314 1315 1316 1317 1318 1319 1320 |
int
TclOODecrRefCount(
Object *oPtr)
{
if (oPtr->refCount-- <= 1) {
if (oPtr->classPtr != NULL) {
| | | | 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 |
int
TclOODecrRefCount(
Object *oPtr)
{
if (oPtr->refCount-- <= 1) {
if (oPtr->classPtr != NULL) {
Tcl_Free(oPtr->classPtr);
}
Tcl_Free(oPtr);
return 1;
}
return 0;
}
/*
* ----------------------------------------------------------------------
|
| ︙ | ︙ | |||
1374 1375 1376 1377 1378 1379 1380 |
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) {
| | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 |
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 = Tcl_Alloc(sizeof(Object *) * ALLOC_CHUNK);
} else {
clsPtr->instances.list = 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
|
| ︙ | ︙ | |||
1438 1439 1440 1441 1442 1443 1444 |
{
if (Deleted(superPtr->thisPtr)) {
return;
}
if (superPtr->subclasses.num >= superPtr->subclasses.size) {
superPtr->subclasses.size += ALLOC_CHUNK;
if (superPtr->subclasses.size == ALLOC_CHUNK) {
| | | | 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 |
{
if (Deleted(superPtr->thisPtr)) {
return;
}
if (superPtr->subclasses.num >= superPtr->subclasses.size) {
superPtr->subclasses.size += ALLOC_CHUNK;
if (superPtr->subclasses.size == ALLOC_CHUNK) {
superPtr->subclasses.list = Tcl_Alloc(sizeof(Class *) * ALLOC_CHUNK);
} else {
superPtr->subclasses.list = Tcl_Realloc(superPtr->subclasses.list,
sizeof(Class *) * superPtr->subclasses.size);
}
}
superPtr->subclasses.list[superPtr->subclasses.num++] = subPtr;
AddRef(subPtr->thisPtr);
}
|
| ︙ | ︙ | |||
1503 1504 1505 1506 1507 1508 1509 |
{
if (Deleted(superPtr->thisPtr)) {
return;
}
if (superPtr->mixinSubs.num >= superPtr->mixinSubs.size) {
superPtr->mixinSubs.size += ALLOC_CHUNK;
if (superPtr->mixinSubs.size == ALLOC_CHUNK) {
| | | | | | | 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 |
{
if (Deleted(superPtr->thisPtr)) {
return;
}
if (superPtr->mixinSubs.num >= superPtr->mixinSubs.size) {
superPtr->mixinSubs.size += ALLOC_CHUNK;
if (superPtr->mixinSubs.size == ALLOC_CHUNK) {
superPtr->mixinSubs.list = Tcl_Alloc(sizeof(Class *) * ALLOC_CHUNK);
} else {
superPtr->mixinSubs.list = 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,
|
| ︙ | ︙ | |||
1543 1544 1545 1546 1547 1548 1549 |
TclSetNsPath((Namespace *) clsPtr->thisPtr->namespacePtr, 2, path);
} else {
TclSetNsPath((Namespace *) clsPtr->thisPtr->namespacePtr, 1,
&fPtr->ooNs);
}
}
| | | | | | 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 |
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 = 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 = Tcl_Alloc(sizeof(Class *));
clsPtr->superclasses.list[0] = fPtr->objectCls;
AddRef(fPtr->objectCls->thisPtr);
/*
* Finish connecting the class structure to the object structure.
*/
|
| ︙ | ︙ | |||
1627 1628 1629 1630 1631 1632 1633 |
/*
* Run constructors, except when objc < 0, which is a special flag case
* used for object cloning only.
*/
if (objc >= 0) {
CallContext *contextPtr =
| | | 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 |
/*
* 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;
|
| ︙ | ︙ | |||
1700 1701 1702 1703 1704 1705 1706 |
* object cloning only). If there aren't any constructors, we do nothing.
*/
if (objc < 0) {
*objectPtr = (Tcl_Object) oPtr;
return TCL_OK;
}
| | | 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 |
* 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;
|
| ︙ | ︙ | |||
1727 1728 1729 1730 1731 1732 1733 |
*/
TclNRAddCallback(interp, FinalizeAlloc, contextPtr, oPtr, state,
objectPtr);
TclPushTailcallPoint(interp);
return TclOOInvokeContext(contextPtr, interp, objc, objv);
}
| < < | | < < < < < < < | | | | | < < | 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 |
*/
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 = data[0];
|
| ︙ | ︙ | |||
1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 |
{
Object *oPtr = (Object *) sourceObject, *o2Ptr;
FOREACH_HASH_DECLS;
Method *mPtr;
Class *mixinPtr;
CallContext *contextPtr;
Tcl_Obj *keyPtr, *filterObj, *variableObj, *args[3];
int i, result;
/*
* Sanity check.
*/
if (IsRootClass(oPtr)) {
| > | 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 |
{
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)) {
|
| ︙ | ︙ | |||
1928 1929 1930 1931 1932 1933 1934 |
if (o2Ptr->mixins.num != 0) {
FOREACH(mixinPtr, o2Ptr->mixins) {
if (mixinPtr && mixinPtr != o2Ptr->selfCls) {
TclOORemoveFromInstances(o2Ptr, mixinPtr);
}
TclOODecrRefCount(mixinPtr->thisPtr);
}
| | > > | > > | > > > > > > > > | 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 |
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_DELETED | ROOT_OBJECT | ROOT_CLASS | FILTER_HANDLING);
/*
* Copy the object's metadata.
*/
if (oPtr->metadataPtr != NULL) {
Tcl_ObjectMetadataType *metadataTypePtr;
ClientData value, duplicate;
|
| ︙ | ︙ | |||
2017 2018 2019 2020 2021 2022 2023 |
*/
FOREACH(superPtr, cls2Ptr->superclasses) {
TclOORemoveFromSubclasses(cls2Ptr, superPtr);
TclOODecrRefCount(superPtr->thisPtr);
}
if (cls2Ptr->superclasses.num) {
| | | > | | > | > > > > > > > | > > | > > | 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 |
*/
FOREACH(superPtr, cls2Ptr->superclasses) {
TclOORemoveFromSubclasses(cls2Ptr, superPtr);
TclOODecrRefCount(superPtr->thisPtr);
}
if (cls2Ptr->superclasses.num) {
cls2Ptr->superclasses.list = Tcl_Realloc(cls2Ptr->superclasses.list,
sizeof(Class *) * clsPtr->superclasses.num);
} else {
cls2Ptr->superclasses.list =
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.
*/
|
| ︙ | ︙ | |||
2125 2126 2127 2128 2129 2130 2131 |
duplicate);
}
}
}
}
TclResetRewriteEnsemble(interp, 1);
| | > | 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 |
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]);
|
| ︙ | ︙ | |||
2301 2302 2303 2304 2305 2306 2307 |
* Attach the metadata store if not done already.
*/
if (clsPtr->metadataPtr == NULL) {
if (metadata == NULL) {
return;
}
| | | 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 |
* Attach the metadata store if not done already.
*/
if (clsPtr->metadataPtr == NULL) {
if (metadata == NULL) {
return;
}
clsPtr->metadataPtr = 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.
*/
|
| ︙ | ︙ | |||
2381 2382 2383 2384 2385 2386 2387 |
* Attach the metadata store if not done already.
*/
if (oPtr->metadataPtr == NULL) {
if (metadata == NULL) {
return;
}
| | | 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 |
* Attach the metadata store if not done already.
*/
if (oPtr->metadataPtr == NULL) {
if (metadata == NULL) {
return;
}
oPtr->metadataPtr = 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.
*/
|
| ︙ | ︙ | |||
2413 2414 2415 2416 2417 2418 2419 |
}
Tcl_SetHashValue(hPtr, metadata);
}
/*
* ----------------------------------------------------------------------
*
| | | | | | | 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 |
}
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(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);
}
|
| ︙ | ︙ | |||
2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 |
(Class *) startCls);
}
}
/*
* ----------------------------------------------------------------------
*
* 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.
*
* ----------------------------------------------------------------------
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 |
(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 = 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.
*
* ----------------------------------------------------------------------
|
| ︙ | ︙ | |||
2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 |
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;
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;
}
/*
* Give plugged in code a chance to remap the method name.
*/
methodNamePtr = objv[1];
if (oPtr->mapMethodNameProc != NULL) {
| > > > > > > > > > > > > > > > > > > > > > | 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 |
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 = 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) {
|
| ︙ | ︙ | |||
2562 2563 2564 2565 2566 2567 2568 | /* * Get the call chain for the remapped name. */ Tcl_IncrRefCount(mappedMethodName); contextPtr = TclOOGetCallContext(oPtr, mappedMethodName, | | > | > | 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 |
/*
* 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;
|
| ︙ | ︙ | |||
2669 2670 2671 2672 2673 2674 2675 |
int skip)
{
CallContext *contextPtr = (CallContext *) context;
int savedIndex = contextPtr->index;
int savedSkip = contextPtr->skip;
int result;
| | | 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 |
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.
*/
|
| ︙ | ︙ | |||
2738 2739 2740 2741 2742 2743 2744 |
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv,
int skip)
{
register CallContext *contextPtr = (CallContext *) context;
| | | 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 |
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv,
int skip)
{
register 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.
*/
|
| ︙ | ︙ | |||
2829 2830 2831 2832 2833 2834 2835 |
* exactly the name of its public command. */
{
Command *cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objPtr);
if (cmdPtr == NULL) {
goto notAnObject;
}
| | | | 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 |
* 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 cmdPtr->objClientData;
notAnObject:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
|
| ︙ | ︙ |
Changes to generic/tclOO.decls.
| ︙ | ︙ | |||
47 48 49 50 51 52 53 |
Tcl_Object Tcl_MethodDeclarerObject(Tcl_Method method)
}
declare 8 {
int Tcl_MethodIsPublic(Tcl_Method method)
}
declare 9 {
int Tcl_MethodIsType(Tcl_Method method, const Tcl_MethodType *typePtr,
| | | | | | | 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 |
Tcl_Object Tcl_MethodDeclarerObject(Tcl_Method method)
}
declare 8 {
int Tcl_MethodIsPublic(Tcl_Method method)
}
declare 9 {
int Tcl_MethodIsType(Tcl_Method method, const Tcl_MethodType *typePtr,
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 {
|
| ︙ | ︙ | |||
83 84 85 86 87 88 89 |
declare 17 {
Tcl_Object Tcl_ObjectContextObject(Tcl_ObjectContext context)
}
declare 18 {
int Tcl_ObjectContextSkippedArgs(Tcl_ObjectContext context)
}
declare 19 {
| | | | | | 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 |
declare 17 {
Tcl_Object Tcl_ObjectContextObject(Tcl_ObjectContext context)
}
declare 18 {
int Tcl_ObjectContextSkippedArgs(Tcl_ObjectContext context)
}
declare 19 {
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 {
|
| ︙ | ︙ | |||
122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 |
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)
}
######################################################################
# 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,
| > > > | | | 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 |
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 {
|
| ︙ | ︙ | |||
175 176 177 178 179 180 181 |
Method *TclOONewForwardInstanceMethod(Tcl_Interp *interp, Object *oPtr,
int isPublic, Tcl_Obj *nameObj, Tcl_Obj *prefixObj)
}
declare 9 {
Tcl_Method TclOONewProcInstanceMethodEx(Tcl_Interp *interp,
Tcl_Object oPtr, TclOO_PreCallProc *preCallPtr,
TclOO_PostCallProc *postCallPtr, ProcErrorProc *errProc,
| | | | 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 |
Method *TclOONewForwardInstanceMethod(Tcl_Interp *interp, Object *oPtr,
int isPublic, Tcl_Obj *nameObj, Tcl_Obj *prefixObj)
}
declare 9 {
Tcl_Method TclOONewProcInstanceMethodEx(Tcl_Interp *interp,
Tcl_Object oPtr, TclOO_PreCallProc *preCallPtr,
TclOO_PostCallProc *postCallPtr, ProcErrorProc *errProc,
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)
|
| ︙ | ︙ |
Changes to generic/tclOO.h.
| ︙ | ︙ | |||
51 52 53 54 55 56 57 | /* * 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. */ | | | | | | | 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 | /* * 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). |
| ︙ | ︙ | |||
90 91 92 93 94 95 96 97 98 99 100 101 102 103 | /* * 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 /* * 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). */ | > > > > > > > > > | 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 | /* * 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). */ |
| ︙ | ︙ |
Changes to generic/tclOOBasic.c.
| ︙ | ︙ | |||
79 80 81 82 83 84 85 |
ClientData clientData,
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
| | > > > > > > > > > > > | | > > > > > > > > > > > | > > | > > | 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 |
ClientData 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_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 = data[0];
Object *oPtr = 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 --
*
|
| ︙ | ︙ | |||
153 154 155 156 157 158 159 |
* 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;
| | | 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 |
* 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) {
|
| ︙ | ︙ | |||
178 179 180 181 182 183 184 |
*/
if (objc - Tcl_ObjectContextSkippedArgs(context) < 1) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
"objectName ?arg ...?");
return TCL_ERROR;
}
| | | 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 |
*/
if (objc - Tcl_ObjectContextSkippedArgs(context) < 1) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
"objectName ?arg ...?");
return TCL_ERROR;
}
objName = 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;
}
|
| ︙ | ︙ | |||
218 219 220 221 222 223 224 |
* 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;
| | | 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 |
* 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) {
|
| ︙ | ︙ | |||
243 244 245 246 247 248 249 |
*/
if (objc - Tcl_ObjectContextSkippedArgs(context) < 2) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
"objectName namespaceName ?arg ...?");
return TCL_ERROR;
}
| | | | 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 |
*/
if (objc - Tcl_ObjectContextSkippedArgs(context) < 2) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
"objectName namespaceName ?arg ...?");
return TCL_ERROR;
}
objName = 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;
}
|
| ︙ | ︙ | |||
343 344 345 346 347 348 349 |
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;
| | > | 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 |
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);
|
| ︙ | ︙ | |||
495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 |
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 *oPtr = contextPtr->oPtr;
const char **methodNames;
int numMethodNames, i, skip = Tcl_ObjectContextSkippedArgs(context);
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;
}
/*
* Get the list of methods that we want to know about.
*/
| > > > > > > > > > > > > > > > > > > > > > > > > | | 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 |
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 = 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) {
|
| ︙ | ︙ | |||
550 551 552 553 554 555 556 |
}
Tcl_AppendToObj(errorMsg, methodNames[i], -1);
}
if (i) {
Tcl_AppendToObj(errorMsg, " or ", -1);
}
Tcl_AppendToObj(errorMsg, methodNames[i], -1);
| | | 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 |
}
Tcl_AppendToObj(errorMsg, methodNames[i], -1);
}
if (i) {
Tcl_AppendToObj(errorMsg, " or ", -1);
}
Tcl_AppendToObj(errorMsg, methodNames[i], -1);
Tcl_Free((void *)methodNames);
Tcl_SetObjResult(interp, errorMsg);
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[skip]), NULL);
return TCL_ERROR;
}
/*
|
| ︙ | ︙ | |||
680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 |
* 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;
const char *arg;
if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
"varName");
return TCL_ERROR;
}
argPtr = objv[objc-1];
| > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 |
* 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 = 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,
|
| ︙ | ︙ | |||
725 726 727 728 729 730 731 |
/*
* Now that we've pinned down what variable we're really talking about
* (including traversing variable links), convert back to a name.
*/
varNamePtr = Tcl_NewObj();
if (aryVar != NULL) {
| < < < < < < < | | > | < < < < | 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 |
/*
* Now that we've pinned down what variable we're really talking about
* (including traversing variable links), convert back to a name.
*/
varNamePtr = Tcl_NewObj();
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;
}
|
| ︙ | ︙ |
Changes to generic/tclOOCall.c.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 |
*/
#ifdef HAVE_CONFIG_H
#include "config.h"
#endif
#include "tclInt.h"
#include "tclOOInt.h"
/*
* 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. */
};
/*
* 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))
/*
* 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 AddMethodToCallChain(Method *const mPtr,
struct ChainBuilder *const cbPtr,
Tcl_HashTable *const doneFilters,
Class *const filterDecl, int flags);
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > | > > > > > > > | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 |
*/
#ifdef HAVE_CONFIG_H
#include "config.h"
#endif
#include "tclInt.h"
#include "tclOOInt.h"
#include <assert.h>
/*
* 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.
|
| ︙ | ︙ | |||
138 139 140 141 142 143 144 |
FOREACH_HASH_VALUE(callPtr, tablePtr) {
if (callPtr) {
TclOODeleteChain(callPtr);
}
}
Tcl_DeleteHashTable(tablePtr);
| | | | > > < < | > | 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 |
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)
{
|
| ︙ | ︙ | |||
211 212 213 214 215 216 217 |
*/
static void
DupMethodNameRep(
Tcl_Obj *srcPtr,
Tcl_Obj *dstPtr)
{
| < | | < < < < | | | 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 |
*/
static void
DupMethodNameRep(
Tcl_Obj *srcPtr,
Tcl_Obj *dstPtr)
{
StashCallChain(dstPtr,
TclFetchIntRep(srcPtr, &methodNameType)->twoPtrValue.ptr1);
}
static void
FreeMethodNameRep(
Tcl_Obj *objPtr)
{
TclOODeleteChain(
TclFetchIntRep(objPtr, &methodNameType)->twoPtrValue.ptr1);
}
/*
* ----------------------------------------------------------------------
*
* TclOOInvokeContext --
*
|
| ︙ | ︙ | |||
265 266 267 268 269 270 271 |
* entries in the chain so that they do not get deleted out from under our
* feet.
*/
if (contextPtr->index == 0) {
int i;
| | | 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 |
* 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.
*/
|
| ︙ | ︙ | |||
343 344 345 346 347 348 349 |
ClientData data[],
Tcl_Interp *interp,
int result)
{
CallContext *contextPtr = data[0];
int i;
| | > > > > > > > > | < < > | | | | < < < < < < | | | | < < < < < | < < < < < < | | > > > > | > > | > > | < < < < < | < < < | < < < < | < < < < < < < < < | < < < < | < < < < < < < < < < | < | < < > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > < | | > | > | | | | | | | | | | | | | | | | | > | | | | | | | | > | < < < > | > > | | 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 |
ClientData data[],
Tcl_Interp *interp,
int result)
{
CallContext *contextPtr = 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 = 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 --
*
|
| ︙ | ︙ | |||
610 611 612 613 614 615 616 617 618 619 620 621 622 623 |
* 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. */
{
/*
* 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;
| > > | 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 |
* 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;
|
| ︙ | ︙ | |||
640 641 642 643 644 645 646 |
&isNew);
if (!isNew) {
break;
}
if (clsPtr->mixins.num != 0) {
Class *mixinPtr;
| < < < < < | < < < < < < < < < < > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | > > > | > > | < | | | | < > | | | | | > < > | > | | > > > > | | > | > > > > > > > > | | > > | 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 |
&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 = 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 = 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 = 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 --
*
|
| ︙ | ︙ | |||
812 813 814 815 816 817 818 |
* 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.
*/
| | | | | | | | | 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 |
* 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 =
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 = 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++;
}
|
| ︙ | ︙ | |||
953 954 955 956 957 958 959 960 961 962 963 964 965 966 |
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. */
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;
| > > > > > > | | 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 |
Tcl_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)) {
|
| ︙ | ︙ | |||
1000 1001 1002 1003 1004 1005 1006 | /* * 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). */ | > | | | | | 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 |
/*
* 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 = 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 {
|
| ︙ | ︙ | |||
1040 1041 1042 1043 1044 1045 1046 |
Tcl_SetHashValue(hPtr, NULL);
TclOODeleteChain(callPtr);
}
doFilters = 1;
}
| | | | > | | | 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 |
Tcl_SetHashValue(hPtr, NULL);
TclOODeleteChain(callPtr);
}
doFilters = 1;
}
callPtr = 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;
|
| ︙ | ︙ | |||
1084 1085 1086 1087 1088 1089 1090 |
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) {
| | | | | > > > > > | | > | | | > | | | | | | 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 |
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_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_Alloc(sizeof(Tcl_HashTable));
Tcl_InitObjHashTable(oPtr->chainCache);
}
hPtr = Tcl_CreateHashEntry(oPtr->chainCache,
(char *) methodNameObj, &i);
}
}
|
| ︙ | ︙ | |||
1238 1239 1240 1241 1242 1243 1244 |
* in the class).
*/
if (clsPtr->classChainCache != NULL) {
hPtr = Tcl_FindHashEntry(clsPtr->classChainCache,
(char *) methodNameObj);
if (hPtr != NULL && Tcl_GetHashValue(hPtr) != NULL) {
| | < | | 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 |
* 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 = Tcl_GetHashValue(hPtr);
if (IsStillValid(callPtr, &obj, flags, reuseMask)) {
callPtr->refCount++;
return callPtr;
}
Tcl_SetHashValue(hPtr, NULL);
TclOODeleteChain(callPtr);
}
} else {
hPtr = NULL;
}
callPtr = 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;
|
| ︙ | ︙ | |||
1283 1284 1285 1286 1287 1288 1289 |
Tcl_DeleteHashTable(&doneFilters);
count = cb.filterLength = callPtr->numChain;
/*
* Add the actual method implementations.
*/
| | | > | | | | | | 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 |
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_Alloc(sizeof(Tcl_HashTable));
Tcl_InitObjHashTable(clsPtr->classChainCache);
}
hPtr = Tcl_CreateHashEntry(clsPtr->classChainCache,
(char *) methodNameObj, &i);
}
callPtr->refCount++;
Tcl_SetHashValue(hPtr, callPtr);
|
| ︙ | ︙ | |||
1377 1378 1379 1380 1381 1382 1383 |
if (MIXIN_CONSISTENT(flags)) {
FOREACH(filterObj, clsPtr->filters) {
int isNew;
(void) Tcl_CreateHashEntry(doneFilters, (char *) filterObj,
&isNew);
if (isNew) {
| | | | 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 |
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.
|
| ︙ | ︙ | |||
1406 1407 1408 1409 1410 1411 1412 |
return;
}
}
/*
* ----------------------------------------------------------------------
*
| | | > > | | | > > | | 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 |
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. */
|
| ︙ | ︙ | |||
1442 1443 1444 1445 1446 1447 1448 |
*
* Note that mixins must be processed before the main class hierarchy.
* [Bug 1998221]
*/
tailRecurse:
FOREACH(superPtr, classPtr->mixins) {
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | < > > > > | | < | < | | > | | | | | > > | | | | | | | > > | | | | | | | | | < | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 |
*
* 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,
(char *) methodName);
if (hPtr != NULL) {
register Method *mPtr = 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;
}
}
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) {
register Method *mPtr = 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);
}
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 = 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 ; i<definePtr->num ; 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 =
Tcl_Alloc(sizeof(DefineEntry) * definePtr->size);
memcpy(definePtr->list, staticList,
sizeof(DefineEntry) * definePtr->num);
} else {
definePtr->list = Tcl_Realloc(definePtr->list,
sizeof(DefineEntry) * definePtr->size);
}
}
definePtr->list[i].definerCls = definerCls;
definePtr->list[i].namespaceName = namespaceName;
definePtr->num++;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclOODecls.h.
| ︙ | ︙ | |||
52 53 54 55 56 57 58 | /* 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, | | | | | | | | | | > > | | | | | | | > | 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 |
/* 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 TclOOPrivateStubs *tclOOPrivateStubs;
} 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
|
| ︙ | ︙ | |||
225 226 227 228 229 230 231 232 233 234 235 236 237 | (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 */ #endif /* defined(USE_TCLOO_STUBS) */ /* !END!: Do not edit above this line. */ #endif /* _TCLOODECLS */ | > > | 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 | (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 */ |
Changes to generic/tclOODefineCmds.c.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 |
#ifdef HAVE_CONFIG_H
#include "config.h"
#endif
#include "tclInt.h"
#include "tclOOInt.h"
/*
* 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;
};
| > > > > > > > | | > > > > > > > > > > | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 |
#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);
|
| ︙ | ︙ | |||
99 100 101 102 103 104 105 106 107 108 109 110 111 |
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);
/*
* Now define the slots used in declarations.
*/
static const struct DeclaredSlot slots[] = {
| > > > | | | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 |
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
|
| ︙ | ︙ | |||
214 215 216 217 218 219 220 |
}
if (numFilters == 0) {
/*
* No list of filters was supplied, so we're deleting filters.
*/
| | | | | | 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 |
}
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_Alloc(size);
} else {
filtersList = 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;
}
|
| ︙ | ︙ | |||
274 275 276 277 278 279 280 |
}
if (numFilters == 0) {
/*
* No list of filters was supplied, so we're deleting filters.
*/
| | | | | | 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 |
}
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_Alloc(size);
} else {
filtersList = 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;
}
|
| ︙ | ︙ | |||
330 331 332 333 334 335 336 |
if (numMixins == 0) {
if (oPtr->mixins.num != 0) {
FOREACH(mixinPtr, oPtr->mixins) {
TclOORemoveFromInstances(oPtr, mixinPtr);
TclOODecrRefCount(mixinPtr->thisPtr);
}
| | | | > > | > > | 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 |
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 = Tcl_Realloc(oPtr->mixins.list,
sizeof(Class *) * numMixins);
} else {
oPtr->mixins.list = 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++;
}
|
| ︙ | ︙ | |||
387 388 389 390 391 392 393 |
if (numMixins == 0) {
if (classPtr->mixins.num != 0) {
FOREACH(mixinPtr, classPtr->mixins) {
TclOORemoveFromMixinSubs(classPtr, mixinPtr);
TclOODecrRefCount(mixinPtr->thisPtr);
}
| | | | > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 |
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 = Tcl_Realloc(classPtr->mixins.list,
sizeof(Class *) * numMixins);
} else {
classPtr->mixins.list = 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 ; i<varc ; i++) {
Tcl_IncrRefCount(varv[i]);
}
FOREACH(variableObj, *vnlPtr) {
Tcl_DecrRefCount(variableObj);
}
if (i != varc) {
if (varc == 0) {
Tcl_Free(vnlPtr->list);
} else if (i) {
vnlPtr->list = Tcl_Realloc(vnlPtr->list, sizeof(Tcl_Obj *) * varc);
} else {
vnlPtr->list = Tcl_Alloc(sizeof(Tcl_Obj *) * varc);
}
}
vnlPtr->num = 0;
if (varc > 0) {
Tcl_InitObjHashTable(&uniqueTable);
for (i=n=0 ; i<varc ; i++) {
Tcl_CreateHashEntry(&uniqueTable, varv[i], &created);
if (created) {
vnlPtr->list[n++] = varv[i];
} else {
Tcl_DecrRefCount(varv[i]);
}
}
vnlPtr->num = n;
/*
* Shouldn't be necessary, but maintain num/list invariant.
*/
if (n != varc) {
vnlPtr->list = Tcl_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 ; i<varc ; i++) {
Tcl_IncrRefCount(varv[i]);
}
FOREACH_STRUCT(privatePtr, *pvlPtr) {
Tcl_DecrRefCount(privatePtr->variableObj);
Tcl_DecrRefCount(privatePtr->fullNameObj);
}
if (i != varc) {
if (varc == 0) {
Tcl_Free(pvlPtr->list);
} else if (i) {
pvlPtr->list = Tcl_Realloc(pvlPtr->list,
sizeof(PrivateVariableMapping) * varc);
} else {
pvlPtr->list = Tcl_Alloc(sizeof(PrivateVariableMapping) * varc);
}
}
pvlPtr->num = 0;
if (varc > 0) {
Tcl_InitObjHashTable(&uniqueTable);
for (i=n=0 ; i<varc ; i++) {
Tcl_CreateHashEntry(&uniqueTable, varv[i], &created);
if (created) {
privatePtr = &(pvlPtr->list[n++]);
privatePtr->variableObj = varv[i];
privatePtr->fullNameObj = Tcl_ObjPrintf(
PRIVATE_VARIABLE_PATTERN,
creationEpoch, 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 = Tcl_Realloc(pvlPtr->list,
sizeof(PrivateVariableMapping) * n);
}
Tcl_DeleteHashTable(&uniqueTable);
}
}
/*
* ----------------------------------------------------------------------
*
* RenameDeleteMethod --
*
* Core of the code to rename and delete methods.
|
| ︙ | ︙ | |||
525 526 527 528 529 530 531 |
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Namespace *nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
Tcl_HashSearch search;
Tcl_HashEntry *hPtr;
| | | 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 |
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;
|
| ︙ | ︙ | |||
560 561 562 563 564 565 566 |
}
if (matchedStr != NULL) {
/*
* Got one match, and only one match!
*/
| | > | | | 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 |
}
if (matchedStr != NULL) {
/*
* Got one match, and only one match!
*/
Tcl_Obj **newObjv =
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(
|
| ︙ | ︙ | |||
598 599 600 601 602 603 604 |
static Tcl_Command
FindCommand(
Tcl_Interp *interp,
Tcl_Obj *stringObj,
Tcl_Namespace *const namespacePtr)
{
| | | 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 |
static Tcl_Command
FindCommand(
Tcl_Interp *interp,
Tcl_Obj *stringObj,
Tcl_Namespace *const namespacePtr)
{
size_t length;
const char *nameStr, *string = TclGetStringFromObj(stringObj, &length);
register Namespace *const nsPtr = (Namespace *) namespacePtr;
FOREACH_HASH_DECLS;
Tcl_Command cmd, cmd2;
/*
* If someone is playing games, we stop playing right now.
|
| ︙ | ︙ | |||
666 667 668 669 670 671 672 |
int objc,
Tcl_Obj *const objv[])
{
CallFrame *framePtr, **framePtrPtr = &framePtr;
if (namespacePtr == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
| | < | 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 |
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.
*/
|
| ︙ | ︙ | |||
704 705 706 707 708 709 710 |
TclOOGetDefineCmdContext(
Tcl_Interp *interp)
{
Interp *iPtr = (Interp *) interp;
Tcl_Object object;
if ((iPtr->varFramePtr == NULL)
| | > | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > | 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 |
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 = 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.
|
| ︙ | ︙ | |||
791 792 793 794 795 796 797 |
* current name (post-execution) has to be
* used. This matters, because the object
* could have been renamed... */
const char *typeOfSubject) /* Part of the message, saying whether it was
* an object, class or class-as-object that
* was being configured. */
{
| | | | | 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 |
* current name (post-execution) has to be
* used. This matters, because the object
* could have been renamed... */
const char *typeOfSubject) /* Part of the message, saying whether it was
* an object, class or class-as-object that
* was being configured. */
{
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 --
|
| ︙ | ︙ | |||
849 850 851 852 853 854 855 |
* comments above for why these contortions are necessary.
*/
objPtr = Tcl_NewObj();
obj2Ptr = Tcl_NewObj();
cmd = FindCommand(interp, objv[cmdIndex], nsPtr);
if (cmd == NULL) {
| > | > > | | | 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 |
* comments above for why these contortions are necessary.
*/
objPtr = Tcl_NewObj();
obj2Ptr = Tcl_NewObj();
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;
}
|
| ︙ | ︙ | |||
889 890 891 892 893 894 895 |
int
TclOODefineObjCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
| | | > | | | 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 |
int
TclOODefineObjCmd(
ClientData 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.
*/
|
| ︙ | ︙ | |||
964 965 966 967 968 969 970 |
int
TclOOObjDefObjCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
| | > | | | 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 |
int
TclOOObjDefObjCmd(
ClientData 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.
*/
|
| ︙ | ︙ | |||
1032 1033 1034 1035 1036 1037 1038 |
int
TclOODefineSelfObjCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
| | | > > > | > > > | | | 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 |
int
TclOODefineSelfObjCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Namespace *nsPtr;
Object *oPtr;
int result, private;
oPtr = (Object *) TclOOGetDefineCmdContext(interp);
if (oPtr == NULL) {
return TCL_ERROR;
}
if (objc < 2) {
Tcl_SetObjResult(interp, TclOOObjectName(interp, oPtr));
return TCL_OK;
}
private = 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 (private) {
((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.
*/
|
| ︙ | ︙ | |||
1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 |
Tcl_SetObjResult(interp, TclOOObjectName(interp, oPtr));
return TCL_OK;
}
/*
* ----------------------------------------------------------------------
*
* TclOODefineClassObjCmd --
*
* Implementation of the "class" subcommand of the "oo::objdefine"
* command.
*
* ----------------------------------------------------------------------
*/
int
TclOODefineClassObjCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr;
Class *clsPtr;
/*
* Parse the context to get the object to operate on.
*/
oPtr = (Object *) TclOOGetDefineCmdContext(interp);
if (oPtr == NULL) {
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 |
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(
ClientData 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) {
|
| ︙ | ︙ | |||
1168 1169 1170 1171 1172 1173 1174 |
return TCL_ERROR;
}
clsPtr = GetClassInOuterContext(interp, objv[1],
"the class of an object must be a class");
if (clsPtr == NULL) {
return TCL_ERROR;
}
| > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > | 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 |
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++;
}
}
|
| ︙ | ︙ | |||
1211 1212 1213 1214 1215 1216 1217 |
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr;
Class *clsPtr;
Tcl_Method method;
| | | | 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 |
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);
|
| ︙ | ︙ | |||
1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 |
* 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;
}
/*
* ----------------------------------------------------------------------
*
* TclOODefineDeleteMethodObjCmd --
*
* Implementation of the "deletemethod" subcommand of the "oo::define"
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 |
* 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(
ClientData 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"
|
| ︙ | ︙ | |||
1297 1298 1299 1300 1301 1302 1303 |
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;
}
| | | 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 |
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;
|
| ︙ | ︙ | |||
1337 1338 1339 1340 1341 1342 1343 |
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr;
Class *clsPtr;
Tcl_Method method;
| | | | 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 |
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);
|
| ︙ | ︙ | |||
1423 1424 1425 1426 1427 1428 1429 |
if (!isInstanceExport && !clsPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"attempt to misuse API", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
}
| | | | | > | 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 |
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_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 = 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 = 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.
*/
|
| ︙ | ︙ | |||
1515 1516 1517 1518 1519 1520 1521 |
}
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;
}
| | > > > | | 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 |
}
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);
}
|
| ︙ | ︙ | |||
1555 1556 1557 1558 1559 1560 1561 1562 1563 |
int
TclOODefineMethodObjCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
int isInstanceMethod = (clientData != NULL);
Object *oPtr;
| > > > > > > > > > > > > > > > > | | | > > > > > > > > > > > > > > > > > > > > | | > > | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 |
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 --
*
|
| ︙ | ︙ | |||
1758 1759 1760 1761 1762 1763 1764 |
if (!isInstanceUnexport && !clsPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"attempt to misuse API", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
}
| | | | | | | 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 |
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_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 = 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 = 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.
*/
|
| ︙ | ︙ | |||
1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 |
int
TclOODefineSlots(
Foundation *fPtr)
{
const struct DeclaredSlot *slotInfoPtr;
Tcl_Obj *getName = Tcl_NewStringObj("Get", -1);
Tcl_Obj *setName = Tcl_NewStringObj("Set", -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);
for (slotInfoPtr = slots ; slotInfoPtr->name ; slotInfoPtr++) {
Tcl_Object slotObject = Tcl_NewObjectInstance(fPtr->interp,
| > > | > > > > > | 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 |
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 --
|
| ︙ | ︙ | |||
1967 1968 1969 1970 1971 1972 1973 |
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
int filterc;
Tcl_Obj **filterv;
| | | 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 |
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) {
|
| ︙ | ︙ | |||
2051 2052 2053 2054 2055 2056 2057 |
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
int mixinc, i;
Tcl_Obj **mixinv;
Class **mixins;
| | | | 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 |
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 = 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])) {
|
| ︙ | ︙ | |||
2156 2157 2158 2159 2160 2161 2162 |
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
int superc, i, j;
Tcl_Obj **superv;
Class **superclasses, *superPtr;
| | | 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 |
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) {
|
| ︙ | ︙ | |||
2184 2185 2186 2187 2188 2189 2190 |
return TCL_ERROR;
}
/*
* Allocate some working space.
*/
| | | | | | | 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 |
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 = 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) {
i--;
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; i--) {
TclOODecrRefCount(superclasses[i]->thisPtr);
}
Tcl_Free(superclasses);
return TCL_ERROR;
}
/*
* Corresponding TclOODecrRefCount() is near the end of this
* function.
*/
|
| ︙ | ︙ | |||
2252 2253 2254 2255 2256 2257 2258 |
*/
if (oPtr->classPtr->superclasses.num != 0) {
FOREACH(superPtr, oPtr->classPtr->superclasses) {
TclOORemoveFromSubclasses(oPtr->classPtr, superPtr);
TclOODecrRefCount(superPtr->thisPtr);
}
| | | 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 |
*/
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);
|
| ︙ | ︙ | |||
2284 2285 2286 2287 2288 2289 2290 |
ClientData clientData,
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
| | > > > > > > > > > | | > | | | < < < < < < < < < < < < < < < < < < | | < < < | < < < < < | < < < | < < < < < < < < < | 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 |
ClientData 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;
}
resultObj = Tcl_NewObj();
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(
ClientData 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;
}
/*
* ----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
2458 2459 2460 2461 2462 2463 2464 |
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
int filterc;
Tcl_Obj **filterv;
| | | 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 |
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);
|
| ︙ | ︙ | |||
2532 2533 2534 2535 2536 2537 2538 |
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
int mixinc;
Tcl_Obj **mixinv;
Class **mixins;
int i;
| | | | 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 |
{
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 = 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;
}
}
|
| ︙ | ︙ | |||
2581 2582 2583 2584 2585 2586 2587 |
ClientData clientData,
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
| | > > > > > > > > > | | > | | | < < | | < < < | < | < < < < | | < | > | | > > > > > > > > > > > | > > > > > | | > > > > > > > > | < < | < > | | > | | < < | < > > | > > | < | | > > > | 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 |
ClientData 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;
}
resultObj = Tcl_NewObj();
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(
ClientData 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(
ClientData 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:
*/
|
Changes to generic/tclOOInfo.c.
| ︙ | ︙ | |||
18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 |
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 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 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},
{"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},
| > > > | > | | 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 |
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 --
|
| ︙ | ︙ | |||
110 111 112 113 114 115 116 |
TclMakeEnsemble(interp, "::oo::InfoClass", infoClassCmds);
/*
* Install into the master [info] ensemble.
*/
infoCmd = Tcl_FindCommand(interp, "info", NULL, TCL_GLOBAL_ONLY);
| > | | | | | | > | 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 |
TclMakeEnsemble(interp, "::oo::InfoClass", infoClassCmds);
/*
* Install into the master [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 --
*
|
| ︙ | ︙ | |||
513 514 515 516 517 518 519 |
InfoObjectMethodsCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Object *oPtr;
| | | | > > > > > > > | 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 |
InfoObjectMethodsCmd(
ClientData clientData,
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]);
|
| ︙ | ︙ | |||
549 550 551 552 553 554 555 556 | recurse = 1; break; case OPT_LOCALPRIVATE: flag = PRIVATE_METHOD; break; case OPT_PRIVATE: flag = 0; break; | > > > > > > > | > > > | > > > > > > > > > > > > > > > > > > > > | > | | | 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 |
recurse = 1;
break;
case OPT_LOCALPRIVATE:
flag = PRIVATE_METHOD;
break;
case OPT_PRIVATE:
flag = 0;
break;
case OPT_SCOPE:
if (++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;
}
}
resultObj = Tcl_NewObj();
if (recurse) {
const char **names;
int i, numNames = TclOOGetSortedMethodList(oPtr, NULL, NULL, flag,
&names);
for (i=0 ; i<numNames ; i++) {
Tcl_ListObjAppendElement(NULL, resultObj,
Tcl_NewStringObj(names[i], -1));
}
if (numNames > 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;
}
|
| ︙ | ︙ | |||
680 681 682 683 684 685 686 687 688 689 690 691 692 693 |
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
/*
* ----------------------------------------------------------------------
*
* InfoObjectNsCmd --
*
* Implements [info object namespace $objName]
*
* ----------------------------------------------------------------------
*/
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 |
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
/*
* ----------------------------------------------------------------------
*
* InfoObjectIdCmd --
*
* Implements [info object creationid $objName]
*
* ----------------------------------------------------------------------
*/
static int
InfoObjectIdCmd(
ClientData clientData,
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_NewIntObj(oPtr->creationEpoch));
return TCL_OK;
}
/*
* ----------------------------------------------------------------------
*
* InfoObjectNsCmd --
*
* Implements [info object namespace $objName]
*
* ----------------------------------------------------------------------
*/
|
| ︙ | ︙ | |||
715 716 717 718 719 720 721 | } /* * ---------------------------------------------------------------------- * * InfoObjectVariablesCmd -- * | | | | | | > > > > > > > > > > > > > > > | | > | 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 |
}
/*
* ----------------------------------------------------------------------
*
* InfoObjectVariablesCmd --
*
* Implements [info object variables $objName ?-private?]
*
* ----------------------------------------------------------------------
*/
static int
InfoObjectVariablesCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Object *oPtr;
Tcl_Obj *resultObj;
int i, private = 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;
}
private = 1;
}
oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
if (oPtr == NULL) {
return TCL_ERROR;
}
resultObj = Tcl_NewObj();
if (private) {
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;
}
/*
* ----------------------------------------------------------------------
|
| ︙ | ︙ | |||
941 942 943 944 945 946 947 948 949 950 951 952 953 954 |
Tcl_SetObjResult(interp, Tcl_NewListObj(2, resultObjs));
return TCL_OK;
}
/*
* ----------------------------------------------------------------------
*
* InfoClassDestrCmd --
*
* Implements [info class destructor $clsName]
*
* ----------------------------------------------------------------------
*/
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 |
Tcl_SetObjResult(interp, Tcl_NewListObj(2, resultObjs));
return TCL_OK;
}
/*
* ----------------------------------------------------------------------
*
* InfoClassDefnNsCmd --
*
* Implements [info class definitionnamespace $clsName ?$kind?]
*
* ----------------------------------------------------------------------
*/
static int
InfoClassDefnNsCmd(
ClientData clientData,
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]
*
* ----------------------------------------------------------------------
*/
|
| ︙ | ︙ | |||
1124 1125 1126 1127 1128 1129 1130 | } /* * ---------------------------------------------------------------------- * * InfoClassMethodsCmd -- * | | | | | > > > > > > | 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 |
}
/*
* ----------------------------------------------------------------------
*
* InfoClassMethodsCmd --
*
* Implements [info class methods $clsName ?options...?]
*
* ----------------------------------------------------------------------
*/
static int
InfoClassMethodsCmd(
ClientData clientData,
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]);
|
| ︙ | ︙ | |||
1172 1173 1174 1175 1176 1177 1178 1179 | recurse = 1; break; case OPT_LOCALPRIVATE: flag = PRIVATE_METHOD; break; case OPT_PRIVATE: flag = 0; break; | > > > > > > > | > > > | > > > > > > > > > > > > > > > > > | | | 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 |
recurse = 1;
break;
case OPT_LOCALPRIVATE:
flag = PRIVATE_METHOD;
break;
case OPT_PRIVATE:
flag = 0;
break;
case OPT_SCOPE:
if (++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;
}
}
resultObj = Tcl_NewObj();
if (recurse) {
const char **names;
int i, numNames = TclOOGetSortedClassMethodList(clsPtr, flag, &names);
for (i=0 ; i<numNames ; i++) {
Tcl_ListObjAppendElement(NULL, resultObj,
Tcl_NewStringObj(names[i], -1));
}
if (numNames > 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;
}
|
| ︙ | ︙ | |||
1395 1396 1397 1398 1399 1400 1401 | } /* * ---------------------------------------------------------------------- * * InfoClassVariablesCmd -- * | | | | | | > > > > > > > > > > > > > > > | | > | 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 |
}
/*
* ----------------------------------------------------------------------
*
* InfoClassVariablesCmd --
*
* Implements [info class variables $clsName ?-private?]
*
* ----------------------------------------------------------------------
*/
static int
InfoClassVariablesCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Class *clsPtr;
Tcl_Obj *resultObj;
int i, private = 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;
}
private = 1;
}
clsPtr = GetClassFromObj(interp, objv[1]);
if (clsPtr == NULL) {
return TCL_ERROR;
}
resultObj = Tcl_NewObj();
if (private) {
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;
}
/*
* ----------------------------------------------------------------------
|
| ︙ | ︙ | |||
1461 1462 1463 1464 1465 1466 1467 |
return TCL_ERROR;
}
/*
* Get the call context and render its call chain.
*/
| | > | 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 |
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));
|
| ︙ | ︙ |
Changes to generic/tclOOInt.h.
| ︙ | ︙ | |||
42 43 44 45 46 47 48 |
*/
typedef struct Method {
const Tcl_MethodType *typePtr;
/* The type of method. If NULL, this is a
* special flag record which is just used for
* the setting of the flags field. */
| | | | | | | | | | 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 |
*/
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;
|
| ︙ | ︙ | |||
120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 |
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;
/*
* 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; }
/*
* 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
| > > > > > > > > > > > > > > > > > > > | 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 |
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
|
| ︙ | ︙ | |||
161 162 163 164 165 166 167 |
LIST_STATIC(struct Class *) mixins;
/* Classes mixed into this object. */
LIST_STATIC(Tcl_Obj *) filters;
/* List of filter names. */
struct Class *classPtr; /* This is non-NULL for all classes, and NULL
* for everything else. It points to the class
* structure. */
| | | | | | > > > > > | 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 |
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_DELETED 1 /* Flag to say that an object has been
* destroyed. */
#define DESTRUCTOR_CALLED 2 /* Flag to say that the destructor has been
* called. */
#define CLASS_GONE 4 /* Obsolete. Indicates that the class of this
|
| ︙ | ︙ | |||
210 211 212 213 214 215 216 217 218 219 220 221 222 223 |
* 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. */
/*
* And the definition of a class. Note that every class also has an associated
* object, through which it is manipulated.
*/
typedef struct Class {
| > > > > > > > > | 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 |
* 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 {
|
| ︙ | ︙ | |||
250 251 252 253 254 255 256 |
* 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
| | | > > > > > > > > > > > > > > > > > > > > > | 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 |
* 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.
|
| ︙ | ︙ | |||
299 300 301 302 303 304 305 |
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. */
| | | 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 |
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
|
| ︙ | ︙ | |||
338 339 340 341 342 343 344 |
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. */
| | | | 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 |
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;
|
| ︙ | ︙ | |||
366 367 368 369 370 371 372 | /* * 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 | | > > > > > | | | | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > | | | | > > > | | > > > | | | | | | | | | | | | > > > > > > > | > | > > > | 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 |
/*
* 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 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,
|
| ︙ | ︙ | |||
554 555 556 557 558 559 560 |
* 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; \
| | > > > > > > > > > > > | | | 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 |
* 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 ? \
((key)=(void *)Tcl_GetHashKey((tablePtr),hPtr),\
(val)=Tcl_GetHashValue(hPtr),1):0; hPtr=Tcl_NextHashEntry(&search))
#define FOREACH_HASH_VALUE(val,tablePtr) \
for(hPtr=Tcl_FirstHashEntry((tablePtr),&search); hPtr!=NULL ? \
((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 { \
register 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 */
|
| ︙ | ︙ |
Changes to generic/tclOOIntDecls.h.
| ︙ | ︙ | |||
18 19 20 21 22 23 24 | /* 0 */ TCLAPI Tcl_Object TclOOGetDefineCmdContext(Tcl_Interp *interp); /* 1 */ TCLAPI Tcl_Method TclOOMakeProcInstanceMethod(Tcl_Interp *interp, Object *oPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, const Tcl_MethodType *typePtr, | | | | 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 | /* 0 */ TCLAPI Tcl_Object TclOOGetDefineCmdContext(Tcl_Interp *interp); /* 1 */ TCLAPI Tcl_Method TclOOMakeProcInstanceMethod(Tcl_Interp *interp, Object *oPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, const Tcl_MethodType *typePtr, 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, |
| ︙ | ︙ | |||
55 56 57 58 59 60 61 | Object *oPtr, int isPublic, Tcl_Obj *nameObj, Tcl_Obj *prefixObj); /* 9 */ TCLAPI Tcl_Method TclOONewProcInstanceMethodEx(Tcl_Interp *interp, Tcl_Object oPtr, TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, | | | | | | | | | | 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 | Object *oPtr, int isPublic, Tcl_Obj *nameObj, Tcl_Obj *prefixObj); /* 9 */ TCLAPI Tcl_Method TclOONewProcInstanceMethodEx(Tcl_Interp *interp, Tcl_Object oPtr, TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, ProcErrorProc *errProc, 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, |
| ︙ | ︙ | |||
93 94 95 96 97 98 99 |
Class *const *mixins);
typedef struct TclOOIntStubs {
int magic;
void *hooks;
Tcl_Object (*tclOOGetDefineCmdContext) (Tcl_Interp *interp); /* 0 */
| | | | | | 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 |
Class *const *mixins);
typedef struct TclOOIntStubs {
int magic;
void *hooks;
Tcl_Object (*tclOOGetDefineCmdContext) (Tcl_Interp *interp); /* 0 */
Tcl_Method (*tclOOMakeProcInstanceMethod) (Tcl_Interp *interp, Object *oPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, const Tcl_MethodType *typePtr, 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;
|
| ︙ | ︙ |
Changes to generic/tclOOMethod.c.
| ︙ | ︙ | |||
63 64 65 66 67 68 69 | * 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); | | | | | | | | | 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 | * 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 void MethodErrorHandler(Tcl_Interp *interp, Tcl_Obj *procNameObj); static void ConstructorErrorHandler(Tcl_Interp *interp, Tcl_Obj *procNameObj); static void DestructorErrorHandler(Tcl_Interp *interp, Tcl_Obj *procNameObj); 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 int ProcedureMethodVarResolver(Tcl_Interp *interp, const char *varName, Tcl_Namespace *contextNs, int flags, Tcl_Var *varPtr); static int ProcedureMethodCompiledVarResolver(Tcl_Interp *interp, const char *varName, int length, Tcl_Namespace *contextNs, Tcl_ResolvedVarInfo **rPtrPtr); |
| ︙ | ︙ | |||
117 118 119 120 121 122 123 |
/*
* Helper macros (derived from things private to tclVar.c)
*/
#define TclVarTable(contextNs) \
((Tcl_HashTable *) (&((Namespace *) (contextNs))->varTable))
#define TclVarHashGetValue(hPtr) \
| | | 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 |
/*
* 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.
|
| ︙ | ︙ | |||
142 143 144 145 146 147 148 |
* 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. */
| | | | | | > > > > | 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 |
* 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. */
{
register Object *oPtr = (Object *) object;
register Method *mPtr;
Tcl_HashEntry *hPtr;
int isNew;
if (nameObj == NULL) {
mPtr = Tcl_Alloc(sizeof(Method));
mPtr->namePtr = NULL;
mPtr->refCount = 1;
goto populate;
}
if (!oPtr->methodsPtr) {
oPtr->methodsPtr = 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 = Tcl_Alloc(sizeof(Method));
mPtr->namePtr = nameObj;
mPtr->refCount = 1;
Tcl_IncrRefCount(nameObj);
Tcl_SetHashValue(hPtr, mPtr);
} else {
mPtr = 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;
}
/*
* ----------------------------------------------------------------------
|
| ︙ | ︙ | |||
210 211 212 213 214 215 216 |
* 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. */
| | | | | > > > > | 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 |
* 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. */
{
register Class *clsPtr = (Class *) cls;
register Method *mPtr;
Tcl_HashEntry *hPtr;
int isNew;
if (nameObj == NULL) {
mPtr = Tcl_Alloc(sizeof(Method));
mPtr->namePtr = NULL;
mPtr->refCount = 1;
goto populate;
}
hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, (char *)nameObj,&isNew);
if (isNew) {
mPtr = Tcl_Alloc(sizeof(Method));
mPtr->refCount = 1;
mPtr->namePtr = nameObj;
Tcl_IncrRefCount(nameObj);
Tcl_SetHashValue(hPtr, mPtr);
} else {
mPtr = 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;
}
/*
* ----------------------------------------------------------------------
|
| ︙ | ︙ | |||
274 275 276 277 278 279 280 |
if (mPtr->typePtr != NULL && mPtr->typePtr->deleteProc != NULL) {
mPtr->typePtr->deleteProc(mPtr->clientData);
}
if (mPtr->namePtr != NULL) {
Tcl_DecrRefCount(mPtr->namePtr);
}
| | | 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 |
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 --
|
| ︙ | ︙ | |||
338 339 340 341 342 343 344 |
int argsLen;
register ProcedureMethod *pmPtr;
Tcl_Method method;
if (Tcl_ListObjLength(interp, argsObj, &argsLen) != TCL_OK) {
return NULL;
}
| | | | 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 |
int argsLen;
register ProcedureMethod *pmPtr;
Tcl_Method method;
if (Tcl_ListObjLength(interp, argsObj, &argsLen) != TCL_OK) {
return NULL;
}
pmPtr = 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;
}
/*
|
| ︙ | ︙ | |||
399 400 401 402 403 404 405 |
procName = "<destructor>";
} else if (Tcl_ListObjLength(interp, argsObj, &argsLen) != TCL_OK) {
return NULL;
} else {
procName = (nameObj==NULL ? "<constructor>" : TclGetString(nameObj));
}
| | | | 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 |
procName = "<destructor>";
} else if (Tcl_ListObjLength(interp, argsObj, &argsLen) != TCL_OK) {
return NULL;
} else {
procName = (nameObj==NULL ? "<constructor>" : TclGetString(nameObj));
}
pmPtr = 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;
}
|
| ︙ | ︙ | |||
446 447 448 449 450 451 452 |
* 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. */
| | | 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 |
* 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;
|
| ︙ | ︙ | |||
493 494 495 496 497 498 499 |
* 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;
| | | | 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 |
* 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 = Tcl_Alloc(sizeof(CmdFrame));
Tcl_HashEntry *hPtr;
cfPtr->level = -1;
cfPtr->type = context.type;
cfPtr->line = 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);
|
| ︙ | ︙ | |||
559 560 561 562 563 564 565 |
* _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. */
| | | 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 |
* _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;
|
| ︙ | ︙ | |||
606 607 608 609 610 611 612 |
* 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;
| | | | 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 |
* 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 = Tcl_Alloc(sizeof(CmdFrame));
Tcl_HashEntry *hPtr;
cfPtr->level = -1;
cfPtr->type = context.type;
cfPtr->line = 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);
|
| ︙ | ︙ | |||
654 655 656 657 658 659 660 | * How to invoke a procedure-like method. * * ---------------------------------------------------------------------- */ static int InvokeProcedureMethod( | | | 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 |
* 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 = clientData;
int result;
|
| ︙ | ︙ | |||
733 734 735 736 737 738 739 |
TclNRAddCallback(interp, FinalizePMCall, pmPtr, context, fdPtr, NULL);
return TclNRInterpProcCore(interp, fdPtr->nameObj,
Tcl_ObjectContextSkippedArgs(context), fdPtr->errProc);
}
static int
FinalizePMCall(
| | | 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 |
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 = data[0];
Tcl_ObjectContext context = data[1];
PMFrameData *fdPtr = data[2];
|
| ︙ | ︙ | |||
787 788 789 790 791 792 793 794 795 796 797 798 799 800 |
PMFrameData *fdPtr) /* Place to store information about the call
* frame. */
{
Namespace *nsPtr = (Namespace *) contextPtr->oPtr->namespacePtr;
register int result;
const char *namePtr;
CallFrame **framePtrPtr = &fdPtr->framePtr;
/*
* Compute basic information on the basis of the type of method it is.
*/
if (contextPtr->callPtr->flags & CONSTRUCTOR) {
namePtr = "<constructor>";
| > | 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 |
PMFrameData *fdPtr) /* Place to store information about the call
* frame. */
{
Namespace *nsPtr = (Namespace *) contextPtr->oPtr->namespacePtr;
register 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 = "<constructor>";
|
| ︙ | ︙ | |||
852 853 854 855 856 857 858 |
/*
* [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...
*/
| | | < < | 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 |
/*
* [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;
}
|
| ︙ | ︙ | |||
924 925 926 927 928 929 930 | * * 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 | | | 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 |
*
* 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)
|
| ︙ | ︙ | |||
966 967 968 969 970 971 972 |
*varPtr = rPtr->fetchProc(interp, rPtr);
/*
* Must not retain reference to resolved information. [Bug 3105999]
*/
| < | < | > | > | 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 |
*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.
*/
|
| ︙ | ︙ | |||
1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 |
* 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(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(variableObj, contextPtr->oPtr->variables) {
match = TclGetStringFromObj(variableObj, &len);
if ((len == varLen) && !memcmp(match, varName, len)) {
cacheIt = 1;
goto gotMatch;
}
}
| > > > > > > > > > > > > > > > > > | 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 |
* 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;
}
}
|
| ︙ | ︙ | |||
1073 1074 1075 1076 1077 1078 1079 |
*/
if (infoPtr->cachedObjectVar) {
VarHashRefCount(infoPtr->cachedObjectVar)--;
TclCleanupVar((Var *) infoPtr->cachedObjectVar, NULL);
}
Tcl_DecrRefCount(infoPtr->variableObj);
| | | | | | 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 |
*/
if (infoPtr->cachedObjectVar) {
VarHashRefCount(infoPtr->cachedObjectVar)--;
TclCleanupVar((Var *) infoPtr->cachedObjectVar, NULL);
}
Tcl_DecrRefCount(infoPtr->variableObj);
Tcl_Free(infoPtr);
}
static int
ProcedureMethodCompiledVarResolver(
Tcl_Interp *interp,
const char *varName,
int length,
Tcl_Namespace *contextNs,
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 = 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;
|
| ︙ | ︙ | |||
1123 1124 1125 1126 1127 1128 1129 | * itself) isn't done until it is needed. * * ---------------------------------------------------------------------- */ static Tcl_Obj * RenderDeclarerName( | | | 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 |
* itself) isn't done until it is needed.
*
* ----------------------------------------------------------------------
*/
static Tcl_Obj *
RenderDeclarerName(
void *clientData)
{
struct PNI *pni = clientData;
Tcl_Object object = Tcl_MethodDeclarerObject(pni->method);
if (object == NULL) {
object = Tcl_GetClassAsObject(Tcl_MethodDeclarerClass(pni->method));
}
|
| ︙ | ︙ | |||
1151 1152 1153 1154 1155 1156 1157 | * suitable formatting contexts. * * ---------------------------------------------------------------------- */ #define LIMIT 60 #define ELLIPSIFY(str,len) \ | | | | | | | | | 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 |
* suitable formatting contexts.
*
* ----------------------------------------------------------------------
*/
#define LIMIT 60
#define ELLIPSIFY(str,len) \
((len) > LIMIT ? LIMIT : (int)(len)), (str), ((len) > LIMIT ? "..." : "")
static void
MethodErrorHandler(
Tcl_Interp *interp,
Tcl_Obj *methodNameObj)
{
size_t nameLen, objectNameLen;
CallContext *contextPtr = ((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_Obj *methodNameObj)
{
CallContext *contextPtr = ((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_Obj *methodNameObj)
{
CallContext *contextPtr = ((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)));
}
/*
|
| ︙ | ︙ | |||
1260 1261 1262 1263 1264 1265 1266 |
DeleteProcedureMethodRecord(
ProcedureMethod *pmPtr)
{
TclProcDeleteProc(pmPtr->procPtr);
if (pmPtr->deleteClientdataProc) {
pmPtr->deleteClientdataProc(pmPtr->clientData);
}
| | | | | | 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 |
DeleteProcedureMethodRecord(
ProcedureMethod *pmPtr)
{
TclProcDeleteProc(pmPtr->procPtr);
if (pmPtr->deleteClientdataProc) {
pmPtr->deleteClientdataProc(pmPtr->clientData);
}
Tcl_Free(pmPtr);
}
static void
DeleteProcedureMethod(
void *clientData)
{
register ProcedureMethod *pmPtr = clientData;
if (pmPtr->refCount-- <= 1) {
DeleteProcedureMethodRecord(pmPtr);
}
}
static int
CloneProcedureMethod(
Tcl_Interp *interp,
void *clientData,
void **newClientData)
{
ProcedureMethod *pmPtr = clientData;
ProcedureMethod *pm2Ptr;
Tcl_Obj *bodyObj, *argsObj;
CompiledLocal *localPtr;
/*
|
| ︙ | ︙ | |||
1310 1311 1312 1313 1314 1315 1316 |
/*
* 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);
| | | | | | 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 |
/*
* 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 = 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);
|
| ︙ | ︙ | |||
1372 1373 1374 1375 1376 1377 1378 |
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;
}
| | | 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 |
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 = Tcl_Alloc(sizeof(ForwardMethod));
fmPtr->prefixObj = prefixObj;
Tcl_IncrRefCount(prefixObj);
return (Method *) Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr,
nameObj, flags, &fwdMethodType, fmPtr);
}
/*
|
| ︙ | ︙ | |||
1411 1412 1413 1414 1415 1416 1417 |
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;
}
| | | | 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 |
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 = 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 = clientData;
|
| ︙ | ︙ | |||
1465 1466 1467 1468 1469 1470 1471 |
((Interp *)interp)->lookupNsPtr
= (Namespace *) contextPtr->oPtr->namespacePtr;
return TclNREvalObjv(interp, len, argObjs, TCL_EVAL_NOERR, NULL);
}
static int
FinalizeForwardCall(
| | | 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 |
((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 = data[0];
TclStackFree(interp, argObjs);
return result;
|
| ︙ | ︙ | |||
1487 1488 1489 1490 1491 1492 1493 | * How to delete and clone forwarded methods. * * ---------------------------------------------------------------------- */ static void DeleteForwardMethod( | | | | | | | 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 |
* How to delete and clone forwarded methods.
*
* ----------------------------------------------------------------------
*/
static void
DeleteForwardMethod(
void *clientData)
{
ForwardMethod *fmPtr = clientData;
Tcl_DecrRefCount(fmPtr->prefixObj);
Tcl_Free(fmPtr);
}
static int
CloneForwardMethod(
Tcl_Interp *interp,
void *clientData,
void **newClientData)
{
ForwardMethod *fmPtr = clientData;
ForwardMethod *fm2Ptr = Tcl_Alloc(sizeof(ForwardMethod));
fm2Ptr->prefixObj = fmPtr->prefixObj;
Tcl_IncrRefCount(fm2Ptr->prefixObj);
*newClientData = fm2Ptr;
return TCL_OK;
}
|
| ︙ | ︙ | |||
1540 1541 1542 1543 1544 1545 1546 |
Tcl_Obj *
TclOOGetMethodBody(
Method *mPtr)
{
if (mPtr->typePtr == &procMethodType) {
ProcedureMethod *pmPtr = mPtr->clientData;
| < | < | 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 |
Tcl_Obj *
TclOOGetMethodBody(
Method *mPtr)
{
if (mPtr->typePtr == &procMethodType) {
ProcedureMethod *pmPtr = mPtr->clientData;
(void) TclGetString(pmPtr->procPtr->bodyPtr);
return pmPtr->procPtr->bodyPtr;
}
return NULL;
}
Tcl_Obj *
TclOOGetFwdFromMethod(
|
| ︙ | ︙ | |||
1650 1651 1652 1653 1654 1655 1656 |
return ((Method *) method)->namePtr;
}
int
Tcl_MethodIsType(
Tcl_Method method,
const Tcl_MethodType *typePtr,
| | > > > > > > > | | 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 |
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. */
|
| ︙ | ︙ | |||
1718 1719 1720 1721 1722 1723 1724 |
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,
| | | 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 |
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. */
|
| ︙ | ︙ |
Added generic/tclOOScript.h.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 |
/*
* 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 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 <cloned> {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 <cloned> {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 <cloned> {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:
*/
|
Added generic/tclOOScript.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 |
# tclOOScript.h --
#
# This file contains support scripts for TclOO. They are defined here so
# that the code can be definitely run even in safe interpreters; TclOO's
# core setup is safe.
#
# Copyright (c) 2012-2018 Donal K. Fellows
# Copyright (c) 2013 Andreas Kupries
# Copyright (c) 2017 Gerald Lester
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
::namespace eval ::oo {
::namespace path {}
#
# Commands that are made available to objects by default.
#
namespace eval Helpers {
::namespace path {}
# ------------------------------------------------------------------
#
# callback, mymethod --
#
# Create a script prefix that calls a method on the current
# object. Same operation, two names.
#
# ------------------------------------------------------------------
proc callback {method args} {
list [uplevel 1 {::namespace which my}] $method {*}$args
}
# Make the [callback] command appear as [mymethod] too.
namespace export callback
namespace eval tmp {namespace import ::oo::Helpers::callback}
namespace export -clear
rename tmp::callback mymethod
namespace delete tmp
# ------------------------------------------------------------------
#
# classvariable --
#
# Link to a variable in the class of the current object.
#
# ------------------------------------------------------------------
proc classvariable {name args} {
# Get a reference to the class's namespace
set ns [info object namespace [uplevel 1 {self class}]]
# Double up the list of variable names
foreach v [list $name {*}$args] {
if {[string match *(*) $v]} {
set reason "can't create a scalar variable that looks like an array element"
return -code error -errorcode {TCL UPVAR LOCAL_ELEMENT} \
[format {bad variable name "%s": %s} $v $reason]
}
if {[string match *::* $v]} {
set reason "can't create a local variable with a namespace separator in it"
return -code error -errorcode {TCL UPVAR INVERTED} \
[format {bad variable name "%s": %s} $v $reason]
}
lappend vs $v $v
}
# Lastly, link the caller's local variables to the class's variables
tailcall namespace upvar $ns {*}$vs
}
# ------------------------------------------------------------------
#
# link --
#
# Make a command that invokes a method on the current object.
# The name of the command and the name of the method match by
# default.
#
# ------------------------------------------------------------------
proc link {args} {
set ns [uplevel 1 {::namespace current}]
foreach link $args {
if {[llength $link] == 2} {
lassign $link src dst
} elseif {[llength $link] == 1} {
lassign $link src
set dst $src
} else {
return -code error -errorcode {TCLOO CMDLINK FORMAT} \
"bad link description; must only have one or two elements"
}
if {![string match ::* $src]} {
set src [string cat $ns :: $src]
}
interp alias {} $src {} ${ns}::my $dst
trace add command ${ns}::my delete [list \
::oo::UnlinkLinkedCommand $src]
}
return
}
}
# ----------------------------------------------------------------------
#
# UnlinkLinkedCommand --
#
# Callback used to remove linked command when the underlying mechanism
# that supports it is deleted.
#
# ----------------------------------------------------------------------
proc UnlinkLinkedCommand {cmd args} {
if {[namespace which $cmd] ne {}} {
rename $cmd {}
}
}
# ----------------------------------------------------------------------
#
# DelegateName --
#
# Utility that gets the name of the class delegate for a class. It's
# trivial, but makes working with them much easier as delegate names are
# intentionally hard to create by accident.
#
# ----------------------------------------------------------------------
proc DelegateName {class} {
string cat [info object namespace $class] {:: oo ::delegate}
}
# ----------------------------------------------------------------------
#
# MixinClassDelegates --
#
# Support code called *after* [oo::define] inside the constructor of a
# class that patches in the appropriate class delegates.
#
# ----------------------------------------------------------------------
proc MixinClassDelegates {class} {
if {![info object isa class $class]} {
return
}
set delegate [DelegateName $class]
if {![info object isa class $delegate]} {
return
}
foreach c [info class superclass $class] {
set d [DelegateName $c]
if {![info object isa class $d]} {
continue
}
define $delegate ::oo::define::superclass -append $d
}
objdefine $class ::oo::objdefine::mixin -append $delegate
}
# ----------------------------------------------------------------------
#
# UpdateClassDelegatesAfterClone --
#
# Support code that is like [MixinClassDelegates] except for when a
# class is cloned.
#
# ----------------------------------------------------------------------
proc UpdateClassDelegatesAfterClone {originObject targetObject} {
# Rebuild the class inheritance delegation class
set originDelegate [DelegateName $originObject]
set targetDelegate [DelegateName $targetObject]
if {
[info object isa class $originDelegate]
&& ![info object isa class $targetDelegate]
} then {
copy $originDelegate $targetDelegate
objdefine $targetObject ::oo::objdefine::mixin -set \
{*}[lmap c [info object mixin $targetObject] {
if {$c eq $originDelegate} {set targetDelegate} {set c}
}]
}
}
# ----------------------------------------------------------------------
#
# oo::define::classmethod --
#
# Defines a class method. See define(n) for details.
#
# Note that the ::oo::define namespace is semi-public and a bit weird
# anyway, so we don't regard the namespace path as being under control:
# fully qualified names are used for everything.
#
# ----------------------------------------------------------------------
proc define::classmethod {name {args {}} {body {}}} {
# Create the method on the class if the caller gave arguments and body
::set argc [::llength [::info level 0]]
::if {$argc == 3} {
::return -code error -errorcode {TCL WRONGARGS} [::format \
{wrong # args: should be "%s name ?args body?"} \
[::lindex [::info level 0] 0]]
}
::set cls [::uplevel 1 self]
::if {$argc == 4} {
::oo::define [::oo::DelegateName $cls] method $name $args $body
}
# Make the connection by forwarding
::tailcall forward $name myclass $name
}
# ----------------------------------------------------------------------
#
# oo::define::initialise, oo::define::initialize --
#
# Do specific initialisation for a class. See define(n) for details.
#
# Note that the ::oo::define namespace is semi-public and a bit weird
# anyway, so we don't regard the namespace path as being under control:
# fully qualified names are used for everything.
#
# ----------------------------------------------------------------------
proc define::initialise {body} {
::set clsns [::info object namespace [::uplevel 1 self]]
::tailcall apply [::list {} $body $clsns]
}
# Make the [initialise] definition appear as [initialize] too
namespace eval define {
::namespace export initialise
::namespace eval tmp {::namespace import ::oo::define::initialise}
::namespace export -clear
::rename tmp::initialise initialize
::namespace delete tmp
}
# ----------------------------------------------------------------------
#
# Slot --
#
# The class of slot operations, which are basically lists at the low
# level of TclOO; this provides a more consistent interface to them.
#
# ----------------------------------------------------------------------
define Slot {
# ------------------------------------------------------------------
#
# Slot Get --
#
# Basic slot getter. Retrieves the contents of the slot.
# Particular slots must provide concrete non-erroring
# implementation.
#
# ------------------------------------------------------------------
method Get {} {
return -code error -errorcode {TCLOO ABSTRACT_SLOT} "unimplemented"
}
# ------------------------------------------------------------------
#
# Slot Set --
#
# Basic slot setter. Sets the contents of the slot. Particular
# slots must provide concrete non-erroring implementation.
#
# ------------------------------------------------------------------
method Set list {
return -code error -errorcode {TCLOO ABSTRACT_SLOT} "unimplemented"
}
# ------------------------------------------------------------------
#
# Slot Resolve --
#
# Helper that lets a slot convert a list of arguments of a
# particular type to their canonical forms. Defaults to doing
# nothing (suitable for simple strings).
#
# ------------------------------------------------------------------
method Resolve list {
return $list
}
# ------------------------------------------------------------------
#
# Slot -set, -append, -clear, --default-operation --
#
# Standard public slot operations. If a slot can't figure out
# what method to call directly, it uses --default-operation.
#
# ------------------------------------------------------------------
method -set args {
set my [namespace which my]
set args [lmap a $args {uplevel 1 [list $my Resolve $a]}]
tailcall my Set $args
}
method -append args {
set my [namespace which my]
set args [lmap a $args {uplevel 1 [list $my Resolve $a]}]
set current [uplevel 1 [list $my Get]]
tailcall my Set [list {*}$current {*}$args]
}
method -clear {} {tailcall my Set {}}
method -prepend args {
set my [namespace which my]
set args [lmap a $args {uplevel 1 [list $my Resolve $a]}]
set current [uplevel 1 [list $my Get]]
tailcall my Set [list {*}$args {*}$current]
}
method -remove args {
set my [namespace which my]
set args [lmap a $args {uplevel 1 [list $my Resolve $a]}]
set current [uplevel 1 [list $my Get]]
tailcall my Set [lmap val $current {
if {$val in $args} continue else {set val}
}]
}
# Default handling
forward --default-operation my -append
method unknown {args} {
set def --default-operation
if {[llength $args] == 0} {
tailcall my $def
} elseif {![string match -* [lindex $args 0]]} {
tailcall my $def {*}$args
}
next {*}$args
}
# Set up what is exported and what isn't
export -set -append -clear -prepend -remove
unexport unknown destroy
}
# Set the default operation differently for these slots
objdefine define::superclass forward --default-operation my -set
objdefine define::mixin forward --default-operation my -set
objdefine objdefine::mixin forward --default-operation my -set
# ----------------------------------------------------------------------
#
# oo::object <cloned> --
#
# Handler for cloning objects that clones basic bits (only!) of the
# object's namespace. Non-procedures, traces, sub-namespaces, etc. need
# more complex (and class-specific) handling.
#
# ----------------------------------------------------------------------
define object method <cloned> {originObject} {
# Copy over the procedures from the original namespace
foreach p [info procs [info object namespace $originObject]::*] {
set args [info args $p]
set idx -1
foreach a $args {
if {[info default $p $a d]} {
lset args [incr idx] [list $a $d]
} else {
lset args [incr idx] [list $a]
}
}
set b [info body $p]
set p [namespace tail $p]
proc $p $args $b
}
# Copy over the variables from the original namespace
foreach v [info vars [info object namespace $originObject]::*] {
upvar 0 $v vOrigin
namespace upvar [namespace current] [namespace tail $v] vNew
if {[info exists vOrigin]} {
if {[array exists vOrigin]} {
array set vNew [array get vOrigin]
} else {
set vNew $vOrigin
}
}
}
# General commands, sub-namespaces and advancd variable config (traces,
# etc) are *not* copied over. Classes that want that should do it
# themselves.
}
# ----------------------------------------------------------------------
#
# oo::class <cloned> --
#
# Handler for cloning classes, which fixes up the delegates.
#
# ----------------------------------------------------------------------
define class method <cloned> {originObject} {
next $originObject
# Rebuild the class inheritance delegation class
::oo::UpdateClassDelegatesAfterClone $originObject [self]
}
# ----------------------------------------------------------------------
#
# oo::singleton --
#
# A metaclass that is used to make classes that only permit one instance
# of them to exist. See singleton(n).
#
# ----------------------------------------------------------------------
class create singleton {
superclass class
variable object
unexport create createWithNamespace
method new args {
if {![info exists object] || ![info object isa object $object]} {
set object [next {*}$args]
::oo::objdefine $object {
method destroy {} {
::return -code error -errorcode {TCLOO SINGLETON} \
"may not destroy a singleton object"
}
method <cloned> {originObject} {
::return -code error -errorcode {TCLOO SINGLETON} \
"may not clone a singleton object"
}
}
}
return $object
}
}
# ----------------------------------------------------------------------
#
# oo::abstract --
#
# A metaclass that is used to make classes that can't be directly
# instantiated. See abstract(n).
#
# ----------------------------------------------------------------------
class create abstract {
superclass class
unexport create createWithNamespace new
}
}
# Local Variables:
# mode: tcl
# c-basic-offset: 4
# fill-column: 78
# End:
|
Changes to generic/tclOOStubInit.c.
| ︙ | ︙ | |||
70 71 72 73 74 75 76 77 78 79 |
Tcl_ObjectSetMetadata, /* 22 */
Tcl_ObjectContextInvokeNext, /* 23 */
Tcl_ObjectGetMethodNameMapper, /* 24 */
Tcl_ObjectSetMethodNameMapper, /* 25 */
Tcl_ClassSetConstructor, /* 26 */
Tcl_ClassSetDestructor, /* 27 */
Tcl_GetObjectName, /* 28 */
};
/* !END!: Do not edit above this line. */
| > | 70 71 72 73 74 75 76 77 78 79 80 |
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. */
|
Changes to generic/tclObj.c.
| ︙ | ︙ | |||
13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 | * 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.h" #include <math.h> /* * Table of all object types. */ static Tcl_HashTable typeTable; static int typeTableInitialized = 0; /* 0 means not yet initialized. */ TCL_DECLARE_MUTEX(tableMutex) /* * Head of the list of free Tcl_Obj structs we maintain. */ Tcl_Obj *tclFreeObjList = NULL; /* * The object allocator is single threaded. This mutex is referenced by the * TclNewObj macro, however, so must be visible. */ | > | | | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 |
* 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.h"
#include <math.h>
#include <assert.h>
/*
* Table of all object types.
*/
static Tcl_HashTable typeTable;
static int typeTableInitialized = 0; /* 0 means not yet initialized. */
TCL_DECLARE_MUTEX(tableMutex)
/*
* Head of the list of free Tcl_Obj structs we maintain.
*/
Tcl_Obj *tclFreeObjList = NULL;
/*
* The object allocator is single threaded. This mutex is referenced by the
* TclNewObj macro, however, so must be visible.
*/
#if TCL_THREADS
MODULE_SCOPE Tcl_Mutex tclObjMutex;
Tcl_Mutex tclObjMutex;
#endif
/*
* 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.
*/
char tclEmptyString = '\0';
#if TCL_THREADS && defined(TCL_MEM_DEBUG)
/*
* Structure for tracking the source file and line number where a given
* Tcl_Obj was allocated. We also track the pointer to the Tcl_Obj itself,
* for sanity checking purposes.
*/
typedef struct {
|
| ︙ | ︙ | |||
83 84 85 86 87 88 89 |
* 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. */
| | | 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 |
* any. I.e. this table keeps track of
* invisible and stripped continuation lines.
* Its keys are Tcl_Obj pointers, the values
* are ContLineLoc pointers. See the file
* tclCompile.h for the definition of this
* structure, and for references to all
* related places in the core. */
#if TCL_THREADS && defined(TCL_MEM_DEBUG)
Tcl_HashTable *objThreadMap;/* Thread local table that is used to check
* that a Tcl_Obj was not allocated by some
* other thread. */
#endif /* TCL_MEM_DEBUG && TCL_THREADS */
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
|
| ︙ | ︙ | |||
152 153 154 155 156 157 158 |
#define PopObjToDelete(contextPtr,objPtrVar) \
(objPtrVar) = (contextPtr)->deletionStack; \
(contextPtr)->deletionStack = (Tcl_Obj *) (objPtrVar)->bytes
/*
* Macro to set up the local reference to the deletion context.
*/
| | | | < < < < < < < < < < < | 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 |
#define PopObjToDelete(contextPtr,objPtrVar) \
(objPtrVar) = (contextPtr)->deletionStack; \
(contextPtr)->deletionStack = (Tcl_Obj *) (objPtrVar)->bytes
/*
* Macro to set up the local reference to the deletion context.
*/
#if !TCL_THREADS
static PendingObjData pendingObjData;
#define ObjInitDeletionContext(contextPtr) \
PendingObjData *const contextPtr = &pendingObjData
#elif HAVE_FAST_TSD
static __thread PendingObjData pendingObjData;
#define ObjInitDeletionContext(contextPtr) \
PendingObjData *const contextPtr = &pendingObjData
#else
static Tcl_ThreadDataKey pendingObjDataKey;
#define ObjInitDeletionContext(contextPtr) \
PendingObjData *const contextPtr = \
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 = (void *) 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)); \
} \
(objPtr)->internalRep.twoPtrValue.ptr1 = (bignum).dp; \
(objPtr)->internalRep.twoPtrValue.ptr2 = INT2PTR( ((bignum).sign << 30) \
| ((bignum).alloc << 15) | ((bignum).used)); \
}
/*
* Prototypes for functions defined later in this file:
*/
static int ParseBoolean(Tcl_Obj *objPtr);
static int SetDoubleFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
static int SetIntFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
|
| ︙ | ︙ | |||
414 415 416 417 418 419 420 |
*
*----------------------------------------------------------------------
*/
void
TclFinalizeThreadObjects(void)
{
| | | | | 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 |
*
*----------------------------------------------------------------------
*/
void
TclFinalizeThreadObjects(void)
{
#if TCL_THREADS && defined(TCL_MEM_DEBUG)
Tcl_HashEntry *hPtr;
Tcl_HashSearch hSearch;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
Tcl_HashTable *tablePtr = tsdPtr->objThreadMap;
if (tablePtr != NULL) {
for (hPtr = Tcl_FirstHashEntry(tablePtr, &hSearch);
hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) {
ObjData *objData = Tcl_GetHashValue(hPtr);
if (objData != NULL) {
Tcl_Free(objData);
}
}
Tcl_DeleteHashTable(tablePtr);
Tcl_Free(tablePtr);
tsdPtr->objThreadMap = NULL;
}
#endif
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
507 508 509 510 511 512 513 |
* 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) {
| | | 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 |
* 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_Alloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(tsdPtr->lineCLPtr, TCL_ONE_WORD_KEYS);
Tcl_CreateThreadExitHandler(TclThreadFinalizeContLines,NULL);
}
return tsdPtr;
}
/*
|
| ︙ | ︙ | |||
542 543 544 545 546 547 548 |
int num,
int *loc)
{
int newEntry;
ThreadSpecificData *tsdPtr = TclGetContLineTable();
Tcl_HashEntry *hPtr =
Tcl_CreateHashEntry(tsdPtr->lineCLPtr, objPtr, &newEntry);
| | | 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 |
int num,
int *loc)
{
int newEntry;
ThreadSpecificData *tsdPtr = TclGetContLineTable();
Tcl_HashEntry *hPtr =
Tcl_CreateHashEntry(tsdPtr->lineCLPtr, objPtr, &newEntry);
ContLineLoc *clLocPtr = Tcl_Alloc(sizeof(ContLineLoc) + num*sizeof(int));
if (!newEntry) {
/*
* We're entering ContLineLoc data for the same value more than one
* time. Taking care not to leak the old entry.
*
* This can happen when literals in a proc body are shared. See for
|
| ︙ | ︙ | |||
566 567 568 569 570 571 572 | * 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. */ | | | 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 |
* 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.
*/
Tcl_Free(Tcl_GetHashValue(hPtr));
}
clLocPtr->num = num;
memcpy(&clLocPtr->loc, loc, num*sizeof(int));
clLocPtr->loc[num] = CLL_END; /* Sentinel */
Tcl_SetHashValue(hPtr, clLocPtr);
|
| ︙ | ︙ | |||
602 603 604 605 606 607 608 |
void
TclContinuationsEnterDerived(
Tcl_Obj *objPtr,
int start,
int *clNext)
{
| > | | 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 |
void
TclContinuationsEnterDerived(
Tcl_Obj *objPtr,
int start,
int *clNext)
{
size_t length;
int end, num;
int *wordCLLast = clNext;
/*
* We have to handle invisible continuations lines here as well, despite
* the code we have in TclSubstTokens (TST) for that. Why ? Nesting. If
* our script is the sole argument to an 'eval' command, for example, the
* scriptCLLocPtr we are using was generated by a previous call to TST,
|
| ︙ | ︙ | |||
629 630 631 632 633 634 635 |
*/
/*
* First compute the range of the word within the script. (Is there a
* better way which doesn't shimmer?)
*/
| | | 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 |
*/
/*
* First compute the range of the word within the script. (Is there a
* better way which doesn't shimmer?)
*/
(void)TclGetStringFromObj(objPtr, &length);
end = start + length; /* First char after the word */
/*
* Then compute the table slice covering the range of the word.
*/
while (*wordCLLast >= 0 && *wordCLLast < end) {
|
| ︙ | ︙ | |||
770 771 772 773 774 775 776 |
ThreadSpecificData *tsdPtr = TclGetContLineTable();
Tcl_HashEntry *hPtr;
Tcl_HashSearch hSearch;
for (hPtr = Tcl_FirstHashEntry(tsdPtr->lineCLPtr, &hSearch);
hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) {
| | | | 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 |
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);
}
Tcl_DeleteHashTable(tsdPtr->lineCLPtr);
Tcl_Free(tsdPtr->lineCLPtr);
tsdPtr->lineCLPtr = NULL;
}
/*
*--------------------------------------------------------------
*
* Tcl_RegisterObjType --
|
| ︙ | ︙ | |||
971 972 973 974 975 976 977 |
*--------------------------------------------------------------
*/
void
TclDbDumpActiveObjects(
FILE *outFile)
{
| | | | 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 |
*--------------------------------------------------------------
*/
void
TclDbDumpActiveObjects(
FILE *outFile)
{
#if TCL_THREADS && defined(TCL_MEM_DEBUG)
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);
for (hPtr = Tcl_FirstHashEntry(tablePtr, &hSearch); hPtr != NULL;
hPtr = Tcl_NextHashEntry(&hSearch)) {
ObjData *objData = Tcl_GetHashValue(hPtr);
if (objData != NULL) {
fprintf(outFile,
"key = 0x%p, objPtr = 0x%p, file = %s, line = %d\n",
|
| ︙ | ︙ | |||
1027 1028 1029 1030 1031 1032 1033 |
register Tcl_Obj *objPtr,
register const char *file, /* The name of the source file calling this
* function; used for debugging. */
register int line) /* Line number in the source file; used for
* debugging. */
{
objPtr->refCount = 0;
| < < > | | | | 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 |
register Tcl_Obj *objPtr,
register const char *file, /* The name of the source file calling this
* function; used for debugging. */
register int line) /* Line number in the source file; used for
* debugging. */
{
objPtr->refCount = 0;
objPtr->typePtr = NULL;
TclInitStringRep(objPtr, NULL, 0);
#if TCL_THREADS
/*
* Add entry to a thread local map used to check if a Tcl_Obj was
* allocated by the currently executing thread.
*/
if (!TclInExit()) {
Tcl_HashEntry *hPtr;
Tcl_HashTable *tablePtr;
int isNew;
ObjData *objData;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (tsdPtr->objThreadMap == NULL) {
tsdPtr->objThreadMap = Tcl_Alloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(tsdPtr->objThreadMap, TCL_ONE_WORD_KEYS);
}
tablePtr = tsdPtr->objThreadMap;
hPtr = Tcl_CreateHashEntry(tablePtr, objPtr, &isNew);
if (!isNew) {
Tcl_Panic("expected to create new entry for object map");
}
/*
* Record the debugging information.
*/
objData = Tcl_Alloc(sizeof(ObjData));
objData->objPtr = objPtr;
objData->file = file;
objData->line = line;
Tcl_SetHashValue(hPtr, objData);
}
#endif /* TCL_THREADS */
}
|
| ︙ | ︙ | |||
1183 1184 1185 1186 1187 1188 1189 | /* *---------------------------------------------------------------------- * * TclAllocateFreeObjects -- * * Function to allocate a number of free Tcl_Objs. This is done using a | | | 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 | /* *---------------------------------------------------------------------- * * 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. * * Assumes mutex is held. * * Results: * None. * * Side effects: |
| ︙ | ︙ | |||
1212 1213 1214 1215 1216 1217 1218 |
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
| | | | 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 |
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,
* 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 = Tcl_Alloc(bytesToAlloc);
prevPtr = NULL;
objPtr = (Tcl_Obj *) basePtr;
for (i = 0; i < OBJS_TO_ALLOC_EACH_TIME; i++) {
objPtr->internalRep.twoPtrValue.ptr1 = prevPtr;
prevPtr = objPtr;
objPtr++;
|
| ︙ | ︙ | |||
1267 1268 1269 1270 1271 1272 1273 |
/*
* This macro declares a variable, so must come here...
*/
ObjInitDeletionContext(context);
| | | 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 |
/*
* This macro declares a variable, so must come here...
*/
ObjInitDeletionContext(context);
#if 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()) {
|
| ︙ | ︙ | |||
1292 1293 1294 1295 1296 1297 1298 |
/*
* As the Tcl_Obj is going to be deleted we remove the entry.
*/
ObjData *objData = Tcl_GetHashValue(hPtr);
if (objData != NULL) {
| | | | | | | | | 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 |
/*
* As the Tcl_Obj is going to be deleted we remove the entry.
*/
ObjData *objData = Tcl_GetHashValue(hPtr);
if (objData != NULL) {
Tcl_Free(objData);
}
Tcl_DeleteHashEntry(hPtr);
}
}
# endif
/*
* Check for a double free of the same value. This is slightly tricky
* because it is customary to free a Tcl_Obj when its refcount falls
* either from 1 to 0, or from 0 to -1. Falling from -1 to -2, though,
* and so on, is always a sign of a botch in the caller.
*/
if (objPtr->refCount == (size_t)-2) {
Tcl_Panic("Reference count for %p was negative", objPtr);
}
/*
* Now, in case we just approved drop from 1 to 0 as acceptable, make
* sure we do not accept a second free when falling from 0 to -1.
* Skip that possibility so any double free will trigger the panic.
*/
objPtr->refCount = TCL_AUTO_LENGTH;
/*
* 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_AUTO_LENGTH'.
*/
TclInvalidateStringRep(objPtr);
objPtr->length = TCL_AUTO_LENGTH;
if (ObjDeletePending(context)) {
PushObjToDelete(context, objPtr);
} else {
TCL_DTRACE_OBJ_FREE(objPtr);
if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) {
ObjDeletionLock(context);
typePtr->freeIntRepProc(objPtr);
ObjDeletionUnlock(context);
}
Tcl_MutexLock(&tclObjMutex);
Tcl_Free(objPtr);
Tcl_MutexUnlock(&tclObjMutex);
TclIncrObjsFreed();
ObjDeletionLock(context);
while (ObjOnStack(context)) {
Tcl_Obj *objToFree;
PopObjToDelete(context, objToFree);
TCL_DTRACE_OBJ_FREE(objToFree);
TclFreeIntRep(objToFree);
Tcl_MutexLock(&tclObjMutex);
Tcl_Free(objToFree);
Tcl_MutexUnlock(&tclObjMutex);
TclIncrObjsFreed();
}
ObjDeletionUnlock(context);
}
/*
|
| ︙ | ︙ | |||
1372 1373 1374 1375 1376 1377 1378 |
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
Tcl_HashEntry *hPtr;
if (tsdPtr->lineCLPtr) {
hPtr = Tcl_FindHashEntry(tsdPtr->lineCLPtr, objPtr);
if (hPtr) {
| | | | 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 |
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
Tcl_HashEntry *hPtr;
if (tsdPtr->lineCLPtr) {
hPtr = Tcl_FindHashEntry(tsdPtr->lineCLPtr, objPtr);
if (hPtr) {
Tcl_Free(Tcl_GetHashValue(hPtr));
Tcl_DeleteHashEntry(hPtr);
}
}
}
}
#else /* TCL_MEM_DEBUG */
void
TclFreeObj(
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'.
*/
TclInvalidateStringRep(objPtr);
objPtr->length = TCL_AUTO_LENGTH;
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.
*/
|
| ︙ | ︙ | |||
1463 1464 1465 1466 1467 1468 1469 |
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
Tcl_HashEntry *hPtr;
if (tsdPtr->lineCLPtr) {
hPtr = Tcl_FindHashEntry(tsdPtr->lineCLPtr, objPtr);
if (hPtr) {
| | | 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 |
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
Tcl_HashEntry *hPtr;
if (tsdPtr->lineCLPtr) {
hPtr = Tcl_FindHashEntry(tsdPtr->lineCLPtr, objPtr);
if (hPtr) {
Tcl_Free(Tcl_GetHashValue(hPtr));
Tcl_DeleteHashEntry(hPtr);
}
}
}
}
#endif /* TCL_MEM_DEBUG */
|
| ︙ | ︙ | |||
1493 1494 1495 1496 1497 1498 1499 |
*----------------------------------------------------------------------
*/
int
TclObjBeingDeleted(
Tcl_Obj *objPtr)
{
| | | 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 |
*----------------------------------------------------------------------
*/
int
TclObjBeingDeleted(
Tcl_Obj *objPtr)
{
return (objPtr->length == TCL_AUTO_LENGTH);
}
/*
*----------------------------------------------------------------------
*
* Tcl_DuplicateObj --
*
|
| ︙ | ︙ | |||
1594 1595 1596 1597 1598 1599 1600 |
*/
char *
Tcl_GetString(
register Tcl_Obj *objPtr) /* Object whose string rep byte pointer should
* be returned. */
{
| | < < < | | | | | | | | | | | | < | | | | | | | | > > | 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 |
*/
char *
Tcl_GetString(
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_AUTO_LENGTH
|| objPtr->bytes[objPtr->length] != '\0') {
Tcl_Panic("UpdateStringProc for type '%s' "
"failed to create a valid string rep",
objPtr->typePtr->name);
}
}
return objPtr->bytes;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1655 1656 1657 1658 1659 1660 1661 |
Tcl_GetStringFromObj(
register Tcl_Obj *objPtr, /* Object whose string rep byte pointer should
* be returned. */
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. */
{
| > > > > > > > | > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > | > > > > > > > > > > > > > > > > > | 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 |
Tcl_GetStringFromObj(
register Tcl_Obj *objPtr, /* Object whose string rep byte pointer should
* be returned. */
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_AUTO_LENGTH
|| objPtr->bytes[objPtr->length] != '\0') {
Tcl_Panic("UpdateStringProc for type '%s' "
"failed to create a valid string rep",
objPtr->typePtr->name);
}
}
if (lengthPtr != NULL) {
*lengthPtr = (objPtr->length < 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 = 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 = Tcl_Realloc(objPtr->bytes, numBytes + 1);
objPtr->length = numBytes;
}
/* Terminate */
objPtr->bytes[objPtr->length] = '\0';
return objPtr->bytes;
}
/*
*----------------------------------------------------------------------
*
* Tcl_InvalidateStringRep --
|
| ︙ | ︙ | |||
1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 |
void
Tcl_InvalidateStringRep(
register Tcl_Obj *objPtr) /* Object whose string rep byte pointer should
* be freed. */
{
TclInvalidateStringRep(objPtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetBooleanFromObj --
*
* Attempt to return a boolean from the Tcl object "objPtr". This
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 |
void
Tcl_InvalidateStringRep(
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_GetBooleanFromObj --
*
* Attempt to return a boolean from the Tcl object "objPtr". This
|
| ︙ | ︙ | |||
1799 1800 1801 1802 1803 1804 1805 |
if (ParseBoolean(objPtr) == TCL_OK) {
return TCL_OK;
}
badBoolean:
if (interp != NULL) {
| | > | < | 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 |
if (ParseBoolean(objPtr) == TCL_OK) {
return TCL_OK;
}
badBoolean:
if (interp != NULL) {
size_t length;
const char *str = TclGetStringFromObj(objPtr, &length);
Tcl_Obj *msg;
TclNewLiteralStringObj(msg, "expected boolean value but got \"");
Tcl_AppendLimitedToObj(msg, str, length, 50, "");
Tcl_AppendToObj(msg, "\"", -1);
Tcl_SetObjResult(interp, msg);
Tcl_SetErrorCode(interp, "TCL", "VALUE", "BOOLEAN", NULL);
}
return TCL_ERROR;
}
static int
ParseBoolean(
register Tcl_Obj *objPtr) /* The object to parse/convert. */
{
int newBool;
char lowerCase[6];
size_t i, length;
const char *str = TclGetStringFromObj(objPtr, &length);
if ((length == 0) || (length > 5)) {
/*
* Longest valid boolean string rep. is "false".
*/
return TCL_ERROR;
|
| ︙ | ︙ | |||
2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 |
* 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.doubleValue = dblValue;
objPtr->typePtr = &tclDoubleType;
return objPtr;
}
| > | 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 |
* function; used for debugging. */
int line) /* Line number in the source file; used for
* debugging. */
{
register Tcl_Obj *objPtr;
TclDbNewObj(objPtr, file, line);
/* Optimized TclInvalidateStringRep() */
objPtr->bytes = NULL;
objPtr->internalRep.doubleValue = dblValue;
objPtr->typePtr = &tclDoubleType;
return objPtr;
}
|
| ︙ | ︙ | |||
2111 2112 2113 2114 2115 2116 2117 |
if (objPtr->typePtr == &tclIntType) {
*dblPtr = (double) objPtr->internalRep.wideValue;
return TCL_OK;
}
if (objPtr->typePtr == &tclBignumType) {
mp_int big;
| | | 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 |
if (objPtr->typePtr == &tclIntType) {
*dblPtr = (double) objPtr->internalRep.wideValue;
return TCL_OK;
}
if (objPtr->typePtr == &tclBignumType) {
mp_int big;
TclUnpackBignum(objPtr, big);
*dblPtr = TclBignumToDouble(&big);
return TCL_OK;
}
} while (SetDoubleFromAny(interp, objPtr) == TCL_OK);
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
2172 2173 2174 2175 2176 2177 2178 |
*----------------------------------------------------------------------
*/
static void
UpdateStringOfDouble(
register Tcl_Obj *objPtr) /* Double obj with string rep to update. */
{
| | | > | < | < < < | 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 |
*----------------------------------------------------------------------
*/
static void
UpdateStringOfDouble(
register Tcl_Obj *objPtr) /* Double obj with string rep to update. */
{
char *dst = Tcl_InitStringRep(objPtr, NULL, TCL_DOUBLE_SPACE);
TclOOM(dst, TCL_DOUBLE_SPACE + 1);
Tcl_PrintDouble(NULL, objPtr->internalRep.doubleValue, dst);
(void) Tcl_InitStringRep(objPtr, NULL, strlen(dst));
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetIntFromObj --
*
|
| ︙ | ︙ | |||
2226 2227 2228 2229 2230 2231 2232 |
return TclGetLongFromObj(interp, objPtr, (long *) intPtr);
#else
long l;
if (TclGetLongFromObj(interp, objPtr, &l) != TCL_OK) {
return TCL_ERROR;
}
| | | 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 |
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 (interp != NULL) {
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;
|
| ︙ | ︙ | |||
2288 2289 2290 2291 2292 2293 2294 |
*----------------------------------------------------------------------
*/
static void
UpdateStringOfInt(
register Tcl_Obj *objPtr) /* Int object whose string rep to update. */
{
| > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > | > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | > > | > > > > > > > > > > > > > > > > | 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 |
*----------------------------------------------------------------------
*/
static void
UpdateStringOfInt(
register Tcl_Obj *objPtr) /* Int object whose string rep to update. */
{
char *dst = Tcl_InitStringRep( objPtr, NULL, TCL_INTEGER_SPACE);
TclOOM(dst, TCL_INTEGER_SPACE + 1);
(void) Tcl_InitStringRep(objPtr, NULL,
TclFormatInt(dst, objPtr->internalRep.wideValue));
}
/*
*----------------------------------------------------------------------
*
* 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.
*
*----------------------------------------------------------------------
*/
#ifndef TCL_NO_DEPRECATED
#undef Tcl_NewLongObj
#ifdef TCL_MEM_DEBUG
Tcl_Obj *
Tcl_NewLongObj(
register long longValue) /* Long integer used to initialize the
* new object. */
{
return Tcl_DbNewWideIntObj(longValue, "unknown", 0);
}
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_NewLongObj(
register long longValue) /* Long integer used to initialize the
* new object. */
{
register Tcl_Obj *objPtr;
TclNewIntObj(objPtr, longValue);
return objPtr;
}
#endif /* if TCL_MEM_DEBUG */
#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
*
* 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.
*
*----------------------------------------------------------------------
*/
#ifndef TCL_NO_DEPRECATED
#undef Tcl_DbNewLongObj
#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);
/* Optimized TclInvalidateStringRep */
objPtr->bytes = NULL;
objPtr->internalRep.wideValue = 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_NewWideIntObj(longValue);
}
#endif /* TCL_MEM_DEBUG */
#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
*
* Tcl_GetLongFromObj --
*
* Attempt to return an long integer from the Tcl object "objPtr". If the
|
| ︙ | ︙ | |||
2334 2335 2336 2337 2338 2339 2340 |
if (objPtr->typePtr == &tclIntType) {
*longPtr = objPtr->internalRep.wideValue;
return TCL_OK;
}
#else
if (objPtr->typePtr == &tclIntType) {
/*
| | | | | 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 |
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
* converted to a long, ignoring overflow. The rule preserves
* existing semantics for conversion of integers on input, but
* avoids inadvertent demotion of wide integers to 32-bit ones in
* the internal rep.
*/
Tcl_WideInt w = objPtr->internalRep.wideValue;
if (w >= (Tcl_WideInt)(LONG_MIN)
&& w <= (Tcl_WideInt)(ULONG_MAX)) {
*longPtr = (long) w;
return TCL_OK;
}
goto tooLarge;
}
#endif
if (objPtr->typePtr == &tclDoubleType) {
if (interp != NULL) {
|
| ︙ | ︙ | |||
2369 2370 2371 2372 2373 2374 2375 | * 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; | < < < < | < | > | | | | > > > | > < | > | 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 |
* 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, numBytes = sizeof(unsigned long);
unsigned char *bytes = (unsigned char *) &scratch;
TclUnpackBignum(objPtr, big);
if (mp_to_unsigned_bin_n(&big, bytes, &numBytes) == MP_OKAY) {
while (numBytes-- > 0) {
value = (value << CHAR_BIT) | *bytes++;
}
if (big.sign) {
if (value <= 1 + (unsigned long)LONG_MAX) {
*longPtr = - (long) value;
return TCL_OK;
}
} else {
if (value <= (unsigned long)ULONG_MAX) {
*longPtr = (long) value;
return TCL_OK;
}
}
}
#ifndef TCL_WIDE_INT_IS_LONG
tooLarge:
#endif
if (interp != NULL) {
const char *s = "integer value too large to represent";
|
| ︙ | ︙ | |||
2607 2608 2609 2610 2611 2612 2613 |
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;
| < < < < | | | | > | | | | | > > > | > < | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 |
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;
unsigned long numBytes = sizeof(Tcl_WideInt);
Tcl_WideInt scratch;
unsigned char *bytes = (unsigned char *) &scratch;
TclUnpackBignum(objPtr, big);
if (mp_to_unsigned_bin_n(&big, bytes, &numBytes) == MP_OKAY) {
while (numBytes-- > 0) {
value = (value << CHAR_BIT) | *bytes++;
}
if (big.sign) {
if (value <= 1 + ~(Tcl_WideUInt)WIDE_MIN) {
*wideIntPtr = - (Tcl_WideInt) value;
return TCL_OK;
}
} else {
if (value <= (Tcl_WideUInt)WIDE_MAX) {
*wideIntPtr = (Tcl_WideInt) value;
return TCL_OK;
}
}
}
if (interp != NULL) {
const char *s = "integer value too large to represent";
Tcl_Obj *msg = Tcl_NewStringObj(s, -1);
Tcl_SetObjResult(interp, msg);
Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, NULL);
}
return TCL_ERROR;
}
} while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL,
TCL_PARSE_INTEGER_ONLY)==TCL_OK);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* TclGetWideBitsFromObj --
*
* 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.
*
* Results:
* The return value is a standard Tcl object result. If an error occurs
* during conversion, an error message is left in the interpreter's
* result unless "interp" is NULL.
*
* Side effects:
* 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;
Tcl_WideUInt value = 0, scratch;
unsigned long numBytes = sizeof(Tcl_WideInt);
unsigned char *bytes = (unsigned char *) &scratch;
Tcl_GetBignumFromObj(NULL, objPtr, &big);
mp_mod_2d(&big, (int) (CHAR_BIT * sizeof(Tcl_WideInt)), &big);
mp_to_unsigned_bin_n(&big, bytes, &numBytes);
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;
}
/*
|
| ︙ | ︙ | |||
2661 2662 2663 2664 2665 2666 2667 |
static void
FreeBignum(
Tcl_Obj *objPtr)
{
mp_int toFree; /* Bignum to free */
| | | | 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 |
static void
FreeBignum(
Tcl_Obj *objPtr)
{
mp_int toFree; /* Bignum to free */
TclUnpackBignum(objPtr, toFree);
mp_clear(&toFree);
if (PTR2INT(objPtr->internalRep.twoPtrValue.ptr2) < 0) {
Tcl_Free(objPtr->internalRep.twoPtrValue.ptr1);
}
objPtr->typePtr = NULL;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
2694 2695 2696 2697 2698 2699 2700 |
Tcl_Obj *srcPtr,
Tcl_Obj *copyPtr)
{
mp_int bignumVal;
mp_int bignumCopy;
copyPtr->typePtr = &tclBignumType;
| | | 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 |
Tcl_Obj *srcPtr,
Tcl_Obj *copyPtr)
{
mp_int bignumVal;
mp_int bignumCopy;
copyPtr->typePtr = &tclBignumType;
TclUnpackBignum(srcPtr, bignumVal);
if (mp_init_copy(&bignumCopy, &bignumVal) != MP_OKAY) {
Tcl_Panic("initialization failure in DupBignum");
}
PACK_BIGNUM(bignumCopy, copyPtr);
}
/*
|
| ︙ | ︙ | |||
2727 2728 2729 2730 2731 2732 2733 |
static void
UpdateStringOfBignum(
Tcl_Obj *objPtr)
{
mp_int bignumVal;
int size;
| < | | < > > > | | < | < | 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 |
static void
UpdateStringOfBignum(
Tcl_Obj *objPtr)
{
mp_int bignumVal;
int size;
char *stringVal;
TclUnpackBignum(objPtr, bignumVal);
if (MP_OKAY != mp_radix_size(&bignumVal, 10, &size)) {
Tcl_Panic("radix size failure in UpdateStringOfBignum");
}
if (size < 2) {
/*
* mp_radix_size() returns < 2 when more than INT_MAX bytes would be
* needed to hold the string rep (because mp_radix_size ignores
* integer overflow issues).
*
* Note that so long as we enforce our bignums to the size that fits
* 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_toradix_n(&bignumVal, stringVal, 10, size)) {
Tcl_Panic("conversion failure in UpdateStringOfBignum");
}
(void) Tcl_InitStringRep(objPtr, NULL, size - 1);
}
/*
*----------------------------------------------------------------------
*
* Tcl_NewBignumObj --
*
|
| ︙ | ︙ | |||
2869 2870 2871 2872 2873 2874 2875 |
mp_int *bignumValue) /* Returned bignum value. */
{
do {
if (objPtr->typePtr == &tclBignumType) {
if (copy || Tcl_IsShared(objPtr)) {
mp_int temp;
| | | > > > > > > | | 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 |
mp_int *bignumValue) /* Returned bignum value. */
{
do {
if (objPtr->typePtr == &tclBignumType) {
if (copy || Tcl_IsShared(objPtr)) {
mp_int temp;
TclUnpackBignum(objPtr, temp);
mp_init_copy(bignumValue, &temp);
} else {
TclUnpackBignum(objPtr, *bignumValue);
/* Optimized TclFreeIntRep */
objPtr->internalRep.twoPtrValue.ptr1 = NULL;
objPtr->internalRep.twoPtrValue.ptr2 = NULL;
objPtr->typePtr = NULL;
/*
* TODO: If objPtr has a string rep, this leaves
* it undisturbed. Not clear that's proper. Pure
* bignum values are converted to empty string.
*/
if (objPtr->bytes == NULL) {
TclInitStringRep(objPtr, NULL, 0);
}
}
return TCL_OK;
}
if (objPtr->typePtr == &tclIntType) {
TclInitBignumFromWideInt(bignumValue,
objPtr->internalRep.wideValue);
|
| ︙ | ︙ | |||
2992 2993 2994 2995 2996 2997 2998 |
*/
void
Tcl_SetBignumObj(
Tcl_Obj *objPtr, /* Object to set */
mp_int *bignumValue) /* Value to store */
{
| < < < < < | | | | > > > | | | | | | | | | | | | | | | | < | 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 |
*/
void
Tcl_SetBignumObj(
Tcl_Obj *objPtr, /* Object to set */
mp_int *bignumValue) /* Value to store */
{
Tcl_WideUInt value = 0;
unsigned long numBytes = sizeof(Tcl_WideUInt);
Tcl_WideUInt scratch;
unsigned char *bytes = (unsigned char *) &scratch;
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_SetBignumObj");
}
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)WIDE_MAX + bignumValue->sign)) {
goto tooLargeForWide;
}
if (bignumValue->sign) {
TclSetIntObj(objPtr, -(Tcl_WideInt)value);
} else {
TclSetIntObj(objPtr, (Tcl_WideInt)value);
}
mp_clear(bignumValue);
return;
tooLargeForWide:
TclInvalidateStringRep(objPtr);
TclFreeIntRep(objPtr);
TclSetBignumIntRep(objPtr, bignumValue);
}
/*
|
| ︙ | ︙ | |||
3101 3102 3103 3104 3105 3106 3107 |
} else {
*typePtr = TCL_NUMBER_DOUBLE;
}
*clientDataPtr = &objPtr->internalRep.doubleValue;
return TCL_OK;
}
if (objPtr->typePtr == &tclIntType) {
| | | < | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 3505 3506 3507 3508 3509 3510 3511 3512 3513 3514 3515 3516 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 3549 3550 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 3590 |
} else {
*typePtr = TCL_NUMBER_DOUBLE;
}
*clientDataPtr = &objPtr->internalRep.doubleValue;
return TCL_OK;
}
if (objPtr->typePtr == &tclIntType) {
*typePtr = TCL_NUMBER_INT;
*clientDataPtr = &objPtr->internalRep.wideValue;
return TCL_OK;
}
if (objPtr->typePtr == &tclBignumType) {
static Tcl_ThreadDataKey bignumKey;
mp_int *bigPtr = Tcl_GetThreadData(&bignumKey, sizeof(mp_int));
TclUnpackBignum(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 --
*
* This function is normally called when debugging: i.e., when
|
| ︙ | ︙ | |||
3157 3158 3159 3160 3161 3162 3163 |
#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");
}
| | | 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 3629 |
#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
/*
* 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()) {
|
| ︙ | ︙ | |||
3220 3221 3222 3223 3224 3225 3226 |
#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");
}
| | | 3678 3679 3680 3681 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 |
#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
/*
* 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()) {
|
| ︙ | ︙ | |||
3285 3286 3287 3288 3289 3290 3291 |
#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");
}
| | | 3743 3744 3745 3746 3747 3748 3749 3750 3751 3752 3753 3754 3755 3756 3757 |
#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
/*
* 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()) {
|
| ︙ | ︙ | |||
3373 3374 3375 3376 3377 3378 3379 |
*/
static Tcl_HashEntry *
AllocObjEntry(
Tcl_HashTable *tablePtr, /* Hash table. */
void *keyPtr) /* Key to store in the hash table entry. */
{
| | | | | 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 3846 3847 3848 3849 3850 |
*/
static Tcl_HashEntry *
AllocObjEntry(
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_Alloc(sizeof(Tcl_HashEntry));
hPtr->key.objPtr = objPtr;
Tcl_IncrRefCount(objPtr);
hPtr->clientData = NULL;
return hPtr;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
3405 3406 3407 3408 3409 3410 3411 |
*/
int
TclCompareObjKeys(
void *keyPtr, /* New key to compare. */
Tcl_HashEntry *hPtr) /* Existing key to compare. */
{
| | | 3863 3864 3865 3866 3867 3868 3869 3870 3871 3872 3873 3874 3875 3876 3877 |
*/
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;
register const char *p1, *p2;
register size_t l1, l2;
/*
* If the object pointers are the same then they match.
* OPT: this comparison was moved to the caller
|
| ︙ | ︙ | |||
3468 3469 3470 3471 3472 3473 3474 |
void
TclFreeObjEntry(
Tcl_HashEntry *hPtr) /* Hash entry to free. */
{
Tcl_Obj *objPtr = (Tcl_Obj *) hPtr->key.oneWordValue;
Tcl_DecrRefCount(objPtr);
| | | 3926 3927 3928 3929 3930 3931 3932 3933 3934 3935 3936 3937 3938 3939 3940 |
void
TclFreeObjEntry(
Tcl_HashEntry *hPtr) /* Hash entry to free. */
{
Tcl_Obj *objPtr = (Tcl_Obj *) hPtr->key.oneWordValue;
Tcl_DecrRefCount(objPtr);
Tcl_Free(hPtr);
}
/*
*----------------------------------------------------------------------
*
* TclHashObjKey --
*
|
| ︙ | ︙ | |||
3494 3495 3496 3497 3498 3499 3500 |
*/
TCL_HASH_TYPE
TclHashObjKey(
Tcl_HashTable *tablePtr, /* Hash table. */
void *keyPtr) /* Key from which to compute hash value. */
{
| | | 3952 3953 3954 3955 3956 3957 3958 3959 3960 3961 3962 3963 3964 3965 3966 |
*/
TCL_HASH_TYPE
TclHashObjKey(
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;
/*
* I tried a zillion different hash functions and asked many other people
* for advice. Many people had their own favorite functions, all
|
| ︙ | ︙ | |||
3533 3534 3535 3536 3537 3538 3539 |
*
* See also HashStringKey in tclHash.c.
* See also HashString in tclLiteral.c.
*
* See [tcl-Feature Request #2958832]
*/
| | | 3991 3992 3993 3994 3995 3996 3997 3998 3999 4000 4001 4002 4003 4004 4005 |
*
* See also HashStringKey in tclHash.c.
* See also HashString in tclLiteral.c.
*
* See [tcl-Feature Request #2958832]
*/
if (length) {
result = UCHAR(*string);
while (--length) {
result += (result << 3) + UCHAR(*++string);
}
}
return result;
}
|
| ︙ | ︙ | |||
3658 3659 3660 3661 3662 3663 3664 |
Interp *iPtr = (Interp *) interp;
ResolvedCmdName *fillPtr;
const char *name = TclGetString(objPtr);
if (resPtr) {
fillPtr = resPtr;
} else {
| | | 4116 4117 4118 4119 4120 4121 4122 4123 4124 4125 4126 4127 4128 4129 4130 |
Interp *iPtr = (Interp *) interp;
ResolvedCmdName *fillPtr;
const char *name = TclGetString(objPtr);
if (resPtr) {
fillPtr = resPtr;
} else {
fillPtr = Tcl_Alloc(sizeof(ResolvedCmdName));
fillPtr->refCount = 1;
}
fillPtr->cmdPtr = cmdPtr;
cmdPtr->refCount++;
fillPtr->cmdEpoch = cmdPtr->cmdEpoch;
|
| ︙ | ︙ | |||
3761 3762 3763 3764 3765 3766 3767 | * table or if there are other references to it from other cmdName * objects. */ Command *cmdPtr = resPtr->cmdPtr; TclCleanupCommandMacro(cmdPtr); | | | 4219 4220 4221 4222 4223 4224 4225 4226 4227 4228 4229 4230 4231 4232 4233 |
* table or if there are other references to it from other cmdName
* objects.
*/
Command *cmdPtr = resPtr->cmdPtr;
TclCleanupCommandMacro(cmdPtr);
Tcl_Free(resPtr);
}
objPtr->typePtr = NULL;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
3910 3911 3912 3913 3914 3915 3916 |
/*
* Value is a bignum with a refcount of 14, object pointer at 0x12345678,
* internal representation 0x45671234:0x98765432, string representation
* "1872361827361287"
*/
| | | 4368 4369 4370 4371 4372 4373 4374 4375 4376 4377 4378 4379 4380 4381 4382 |
/*
* 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",
|
| ︙ | ︙ |
Changes to generic/tclOptimize.c.
| ︙ | ︙ | |||
227 228 229 230 231 232 233 |
case INST_PUSH1:
if (nextInst == INST_POP) {
blank = size + InstLength(nextInst);
} else if (nextInst == INST_STR_CONCAT1
&& TclGetUInt1AtPtr(currentInstPtr + size + 1) == 2) {
Tcl_Obj *litPtr = TclFetchLiteral(envPtr,
TclGetUInt1AtPtr(currentInstPtr + 1));
| | | | 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 |
case INST_PUSH1:
if (nextInst == INST_POP) {
blank = size + InstLength(nextInst);
} else if (nextInst == INST_STR_CONCAT1
&& TclGetUInt1AtPtr(currentInstPtr + size + 1) == 2) {
Tcl_Obj *litPtr = TclFetchLiteral(envPtr,
TclGetUInt1AtPtr(currentInstPtr + 1));
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;
|
| ︙ | ︙ |
Changes to generic/tclPanic.c.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 | * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #if defined(_WIN32) || defined(__CYGWIN__) | | < < < | < | < < < < < < < < > | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 |
*
* 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;
/*
*----------------------------------------------------------------------
*
* Tcl_SetPanicProc --
*
* Replace the default panic behavior with the specified function.
*
* Results:
* None.
*
* Side effects:
* Sets the panicProc variable.
*
*----------------------------------------------------------------------
*/
void
Tcl_SetPanicProc(
TCL_NORETURN1 Tcl_PanicProc *proc)
{
panicProc = proc;
TclInitSubsystems();
}
/*
*----------------------------------------------------------------------
*
* Tcl_Panic --
*
|
| ︙ | ︙ | |||
103 104 105 106 107 108 109 |
arg6 = va_arg(argList, char *);
arg7 = va_arg(argList, char *);
arg8 = va_arg(argList, char *);
va_end (argList);
if (panicProc != NULL) {
panicProc(format, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8);
| < | > | < | | | < | 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 |
arg6 = va_arg(argList, char *);
arg7 = va_arg(argList, char *);
arg8 = va_arg(argList, char *);
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
}
}
|
| ︙ | ︙ |
Changes to generic/tclParse.c.
| ︙ | ︙ | |||
15 16 17 18 19 20 21 | #include "tclInt.h" #include "tclParse.h" #include <assert.h> /* * The following table provides parsing information about each possible 8-bit | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 |
#include "tclInt.h"
#include "tclParse.h"
#include <assert.h>
/*
* The following table provides parsing information about each possible 8-bit
* character. The table is designed to be referenced with unsigned characters.
*
* 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
* the Tcl parser.
* TYPE_SPACE - The character is a whitespace character other than
* newline.
* TYPE_COMMAND_END - Character is newline or semicolon.
* TYPE_SUBS - Character begins a substitution or has other special
* meaning in ParseTokens: backslash, dollar sign, or
* open bracket.
* TYPE_QUOTE - Character is a double quote.
* 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[] = {
/*
* Positive character values, from 0-127:
*/
TYPE_SUBS, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
|
| ︙ | ︙ | |||
156 157 158 159 160 161 162 |
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
};
/*
* Prototypes for local functions defined in this file:
*/
| | | | | | | 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 |
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
};
/*
* Prototypes for local functions defined in this file:
*/
static inline int CommandComplete(const char *script, size_t numBytes);
static size_t ParseComment(const char *src, size_t numBytes,
Tcl_Parse *parsePtr);
static int ParseTokens(const char *src, size_t numBytes, int mask,
int flags, Tcl_Parse *parsePtr);
static size_t ParseWhiteSpace(const char *src, size_t numBytes,
int *incompletePtr, char *typePtr);
static size_t ParseAllWhiteSpace(const char *src, size_t numBytes,
int *incompletePtr);
/*
*----------------------------------------------------------------------
*
* TclParseInit --
*
|
| ︙ | ︙ | |||
186 187 188 189 190 191 192 |
*----------------------------------------------------------------------
*/
void
TclParseInit(
Tcl_Interp *interp, /* Interpreter to use for error reporting */
const char *start, /* Start of string to be parsed. */
| | | 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 |
*----------------------------------------------------------------------
*/
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,
* the script consists of all bytes up to the
* first null character. */
Tcl_Parse *parsePtr) /* Points to struct to initialize */
{
parsePtr->numWords = 0;
parsePtr->tokenPtr = parsePtr->staticTokens;
parsePtr->numTokens = 0;
|
| ︙ | ︙ | |||
232 233 234 235 236 237 238 |
int
Tcl_ParseCommand(
Tcl_Interp *interp, /* Interpreter to use for error reporting; if
* NULL, then no error message is provided. */
const char *start, /* First character of string containing one or
* more Tcl commands. */
| | | | | | | 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 |
int
Tcl_ParseCommand(
Tcl_Interp *interp, /* Interpreter to use for error reporting; if
* NULL, then no error message is provided. */
const char *start, /* First character of string containing one or
* more Tcl commands. */
size_t numBytes, /* Total number of bytes in string. If -1,
* the script consists of all bytes up to the
* first null character. */
int nested, /* Non-zero means this is a nested command:
* close bracket should be considered a
* command terminator. If zero, then close
* bracket has no special meaning. */
Tcl_Parse *parsePtr)
/* Structure to fill in with information about
* the parsed command; any previous
* information in the structure is ignored. */
{
const char *src; /* Points to current character in the
* command. */
char type; /* Result returned by CHAR_TYPE(*src). */
Tcl_Token *tokenPtr; /* Pointer to token being filled in. */
int wordIndex; /* Index of word token for current word. */
int terminators; /* CHAR_TYPE bits that indicate the end of a
* command. */
const char *termPtr; /* Set by Tcl_ParseBraces/QuotedString to
* point to char after terminating one. */
size_t scanned;
if ((start == NULL) && (numBytes != 0)) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"can't parse a NULL pointer", -1));
}
return TCL_ERROR;
}
if (numBytes == TCL_AUTO_LENGTH) {
numBytes = strlen(start);
}
TclParseInit(interp, start, numBytes, parsePtr);
parsePtr->commentStart = NULL;
parsePtr->commentSize = 0;
parsePtr->commandStart = NULL;
parsePtr->commandSize = 0;
|
| ︙ | ︙ | |||
381 382 383 384 385 386 387 | */ expPtr = &parsePtr->tokenPtr[expIdx]; if ((0 == expandWord) /* Haven't seen prefix already */ && (1 == parsePtr->numTokens - expIdx) /* Only one token */ | | | 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 |
*/
expPtr = &parsePtr->tokenPtr[expIdx];
if ((0 == expandWord)
/* Haven't seen prefix already */
&& (1 == parsePtr->numTokens - expIdx)
/* Only one token */
&& (((1 == expPtr->size)
/* Same length as prefix */
&& (expPtr->start[0] == '*')))
/* Is the prefix */
&& (numBytes > 0) && (0 == ParseWhiteSpace(termPtr,
numBytes, &parsePtr->incomplete, &type))
&& (type != TYPE_COMMAND_END)
/* Non-whitespace follows */) {
|
| ︙ | ︙ | |||
416 417 418 419 420 421 422 |
* case of a word consisting of a single range of literal text.
*/
tokenPtr = &parsePtr->tokenPtr[wordIndex];
tokenPtr->size = src - tokenPtr->start;
tokenPtr->numComponents = parsePtr->numTokens - (wordIndex + 1);
if (expandWord) {
| > | | 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 |
* case of a word consisting of a single range of literal text.
*/
tokenPtr = &parsePtr->tokenPtr[wordIndex];
tokenPtr->size = src - tokenPtr->start;
tokenPtr->numComponents = parsePtr->numTokens - (wordIndex + 1);
if (expandWord) {
size_t i;
int isLiteral = 1;
/*
* When a command includes a word that is an expanded literal; for
* example, {*}{1 2 3}, the parser performs that expansion
* immediately, generating several TCL_TOKEN_SIMPLE_WORDs instead
* of a single TCL_TOKEN_EXPAND_WORD that the Tcl_ParseCommand()
* caller might have to expand. This notably makes it simpler for
|
| ︙ | ︙ | |||
462 463 464 465 466 467 468 |
/*
* Step through the literal string, parsing and counting list
* elements.
*/
while (nextElem < listEnd) {
| | | 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 |
/*
* Step through the literal string, parsing and counting list
* elements.
*/
while (nextElem < listEnd) {
size_t size;
code = TclFindElement(NULL, nextElem, listEnd - nextElem,
&elemStart, &nextElem, &size, &literal);
if ((code != TCL_OK) || !literal) {
break;
}
if (elemStart < listEnd) {
|
| ︙ | ︙ | |||
588 589 590 591 592 593 594 | * None. * *---------------------------------------------------------------------- */ int TclIsSpaceProc( | | | 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 |
* None.
*
*----------------------------------------------------------------------
*/
int
TclIsSpaceProc(
int byte)
{
return CHAR_TYPE(byte) & (TYPE_SPACE) || byte == '\n';
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
617 618 619 620 621 622 623 | * None. * *---------------------------------------------------------------------- */ int TclIsBareword( | | | 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 |
* None.
*
*----------------------------------------------------------------------
*/
int
TclIsBareword(
int byte)
{
if (byte < '0' || byte > 'z') {
return 0;
}
if (byte <= '9' || byte >= 'a') {
return 1;
}
|
| ︙ | ︙ | |||
654 655 656 657 658 659 660 | * * Side effects: * None. * *---------------------------------------------------------------------- */ | | | | 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 |
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static size_t
ParseWhiteSpace(
const char *src, /* First character to parse. */
size_t 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 */
{
register char type = TYPE_NORMAL;
register const char *p = src;
|
| ︙ | ︙ | |||
708 709 710 711 712 713 714 | * * Results: * Returns the number of bytes recognized as white space. * *---------------------------------------------------------------------- */ | | | | | | | 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 |
*
* Results:
* Returns the number of bytes recognized as white space.
*
*----------------------------------------------------------------------
*/
static size_t
ParseAllWhiteSpace(
const char *src, /* First character to parse. */
size_t numBytes, /* Max number of byes to scan */
int *incompletePtr) /* Set true if parse is incomplete. */
{
char type;
const char *p = src;
do {
size_t scanned = ParseWhiteSpace(p, numBytes, incompletePtr, &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);
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
760 761 762 763 764 765 766 |
*
*----------------------------------------------------------------------
*/
int
TclParseHex(
const char *src, /* First character to parse. */
| | | | 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 |
*
*----------------------------------------------------------------------
*/
int
TclParseHex(
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
* the character resulting from the
* conversion is to be written. */
{
int result = 0;
register const char *p = src;
while (numBytes--) {
|
| ︙ | ︙ | |||
816 817 818 819 820 821 822 |
*----------------------------------------------------------------------
*/
int
TclParseBackslash(
const char *src, /* Points to the backslash character of a a
* backslash sequence. */
| | | | | | 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 |
*----------------------------------------------------------------------
*/
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
* 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 TCL_UTF_MAX bytes will be
* written there. */
{
register const char *p = src+1;
Tcl_UniChar unichar = 0;
int result;
size_t count;
char buf[4] = "";
if (numBytes == 0) {
if (readPtr != NULL) {
*readPtr = 0;
}
return 0;
}
|
| ︙ | ︙ | |||
886 887 888 889 890 891 892 |
case 'v':
result = 0xb;
break;
case 'x':
count += TclParseHex(p+1, (numBytes > 3) ? 2 : numBytes-2, &result);
if (count == 2) {
/*
| | | | | 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 |
case 'v':
result = 0xb;
break;
case 'x':
count += TclParseHex(p+1, (numBytes > 3) ? 2 : numBytes-2, &result);
if (count == 2) {
/*
* No hexdigits -> This is just "x".
*/
result = 'x';
} else {
/*
* Keep only the last byte (2 hex digits).
*/
result = (unsigned char) result;
}
break;
case 'u':
count += TclParseHex(p+1, (numBytes > 5) ? 4 : numBytes-2, &result);
if (count == 2) {
/*
* No hexdigits -> This is just "u".
*/
result = 'u';
}
break;
case 'U':
count += TclParseHex(p+1, (numBytes > 9) ? 8 : numBytes-2, &result);
if (count == 2) {
/*
* No hexdigits -> This is just "U".
*/
result = 'U';
}
break;
case '\n':
count--;
do {
|
| ︙ | ︙ | |||
963 964 965 966 967 968 969 |
*/
if (Tcl_UtfCharComplete(p, numBytes - 1)) {
count = TclUtfToUniChar(p, &unichar) + 1; /* +1 for '\' */
} else {
char utfBytes[TCL_UTF_MAX];
| | | > > > > > | | | | 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 |
*/
if (Tcl_UtfCharComplete(p, numBytes - 1)) {
count = TclUtfToUniChar(p, &unichar) + 1; /* +1 for '\' */
} else {
char utfBytes[TCL_UTF_MAX];
memcpy(utfBytes, p, numBytes - 1);
utfBytes[numBytes - 1] = '\0';
count = TclUtfToUniChar(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;
}
/*
*----------------------------------------------------------------------
*
* ParseComment --
*
* Scans up to numBytes bytes starting at src, consuming a Tcl comment as
* defined by Tcl's parsing rules.
*
* Results:
* Records in parsePtr information about the parse. Returns the number of
* bytes consumed.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static size_t
ParseComment(
const char *src, /* First character to parse. */
size_t numBytes, /* Max number of bytes to scan. */
Tcl_Parse *parsePtr) /* Information about parse in progress.
* Updated if parsing indicates an incomplete
* command. */
{
register const char *p = src;
int incomplete = parsePtr->incomplete;
while (numBytes) {
size_t scanned = ParseAllWhiteSpace(p, numBytes, &incomplete);
p += scanned;
numBytes -= scanned;
if ((numBytes == 0) || (*p != '#')) {
break;
}
if (parsePtr->commentStart == NULL) {
|
| ︙ | ︙ | |||
1072 1073 1074 1075 1076 1077 1078 |
*
*----------------------------------------------------------------------
*/
static int
ParseTokens(
register const char *src, /* First character to parse. */
| | | 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 |
*
*----------------------------------------------------------------------
*/
static int
ParseTokens(
register const char *src, /* First character to parse. */
size_t numBytes, /* Max number of bytes to scan. */
int mask, /* Specifies when to stop parsing. The parse
* stops at the first unquoted character whose
* CHAR_TYPE contains any of the bits in
* mask. */
int flags, /* OR-ed bits indicating what substitutions to
* perform: TCL_SUBST_COMMANDS,
* TCL_SUBST_VARIABLES, and
|
| ︙ | ︙ | |||
1312 1313 1314 1315 1316 1317 1318 |
void
Tcl_FreeParse(
Tcl_Parse *parsePtr) /* Structure that was filled in by a previous
* call to Tcl_ParseCommand. */
{
if (parsePtr->tokenPtr != parsePtr->staticTokens) {
| | | 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 |
void
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);
parsePtr->tokenPtr = parsePtr->staticTokens;
}
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1350 1351 1352 1353 1354 1355 1356 |
int
Tcl_ParseVarName(
Tcl_Interp *interp, /* Interpreter to use for error reporting; if
* NULL, then no error message is provided. */
const char *start, /* Start of variable substitution string.
* First character must be "$". */
| | | | 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 |
int
Tcl_ParseVarName(
Tcl_Interp *interp, /* Interpreter to use for error reporting; if
* NULL, then no error message is provided. */
const char *start, /* Start of variable substitution string.
* First character must be "$". */
size_t numBytes, /* Total number of bytes in string. If -1,
* the string consists of all bytes up to the
* first null character. */
Tcl_Parse *parsePtr, /* Structure to fill in with information about
* the variable name. */
int append) /* Non-zero means append tokens to existing
* information in parsePtr; zero means ignore
* existing tokens in parsePtr and
* reinitialize it. */
{
Tcl_Token *tokenPtr;
register const char *src;
int varIndex;
unsigned array;
if ((numBytes == 0) || (start == NULL)) {
return TCL_ERROR;
}
if (numBytes == TCL_AUTO_LENGTH) {
numBytes = strlen(start);
}
if (!append) {
TclParseInit(interp, start, numBytes, parsePtr);
}
|
| ︙ | ︙ | |||
1628 1629 1630 1631 1632 1633 1634 |
int
Tcl_ParseBraces(
Tcl_Interp *interp, /* Interpreter to use for error reporting; if
* NULL, then no error message is provided. */
const char *start, /* Start of string enclosed in braces. The
* first character must be {'. */
| | | > | | 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 |
int
Tcl_ParseBraces(
Tcl_Interp *interp, /* Interpreter to use for error reporting; if
* NULL, then no error message is provided. */
const char *start, /* Start of string enclosed in braces. The
* first character must be {'. */
size_t numBytes, /* Total number of bytes in string. If -1,
* the string consists of all bytes up to the
* first null character. */
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
* reinitialize it. */
const char **termPtr) /* If non-NULL, points to word in which to
* store a pointer to the character just after
* the terminating '}' if the parse was
* successful. */
{
Tcl_Token *tokenPtr;
register const char *src;
int startIndex, level;
size_t length;
if ((numBytes == 0) || (start == NULL)) {
return TCL_ERROR;
}
if (numBytes == TCL_AUTO_LENGTH) {
numBytes = strlen(start);
}
if (!append) {
TclParseInit(interp, start, numBytes, parsePtr);
}
|
| ︙ | ︙ | |||
1830 1831 1832 1833 1834 1835 1836 |
int
Tcl_ParseQuotedString(
Tcl_Interp *interp, /* Interpreter to use for error reporting; if
* NULL, then no error message is provided. */
const char *start, /* Start of the quoted string. The first
* character must be '"'. */
| | | | 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 |
int
Tcl_ParseQuotedString(
Tcl_Interp *interp, /* Interpreter to use for error reporting; if
* NULL, then no error message is provided. */
const char *start, /* Start of the quoted string. The first
* character must be '"'. */
size_t numBytes, /* Total number of bytes in string. If -1,
* the string consists of all bytes up to the
* first null character. */
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
* reinitialize it. */
const char **termPtr) /* If non-NULL, points to word in which to
* store a pointer to the character just after
* the quoted string's terminating close-quote
* if the parse succeeds. */
{
if ((numBytes == 0) || (start == NULL)) {
return TCL_ERROR;
}
if (numBytes == TCL_AUTO_LENGTH) {
numBytes = strlen(start);
}
if (!append) {
TclParseInit(interp, start, numBytes, parsePtr);
}
|
| ︙ | ︙ | |||
1912 1913 1914 1915 1916 1917 1918 |
*----------------------------------------------------------------------
*/
void
TclSubstParse(
Tcl_Interp *interp,
const char *bytes,
| | | | 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 |
*----------------------------------------------------------------------
*/
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;
TclParseInit(interp, p, length, parsePtr);
/*
* First parse the string rep of objPtr, as if it were enclosed as a
* "-quoted word in a normal Tcl command. Honor flags that selectively
|
| ︙ | ︙ | |||
2174 2175 2176 2177 2178 2179 2180 |
isLiteral = 0;
break;
}
}
if (isLiteral) {
maxNumCL = NUM_STATIC_POS;
| | | | 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 |
isLiteral = 0;
break;
}
}
if (isLiteral) {
maxNumCL = NUM_STATIC_POS;
clPosition = Tcl_Alloc(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] = "";
switch (tokenPtr->type) {
case TCL_TOKEN_TEXT:
append = tokenPtr->start;
appendByteLength = tokenPtr->size;
break;
|
| ︙ | ︙ | |||
2214 2215 2216 2217 2218 2219 2220 |
* everything, just the number of lines we have to add as
* correction.
*/
if ((appendByteLength == 1) && (utfCharBytes[0] == ' ')
&& (tokenPtr->start[1] == '\n')) {
if (isLiteral) {
| | | | | 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 |
* everything, just the number of lines we have to add as
* correction.
*/
if ((appendByteLength == 1) && (utfCharBytes[0] == ' ')
&& (tokenPtr->start[1] == '\n')) {
if (isLiteral) {
size_t clPos;
if (result == 0) {
clPos = 0;
} else {
(void)TclGetStringFromObj(result, &clPos);
}
if (numCL >= maxNumCL) {
maxNumCL *= 2;
clPosition = Tcl_Realloc(clPosition,
maxNumCL * sizeof(int));
}
clPosition[numCL] = clPos;
numCL++;
}
adjust++;
}
|
| ︙ | ︙ | |||
2382 2383 2384 2385 2386 2387 2388 |
/*
* Release the temp table we used to collect the locations of
* continuation lines, if any.
*/
if (maxNumCL) {
| | | 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 |
/*
* Release the temp table we used to collect the locations of
* continuation lines, if any.
*/
if (maxNumCL) {
Tcl_Free(clPosition);
}
} else {
Tcl_ResetResult(interp);
}
}
if (tokensLeftPtr != NULL) {
*tokensLeftPtr = count;
|
| ︙ | ︙ | |||
2420 2421 2422 2423 2424 2425 2426 |
*
*----------------------------------------------------------------------
*/
static inline int
CommandComplete(
const char *script, /* Script to check. */
| | | 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 |
*
*----------------------------------------------------------------------
*/
static inline int
CommandComplete(
const char *script, /* Script to check. */
size_t numBytes) /* Number of bytes in script. */
{
Tcl_Parse parse;
const char *p, *end;
int result;
p = script;
end = p + numBytes;
|
| ︙ | ︙ | |||
2494 2495 2496 2497 2498 2499 2500 |
*/
int
TclObjCommandComplete(
Tcl_Obj *objPtr) /* Points to object holding script to
* check. */
{
| | | 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 |
*/
int
TclObjCommandComplete(
Tcl_Obj *objPtr) /* Points to object holding script to
* check. */
{
size_t length;
const char *script = TclGetStringFromObj(objPtr, &length);
return CommandComplete(script, length);
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclParse.h.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 | #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 | | | 8 9 10 11 12 13 14 15 16 17 | #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[]; |
Changes to generic/tclPathObj.c.
| ︙ | ︙ | |||
21 22 23 24 25 26 27 | static Tcl_Obj * AppendPath(Tcl_Obj *head, Tcl_Obj *tail); static void DupFsPathInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); static void FreeFsPathInternalRep(Tcl_Obj *pathPtr); static void UpdateStringOfFsPath(Tcl_Obj *pathPtr); static int SetFsPathFromAny(Tcl_Interp *interp, Tcl_Obj *pathPtr); | | | < < < | < < | | | | < < < < | 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 |
static Tcl_Obj * AppendPath(Tcl_Obj *head, Tcl_Obj *tail);
static void DupFsPathInternalRep(Tcl_Obj *srcPtr,
Tcl_Obj *copyPtr);
static void FreeFsPathInternalRep(Tcl_Obj *pathPtr);
static void UpdateStringOfFsPath(Tcl_Obj *pathPtr);
static int SetFsPathFromAny(Tcl_Interp *interp, Tcl_Obj *pathPtr);
static size_t FindSplitPos(const char *path, int separator);
static int IsSeparatorOrNull(int ch);
static Tcl_Obj * GetExtension(Tcl_Obj *pathPtr);
static int MakePathFromNormalized(Tcl_Interp *interp,
Tcl_Obj *pathPtr);
/*
* Define the 'path' object type, which Tcl uses to represent file paths
* internally.
*/
static const Tcl_ObjType fsPathType = {
"path", /* name */
FreeFsPathInternalRep, /* freeIntRepProc */
DupFsPathInternalRep, /* dupIntRepProc */
UpdateStringOfFsPath, /* updateStringProc */
SetFsPathFromAny /* setFromAnyProc */
};
/*
* struct FsPath --
*
* 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.
*
* There are two cases, with the first being the most common:
*
* (i) flags == 0, => Ordinary path.
*
* translatedPathPtr contains the translated path. If it is NULL then the path
* is pure normalized. 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; /* 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. */
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. */
|
| ︙ | ︙ | |||
106 107 108 109 110 111 112 | #define TCLPATH_NEEDNORM 4 /* * Define some macros to give us convenient access to path-object specific * fields. */ | | > > | > > > | 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 |
#define TCLPATH_NEEDNORM 4
/*
* Define some macros to give us convenient access to path-object specific
* fields.
*/
#define PATHOBJ(pathPtr) ((FsPath *) (TclFetchIntRep((pathPtr), &fsPathType)->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)
#define PATHFLAGS(pathPtr) (PATHOBJ(pathPtr)->flags)
/*
*---------------------------------------------------------------------------
*
* TclFSNormalizeAbsolutePath --
*
|
| ︙ | ︙ | |||
221 222 223 224 225 226 227 |
oldDirSep = dirSep;
}
again:
if (IsSeparatorOrNull(dirSep[2])) {
/*
* Need to skip '.' in the path.
*/
| | | | | | 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 |
oldDirSep = dirSep;
}
again:
if (IsSeparatorOrNull(dirSep[2])) {
/*
* Need to skip '.' in the path.
*/
size_t curLen;
if (retVal == NULL) {
const char *path = TclGetString(pathPtr);
retVal = Tcl_NewStringObj(path, dirSep - path);
Tcl_IncrRefCount(retVal);
}
(void)TclGetStringFromObj(retVal, &curLen);
if (curLen == 0) {
Tcl_AppendToObj(retVal, dirSep, 1);
}
dirSep += 2;
oldDirSep = dirSep;
if (dirSep[0] != 0 && dirSep[1] == '.') {
goto again;
}
continue;
}
if (dirSep[2] == '.' && IsSeparatorOrNull(dirSep[3])) {
Tcl_Obj *linkObj;
size_t curLen;
char *linkStr;
/*
* Have '..' so need to skip previous directory.
*/
if (retVal == NULL) {
const char *path = TclGetString(pathPtr);
retVal = Tcl_NewStringObj(path, dirSep - path);
Tcl_IncrRefCount(retVal);
}
(void)TclGetStringFromObj(retVal, &curLen);
if (curLen == 0) {
Tcl_AppendToObj(retVal, dirSep, 1);
}
if (!first || (tclPlatform == TCL_PLATFORM_UNIX)) {
linkObj = Tcl_FSLink(retVal, NULL, 0);
/* Safety check in case driver caused sharing */
|
| ︙ | ︙ | |||
287 288 289 290 291 292 293 | * to retVal's directory. This means concatenating * the link onto the directory of the path so far. */ const char *path = TclGetStringFromObj(retVal, &curLen); | | | 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 |
* to retVal's directory. This means concatenating
* the link onto the directory of the path so far.
*/
const char *path =
TclGetStringFromObj(retVal, &curLen);
while (curLen-- > 0) {
if (IsSeparatorOrNull(path[curLen])) {
break;
}
}
/*
* We want the trailing slash.
|
| ︙ | ︙ | |||
320 321 322 323 324 325 326 |
linkStr = TclGetStringFromObj(retVal, &curLen);
/*
* Convert to forward-slashes on windows.
*/
if (tclPlatform == TCL_PLATFORM_WINDOWS) {
| | | | 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 |
linkStr = TclGetStringFromObj(retVal, &curLen);
/*
* Convert to forward-slashes on windows.
*/
if (tclPlatform == TCL_PLATFORM_WINDOWS) {
size_t i;
for (i = 0; i < curLen; i++) {
if (linkStr[i] == '\\') {
linkStr[i] = '/';
}
}
}
}
} else {
linkStr = TclGetStringFromObj(retVal, &curLen);
}
/*
* Either way, we now remove the last path element (but
* not the first character of the path).
*/
while (curLen-- > 0) {
if (IsSeparatorOrNull(linkStr[curLen])) {
if (curLen) {
Tcl_SetObjLength(retVal, curLen);
} else {
Tcl_SetObjLength(retVal, 1);
}
break;
|
| ︙ | ︙ | |||
400 401 402 403 404 405 406 |
}
/*
* Ensure a windows drive like C:/ has a trailing separator.
*/
if (tclPlatform == TCL_PLATFORM_WINDOWS) {
| | | 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 |
}
/*
* Ensure a windows drive like C:/ has a trailing separator.
*/
if (tclPlatform == TCL_PLATFORM_WINDOWS) {
size_t len;
const char *path = TclGetStringFromObj(retVal, &len);
if (len == 2 && path[0] != 0 && path[1] == ':') {
if (Tcl_IsShared(retVal)) {
TclDecrRefCount(retVal);
retVal = Tcl_DuplicateObj(retVal);
Tcl_IncrRefCount(retVal);
|
| ︙ | ︙ | |||
560 561 562 563 564 565 566 |
Tcl_Obj *
TclPathPart(
Tcl_Interp *interp, /* Used for error reporting */
Tcl_Obj *pathPtr, /* Path to take dirname of */
Tcl_PathPart portion) /* Requested portion of name */
{
| | | < | | 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 |
Tcl_Obj *
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)) {
FsPath *fsPathPtr = PATHOBJ(pathPtr);
if (PATHFLAGS(pathPtr) != 0) {
switch (portion) {
case TCL_PATH_DIRNAME: {
/*
* Check if the joined-on bit has any directory delimiters in
* it. If so, the 'dirname' would be a joining of the main
* part with the dirname of the joined-on bit. We could handle
* that special case here, but we don't, and instead just use
* the standardPath code.
*/
size_t numBytes;
const char *rest = TclGetStringFromObj(fsPathPtr->normPathPtr, &numBytes);
if (strchr(rest, '/') != NULL) {
goto standardPath;
}
/*
* If the joined-on bit is empty, then [file dirname] is
* documented to return all but the last non-empty element
|
| ︙ | ︙ | |||
612 613 614 615 616 617 618 | /* * Check if the joined-on bit has any directory delimiters in * it. If so, the 'tail' would be only the part following the * last delimiter. We could handle that special case here, but * we don't, and instead just use the standardPath code. */ | | < | | 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 |
/*
* Check if the joined-on bit has any directory delimiters in
* it. If so, the 'tail' would be only the part following the
* last delimiter. We could handle that special case here, but
* we don't, and instead just use the standardPath code.
*/
size_t numBytes;
const char *rest = TclGetStringFromObj(fsPathPtr->normPathPtr, &numBytes);
if (strchr(rest, '/') != NULL) {
goto standardPath;
}
/*
* If the joined-on bit is empty, then [file tail] is
* documented to return the last non-empty element
|
| ︙ | ︙ | |||
641 642 643 644 645 646 647 |
Tcl_IncrRefCount(fsPathPtr->normPathPtr);
return fsPathPtr->normPathPtr;
}
case TCL_PATH_EXTENSION:
return GetExtension(fsPathPtr->normPathPtr);
case TCL_PATH_ROOT: {
const char *fileName, *extension;
| | | 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 |
Tcl_IncrRefCount(fsPathPtr->normPathPtr);
return fsPathPtr->normPathPtr;
}
case TCL_PATH_EXTENSION:
return GetExtension(fsPathPtr->normPathPtr);
case TCL_PATH_ROOT: {
const char *fileName, *extension;
size_t length;
fileName = TclGetStringFromObj(fsPathPtr->normPathPtr,
&length);
extension = TclGetExtension(fileName);
if (extension == NULL) {
/*
* There is no extension so the root is the same as the
|
| ︙ | ︙ | |||
664 665 666 667 668 669 670 | * suffix removed. Do that by joining our "head" to * our "tail" with the extension suffix removed from * the tail. */ Tcl_Obj *resultPtr = TclNewFSPathObj(fsPathPtr->cwdPtr, fileName, | | | 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 | * suffix removed. Do that by joining our "head" to * our "tail" with the extension suffix removed from * the tail. */ Tcl_Obj *resultPtr = TclNewFSPathObj(fsPathPtr->cwdPtr, fileName, length - strlen(extension)); Tcl_IncrRefCount(resultPtr); return resultPtr; } } default: /* We should never get here */ |
| ︙ | ︙ | |||
692 693 694 695 696 697 698 |
Tcl_Obj *splitPtr, *resultPtr;
standardPath:
resultPtr = NULL;
if (portion == TCL_PATH_EXTENSION) {
return GetExtension(pathPtr);
} else if (portion == TCL_PATH_ROOT) {
| | | | 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 |
Tcl_Obj *splitPtr, *resultPtr;
standardPath:
resultPtr = NULL;
if (portion == TCL_PATH_EXTENSION) {
return GetExtension(pathPtr);
} else if (portion == TCL_PATH_ROOT) {
size_t length;
const char *fileName, *extension;
fileName = TclGetStringFromObj(pathPtr, &length);
extension = TclGetExtension(fileName);
if (extension == NULL) {
Tcl_IncrRefCount(pathPtr);
return pathPtr;
} else {
Tcl_Obj *root = Tcl_NewStringObj(fileName,
length - strlen(extension));
Tcl_IncrRefCount(root);
return root;
}
}
/*
|
| ︙ | ︙ | |||
825 826 827 828 829 830 831 |
Tcl_Obj *
Tcl_FSJoinPath(
Tcl_Obj *listObj, /* Path elements to join, may have a zero
* reference count. */
int elements) /* Number of elements to use (-1 = all) */
{
| | < | < | | > > > | | | | > > > | | 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 |
Tcl_Obj *
Tcl_FSJoinPath(
Tcl_Obj *listObj, /* Path elements to join, may have a zero
* reference count. */
int elements) /* Number of elements to use (-1 = all) */
{
Tcl_Obj *res;
int objc;
Tcl_Obj **objv;
if (Tcl_ListObjLength(NULL, listObj, &objc) != TCL_OK) {
return NULL;
}
elements = ((elements >= 0) && (elements <= objc)) ? elements : objc;
Tcl_ListObjGetElements(NULL, listObj, &objc, &objv);
res = TclJoinPath(elements, objv, 0);
return res;
}
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;
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);
/*
* 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 for that elt is absolute.
*/
if ((eltIr)
&& !((elt->bytes != NULL) && (elt->bytes[0] == '\0'))
&& TclGetPathType(elt, NULL, NULL, NULL) == TCL_PATH_ABSOLUTE) {
Tcl_Obj *tailObj = objv[1];
Tcl_PathType type;
/* if forceRelative - second path is relative */
type = forceRelative ? TCL_PATH_RELATIVE :
TclGetPathType(tailObj, NULL, NULL, NULL);
if (type == TCL_PATH_RELATIVE) {
const char *str;
size_t len;
str = TclGetStringFromObj(tailObj, &len);
if (len == 0) {
/*
* This happens if we try to handle the root volume '/'.
* There's no need to return a special path object, when
* the base itself is just fine!
|
| ︙ | ︙ | |||
912 913 914 915 916 917 918 | /* * Finally, on Windows, 'file join' is defined to convert * all backslashes to forward slashes, so the base part * cannot have backslashes either. */ if ((tclPlatform != TCL_PLATFORM_WINDOWS) | | | 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 |
/*
* Finally, on Windows, 'file join' is defined to convert
* all backslashes to forward slashes, so the base part
* cannot have backslashes either.
*/
if ((tclPlatform != TCL_PLATFORM_WINDOWS)
|| (strchr(TclGetString(elt), '\\') == NULL)) {
if (PATHFLAGS(elt)) {
return TclNewFSPathObj(elt, str, len);
}
if (TCL_PATH_ABSOLUTE != Tcl_FSGetPathType(elt)) {
return TclNewFSPathObj(elt, str, len);
}
|
| ︙ | ︙ | |||
948 949 950 951 952 953 954 |
}
}
}
assert ( res == NULL );
for (i = 0; i < elements; i++) {
| | > > > | | 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 |
}
}
}
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);
driveNameLength = 0;
/* if forceRelative - all paths excepting first one are relative */
type = (forceRelative && (i > 0)) ? TCL_PATH_RELATIVE :
TclGetPathType(elt, &fsPtr, &driveNameLength, &driveName);
if (type != TCL_PATH_RELATIVE) {
/*
* Zero out the current result.
*/
if (res != NULL) {
TclDecrRefCount(res);
|
| ︙ | ︙ | |||
1094 1095 1096 1097 1098 1099 1100 |
res = Tcl_DuplicateObj(res);
Tcl_IncrRefCount(res);
}
}
if (length > 0 && ptr[length -1] != '/') {
Tcl_AppendToObj(res, &separator, 1);
| | | | 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 |
res = Tcl_DuplicateObj(res);
Tcl_IncrRefCount(res);
}
}
if (length > 0 && ptr[length -1] != '/') {
Tcl_AppendToObj(res, &separator, 1);
(void)TclGetStringFromObj(res, &length);
}
Tcl_SetObjLength(res, length + strlen(strElt));
ptr = TclGetString(res) + length;
for (; *strElt != '\0'; strElt++) {
if (*strElt == separator) {
while (strElt[1] == separator) {
strElt++;
}
|
| ︙ | ︙ | |||
1160 1161 1162 1163 1164 1165 1166 |
* converting this object to FsPath type for the first time, we don't need
* to worry whether the 'cwd' has changed. On the other hand, if this
* 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.
*/
| | < | < | < < < < < < < < < < < < < < < < < < < < < | 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 |
* converting this object to FsPath type for the first time, we don't need
* to worry whether the 'cwd' has changed. On the other hand, if this
* 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 (TclFSEpochOk(PATHOBJ(pathPtr)->filesystemEpoch)) {
return TCL_OK;
}
TclGetString(pathPtr);
Tcl_StoreIntRep(pathPtr, &fsPathType, NULL);
}
return SetFsPathFromAny(interp, pathPtr);
}
/*
* Helper function for normalization.
*/
static int
|
| ︙ | ︙ | |||
1221 1222 1223 1224 1225 1226 1227 | /* * 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. */ | | | 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 |
/*
* 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
FindSplitPos(
const char *path,
int separator)
{
int count = 0;
switch (tclPlatform) {
case TCL_PLATFORM_UNIX:
|
| ︙ | ︙ | |||
1275 1276 1277 1278 1279 1280 1281 |
*---------------------------------------------------------------------------
*/
Tcl_Obj *
TclNewFSPathObj(
Tcl_Obj *dirPtr,
const char *addStrRep,
| | | 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 |
*---------------------------------------------------------------------------
*/
Tcl_Obj *
TclNewFSPathObj(
Tcl_Obj *dirPtr,
const char *addStrRep,
size_t len)
{
FsPath *fsPathPtr;
Tcl_Obj *pathPtr;
const char *p;
int state = 0, count = 0;
/* [Bug 2806250] - this is only a partial solution of the problem.
|
| ︙ | ︙ | |||
1307 1308 1309 1310 1311 1312 1313 |
pathPtr = AppendPath(dirPtr, tail);
Tcl_DecrRefCount(tail);
return pathPtr;
}
pathPtr = Tcl_NewObj();
| | < < | | | > | 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 |
pathPtr = AppendPath(dirPtr, tail);
Tcl_DecrRefCount(tail);
return pathPtr;
}
pathPtr = Tcl_NewObj();
fsPathPtr = Tcl_Alloc(sizeof(FsPath));
/*
* Set up the path.
*/
fsPathPtr->translatedPathPtr = NULL;
fsPathPtr->normPathPtr = Tcl_NewStringObj(addStrRep, len);
Tcl_IncrRefCount(fsPathPtr->normPathPtr);
fsPathPtr->cwdPtr = dirPtr;
Tcl_IncrRefCount(dirPtr);
fsPathPtr->nativePathPtr = NULL;
fsPathPtr->fsPtr = NULL;
fsPathPtr->filesystemEpoch = 0;
SETPATHOBJ(pathPtr, fsPathPtr);
PATHFLAGS(pathPtr) = TCLPATH_APPENDED;
TclInvalidateStringRep(pathPtr);
/*
* Look for path components made up of only "."
* This is overly conservative analysis to keep simple. It may mark some
* things as needing more aggressive normalization that don't actually
* need it. No harm done.
*/
for (p = addStrRep; len+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;
|
| ︙ | ︙ | |||
1375 1376 1377 1378 1379 1380 1381 |
}
static Tcl_Obj *
AppendPath(
Tcl_Obj *head,
Tcl_Obj *tail)
{
| < > | | | 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 |
}
static Tcl_Obj *
AppendPath(
Tcl_Obj *head,
Tcl_Obj *tail)
{
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.
*/
bytes = TclGetStringFromObj(tail, &length);
if (length == 0) {
Tcl_AppendToObj(copy, "/", 1);
} else {
TclpNativeJoinPath(copy, bytes);
}
return copy;
}
|
| ︙ | ︙ | |||
1424 1425 1426 1427 1428 1429 1430 |
Tcl_Obj *
TclFSMakePathRelative(
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. */
{
| | > | | 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 |
Tcl_Obj *
TclFSMakePathRelative(
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;
const char *tempStr;
Tcl_ObjIntRep *irPtr = TclFetchIntRep(pathPtr, &fsPathType);
if (irPtr) {
FsPath *fsPathPtr = PATHOBJ(pathPtr);
if (PATHFLAGS(pathPtr) != 0 && fsPathPtr->cwdPtr == cwdPtr) {
return fsPathPtr->normPathPtr;
}
}
|
| ︙ | ︙ | |||
1495 1496 1497 1498 1499 1500 1501 |
static int
MakePathFromNormalized(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *pathPtr) /* The object to convert. */
{
FsPath *fsPathPtr;
| < < < | < < < < < < < < < < < < < | | < | < < < | < < < < | < | | 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 |
static int
MakePathFromNormalized(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *pathPtr) /* The object to convert. */
{
FsPath *fsPathPtr;
if (TclHasIntRep(pathPtr, &fsPathType)) {
return TCL_OK;
}
fsPathPtr = Tcl_Alloc(sizeof(FsPath));
/*
* It's a pure normalized absolute path.
*/
fsPathPtr->translatedPathPtr = NULL;
Tcl_IncrRefCount(fsPathPtr->normPathPtr = Tcl_DuplicateObj(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;
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_FSNewNativePath --
*
* 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.
*
* Results:
* NULL or a valid path object pointer, with refCount zero.
*
* Side effects:
* New memory may be allocated.
*
|
| ︙ | ︙ | |||
1591 1592 1593 1594 1595 1596 1597 |
}
/*
* Free old representation; shouldn't normally be any, but best to be
* safe.
*/
| < < < < < < < | < < | < < < < | < | 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 |
}
/*
* Free old representation; shouldn't normally be any, but best to be
* safe.
*/
Tcl_StoreIntRep(pathPtr, &fsPathType, NULL);
fsPathPtr = Tcl_Alloc(sizeof(FsPath));
fsPathPtr->translatedPathPtr = NULL;
Tcl_IncrRefCount(fsPathPtr->normPathPtr = Tcl_DuplicateObj(pathPtr));
fsPathPtr->cwdPtr = NULL;
fsPathPtr->nativePathPtr = clientData;
fsPathPtr->fsPtr = fromFilesystem;
fsPathPtr->filesystemEpoch = TclFSEpoch();
SETPATHOBJ(pathPtr, fsPathPtr);
PATHFLAGS(pathPtr) = 0;
return pathPtr;
}
/*
*---------------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 |
* (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);
if (translatedCwdPtr == NULL) {
return NULL;
}
retObj = Tcl_FSJoinToPath(translatedCwdPtr, 1,
&srcFsPathPtr->normPathPtr);
| > > | > | < | 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 |
* (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->filesystemEpoch
= PATHOBJ(translatedCwdPtr)->filesystemEpoch;
} else {
srcFsPathPtr->filesystemEpoch = 0;
}
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.
*/
|
| ︙ | ︙ | |||
1729 1730 1731 1732 1733 1734 1735 |
Tcl_FSGetTranslatedStringPath(
Tcl_Interp *interp,
Tcl_Obj *pathPtr)
{
Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(interp, pathPtr);
if (transPtr != NULL) {
| | | | | 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 |
Tcl_FSGetTranslatedStringPath(
Tcl_Interp *interp,
Tcl_Obj *pathPtr)
{
Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(interp, pathPtr);
if (transPtr != NULL) {
size_t len;
const char *orig = TclGetStringFromObj(transPtr, &len);
char *result = Tcl_Alloc(len+1);
memcpy(result, orig, len+1);
TclDecrRefCount(transPtr);
return result;
}
return NULL;
}
|
| ︙ | ︙ | |||
1779 1780 1781 1782 1783 1784 1785 |
if (PATHFLAGS(pathPtr) != 0) {
/*
* This is a special path object which is the result of something like
* 'file join'
*/
Tcl_Obj *dir, *copy;
| | > < | | < | | 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 |
if (PATHFLAGS(pathPtr) != 0) {
/*
* 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;
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);
(void)TclGetStringFromObj(fsPathPtr->normPathPtr, &tailLen);
if (tailLen) {
copy = AppendPath(dir, fsPathPtr->normPathPtr);
} else {
copy = Tcl_DuplicateObj(dir);
}
Tcl_IncrRefCount(dir);
Tcl_IncrRefCount(copy);
|
| ︙ | ︙ | |||
1841 1842 1843 1844 1845 1846 1847 |
/* Now we need to construct the new path object. */
if (pathType == TCL_PATH_RELATIVE) {
Tcl_Obj *origDir = fsPathPtr->cwdPtr;
/*
* NOTE: here we are (dangerously?) assuming that origDir points
| | > | < | < | | | < | 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 |
/* Now we need to construct the new path object. */
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
* 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.
*/
FsPath *origDirFsPathPtr = PATHOBJ(origDir);
fsPathPtr->cwdPtr = origDirFsPathPtr->cwdPtr;
Tcl_IncrRefCount(fsPathPtr->cwdPtr);
TclDecrRefCount(fsPathPtr->normPathPtr);
fsPathPtr->normPathPtr = copy;
/*
* That's our reference to copy used.
*/
copy = NULL;
TclDecrRefCount(dir);
TclDecrRefCount(origDir);
} else {
TclDecrRefCount(fsPathPtr->cwdPtr);
fsPathPtr->cwdPtr = NULL;
TclDecrRefCount(fsPathPtr->normPathPtr);
fsPathPtr->normPathPtr = copy;
/*
* That's our reference to copy used.
*/
copy = NULL;
TclDecrRefCount(dir);
}
PATHFLAGS(pathPtr) = 0;
}
/*
* Ensure cwd hasn't changed.
*/
if (fsPathPtr->cwdPtr != NULL) {
if (!TclFSCwdPointerEquals(&fsPathPtr->cwdPtr)) {
TclGetString(pathPtr);
Tcl_StoreIntRep(pathPtr, &fsPathType, NULL);
if (SetFsPathFromAny(interp, pathPtr) != TCL_OK) {
return NULL;
}
fsPathPtr = PATHOBJ(pathPtr);
} else if (fsPathPtr->normPathPtr == NULL) {
size_t cwdLen;
Tcl_Obj *copy;
copy = AppendPath(fsPathPtr->cwdPtr, pathPtr);
(void) TclGetStringFromObj(fsPathPtr->cwdPtr, &cwdLen);
cwdLen += (TclGetString(copy)[cwdLen] == '/');
/*
* Normalize the combined string, but only starting after the end
* of the previously normalized 'dir'. This should be much faster!
*/
TclFSNormalizeToUniquePath(interp, copy, cwdLen-1);
fsPathPtr->normPathPtr = copy;
Tcl_IncrRefCount(fsPathPtr->normPathPtr);
}
}
if (fsPathPtr->normPathPtr == NULL) {
Tcl_Obj *useThisCwd = NULL;
/*
* Since normPathPtr is NULL, but this is a valid path object, we know
* that the translatedPathPtr cannot be NULL.
*/
Tcl_Obj *absolutePath = fsPathPtr->translatedPathPtr;
|
| ︙ | ︙ | |||
1962 1963 1964 1965 1966 1967 1968 |
if (type == TCL_PATH_RELATIVE) {
useThisCwd = Tcl_FSGetCwd(interp);
if (useThisCwd == NULL) {
return NULL;
}
| < < | < < < < < < < < < < < < < < < < < < | | < < < < < | > | < | 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 |
if (type == TCL_PATH_RELATIVE) {
useThisCwd = Tcl_FSGetCwd(interp);
if (useThisCwd == NULL) {
return NULL;
}
Tcl_DecrRefCount(absolutePath);
absolutePath = Tcl_FSJoinToPath(useThisCwd, 1, &absolutePath);
Tcl_IncrRefCount(absolutePath);
/*
* We have a refCount on the cwd.
*/
#ifdef _WIN32
} else if (type == TCL_PATH_VOLUME_RELATIVE) {
/*
* Only Windows has volume-relative paths.
*/
Tcl_DecrRefCount(absolutePath);
absolutePath = TclWinVolumeRelativeNormalize(interp,
path, &useThisCwd);
if (absolutePath == NULL) {
return NULL;
}
#endif /* _WIN32 */
}
}
/*
* Already has refCount incremented.
*/
if (fsPathPtr->normPathPtr) {
Tcl_DecrRefCount(fsPathPtr->normPathPtr);
}
fsPathPtr->normPathPtr = TclFSNormalizeAbsolutePath(interp,
absolutePath);
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.
*/
|
| ︙ | ︙ | |||
2166 2167 2168 2169 2170 2171 2172 |
int
TclFSEnsureEpochOk(
Tcl_Obj *pathPtr,
const Tcl_Filesystem **fsPtrPtr)
{
FsPath *srcFsPathPtr;
| | < | < | | 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 |
int
TclFSEnsureEpochOk(
Tcl_Obj *pathPtr,
const Tcl_Filesystem **fsPtrPtr)
{
FsPath *srcFsPathPtr;
if (!TclHasIntRep(pathPtr, &fsPathType)) {
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)) {
/*
* We have to discard the stale representation and recalculate it.
*/
TclGetString(pathPtr);
Tcl_StoreIntRep(pathPtr, &fsPathType, NULL);
if (SetFsPathFromAny(NULL, pathPtr) != TCL_OK) {
return TCL_ERROR;
}
srcFsPathPtr = PATHOBJ(pathPtr);
}
/*
|
| ︙ | ︙ | |||
2230 2231 2232 2233 2234 2235 2236 |
{
FsPath *srcFsPathPtr;
/*
* Make sure pathPtr is of the correct type.
*/
| | | 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 |
{
FsPath *srcFsPathPtr;
/*
* Make sure pathPtr is of the correct type.
*/
if (!TclHasIntRep(pathPtr, &fsPathType)) {
if (SetFsPathFromAny(NULL, pathPtr) != TCL_OK) {
return;
}
}
srcFsPathPtr = PATHOBJ(pathPtr);
srcFsPathPtr->fsPtr = fsPtr;
|
| ︙ | ︙ | |||
2265 2266 2267 2268 2269 2270 2271 |
int
Tcl_FSEqualPaths(
Tcl_Obj *firstPtr,
Tcl_Obj *secondPtr)
{
const char *firstStr, *secondStr;
| | > | 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 |
int
Tcl_FSEqualPaths(
Tcl_Obj *firstPtr,
Tcl_Obj *secondPtr)
{
const char *firstStr, *secondStr;
size_t firstLen, secondLen;
int tempErrno;
if (firstPtr == secondPtr) {
return 1;
}
if (firstPtr == NULL || secondPtr == NULL) {
return 0;
|
| ︙ | ︙ | |||
2324 2325 2326 2327 2328 2329 2330 |
*/
static int
SetFsPathFromAny(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *pathPtr) /* The object to convert. */
{
| | | | 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 |
*/
static int
SetFsPathFromAny(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *pathPtr) /* The object to convert. */
{
size_t len;
FsPath *fsPathPtr;
Tcl_Obj *transPtr;
char *name;
if (TclHasIntRep(pathPtr, &fsPathType)) {
return TCL_OK;
}
/*
* First step is to translate the filename. This is similar to
* Tcl_TranslateFilename, but shouldn't convert everything to windows
* backslashes on that platform. The current implementation of this piece
|
| ︙ | ︙ | |||
2353 2354 2355 2356 2357 2358 2359 |
name = TclGetStringFromObj(pathPtr, &len);
/*
* Handle tilde substitutions, if needed.
*/
| | | < < | | > | | < < | | < < < < > > > > > > > | | > < < < < | < | 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 |
name = TclGetStringFromObj(pathPtr, &len);
/*
* Handle tilde substitutions, if needed.
*/
if (len && name[0] == '~') {
Tcl_DString temp;
size_t split;
char separator = '/';
/*
* We have multiple cases '~/foo/bar...', '~user/foo/bar...', etc.
* split becomes value 1 for '~/...' as well as for '~'.
*/
split = FindSplitPos(name, separator);
/*
* Do some tilde substitution.
*/
if (split == 1) {
/*
* We have just '~' (or '~/...')
*/
const char *dir;
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);
}
return TCL_ERROR;
}
Tcl_DStringInit(&temp);
Tcl_JoinPath(1, &dir, &temp);
Tcl_DStringFree(&dirString);
} else {
/*
* 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_DStringFree(&userName);
Tcl_DStringFree(&temp);
return TCL_ERROR;
}
Tcl_DStringFree(&userName);
}
transPtr = TclDStringToObj(&temp);
if (split != len) {
/*
* Join up the tilde substitution with the rest.
|
| ︙ | ︙ | |||
2447 2448 2449 2450 2451 2452 2453 |
/*
* Skip '~'. It's replaced by its expansion.
*/
objc--; objv++;
while (objc--) {
| | > | > | > > | > | | < | | < | | > > < < < < < < | 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 |
/*
* Skip '~'. It's replaced by its expansion.
*/
objc--; objv++;
while (objc--) {
TclpNativeJoinPath(transPtr, TclGetString(*objv));
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]);
}
if (transPtr != pair[1]) {
Tcl_DecrRefCount(pair[1]);
}
}
}
} 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 = Tcl_Alloc(sizeof(FsPath));
if (transPtr == pathPtr) {
transPtr = Tcl_DuplicateObj(pathPtr);
fsPathPtr->filesystemEpoch = 0;
} else {
fsPathPtr->filesystemEpoch = TclFSEpoch();
}
Tcl_IncrRefCount(transPtr);
fsPathPtr->translatedPathPtr = transPtr;
fsPathPtr->normPathPtr = NULL;
fsPathPtr->cwdPtr = NULL;
fsPathPtr->nativePathPtr = NULL;
fsPathPtr->fsPtr = NULL;
SETPATHOBJ(pathPtr, fsPathPtr);
PATHFLAGS(pathPtr) = 0;
return TCL_OK;
}
static void
FreeFsPathInternalRep(
Tcl_Obj *pathPtr) /* Path object with internal rep to free. */
{
|
| ︙ | ︙ | |||
2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 |
if (fsPathPtr->normPathPtr != pathPtr) {
TclDecrRefCount(fsPathPtr->normPathPtr);
}
fsPathPtr->normPathPtr = NULL;
}
if (fsPathPtr->cwdPtr != NULL) {
TclDecrRefCount(fsPathPtr->cwdPtr);
}
if (fsPathPtr->nativePathPtr != NULL && fsPathPtr->fsPtr != NULL) {
Tcl_FSFreeInternalRepProc *freeProc =
fsPathPtr->fsPtr->freeInternalRepProc;
if (freeProc != NULL) {
freeProc(fsPathPtr->nativePathPtr);
fsPathPtr->nativePathPtr = NULL;
}
}
| > | < | < < < < | | | | | < < < < < | | | < | 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 |
if (fsPathPtr->normPathPtr != pathPtr) {
TclDecrRefCount(fsPathPtr->normPathPtr);
}
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);
fsPathPtr->nativePathPtr = NULL;
}
}
Tcl_Free(fsPathPtr);
}
static void
DupFsPathInternalRep(
Tcl_Obj *srcPtr, /* Path obj with internal rep to copy. */
Tcl_Obj *copyPtr) /* Path obj with internal rep to set. */
{
FsPath *srcFsPathPtr = PATHOBJ(srcPtr);
FsPath *copyFsPathPtr = Tcl_Alloc(sizeof(FsPath));
SETPATHOBJ(copyPtr, copyFsPathPtr);
copyFsPathPtr->translatedPathPtr = srcFsPathPtr->translatedPathPtr;
if (copyFsPathPtr->translatedPathPtr != NULL) {
Tcl_IncrRefCount(copyFsPathPtr->translatedPathPtr);
}
copyFsPathPtr->normPathPtr = srcFsPathPtr->normPathPtr;
if (copyFsPathPtr->normPathPtr != NULL) {
Tcl_IncrRefCount(copyFsPathPtr->normPathPtr);
}
copyFsPathPtr->cwdPtr = srcFsPathPtr->cwdPtr;
if (copyFsPathPtr->cwdPtr != NULL) {
Tcl_IncrRefCount(copyFsPathPtr->cwdPtr);
}
|
| ︙ | ︙ | |||
2582 2583 2584 2585 2586 2587 2588 |
copyFsPathPtr->nativePathPtr = NULL;
}
} else {
copyFsPathPtr->nativePathPtr = NULL;
}
copyFsPathPtr->fsPtr = srcFsPathPtr->fsPtr;
copyFsPathPtr->filesystemEpoch = srcFsPathPtr->filesystemEpoch;
| < < | 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 |
copyFsPathPtr->nativePathPtr = NULL;
}
} else {
copyFsPathPtr->nativePathPtr = NULL;
}
copyFsPathPtr->fsPtr = srcFsPathPtr->fsPtr;
copyFsPathPtr->filesystemEpoch = srcFsPathPtr->filesystemEpoch;
}
/*
*---------------------------------------------------------------------------
*
* UpdateStringOfFsPath --
*
|
| ︙ | ︙ | |||
2607 2608 2609 2610 2611 2612 2613 |
*/
static void
UpdateStringOfFsPath(
register Tcl_Obj *pathPtr) /* path obj with string rep to update. */
{
FsPath *fsPathPtr = PATHOBJ(pathPtr);
| | > > | > > > | < | 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 |
*/
static void
UpdateStringOfFsPath(
register Tcl_Obj *pathPtr) /* path obj with string rep to update. */
{
FsPath *fsPathPtr = PATHOBJ(pathPtr);
size_t 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->length = cwdLen;
TclInitStringRep(copy, NULL, 0);
TclDecrRefCount(copy);
}
/*
*---------------------------------------------------------------------------
*
* TclNativePathInFilesystem --
|
| ︙ | ︙ | |||
2656 2657 2658 2659 2660 2661 2662 |
/*
* 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.
*/
| | | | | 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 |
/*
* 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->bytes != NULL && pathPtr->bytes[0] == '\0') {
/*
* We reject the empty path "".
*/
return -1;
}
/*
* 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
* situation.
*/
size_t len;
(void) TclGetStringFromObj(pathPtr, &len);
if (len == 0) {
/*
* We reject the empty path "".
*/
|
| ︙ | ︙ |
Changes to generic/tclPipe.c.
| ︙ | ︙ | |||
184 185 186 187 188 189 190 |
Tcl_Pid *pidPtr) /* Array of pids to detach. */
{
register Detached *detPtr;
int i;
Tcl_MutexLock(&pipeMutex);
for (i = 0; i < numPids; i++) {
| | | 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 |
Tcl_Pid *pidPtr) /* Array of pids to detach. */
{
register Detached *detPtr;
int i;
Tcl_MutexLock(&pipeMutex);
for (i = 0; i < numPids; i++) {
detPtr = Tcl_Alloc(sizeof(Detached));
detPtr->pid = pidPtr[i];
detPtr->nextPtr = detList;
detList = detPtr;
}
Tcl_MutexUnlock(&pipeMutex);
}
|
| ︙ | ︙ | |||
234 235 236 237 238 239 240 |
}
nextPtr = detPtr->nextPtr;
if (prevPtr == NULL) {
detList = detPtr->nextPtr;
} else {
prevPtr->nextPtr = detPtr->nextPtr;
}
| | | 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 |
}
nextPtr = detPtr->nextPtr;
if (prevPtr == NULL) {
detList = detPtr->nextPtr;
} else {
prevPtr->nextPtr = detPtr->nextPtr;
}
Tcl_Free(detPtr);
detPtr = nextPtr;
}
Tcl_MutexUnlock(&pipeMutex);
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
329 330 331 332 333 334 335 |
* Make sure we start at the beginning of the file.
*/
if (interp != NULL) {
int count;
Tcl_Obj *objPtr;
| | | | 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 |
* Make sure we start at the beginning of the file.
*/
if (interp != NULL) {
int count;
Tcl_Obj *objPtr;
Tcl_Seek(errorChan, 0, SEEK_SET);
objPtr = Tcl_NewObj();
count = Tcl_ReadChars(errorChan, objPtr, -1, 0);
if (count == -1) {
result = TCL_ERROR;
Tcl_DecrRefCount(objPtr);
Tcl_ResetResult(interp);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"error reading stderr output file: %s",
Tcl_PosixError(interp)));
} else if (count > 0) {
|
| ︙ | ︙ | |||
820 821 822 823 824 825 826 |
/*
* Scan through the argc array, creating a process for each group of
* arguments between the "|" characters.
*/
Tcl_ReapDetachedProcs();
| | | 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 |
/*
* Scan through the argc array, creating a process for each group of
* arguments between the "|" characters.
*/
Tcl_ReapDetachedProcs();
pidPtr = Tcl_Alloc(cmdCount * sizeof(Tcl_Pid));
curInFile = inputFile;
for (i = 0; i < argc; i = lastArg + 1) {
int result, joinThisError;
Tcl_Pid pid;
const char *oldName;
|
| ︙ | ︙ | |||
974 975 976 977 978 979 980 |
}
if (pidPtr != NULL) {
for (i = 0; i < numPids; i++) {
if (pidPtr[i] != (Tcl_Pid) -1) {
Tcl_DetachPids(1, &pidPtr[i]);
}
}
| | | 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 |
}
if (pidPtr != NULL) {
for (i = 0; i < numPids; i++) {
if (pidPtr[i] != (Tcl_Pid) -1) {
Tcl_DetachPids(1, &pidPtr[i]);
}
}
Tcl_Free(pidPtr);
}
numPids = -1;
goto cleanup;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
1078 1079 1080 1081 1082 1083 1084 |
goto error;
}
return channel;
error:
if (numPids > 0) {
Tcl_DetachPids(numPids, pidPtr);
| | | 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 |
goto error;
}
return channel;
error:
if (numPids > 0) {
Tcl_DetachPids(numPids, pidPtr);
Tcl_Free(pidPtr);
}
if (inPipe != NULL) {
TclpCloseFile(inPipe);
}
if (outPipe != NULL) {
TclpCloseFile(outPipe);
}
|
| ︙ | ︙ |
Changes to generic/tclPkg.c.
| ︙ | ︙ | |||
34 35 36 37 38 39 40 |
* 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 {
| | > | > | > < | < < < | | 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 |
* 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;
PkgAvail *availPtr; /* First in list of all available versions of
* this package. */
const void *clientData; /* Client data. */
} Package;
typedef struct Require {
void *clientDataPtr;
const char *name;
Package *pkgPtr;
char *versionToProvide;
} Require;
typedef struct RequireProcArgs {
const char *name;
|
| ︙ | ︙ | |||
108 109 110 111 112 113 114 | static int TclNRPackageObjCmdCleanup(ClientData data[], Tcl_Interp *interp, int result); /* * Helper macros. */ #define DupBlock(v,s,len) \ | | | 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 |
static int TclNRPackageObjCmdCleanup(ClientData data[], Tcl_Interp *interp, int result);
/*
* Helper macros.
*/
#define DupBlock(v,s,len) \
((v) = Tcl_Alloc(len), memcpy((v),(s),(len)))
#define DupString(v,s) \
do { \
size_t local__len = strlen(s) + 1; \
DupBlock((v),(s),local__len); \
} while (0)
/*
|
| ︙ | ︙ | |||
151 152 153 154 155 156 157 |
{
Package *pkgPtr;
char *pvi, *vi;
int res;
pkgPtr = FindPackage(interp, name);
if (pkgPtr->version == NULL) {
| > | | | | | | | 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 |
{
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);
pkgPtr->clientData = clientData;
return TCL_OK;
}
if (CheckVersionAndConvert(interp, Tcl_GetString(pkgPtr->version), &pvi,
NULL) != TCL_OK) {
return TCL_ERROR;
} else if (CheckVersionAndConvert(interp, version, &vi, NULL) != TCL_OK) {
Tcl_Free(pvi);
return TCL_ERROR;
}
res = CompareVersions(pvi, vi, NULL);
Tcl_Free(pvi);
Tcl_Free(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);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
208 209 210 211 212 213 214 | * Side effects: * The script from some previous "package ifneeded" command may be * invoked to provide the package. * *---------------------------------------------------------------------- */ | > > | | > | > | > > | > | > > > | > > > | | > > | 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 |
* Side effects:
* The script from some previous "package ifneeded" command may be
* invoked to provide the package.
*
*----------------------------------------------------------------------
*/
static void
PkgFilesCleanupProc(
ClientData clientData,
Tcl_Interp *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 = Tcl_GetAssocData(interp, "tclPkgFiles", NULL);
if (!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 new;
Tcl_HashEntry *entry = Tcl_CreateHashEntry(table, name, &new);
Tcl_Obj *list;
|
| ︙ | ︙ | |||
319 320 321 322 323 324 325 | * those unresolved references may cause the loading of the package to * also load a second copy of the Tcl library, leading to all kinds of * 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 | | | | | | | | 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 | * those unresolved references may cause the loading of the package to * also load a second copy of the Tcl library, leading to all kinds of * 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.) * * 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 * to place an error message in the interpreter result and return NULL * to indicate failure to Tcl_InitStubs() so that it will also fail. |
| ︙ | ︙ | |||
354 355 356 357 358 359 360 |
/*
* 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) {
| | | > | > | > > | > > | > > > > | > | > > | | > > > > > > > > > > | > > > > > | | | | | | > > > > > | > > | > > > > | | | | > | | | > | < | < < < < < | > > > > | > > > | > > > | > | > > > > | > | > | | | | > > > > | | < | > > > > | | 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 |
/*
* 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);
}
} else {
if (exact && TCL_OK
!= CheckVersionAndConvert(interp, version, NULL, NULL)) {
return NULL;
}
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);
}
TclDecrRefCount(ov);
}
return result;
}
int
Tcl_PkgRequireProc(
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. */
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 = 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,
int result)
{
const char *name = data[0];
int reqc = PTR2INT(data[1]);
Tcl_Obj *const *reqv = data[2];
int code = CheckAllRequirements(interp, reqc, reqv);
Require *reqPtr;
if (code != TCL_OK) {
return code;
}
reqPtr = 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), (void *) reqv,
PkgRequireCoreStep1);
} else {
Tcl_NRAddCallback(interp,
PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), (void *) reqv,NULL);
}
return TCL_OK;
}
static int
PkgRequireCoreStep1(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Tcl_DString command;
char *script;
Require *reqPtr = data[0];
int reqc = PTR2INT(data[1]);
Tcl_Obj **const reqv = 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 = data[0];
int reqc = PTR2INT(data[1]);
Tcl_Obj **const reqv = 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), (void *) reqv,
PkgRequireCoreFinal);
return TCL_OK;
}
static int
PkgRequireCoreFinal(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Require *reqPtr = data[0];
int reqc = PTR2INT(data[1]), satisfies;
Tcl_Obj **const reqv = 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_Interp *interp,
int result)
{
Tcl_Free(data[0]);
return result;
}
static int
SelectPackage(
ClientData data[],
Tcl_Interp *interp,
int result)
{
PkgAvail *availPtr, *bestPtr, *bestStablePtr;
char *availVersion, *bestVersion, *bestStableVersion;
/* Internal rep. of versions */
int availStable, satisfies;
Require *reqPtr = data[0];
int reqc = PTR2INT(data[1]);
Tcl_Obj **const reqv = data[2];
const char *name = reqPtr->name;
Package *pkgPtr = reqPtr->pkgPtr;
Interp *iPtr = (Interp *) interp;
|
| ︙ | ︙ | |||
571 572 573 574 575 576 577 |
name, (char *) pkgPtr->clientData, name));
AddRequirementsToResult(interp, reqc, reqv);
Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "CIRCULARITY", NULL);
return TCL_ERROR;
}
/*
| | | | | | | | > | > > > | > | > | > | | | > | > | > > > | > | | | | | | > | | | > > | > > | > | > | > | > > > > > | > > | | | | | | | | 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 |
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;
}
}
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,
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 = TclInitPkgFiles(interp);
/*
* Push "ifneeded" package name in "tclPkgFiles" assocdata.
*/
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 = data[0];
int reqc = PTR2INT(data[1]);
Tcl_Obj **const reqv = data[2];
const char *name = reqPtr->name;
char *versionToProvide = reqPtr->versionToProvide;
/*
* Pop the "ifneeded" package name from "tclPkgFiles" assocdata
*/
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 = Tcl_NewIntObj(result);
|
| ︙ | ︙ | |||
793 794 795 796 797 798 799 |
"\n (\"package ifneeded %s %s\" script)",
name, versionToProvide));
}
Tcl_Release(versionToProvide);
if (result != TCL_OK) {
/*
| | | | | | | < | | > | 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 |
"\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,
data[3], reqPtr, INT2PTR(reqc), (void *) reqv, NULL);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_PkgPresentEx --
|
| ︙ | ︙ | |||
962 963 964 965 966 967 968 |
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "package");
return TCL_ERROR;
}
pkgFiles = (PkgFiles *) Tcl_GetAssocData(interp, "tclPkgFiles", NULL);
if (pkgFiles) {
| | > > | > | | | | > | | | | | | | | | | | 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 |
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;
}
case PKG_FORGET: {
const char *keyString;
PkgFiles *pkgFiles = (PkgFiles *)
Tcl_GetAssocData(interp, "tclPkgFiles", NULL);
for (i = 2; i < objc; i++) {
keyString = TclGetString(objv[i]);
if (pkgFiles) {
hPtr = Tcl_FindHashEntry(&pkgFiles->table, keyString);
if (hPtr) {
Tcl_Obj *obj = Tcl_GetHashValue(hPtr);
Tcl_DeleteHashEntry(hPtr);
Tcl_DecrRefCount(obj);
}
}
hPtr = Tcl_FindHashEntry(&iPtr->packageTable, keyString);
if (hPtr == NULL) {
continue;
}
pkgPtr = Tcl_GetHashValue(hPtr);
Tcl_DeleteHashEntry(hPtr);
if (pkgPtr->version != NULL) {
Tcl_DecrRefCount(pkgPtr->version);
}
while (pkgPtr->availPtr != NULL) {
availPtr = pkgPtr->availPtr;
pkgPtr->availPtr = availPtr->nextPtr;
Tcl_EventuallyFree(availPtr->version, TCL_DYNAMIC);
Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC);
if (availPtr->pkgIndex) {
Tcl_EventuallyFree(availPtr->pkgIndex, TCL_DYNAMIC);
availPtr->pkgIndex = NULL;
}
Tcl_Free(availPtr);
}
Tcl_Free(pkgPtr);
}
break;
}
case PKG_IFNEEDED: {
size_t length;
int res;
char *argv3i, *avi;
if ((objc != 4) && (objc != 5)) {
Tcl_WrongNumArgs(interp, 2, objv, "package version ?script?");
return TCL_ERROR;
}
argv3 = TclGetString(objv[3]);
if (CheckVersionAndConvert(interp, argv3, &argv3i, NULL) != TCL_OK) {
return TCL_ERROR;
}
argv2 = TclGetString(objv[2]);
if (objc == 4) {
hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2);
if (hPtr == NULL) {
Tcl_Free(argv3i);
return TCL_OK;
}
pkgPtr = Tcl_GetHashValue(hPtr);
} else {
pkgPtr = FindPackage(interp, argv2);
}
argv3 = TclGetStringFromObj(objv[3], &length);
for (availPtr = pkgPtr->availPtr, prevPtr = NULL; availPtr != NULL;
prevPtr = availPtr, availPtr = availPtr->nextPtr) {
if (CheckVersionAndConvert(interp, availPtr->version, &avi,
NULL) != TCL_OK) {
Tcl_Free(argv3i);
return TCL_ERROR;
}
res = CompareVersions(avi, argv3i, NULL);
Tcl_Free(avi);
if (res == 0) {
if (objc == 4) {
Tcl_Free(argv3i);
Tcl_SetObjResult(interp,
Tcl_NewStringObj(availPtr->script, -1));
return TCL_OK;
}
Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC);
if (availPtr->pkgIndex) {
Tcl_EventuallyFree(availPtr->pkgIndex, TCL_DYNAMIC);
availPtr->pkgIndex = NULL;
}
break;
}
}
Tcl_Free(argv3i);
if (objc == 4) {
return TCL_OK;
}
if (availPtr == NULL) {
availPtr = Tcl_Alloc(sizeof(PkgAvail));
availPtr->pkgIndex = NULL;
DupBlock(availPtr->version, argv3, 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);
break;
}
case PKG_NAMES:
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
} else {
|
| ︙ | ︙ | |||
1162 1163 1164 1165 1166 1167 1168 |
}
argv2 = TclGetString(objv[2]);
if (objc == 3) {
hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2);
if (hPtr != NULL) {
pkgPtr = Tcl_GetHashValue(hPtr);
if (pkgPtr->version != NULL) {
| | < | 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 |
}
argv2 = TclGetString(objv[2]);
if (objc == 3) {
hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2);
if (hPtr != NULL) {
pkgPtr = Tcl_GetHashValue(hPtr);
if (pkgPtr->version != NULL) {
Tcl_SetObjResult(interp, pkgPtr->version);
}
}
return TCL_OK;
}
argv3 = TclGetString(objv[3]);
if (CheckVersionAndConvert(interp, argv3, NULL, NULL) != TCL_OK) {
return TCL_ERROR;
|
| ︙ | ︙ | |||
1213 1214 1215 1216 1217 1218 1219 | Tcl_IncrRefCount(objv[3]); objvListPtr = Tcl_NewListObj(0, NULL); Tcl_IncrRefCount(objvListPtr); Tcl_ListObjAppendElement(interp, objvListPtr, ov); Tcl_ListObjGetElements(interp, objvListPtr, &newobjc, &newObjvPtr); | > | | > > > < | > > | | > > | | | | 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 |
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 {
int i, newobjc = objc-3;
Tcl_Obj *const *newobjv = objv + 3;
if (CheckAllRequirements(interp, objc-3, objv+3) != TCL_OK) {
return TCL_ERROR;
}
objvListPtr = Tcl_NewListObj(0, NULL);
Tcl_IncrRefCount(objvListPtr);
Tcl_IncrRefCount(objv[2]);
for (i = 0; i < newobjc; i++) {
/*
* 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;
}
break;
case PKG_UNKNOWN: {
size_t length;
if (objc == 2) {
if (iPtr->packageUnknown != NULL) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj(iPtr->packageUnknown, -1));
}
} else if (objc == 3) {
if (iPtr->packageUnknown != NULL) {
Tcl_Free(iPtr->packageUnknown);
}
argv2 = TclGetStringFromObj(objv[2], &length);
if (argv2[0] == 0) {
iPtr->packageUnknown = NULL;
} else {
DupBlock(iPtr->packageUnknown, argv2, length+1);
}
} else {
Tcl_WrongNumArgs(interp, 2, objv, "?command?");
return TCL_ERROR;
}
break;
}
|
| ︙ | ︙ | |||
1311 1312 1313 1314 1315 1316 1317 |
return TCL_ERROR;
}
argv3 = TclGetString(objv[3]);
argv2 = TclGetString(objv[2]);
if (CheckVersionAndConvert(interp, argv2, &iva, NULL) != TCL_OK ||
CheckVersionAndConvert(interp, argv3, &ivb, NULL) != TCL_OK) {
if (iva != NULL) {
| | | | | 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 |
return TCL_ERROR;
}
argv3 = TclGetString(objv[3]);
argv2 = TclGetString(objv[2]);
if (CheckVersionAndConvert(interp, argv2, &iva, NULL) != TCL_OK ||
CheckVersionAndConvert(interp, argv3, &ivb, NULL) != TCL_OK) {
if (iva != NULL) {
Tcl_Free(iva);
}
/*
* ivb cannot be set in this branch.
*/
return TCL_ERROR;
}
/*
* Comparison is done on the internal representation.
*/
Tcl_SetObjResult(interp,
Tcl_NewIntObj(CompareVersions(iva, ivb, NULL)));
Tcl_Free(iva);
Tcl_Free(ivb);
break;
case PKG_VERSIONS:
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "package");
return TCL_ERROR;
} else {
Tcl_Obj *resultObj = Tcl_NewObj();
|
| ︙ | ︙ | |||
1362 1363 1364 1365 1366 1367 1368 |
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) {
| | | | > > > > | | | 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 |
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);
return TCL_ERROR;
}
satisfies = SomeRequirementSatisfied(argv2i, objc-3, objv+3);
Tcl_Free(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_Interp *interp,
int result)
{
TclDecrRefCount((Tcl_Obj *) data[0]);
TclDecrRefCount((Tcl_Obj *) data[1]);
return result;
}
/*
*----------------------------------------------------------------------
*
* FindPackage --
|
| ︙ | ︙ | |||
1415 1416 1417 1418 1419 1420 1421 |
Interp *iPtr = (Interp *) interp;
Tcl_HashEntry *hPtr;
int isNew;
Package *pkgPtr;
hPtr = Tcl_CreateHashEntry(&iPtr->packageTable, name, &isNew);
if (isNew) {
| | | 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 |
Interp *iPtr = (Interp *) interp;
Tcl_HashEntry *hPtr;
int isNew;
Package *pkgPtr;
hPtr = Tcl_CreateHashEntry(&iPtr->packageTable, name, &isNew);
if (isNew) {
pkgPtr = Tcl_Alloc(sizeof(Package));
pkgPtr->version = NULL;
pkgPtr->availPtr = NULL;
pkgPtr->clientData = NULL;
Tcl_SetHashValue(hPtr, pkgPtr);
} else {
pkgPtr = Tcl_GetHashValue(hPtr);
}
|
| ︙ | ︙ | |||
1456 1457 1458 1459 1460 1461 1462 |
Tcl_HashEntry *hPtr;
PkgAvail *availPtr;
for (hPtr = Tcl_FirstHashEntry(&iPtr->packageTable, &search);
hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
pkgPtr = Tcl_GetHashValue(hPtr);
if (pkgPtr->version != NULL) {
| | | | | | 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 |
Tcl_HashEntry *hPtr;
PkgAvail *availPtr;
for (hPtr = Tcl_FirstHashEntry(&iPtr->packageTable, &search);
hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
pkgPtr = Tcl_GetHashValue(hPtr);
if (pkgPtr->version != NULL) {
Tcl_DecrRefCount(pkgPtr->version);
}
while (pkgPtr->availPtr != NULL) {
availPtr = pkgPtr->availPtr;
pkgPtr->availPtr = availPtr->nextPtr;
Tcl_EventuallyFree(availPtr->version, TCL_DYNAMIC);
Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC);
if (availPtr->pkgIndex) {
Tcl_EventuallyFree(availPtr->pkgIndex, TCL_DYNAMIC);
availPtr->pkgIndex = NULL;
}
Tcl_Free(availPtr);
}
Tcl_Free(pkgPtr);
}
Tcl_DeleteHashTable(&iPtr->packageTable);
if (iPtr->packageUnknown != NULL) {
Tcl_Free(iPtr->packageUnknown);
}
}
/*
*----------------------------------------------------------------------
*
* CheckVersionAndConvert --
|
| ︙ | ︙ | |||
1513 1514 1515 1516 1517 1518 1519 |
const char *p = string;
char prevChar;
int hasunstable = 0;
/*
* 4* assuming that each char is a separator (a,b become ' -x ').
* 4+ to have spce for an additional -2 at the end
*/
| | | 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 |
const char *p = string;
char prevChar;
int hasunstable = 0;
/*
* 4* assuming that each char is a separator (a,b become ' -x ').
* 4+ to have spce for an additional -2 at the end
*/
char *ibuf = Tcl_Alloc(4 + 4*strlen(string));
char *ip = ibuf;
/*
* Basic rules
* (1) First character has to be a digit.
* (2) All other characters have to be a digit or '.'
* (3) Two '.'s may not follow each other.
|
| ︙ | ︙ | |||
1581 1582 1583 1584 1585 1586 1587 |
prevChar = *p;
}
if (prevChar!='.' && prevChar!='a' && prevChar!='b') {
*ip = '\0';
if (internal != NULL) {
*internal = ibuf;
} else {
| | | | 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 |
prevChar = *p;
}
if (prevChar!='.' && prevChar!='a' && prevChar!='b') {
*ip = '\0';
if (internal != NULL) {
*internal = ibuf;
} else {
Tcl_Free(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);
return TCL_ERROR;
}
/*
|
| ︙ | ︙ | |||
1864 1865 1866 1867 1868 1869 1870 |
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
| | | | | 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 |
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().
*/
DupString(buf, string);
dash = buf + (dash - string);
*dash = '\0'; /* buf now <=> min part */
dash++; /* dash now <=> max part */
if ((CheckVersionAndConvert(interp, buf, NULL, NULL) != TCL_OK) ||
((*dash != '\0') &&
(CheckVersionAndConvert(interp, dash, NULL, NULL) != TCL_OK))) {
Tcl_Free(buf);
return TCL_ERROR;
}
Tcl_Free(buf);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* AddRequirementsToResult --
|
| ︙ | ︙ | |||
1908 1909 1910 1911 1912 1913 1914 |
Tcl_Interp *interp,
int reqc, /* Requirements constraining the desired
* version. */
Tcl_Obj *const reqv[]) /* 0 means to use the latest version
* available. */
{
Tcl_Obj *result = Tcl_GetObjResult(interp);
| > | | 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 |
Tcl_Interp *interp,
int reqc, /* Requirements constraining the desired
* version. */
Tcl_Obj *const reqv[]) /* 0 means to use the latest version
* available. */
{
Tcl_Obj *result = Tcl_GetObjResult(interp);
int i;
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));
|
| ︙ | ︙ | |||
2044 2045 2046 2047 2048 2049 2050 | char *reqi = NULL; int thisIsMajor; CheckVersionAndConvert(NULL, req, &reqi, NULL); strcat(reqi, " -2"); res = CompareVersions(havei, reqi, &thisIsMajor); satisfied = (res == 0) || ((res == 1) && !thisIsMajor); | | | 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 |
char *reqi = NULL;
int thisIsMajor;
CheckVersionAndConvert(NULL, req, &reqi, NULL);
strcat(reqi, " -2");
res = CompareVersions(havei, reqi, &thisIsMajor);
satisfied = (res == 0) || ((res == 1) && !thisIsMajor);
Tcl_Free(reqi);
return satisfied;
}
/*
* Exactly one dash is present (Assumption of valid syntax). Copy the req,
* split at the location of dash and check that both parts are versions.
* Note that the max part can be empty.
|
| ︙ | ︙ | |||
2068 2069 2070 2071 2072 2073 2074 | * We have a min, but no max. For the comparison we generate the * internal rep, padded with 'a0' i.e. '-2'. */ CheckVersionAndConvert(NULL, buf, &min, NULL); strcat(min, " -2"); satisfied = (CompareVersions(havei, min, NULL) >= 0); | | | | 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 |
* We have a min, but no max. For the comparison we generate the
* internal rep, padded with 'a0' i.e. '-2'.
*/
CheckVersionAndConvert(NULL, buf, &min, NULL);
strcat(min, " -2");
satisfied = (CompareVersions(havei, min, NULL) >= 0);
Tcl_Free(min);
Tcl_Free(buf);
return satisfied;
}
/*
* We have both min and max, and generate their internal reps. When
* identical we compare as is, otherwise we pad with 'a0' to ove the range
* a bit.
|
| ︙ | ︙ | |||
2091 2092 2093 2094 2095 2096 2097 |
} else {
strcat(min, " -2");
strcat(max, " -2");
satisfied = ((CompareVersions(min, havei, NULL) <= 0) &&
(CompareVersions(havei, max, NULL) < 0));
}
| | | | | 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 |
} else {
strcat(min, " -2");
strcat(max, " -2");
satisfied = ((CompareVersions(min, havei, NULL) <= 0) &&
(CompareVersions(havei, max, NULL) < 0));
}
Tcl_Free(min);
Tcl_Free(max);
Tcl_Free(buf);
return satisfied;
}
/*
*----------------------------------------------------------------------
*
* Tcl_PkgInitStubsCheck --
|
| ︙ | ︙ |
Changes to generic/tclPkgConfig.c.
| ︙ | ︙ | |||
36 37 38 39 40 41 42 | #include "tclInt.h" /* * Use C preprocessor statements to define the various values for the embedded * configuration information. */ | | | 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 | #include "tclInt.h" /* * Use C preprocessor statements to define the various values for the embedded * configuration information. */ #if TCL_THREADS # define CFG_THREADED "1" #else # define CFG_THREADED "0" #endif #ifdef TCL_MEM_DEBUG # define CFG_MEMDEBUG "1" |
| ︙ | ︙ | |||
101 102 103 104 105 106 107 108 109 110 111 112 113 114 |
/* Runtime paths to various stuff */
{"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},
/* Installation paths to various stuff */
{"libdir,install", CFG_INSTALL_LIBDIR},
{"bindir,install", CFG_INSTALL_BINDIR},
{"scriptdir,install", CFG_INSTALL_SCRDIR},
{"includedir,install", CFG_INSTALL_INCDIR},
| > > | 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 |
/* Runtime paths to various stuff */
{"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},
{"scriptdir,install", CFG_INSTALL_SCRDIR},
{"includedir,install", CFG_INSTALL_INCDIR},
|
| ︙ | ︙ |
Changes to generic/tclPlatDecls.h.
| ︙ | ︙ | |||
37 38 39 40 41 42 43 | /* * Exported function declarations: */ #if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ /* 0 */ | | | | | | | | | | 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 |
/*
* Exported function declarations:
*/
#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */
/* 0 */
TCLAPI TCHAR * Tcl_WinUtfToTChar(const char *str, size_t len,
Tcl_DString *dsPtr);
/* 1 */
TCLAPI char * Tcl_WinTCharToUtf(const TCHAR *str, size_t len,
Tcl_DString *dsPtr);
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
/* 0 */
TCLAPI int Tcl_MacOSXOpenBundleResources(Tcl_Interp *interp,
const char *bundleName, int hasResourceFile,
size_t maxPathLen, char *libraryPath);
/* 1 */
TCLAPI int Tcl_MacOSXOpenVersionedBundleResources(
Tcl_Interp *interp, const char *bundleName,
const char *bundleVersion,
int hasResourceFile, size_t maxPathLen,
char *libraryPath);
#endif /* MACOSX */
typedef struct TclPlatStubs {
int magic;
void *hooks;
#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */
TCHAR * (*tcl_WinUtfToTChar) (const char *str, size_t len, Tcl_DString *dsPtr); /* 0 */
char * (*tcl_WinTCharToUtf) (const TCHAR *str, size_t len, Tcl_DString *dsPtr); /* 1 */
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
int (*tcl_MacOSXOpenBundleResources) (Tcl_Interp *interp, const char *bundleName, int hasResourceFile, size_t maxPathLen, char *libraryPath); /* 0 */
int (*tcl_MacOSXOpenVersionedBundleResources) (Tcl_Interp *interp, const char *bundleName, const char *bundleVersion, int hasResourceFile, size_t maxPathLen, char *libraryPath); /* 1 */
#endif /* MACOSX */
} TclPlatStubs;
extern const TclPlatStubs *tclPlatStubsPtr;
#ifdef __cplusplus
}
|
| ︙ | ︙ |
Changes to generic/tclPort.h.
| ︙ | ︙ | |||
20 21 22 23 24 25 26 | #if defined(_WIN32) # include "tclWinPort.h" #else # include "tclUnixPort.h" #endif #include "tcl.h" | | < < < < < < < | < < < < < | | 20 21 22 23 24 25 26 27 28 29 30 31 | #if defined(_WIN32) # include "tclWinPort.h" #else # include "tclUnixPort.h" #endif #include "tcl.h" #define UWIDE_MAX ((Tcl_WideUInt)-1) #define WIDE_MAX ((Tcl_WideInt)(UWIDE_MAX >> 1)) #define WIDE_MIN ((Tcl_WideInt)((Tcl_WideUInt)WIDE_MAX+1)) #endif /* _TCLPORT */ |
Changes to generic/tclPreserve.c.
| ︙ | ︙ | |||
33 34 35 36 37 38 39 | /* * Global data structures used to hold the list of preserved data references. * These variables are protected by "preserveMutex". */ static Reference *refArray = NULL; /* First in array of references. */ | | | | 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 | /* * Global data structures used to hold the list of preserved data references. * These variables are protected by "preserveMutex". */ static Reference *refArray = NULL; /* First in array of references. */ static size_t spaceAvl = 0; /* Total number of structures available at * *firstRefPtr. */ static size_t inUse = 0; /* Count of structures currently in use in * refArray. */ TCL_DECLARE_MUTEX(preserveMutex)/* To protect the above statics */ #define INITIAL_SIZE 2 /* Initial number of reference slots to make */ /* * The following data structure is used to keep track of whether an arbitrary |
| ︙ | ︙ | |||
85 86 87 88 89 90 91 |
/* ARGSUSED */
void
TclFinalizePreserve(void)
{
Tcl_MutexLock(&preserveMutex);
if (spaceAvl != 0) {
| | | 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 |
/* ARGSUSED */
void
TclFinalizePreserve(void)
{
Tcl_MutexLock(&preserveMutex);
if (spaceAvl != 0) {
Tcl_Free(refArray);
refArray = NULL;
inUse = 0;
spaceAvl = 0;
}
Tcl_MutexUnlock(&preserveMutex);
}
|
| ︙ | ︙ | |||
117 118 119 120 121 122 123 |
*/
void
Tcl_Preserve(
ClientData clientData) /* Pointer to malloc'ed block of memory. */
{
Reference *refPtr;
| | | 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 |
*/
void
Tcl_Preserve(
ClientData clientData) /* Pointer to malloc'ed block of memory. */
{
Reference *refPtr;
size_t i;
/*
* See if there is already a reference for this pointer. If so, just
* increment its reference count.
*/
Tcl_MutexLock(&preserveMutex);
|
| ︙ | ︙ | |||
140 141 142 143 144 145 146 |
/*
* Make a reference array if it doesn't already exist, or make it bigger
* if it is full.
*/
if (inUse == spaceAvl) {
spaceAvl = spaceAvl ? 2*spaceAvl : INITIAL_SIZE;
| | | 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 |
/*
* Make a reference array if it doesn't already exist, or make it bigger
* if it is full.
*/
if (inUse == spaceAvl) {
spaceAvl = spaceAvl ? 2*spaceAvl : INITIAL_SIZE;
refArray = Tcl_Realloc(refArray, spaceAvl * sizeof(Reference));
}
/*
* Make a new entry for the new reference.
*/
refPtr = &refArray[inUse];
|
| ︙ | ︙ | |||
180 181 182 183 184 185 186 |
*/
void
Tcl_Release(
ClientData clientData) /* Pointer to malloc'ed block of memory. */
{
Reference *refPtr;
| | | 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 |
*/
void
Tcl_Release(
ClientData clientData) /* Pointer to malloc'ed block of memory. */
{
Reference *refPtr;
size_t i;
Tcl_MutexLock(&preserveMutex);
for (i=0, refPtr=refArray ; i<inUse ; i++, refPtr++) {
int mustFree;
Tcl_FreeProc *freeProc;
if (refPtr->clientData != clientData) {
|
| ︙ | ︙ | |||
220 221 222 223 224 225 226 |
* Only then should we dabble around with potentially-slow memory
* managers...
*/
Tcl_MutexUnlock(&preserveMutex);
if (mustFree) {
if (freeProc == TCL_DYNAMIC) {
| | | 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 |
* Only then should we dabble around with potentially-slow memory
* managers...
*/
Tcl_MutexUnlock(&preserveMutex);
if (mustFree) {
if (freeProc == TCL_DYNAMIC) {
Tcl_Free(clientData);
} else {
freeProc(clientData);
}
}
return;
}
Tcl_MutexUnlock(&preserveMutex);
|
| ︙ | ︙ | |||
260 261 262 263 264 265 266 |
void
Tcl_EventuallyFree(
ClientData clientData, /* Pointer to malloc'ed block of memory. */
Tcl_FreeProc *freeProc) /* Function to actually do free. */
{
Reference *refPtr;
| | | 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 |
void
Tcl_EventuallyFree(
ClientData clientData, /* Pointer to malloc'ed block of memory. */
Tcl_FreeProc *freeProc) /* Function to actually do free. */
{
Reference *refPtr;
size_t i;
/*
* See if there is a reference for this pointer. If so, set its "mustFree"
* flag (the flag had better not be set already!).
*/
Tcl_MutexLock(&preserveMutex);
|
| ︙ | ︙ | |||
287 288 289 290 291 292 293 |
Tcl_MutexUnlock(&preserveMutex);
/*
* No reference for this block. Free it now.
*/
if (freeProc == TCL_DYNAMIC) {
| | | 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 |
Tcl_MutexUnlock(&preserveMutex);
/*
* No reference for this block. Free it now.
*/
if (freeProc == TCL_DYNAMIC) {
Tcl_Free(clientData);
} else {
freeProc(clientData);
}
}
/*
*---------------------------------------------------------------------------
|
| ︙ | ︙ | |||
323 324 325 326 327 328 329 |
TclHandle
TclHandleCreate(
void *ptr) /* Pointer to an arbitrary block of memory to
* be tracked for deletion. Must not be
* NULL. */
{
| | | 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 |
TclHandle
TclHandleCreate(
void *ptr) /* Pointer to an arbitrary block of memory to
* be tracked for deletion. Must not be
* NULL. */
{
HandleStruct *handlePtr = Tcl_Alloc(sizeof(HandleStruct));
handlePtr->ptr = ptr;
#ifdef TCL_MEM_DEBUG
handlePtr->ptr2 = ptr;
#endif
handlePtr->refCount = 0;
return (TclHandle) handlePtr;
|
| ︙ | ︙ | |||
373 374 375 376 377 378 379 |
if (handlePtr->ptr2 != handlePtr->ptr) {
Tcl_Panic("someone has changed the block referenced by the handle %p\nfrom %p to %p",
handlePtr, handlePtr->ptr2, handlePtr->ptr);
}
#endif
handlePtr->ptr = NULL;
if (handlePtr->refCount == 0) {
| | | 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 |
if (handlePtr->ptr2 != handlePtr->ptr) {
Tcl_Panic("someone has changed the block referenced by the handle %p\nfrom %p to %p",
handlePtr, handlePtr->ptr2, handlePtr->ptr);
}
#endif
handlePtr->ptr = NULL;
if (handlePtr->refCount == 0) {
Tcl_Free(handlePtr);
}
}
/*
*---------------------------------------------------------------------------
*
* TclHandlePreserve --
|
| ︙ | ︙ | |||
456 457 458 459 460 461 462 |
}
if ((handlePtr->ptr != NULL) && (handlePtr->ptr != handlePtr->ptr2)) {
Tcl_Panic("someone has changed the block referenced by the handle %p\nfrom %p to %p",
handlePtr, handlePtr->ptr2, handlePtr->ptr);
}
#endif
if ((handlePtr->refCount-- <= 1) && (handlePtr->ptr == NULL)) {
| | | 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 |
}
if ((handlePtr->ptr != NULL) && (handlePtr->ptr != handlePtr->ptr2)) {
Tcl_Panic("someone has changed the block referenced by the handle %p\nfrom %p to %p",
handlePtr, handlePtr->ptr2, handlePtr->ptr);
}
#endif
if ((handlePtr->refCount-- <= 1) && (handlePtr->ptr == NULL)) {
Tcl_Free(handlePtr);
}
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclProc.c.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
#include "tclCompile.h"
/*
* 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 {
| > | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
#include "tclCompile.h"
#include <assert.h>
/*
* 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 {
|
| ︙ | ︙ | |||
63 64 65 66 67 68 69 70 71 72 73 74 75 76 |
NULL, /* UpdateString function; Tcl_GetString and
* Tcl_GetStringFromObj should panic
* instead. */
NULL /* SetFromAny function; Tcl_ConvertToType
* should panic instead. */
};
/*
* The [upvar]/[uplevel] level reference type. Uses the longValue field
* to remember the integer value of a parsed #<integer> format.
*
* Uses the default behaviour throughout, and never disposes of the string
* rep; it's just a cache type.
*/
| > > > > > > > > > > > > > > > > | 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 |
NULL, /* UpdateString function; Tcl_GetString and
* Tcl_GetStringFromObj should panic
* 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 ? irPtr->twoPtrValue.ptr1 : NULL; \
} while (0)
/*
* The [upvar]/[uplevel] level reference type. Uses the longValue field
* to remember the integer value of a parsed #<integer> format.
*
* Uses the default behaviour throughout, and never disposes of the string
* rep; it's just a cache type.
*/
|
| ︙ | ︙ | |||
85 86 87 88 89 90 91 | * 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. */ | | > > > > > > > > > > > > > > > > > > | 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 |
* representation.
*
* Internally, ptr1 is a pointer to a Proc instance that is not bound to a
* command name, and ptr2 is a pointer to the namespace that the Proc instance
* will execute within. IF YOU CHANGE THIS, CHECK IN tclDisassemble.c TOO.
*/
static const Tcl_ObjType lambdaType = {
"lambdaExpr", /* name */
FreeLambdaInternalRep, /* freeIntRepProc */
DupLambdaInternalRep, /* dupIntRepProc */
NULL, /* updateStringProc */
SetLambdaFromAny /* setFromAnyProc */
};
#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 ? irPtr->twoPtrValue.ptr1 : NULL; \
(nsObjPtr) = irPtr ? irPtr->twoPtrValue.ptr2 : NULL; \
} while (0)
/*
*----------------------------------------------------------------------
*
* Tcl_ProcObjCmd --
*
* This object-based function is invoked to process the "proc" Tcl
|
| ︙ | ︙ | |||
224 225 226 227 228 229 230 |
* proc body was not created by substitution.
*/
if (contextPtr->line
&& (contextPtr->nline >= 4) && (contextPtr->line[3] >= 0)) {
int isNew;
Tcl_HashEntry *hePtr;
| | | | 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 |
* proc body was not created by substitution.
*/
if (contextPtr->line
&& (contextPtr->nline >= 4) && (contextPtr->line[3] >= 0)) {
int isNew;
Tcl_HashEntry *hePtr;
CmdFrame *cfPtr = Tcl_Alloc(sizeof(CmdFrame));
cfPtr->level = -1;
cfPtr->type = contextPtr->type;
cfPtr->line = Tcl_Alloc(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);
|
| ︙ | ︙ | |||
256 257 258 259 260 261 262 |
CmdFrame *cfOldPtr = Tcl_GetHashValue(hePtr);
if (cfOldPtr->type == TCL_LOCATION_SOURCE) {
Tcl_DecrRefCount(cfOldPtr->data.eval.path);
cfOldPtr->data.eval.path = NULL;
}
| | | | 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 |
CmdFrame *cfOldPtr = Tcl_GetHashValue(hePtr);
if (cfOldPtr->type == TCL_LOCATION_SOURCE) {
Tcl_DecrRefCount(cfOldPtr->data.eval.path);
cfOldPtr->data.eval.path = NULL;
}
Tcl_Free(cfOldPtr->line);
cfOldPtr->line = NULL;
Tcl_Free(cfOldPtr);
}
Tcl_SetHashValue(hePtr, cfPtr);
}
/*
* 'contextPtr' is going out of scope; account for the reference
* that it's holding to the path name.
|
| ︙ | ︙ | |||
301 302 303 304 305 306 307 |
procArgs = TclGetString(objv[2]);
while (*procArgs == ' ') {
procArgs++;
}
if ((procArgs[0] == 'a') && (strncmp(procArgs, "args", 4) == 0)) {
| | | 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 |
procArgs = TclGetString(objv[2]);
while (*procArgs == ' ') {
procArgs++;
}
if ((procArgs[0] == 'a') && (strncmp(procArgs, "args", 4) == 0)) {
size_t numBytes;
procArgs +=4;
while (*procArgs != '\0') {
if (*procArgs != ' ') {
goto done;
}
procArgs++;
|
| ︙ | ︙ | |||
366 367 368 369 370 371 372 |
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;
| | | < < | | > < > | | 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 |
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;
register Proc *procPtr = NULL;
int i, result, numArgs;
register CompiledLocal *localPtr = NULL;
Tcl_Obj **argArray;
int precompiled = 0;
ProcGetIntRep(bodyPtr, procPtr);
if (procPtr != NULL) {
/*
* Because the body is a TclProProcBody, the actual body is already
* 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).
*
* We don't create and initialize a Proc structure for the procedure;
* 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->iPtr = iPtr;
procPtr->refCount++;
precompiled = 1;
} else {
/*
* If the procedure's body object is shared because its string value
* is identical to, e.g., the body of another procedure, we must
* create a private copy for this procedure to use. Such sharing of
* procedure bodies is rare but can cause problems. A procedure body
* is compiled in a context that includes the number of "slots"
* allocated by the compiler for local variables. There is a local
* variable slot for each formal parameter (the
* "procPtr->numCompiledLocals = numArgs" assignment below). This
* means that the same code can not be shared by two procedures that
* have a different number of arguments, even if their bodies are
* identical. Note that we don't use Tcl_DuplicateObj since we would
* not want any bytecode internal representation.
*/
if (Tcl_IsShared(bodyPtr)) {
const char *bytes;
size_t length;
Tcl_Obj *sharedBodyPtr = bodyPtr;
bytes = TclGetStringFromObj(bodyPtr, &length);
bodyPtr = Tcl_NewStringObj(bytes, length);
/*
* TIP #280.
|
| ︙ | ︙ | |||
431 432 433 434 435 436 437 | * Create and initialize a Proc structure for the procedure. We * increment the ref count of the procedure's body object since there * will be a reference to it in the Proc structure. */ Tcl_IncrRefCount(bodyPtr); | | | 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 | * Create and initialize a Proc structure for the procedure. We * increment the ref count of the procedure's body object since there * will be a reference to it in the Proc structure. */ Tcl_IncrRefCount(bodyPtr); procPtr = Tcl_Alloc(sizeof(Proc)); procPtr->iPtr = iPtr; procPtr->refCount = 1; procPtr->bodyPtr = bodyPtr; procPtr->numArgs = 0; /* Actual argument count is set below. */ procPtr->numCompiledLocals = 0; procPtr->firstLocalPtr = NULL; procPtr->lastLocalPtr = NULL; |
| ︙ | ︙ | |||
470 471 472 473 474 475 476 |
localPtr = procPtr->firstLocalPtr;
} else {
procPtr->numArgs = numArgs;
procPtr->numCompiledLocals = numArgs;
}
for (i = 0; i < numArgs; i++) {
| > | | | < < < | < < < < | | | | | | > | | 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 |
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;
/*
* Now divide the specifier up into name and default.
*/
result = Tcl_ListObjGetElements(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);
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);
goto procError;
}
argname = TclGetStringFromObj(fieldValues[0], &nameLength);
/*
* Check that the formal parameter name is a scalar.
*/
argnamei = argname;
argnamelast = Tcl_UtfPrev(argname + nameLength, 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;
}
|
| ︙ | ︙ | |||
551 552 553 554 555 556 557 | * * The only other flag vlaue that is important to retrieve from * precompiled procs is VAR_TEMPORARY (also unchanged). It is * needed later when retrieving the variable names. */ if ((localPtr->nameLength != nameLength) | | > | | | | > | | | 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 |
*
* The only other flag vlaue that is important to retrieve from
* 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)
|| (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);
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);
goto procError;
|
| ︙ | ︙ | |||
599 600 601 602 603 604 605 |
localPtr = localPtr->nextPtr;
} else {
/*
* Allocate an entry in the runtime procedure frame's array of
* local variables for the argument.
*/
| | | | | < | | | | 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 |
localPtr = localPtr->nextPtr;
} else {
/*
* Allocate an entry in the runtime procedure frame's array of
* local variables for the argument.
*/
localPtr = Tcl_Alloc(offsetof(CompiledLocal, name) + fieldValues[0]->length +1);
if (procPtr->firstLocalPtr == NULL) {
procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr;
} else {
procPtr->lastLocalPtr->nextPtr = localPtr;
procPtr->lastLocalPtr = localPtr;
}
localPtr->nextPtr = NULL;
localPtr->nameLength = nameLength;
localPtr->frameIndex = i;
localPtr->flags = VAR_ARGUMENT;
localPtr->resolveInfo = NULL;
if (fieldCount == 2) {
localPtr->defValuePtr = fieldValues[1];
Tcl_IncrRefCount(localPtr->defValuePtr);
} else {
localPtr->defValuePtr = NULL;
}
memcpy(localPtr->name, argname, fieldValues[0]->length + 1);
if ((i == numArgs - 1)
&& (localPtr->nameLength == 4)
&& (localPtr->name[0] == 'a')
&& (memcmp(localPtr->name, "args", 4) == 0)) {
localPtr->flags |= VAR_IS_ARGS;
}
}
}
*procPtrPtr = procPtr;
return TCL_OK;
procError:
if (precompiled) {
procPtr->refCount--;
} else {
Tcl_DecrRefCount(bodyPtr);
while (procPtr->firstLocalPtr != NULL) {
localPtr = procPtr->firstLocalPtr;
procPtr->firstLocalPtr = localPtr->nextPtr;
if (localPtr->defValuePtr != NULL) {
Tcl_DecrRefCount(localPtr->defValuePtr);
}
Tcl_Free(localPtr);
}
Tcl_Free(procPtr);
}
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
684 685 686 687 688 689 690 |
int
TclGetFrame(
Tcl_Interp *interp, /* Interpreter in which to find frame. */
const char *name, /* String describing frame. */
CallFrame **framePtrPtr) /* Store pointer to frame here (or NULL if
* global frame indicated). */
{
| < | < | < < < < < < < < < < < < < < < < < < | < < < | < | < < < < | < < | < | < < < < < | 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 |
int
TclGetFrame(
Tcl_Interp *interp, /* Interpreter in which to find 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;
}
/*
*----------------------------------------------------------------------
*
* TclObjGetFrame --
*
|
| ︙ | ︙ | |||
765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 |
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). */
{
register Interp *iPtr = (Interp *) interp;
int curLevel, level, result;
const char *name = NULL;
/*
* Parse object to figure out which level number to go to.
*/
result = 0;
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 */
| > > | > | > > | | > | | | > > > | | | > | > | < > > | | | < < | 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 |
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). */
{
register Interp *iPtr = (Interp *) interp;
int curLevel, level, result;
const Tcl_ObjIntRep *irPtr;
const char *name = NULL;
Tcl_WideInt w;
/*
* Parse object to figure out which level number to go to.
*/
result = 0;
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(interp, 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 == 0) {
level = curLevel - 1;
}
if (result != -1) {
if (level >= 0) {
CallFrame *framePtr;
for (framePtr = iPtr->varFramePtr; framePtr != NULL;
framePtr = framePtr->callerVarPtr) {
if (framePtr->level == level) {
*framePtrPtr = framePtr;
return result;
}
}
}
}
if (name == NULL) {
name = TclGetString(objPtr);
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf("bad level \"%s\"", name));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LEVEL", name, NULL);
return -1;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
1031 1032 1033 1034 1035 1036 1037 |
static int
ProcWrongNumArgs(
Tcl_Interp *interp,
int skip)
{
CallFrame *framePtr = ((Interp *)interp)->varFramePtr;
register Proc *procPtr = framePtr->procPtr;
| < > | > | | | | | | | | | | | | | | | > | 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 |
static int
ProcWrongNumArgs(
Tcl_Interp *interp,
int skip)
{
CallFrame *framePtr = ((Interp *)interp)->varFramePtr;
register Proc *procPtr = framePtr->procPtr;
int localCt = procPtr->numCompiledLocals, numArgs, i;
Tcl_Obj **desiredObjs;
const char *final = NULL;
/*
* Build up desired argument list for Tcl_WrongNumArgs
*/
numArgs = framePtr->procPtr->numArgs;
desiredObjs = TclStackAlloc(interp,
(int) sizeof(Tcl_Obj *) * (numArgs+1));
if (framePtr->isProcCallFrame & FRAME_IS_LAMBDA) {
desiredObjs[0] = Tcl_NewStringObj("lambdaExpr", -1);
} else {
desiredObjs[0] = framePtr->objv[skip-1];
}
Tcl_IncrRefCount(desiredObjs[0]);
if (localCt > 0) {
register 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;
}
}
Tcl_ResetResult(interp);
Tcl_WrongNumArgs(interp, numArgs+1, desiredObjs, final);
for (i=0 ; i<=numArgs ; i++) {
Tcl_DecrRefCount(desiredObjs[i]);
|
| ︙ | ︙ | |||
1112 1113 1114 1115 1116 1117 1118 |
Namespace *nsPtr) /* Pointer to current namespace. */
{
Var *varPtr = framePtr->compiledLocals;
Tcl_Obj *bodyPtr;
ByteCode *codePtr;
bodyPtr = framePtr->procPtr->bodyPtr;
| | > < | 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 |
Namespace *nsPtr) /* Pointer to current namespace. */
{
Var *varPtr = framePtr->compiledLocals;
Tcl_Obj *bodyPtr;
ByteCode *codePtr;
bodyPtr = framePtr->procPtr->bodyPtr;
ByteCodeGetIntRep(bodyPtr, &tclByteCodeType, codePtr);
if (codePtr == NULL) {
Tcl_Panic("body object for proc attached to frame is not a byte code type");
}
if (framePtr->numCompiledLocals) {
if (!codePtr->localCachePtr) {
InitLocalCache(framePtr->procPtr) ;
}
framePtr->localCachePtr = codePtr->localCachePtr;
framePtr->localCachePtr->refCount++;
|
| ︙ | ︙ | |||
1184 1185 1186 1187 1188 1189 1190 |
firstLocalPtr = localPtr;
for (; localPtr != NULL; localPtr = localPtr->nextPtr) {
if (localPtr->resolveInfo) {
if (localPtr->resolveInfo->deleteProc) {
localPtr->resolveInfo->deleteProc(localPtr->resolveInfo);
} else {
| | | 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 |
firstLocalPtr = localPtr;
for (; localPtr != NULL; localPtr = localPtr->nextPtr) {
if (localPtr->resolveInfo) {
if (localPtr->resolveInfo->deleteProc) {
localPtr->resolveInfo->deleteProc(localPtr->resolveInfo);
} else {
Tcl_Free(localPtr->resolveInfo);
}
localPtr->resolveInfo = NULL;
}
localPtr->flags &= ~VAR_RESOLVED;
if (haveResolvers &&
!(localPtr->flags & (VAR_ARGUMENT|VAR_TEMPORARY))) {
|
| ︙ | ︙ | |||
1270 1271 1272 1273 1274 1275 1276 |
register Tcl_Obj *objPtr = *namePtrPtr;
if (objPtr) {
/* TclReleaseLiteral calls Tcl_DecrRefCount for us */
TclReleaseLiteral(interp, objPtr);
}
}
| | | > > | | 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 |
register Tcl_Obj *objPtr = *namePtrPtr;
if (objPtr) {
/* TclReleaseLiteral calls Tcl_DecrRefCount for us */
TclReleaseLiteral(interp, objPtr);
}
}
Tcl_Free(localCachePtr);
}
static void
InitLocalCache(
Proc *procPtr)
{
Interp *iPtr = procPtr->iPtr;
ByteCode *codePtr;
int localCt = procPtr->numCompiledLocals;
int numArgs = procPtr->numArgs, i = 0;
Tcl_Obj **namePtr;
Var *varPtr;
LocalCache *localCachePtr;
CompiledLocal *localPtr;
int new;
ByteCodeGetIntRep(procPtr->bodyPtr, &tclByteCodeType, codePtr);
/*
* Cache the names and initial values of local variables; store the
* cache in both the framePtr for this execution and in the codePtr
* for future calls.
*/
localCachePtr = Tcl_Alloc(sizeof(LocalCache)
+ (localCt - 1) * sizeof(Tcl_Obj *)
+ numArgs * sizeof(Var));
namePtr = &localCachePtr->varName0;
varPtr = (Var *) (namePtr + localCt);
localPtr = procPtr->firstLocalPtr;
while (localPtr) {
|
| ︙ | ︙ | |||
1355 1356 1357 1358 1359 1360 1361 |
* 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;
register Proc *procPtr = framePtr->procPtr;
| | > > | 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 |
* 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;
register Proc *procPtr = framePtr->procPtr;
ByteCode *codePtr;
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 .
*/
if (localCt) {
|
| ︙ | ︙ | |||
1534 1535 1536 1537 1538 1539 1540 |
* If necessary (i.e. if we haven't got a suitable compilation already
* cached) compile the procedure's body. The compiler will allocate frame
* 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.
*/
| | > < | 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 |
* If necessary (i.e. if we haven't got a suitable compilation already
* cached) compile the procedure's body. The compiler will allocate frame
* 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) {
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!),
* the code must be from the current epoch (so subcommand compilation
* 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->compileEpoch != iPtr->compileEpoch)
|| (codePtr->nsPtr != nsPtr)
|| (codePtr->nsEpoch != nsPtr->resolverEpoch)) {
goto doCompilation;
}
} else {
|
| ︙ | ︙ | |||
1744 1745 1746 1747 1748 1749 1750 |
#endif /* USE_DTRACE */
/*
* Invoke the commands in the procedure's body.
*/
procPtr->refCount++;
| | | 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 |
#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
|
| ︙ | ︙ | |||
1878 1879 1880 1881 1882 1883 1884 |
* 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. */
{
Interp *iPtr = (Interp *) interp;
Tcl_CallFrame *framePtr;
| | > > | | > | | 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 |
* 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. */
{
Interp *iPtr = (Interp *) interp;
Tcl_CallFrame *framePtr;
ByteCode *codePtr;
ByteCodeGetIntRep(bodyPtr, &tclByteCodeType, codePtr);
/*
* 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
* someone redefining a core command (this might make the compiled code
* wrong). Also, if the code was compiled in/for a different interpreter,
* we recompile it. Note that compiling the body might increase
* procPtr->numCompiledLocals if new local variables are found while
* compiling.
*
* 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)
&& (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 == NULL) {
Tcl_HashEntry *hePtr;
#ifdef TCL_COMPILE_DEBUG
if (tclTraceCompile >= 1) {
/*
* Display a line summarizing the top level command we are about
* to compile.
|
| ︙ | ︙ | |||
1974 1975 1976 1977 1978 1979 1980 |
CompiledLocal *toFree = clPtr;
clPtr = clPtr->nextPtr;
if (toFree->resolveInfo) {
if (toFree->resolveInfo->deleteProc) {
toFree->resolveInfo->deleteProc(toFree->resolveInfo);
} else {
| | | | 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 |
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);
|
| ︙ | ︙ | |||
2038 2039 2040 2041 2042 2043 2044 |
static void
MakeProcError(
Tcl_Interp *interp, /* The interpreter in which the procedure was
* called. */
Tcl_Obj *procNameObj) /* Name of the procedure. Used for error
* messages and trace information. */
{
| | > | | 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 |
static void
MakeProcError(
Tcl_Interp *interp, /* The interpreter in which the procedure was
* called. */
Tcl_Obj *procNameObj) /* Name of the procedure. Used for error
* messages and trace information. */
{
unsigned int overflow, limit = 60;
size_t nameLen;
const char *procName = TclGetStringFromObj(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)));
}
/*
*----------------------------------------------------------------------
*
* TclProcDeleteProc --
|
| ︙ | ︙ | |||
2119 2120 2121 2122 2123 2124 2125 |
CompiledLocal *nextPtr = localPtr->nextPtr;
resVarInfo = localPtr->resolveInfo;
if (resVarInfo) {
if (resVarInfo->deleteProc) {
resVarInfo->deleteProc(resVarInfo);
} else {
| | | | | 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 |
CompiledLocal *nextPtr = localPtr->nextPtr;
resVarInfo = localPtr->resolveInfo;
if (resVarInfo) {
if (resVarInfo->deleteProc) {
resVarInfo->deleteProc(resVarInfo);
} else {
Tcl_Free(resVarInfo);
}
}
if (localPtr->defValuePtr != NULL) {
defPtr = localPtr->defValuePtr;
Tcl_DecrRefCount(defPtr);
}
Tcl_Free(localPtr);
localPtr = nextPtr;
}
Tcl_Free(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.
*/
|
| ︙ | ︙ | |||
2154 2155 2156 2157 2158 2159 2160 |
cfPtr = Tcl_GetHashValue(hePtr);
if (cfPtr) {
if (cfPtr->type == TCL_LOCATION_SOURCE) {
Tcl_DecrRefCount(cfPtr->data.eval.path);
cfPtr->data.eval.path = NULL;
}
| | | | 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 |
cfPtr = 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);
cfPtr->line = NULL;
Tcl_Free(cfPtr);
}
Tcl_DeleteHashEntry(hePtr);
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
2266 2267 2268 2269 2270 2271 2272 |
if (!procPtr) {
return NULL;
}
TclNewObj(objPtr);
if (objPtr) {
| < < | < | 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 |
if (!procPtr) {
return NULL;
}
TclNewObj(objPtr);
if (objPtr) {
ProcSetIntRep(objPtr, procPtr);
}
return objPtr;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
2297 2298 2299 2300 2301 2302 2303 |
*/
static void
ProcBodyDup(
Tcl_Obj *srcPtr, /* Object to copy. */
Tcl_Obj *dupPtr) /* Target object for the duplication. */
{
| | > < < | | 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 |
*/
static void
ProcBodyDup(
Tcl_Obj *srcPtr, /* Object to copy. */
Tcl_Obj *dupPtr) /* Target object for the duplication. */
{
Proc *procPtr;
ProcGetIntRep(srcPtr, procPtr);
ProcSetIntRep(dupPtr, procPtr);
}
/*
*----------------------------------------------------------------------
*
* ProcBodyFree --
*
|
| ︙ | ︙ | |||
2327 2328 2329 2330 2331 2332 2333 |
*----------------------------------------------------------------------
*/
static void
ProcBodyFree(
Tcl_Obj *objPtr) /* The object to clean up. */
{
| | > > | 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 |
*----------------------------------------------------------------------
*/
static void
ProcBodyFree(
Tcl_Obj *objPtr) /* The object to clean up. */
{
Proc *procPtr;
ProcGetIntRep(objPtr, procPtr);
if (procPtr->refCount-- <= 1) {
TclProcCleanupProc(procPtr);
}
}
/*
|
| ︙ | ︙ | |||
2353 2354 2355 2356 2357 2358 2359 |
*/
static void
DupLambdaInternalRep(
Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
register Tcl_Obj *copyPtr) /* Object with internal rep to set. */
{
| | | | | | | | | > > > < | | | 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 |
*/
static void
DupLambdaInternalRep(
Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
register Tcl_Obj *copyPtr) /* Object with internal rep to set. */
{
Proc *procPtr;
Tcl_Obj *nsObjPtr;
LambdaGetIntRep(srcPtr, procPtr, nsObjPtr);
assert(procPtr != NULL);
procPtr->refCount++;
LambdaSetIntRep(copyPtr, procPtr, nsObjPtr);
}
static void
FreeLambdaInternalRep(
register Tcl_Obj *objPtr) /* CmdName object with internal representation
* to free. */
{
Proc *procPtr;
Tcl_Obj *nsObjPtr;
LambdaGetIntRep(objPtr, procPtr, nsObjPtr);
assert(procPtr != NULL);
if (procPtr->refCount-- <= 1) {
TclProcCleanupProc(procPtr);
}
TclDecrRefCount(nsObjPtr);
}
static int
SetLambdaFromAny(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
register Tcl_Obj *objPtr) /* The object to convert. */
{
Interp *iPtr = (Interp *) interp;
const char *name;
Tcl_Obj *argsPtr, *bodyPtr, *nsObjPtr, **objv;
int isNew, objc, result;
CmdFrame *cfPtr = NULL;
Proc *procPtr;
if (interp == NULL) {
return TCL_ERROR;
}
/*
* Convert objPtr to list type first; if it cannot be converted, or if its
* length is not 2, then it cannot be converted to lambdaType.
*/
result = 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);
return TCL_ERROR;
}
argsPtr = objv[0];
bodyPtr = objv[1];
|
| ︙ | ︙ | |||
2490 2491 2492 2493 2494 2495 2496 | int buf[2]; /* * Move from approximation (line of list cmd word) to actual * location (line of 2nd list element). */ | | | | 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 | int buf[2]; /* * Move from approximation (line of list cmd word) to actual * location (line of 2nd list element). */ cfPtr = Tcl_Alloc(sizeof(CmdFrame)); TclListLines(objPtr, contextPtr->line[1], 2, buf, NULL); cfPtr->level = -1; cfPtr->type = contextPtr->type; cfPtr->line = Tcl_Alloc(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); |
| ︙ | ︙ | |||
2538 2539 2540 2541 2542 2543 2544 |
TclNewLiteralStringObj(nsObjPtr, "::");
Tcl_AppendObjToObj(nsObjPtr, objv[2]);
} else {
nsObjPtr = objv[2];
}
}
| < < | | > | | > > > > > > > > | > | > > | | > > > > > > > > > > > | 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 |
TclNewLiteralStringObj(nsObjPtr, "::");
Tcl_AppendObjToObj(nsObjPtr, objv[2]);
} else {
nsObjPtr = objv[2];
}
}
/*
* 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;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ApplyObjCmd --
*
* This object-based function is invoked to process the "apply" Tcl
|
| ︙ | ︙ | |||
2588 2589 2590 2591 2592 2593 2594 |
int
TclNRApplyObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
| < < | | < | < < | < < | | < | 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 |
int
TclNRApplyObjCmd(
ClientData dummy, /* Not used. */
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 = TclStackAlloc(interp, sizeof(ApplyExtraData));
memset(&extraPtr->cmd, 0, sizeof(Command));
|
| ︙ | ︙ | |||
2695 2696 2697 2698 2699 2700 2701 |
static void
MakeLambdaError(
Tcl_Interp *interp, /* The interpreter in which the procedure was
* called. */
Tcl_Obj *procNameObj) /* Name of the procedure. Used for error
* messages and trace information. */
{
| | > | | 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 |
static void
MakeLambdaError(
Tcl_Interp *interp, /* The interpreter in which the procedure was
* called. */
Tcl_Obj *procNameObj) /* Name of the procedure. Used for error
* messages and trace information. */
{
unsigned int overflow, limit = 60;
size_t nameLen;
const char *procName = TclGetStringFromObj(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)));
}
/*
*----------------------------------------------------------------------
*
* TclGetCmdFrameForProcedure --
|
| ︙ | ︙ |
Changes to generic/tclProcess.c.
1 2 3 | /* * tclProcess.c -- * | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 |
/*
* 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,
|
| ︙ | ︙ | |||
126 127 128 129 130 131 132 |
Tcl_DecrRefCount(info->error);
}
/*
* Free allocated structure.
*/
| | | 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 |
Tcl_DecrRefCount(info->error);
}
/*
* Free allocated structure.
*/
Tcl_Free(info);
}
/*
*----------------------------------------------------------------------
*
* RefreshProcessInfo --
*
|
| ︙ | ︙ | |||
156 157 158 159 160 161 162 |
)
{
if (info->status == TCL_PROCESS_UNCHANGED) {
/*
* Refresh & store status.
*/
| | | 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 |
)
{
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.
|
| ︙ | ︙ | |||
189 190 191 192 193 194 195 |
*
*----------------------------------------------------------------------
*/
TclProcessWaitStatus
WaitProcessStatus(
Tcl_Pid pid, /* Process id. */
| | | | 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 |
*
*----------------------------------------------------------------------
*/
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.
*/
|
| ︙ | ︙ | |||
366 367 368 369 370 371 372 |
return Tcl_NewObj();
}
if (info->status == TCL_PROCESS_EXITED && info->code == 0) {
/*
* Normal exit, return TCL_OK.
*/
| | | | 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 |
return Tcl_NewObj();
}
if (info->status == TCL_PROCESS_EXITED && info->code == 0) {
/*
* Normal exit, return TCL_OK.
*/
return Tcl_NewIntObj(TCL_OK);
}
/*
* Abnormal exit, return {TCL_ERROR msg error}
*/
resultObjs[0] = Tcl_NewIntObj(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.
|
| ︙ | ︙ | |||
419 420 421 422 423 424 425 |
/*
* Return the list of all chid process ids.
*/
list = Tcl_NewListObj(0, NULL);
Tcl_MutexLock(&infoTablesMutex);
| | | | | 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 |
/*
* 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_NewIntObj(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.
|
| ︙ | ︙ | |||
500 501 502 503 504 505 506 |
if (objc == 1) {
/*
* Return a dict with all child process statuses.
*/
dict = Tcl_NewDictObj();
Tcl_MutexLock(&infoTablesMutex);
| | | | | | | | | | | | 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 |
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_NewIntObj(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_NewIntObj(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.
|
| ︙ | ︙ | |||
628 629 630 631 632 633 634 |
if (objc == 1) {
/*
* Purge all terminated processes.
*/
Tcl_MutexLock(&infoTablesMutex);
| | | | | | 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 |
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);
|
| ︙ | ︙ | |||
683 684 685 686 687 688 689 |
return TCL_OK;
}
/*----------------------------------------------------------------------
*
* ProcessAutopurgeObjCmd --
*
| | | 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 |
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().
|
| ︙ | ︙ | |||
711 712 713 714 715 716 717 |
return TCL_ERROR;
}
if (objc == 2) {
/*
* Set given value.
*/
| | | | | 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 |
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;
}
/*
|
| ︙ | ︙ | |||
795 796 797 798 799 800 801 |
*----------------------------------------------------------------------
*/
void
TclProcessCreated(
Tcl_Pid pid) /* Process id. */
{
| | | 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 |
*----------------------------------------------------------------------
*/
void
TclProcessCreated(
Tcl_Pid pid) /* Process id. */
{
size_t resolvedPid;
Tcl_HashEntry *entry, *entry2;
int isNew;
ProcessInfo *info;
/*
* Get resolved pid first.
*/
|
| ︙ | ︙ | |||
817 818 819 820 821 822 823 |
*/
entry = Tcl_CreateHashEntry(&infoTablePerPid, pid, &isNew);
if (!isNew) {
/*
* Pid was reused, free old info and reuse structure.
*/
| | | | | 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 |
*/
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);
|
| ︙ | ︙ | |||
883 884 885 886 887 888 889 890 891 892 893 894 |
ProcessInfo *info;
TclProcessWaitStatus result;
/*
* First search for pid in table.
*/
entry = Tcl_FindHashEntry(&infoTablePerPid, pid);
if (!entry) {
/*
* Unknown process, just call WaitProcessStatus and return.
*/
| > | | > > | > | | > | 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 |
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;
}
|
Changes to generic/tclRegexp.c.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 16 17 18 19 20 21 22 | * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #include "tclRegexp.h" /* *---------------------------------------------------------------------- * The routines in this file use Henry Spencer's regular expression package * contained in the following additional source files: * * regc_color.c regc_cvec.c regc_lex.c | > | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 | * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #include "tclRegexp.h" #include <assert.h> /* *---------------------------------------------------------------------- * The routines in this file use Henry Spencer's regular expression package * contained in the following additional source files: * * regc_color.c regc_cvec.c regc_lex.c |
| ︙ | ︙ | |||
65 66 67 68 69 70 71 |
#define NUM_REGEXPS 30
typedef struct {
int initialized; /* Set to 1 when the module is initialized. */
char *patterns[NUM_REGEXPS];/* Strings corresponding to compiled regular
* expression patterns. NULL means that this
* slot isn't used. Malloc-ed. */
| | | | | > > > > > > > > > > > > > > > > > | 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 |
#define NUM_REGEXPS 30
typedef struct {
int initialized; /* Set to 1 when the module is initialized. */
char *patterns[NUM_REGEXPS];/* Strings corresponding to compiled regular
* expression patterns. NULL means that this
* slot isn't used. Malloc-ed. */
size_t patLengths[NUM_REGEXPS];/* Number of non-null characters in
* corresponding entry in patterns. -1 means
* entry isn't used. */
struct TclRegexp *regexps[NUM_REGEXPS];
/* Compiled forms of above strings. Also
* malloc-ed, or NULL if not in use yet. */
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
/*
* Declarations for functions used only in this file.
*/
static TclRegexp * CompileRegexp(Tcl_Interp *interp, const char *pattern,
size_t 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);
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 = {
"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 ? irPtr->twoPtrValue.ptr1 : NULL; \
} while (0)
/*
*----------------------------------------------------------------------
*
* Tcl_RegExpCompile --
*
* Compile a regular expression into a form suitable for fast matching.
|
| ︙ | ︙ | |||
168 169 170 171 172 173 174 |
* returned by previous call to
* Tcl_GetRegExpFromObj. */
const char *text, /* Text against which to match re. */
const char *start) /* If text is part of a larger string, this
* identifies beginning of larger string, so
* that "^" won't match. */
{
| | > | 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 |
* returned by previous call to
* Tcl_GetRegExpFromObj. */
const char *text, /* Text against which to match re. */
const char *start) /* If text is part of a larger string, this
* identifies beginning of larger string, so
* that "^" won't match. */
{
int flags, result;
size_t numChars;
TclRegexp *regexp = (TclRegexp *) re;
Tcl_DString ds;
const Tcl_UniChar *ustr;
/*
* If the starting point is offset from the beginning of the buffer, then
* we need to tell the regexp engine not to match "^".
|
| ︙ | ︙ | |||
228 229 230 231 232 233 234 |
*---------------------------------------------------------------------------
*/
void
Tcl_RegExpRange(
Tcl_RegExp re, /* Compiled regular expression that has been
* passed to Tcl_RegExpExec. */
| | | | | 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 |
*---------------------------------------------------------------------------
*/
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,
* > 0 means give the range of a matching
* subrange. */
const char **startPtr, /* Store address of first character in
* (sub-)range here. */
const char **endPtr) /* Store address of character just after last
* in (sub-)range here. */
{
TclRegexp *regexpPtr = (TclRegexp *) re;
const char *string;
if (index > regexpPtr->re.re_nsub) {
*startPtr = *endPtr = NULL;
} else if (regexpPtr->matches[index].rm_so == TCL_INDEX_NONE) {
*startPtr = *endPtr = NULL;
} else {
if (regexpPtr->objPtr) {
string = TclGetString(regexpPtr->objPtr);
} else {
string = regexpPtr->string;
}
|
| ︙ | ︙ | |||
280 281 282 283 284 285 286 |
static int
RegExpExecUniChar(
Tcl_Interp *interp, /* Interpreter to use for error reporting. */
Tcl_RegExp re, /* Compiled regular expression; returned by a
* previous call to Tcl_GetRegExpFromObj */
const Tcl_UniChar *wString, /* String against which to match re. */
| | < | < | | | | 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 |
static int
RegExpExecUniChar(
Tcl_Interp *interp, /* Interpreter to use for error reporting. */
Tcl_RegExp re, /* Compiled regular expression; returned by a
* previous call to Tcl_GetRegExpFromObj */
const Tcl_UniChar *wString, /* String against which to match re. */
size_t numChars, /* Length of Tcl_UniChar string. */
size_t nm, /* How many subexpression matches (counting
* the whole match as subexpression 0) are of
* interest. -1 means "don't know". */
int flags) /* Regular expression flags. */
{
int status;
TclRegexp *regexpPtr = (TclRegexp *) re;
size_t last = regexpPtr->re.re_nsub + 1;
if (nm >= last) {
nm = last;
}
status = TclReExec(®expPtr->re, wString, numChars,
®expPtr->details, nm, regexpPtr->matches, flags);
/*
* Check for errors.
*/
if (status != REG_OKAY) {
|
| ︙ | ︙ | |||
340 341 342 343 344 345 346 |
*---------------------------------------------------------------------------
*/
void
TclRegExpRangeUniChar(
Tcl_RegExp re, /* Compiled regular expression that has been
* passed to Tcl_RegExpExec. */
| | | | | | | | | | 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 |
*---------------------------------------------------------------------------
*/
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,
* > 0 means give the range of a matching
* subrange, TCL_INDEX_NONE means the range of the
* rm_extend field. */
size_t *startPtr, /* Store address of first character in
* (sub-)range here. */
size_t *endPtr) /* Store address of character just after last
* in (sub-)range here. */
{
TclRegexp *regexpPtr = (TclRegexp *) re;
if ((regexpPtr->flags®_EXPECT) && (index == TCL_INDEX_NONE)) {
*startPtr = regexpPtr->details.rm_extend.rm_so;
*endPtr = regexpPtr->details.rm_extend.rm_eo;
} else if (index + 1 > regexpPtr->re.re_nsub + 1) {
*startPtr = TCL_INDEX_NONE;
*endPtr = TCL_INDEX_NONE;
} else {
*startPtr = regexpPtr->matches[index].rm_so;
*endPtr = regexpPtr->matches[index].rm_eo;
}
}
/*
|
| ︙ | ︙ | |||
420 421 422 423 424 425 426 |
int
Tcl_RegExpExecObj(
Tcl_Interp *interp, /* Interpreter to use for error reporting. */
Tcl_RegExp re, /* Compiled regular expression; must have been
* returned by previous call to
* Tcl_GetRegExpFromObj. */
Tcl_Obj *textObj, /* Text against which to match re. */
| | | | | 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 |
int
Tcl_RegExpExecObj(
Tcl_Interp *interp, /* Interpreter to use for error reporting. */
Tcl_RegExp re, /* Compiled regular expression; must have been
* returned by previous call to
* Tcl_GetRegExpFromObj. */
Tcl_Obj *textObj, /* Text against which to match re. */
size_t offset, /* Character index that marks where matching
* should begin. */
size_t 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 reflags = regexpPtr->flags;
#define TCL_REG_GLOBOK_FLAGS \
(TCL_REG_ADVANCED | TCL_REG_NOSUB | TCL_REG_NOCASE)
/*
* Take advantage of the equivalent glob pattern, if one exists.
* This is possible based only on the right mix of incoming flags (0)
|
| ︙ | ︙ | |||
460 461 462 463 464 465 466 |
/*
* Save the target object so we can extract strings from it later.
*/
regexpPtr->string = NULL;
regexpPtr->objPtr = textObj;
| | | 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 |
/*
* Save the target object so we can extract strings from it later.
*/
regexpPtr->string = NULL;
regexpPtr->objPtr = textObj;
udata = TclGetUnicodeFromObj(textObj, &length);
if (offset > length) {
offset = length;
}
udata += offset;
length -= offset;
|
| ︙ | ︙ | |||
572 573 574 575 576 577 578 |
* the interp regexp cache. */
Tcl_Obj *objPtr, /* Object whose string rep contains regular
* expression pattern. Internal rep will be
* changed to compiled form of this regular
* expression. */
int flags) /* Regular expression compilation flags. */
{
| | < < < < | < | < < < < < < < < < < < < | < < | 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 |
* the interp regexp cache. */
Tcl_Obj *objPtr, /* Object whose string rep contains regular
* expression pattern. Internal rep will be
* changed to compiled form of this regular
* expression. */
int flags) /* Regular expression compilation flags. */
{
size_t length;
TclRegexp *regexpPtr;
const char *pattern;
RegexpGetIntRep(objPtr, regexpPtr);
if ((regexpPtr == NULL) || (regexpPtr->flags != flags)) {
pattern = TclGetStringFromObj(objPtr, &length);
regexpPtr = CompileRegexp(interp, pattern, length, flags);
if (regexpPtr == NULL) {
return NULL;
}
RegexpSetIntRep(objPtr, regexpPtr);
}
return (Tcl_RegExp) regexpPtr;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
675 676 677 678 679 680 681 |
* Assume that there will never be more than INT_MAX subexpressions. This
* is a pretty reasonable assumption; the RE engine doesn't scale _that_
* well and Tcl has other limits that constrain things as well...
*/
resultObj = Tcl_NewObj();
Tcl_ListObjAppendElement(NULL, resultObj,
| | | 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 |
* Assume that there will never be more than INT_MAX subexpressions. This
* is a pretty reasonable assumption; the RE engine doesn't scale _that_
* well and Tcl has other limits that constrain things as well...
*/
resultObj = Tcl_NewObj();
Tcl_ListObjAppendElement(NULL, resultObj,
TclNewWideIntObjFromSize(regexpPtr->re.re_nsub));
/*
* Now append a list of all the bit-flags set for the RE.
*/
TclNewObj(infoObj);
for (inf=infonames ; inf->bit != 0 ; inf++) {
|
| ︙ | ︙ | |||
752 753 754 755 756 757 758 |
*----------------------------------------------------------------------
*/
static void
FreeRegexpInternalRep(
Tcl_Obj *objPtr) /* Regexp object with internal rep to free. */
{
| | > > > > < | 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 |
*----------------------------------------------------------------------
*/
static void
FreeRegexpInternalRep(
Tcl_Obj *objPtr) /* Regexp object with internal rep to free. */
{
TclRegexp *regexpRepPtr;
RegexpGetIntRep(objPtr, regexpRepPtr);
assert(regexpRepPtr != NULL);
/*
* If this is the last reference to the regexp, free it.
*/
if (regexpRepPtr->refCount-- <= 1) {
FreeRegexp(regexpRepPtr);
}
}
/*
*----------------------------------------------------------------------
*
* DupRegexpInternalRep --
*
|
| ︙ | ︙ | |||
786 787 788 789 790 791 792 |
*/
static void
DupRegexpInternalRep(
Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
Tcl_Obj *copyPtr) /* Object with internal rep to set. */
{
| | | | > | > | 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 |
*/
static void
DupRegexpInternalRep(
Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
Tcl_Obj *copyPtr) /* Object with internal rep to set. */
{
TclRegexp *regexpPtr;
RegexpGetIntRep(srcPtr, regexpPtr);
assert(regexpPtr != NULL);
RegexpSetIntRep(copyPtr, regexpPtr);
}
/*
*----------------------------------------------------------------------
*
* SetRegexpFromAny --
*
|
| ︙ | ︙ | |||
850 851 852 853 854 855 856 |
*----------------------------------------------------------------------
*/
static TclRegexp *
CompileRegexp(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
const char *string, /* The regexp to compile (UTF-8). */
| | | 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 |
*----------------------------------------------------------------------
*/
static TclRegexp *
CompileRegexp(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
const char *string, /* The regexp to compile (UTF-8). */
size_t length, /* The length of the string in bytes. */
int flags) /* Compilation flags. */
{
TclRegexp *regexpPtr;
const Tcl_UniChar *uniString;
int numChars, status, i, exact;
Tcl_DString stringBuf;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
|
| ︙ | ︙ | |||
908 909 910 911 912 913 914 |
}
}
/*
* This is a new expression, so compile it and add it to the cache.
*/
| | | 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 |
}
}
/*
* This is a new expression, so compile it and add it to the cache.
*/
regexpPtr = Tcl_Alloc(sizeof(TclRegexp));
regexpPtr->objPtr = NULL;
regexpPtr->string = NULL;
regexpPtr->details.rm_extend.rm_so = -1;
regexpPtr->details.rm_extend.rm_eo = -1;
/*
* Get the up-to-date string representation and map to unicode.
|
| ︙ | ︙ | |||
935 936 937 938 939 940 941 |
Tcl_DStringFree(&stringBuf);
if (status != REG_OKAY) {
/*
* Clean up and report errors in the interpreter, if possible.
*/
| | | 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 |
Tcl_DStringFree(&stringBuf);
if (status != REG_OKAY) {
/*
* Clean up and report errors in the interpreter, if possible.
*/
Tcl_Free(regexpPtr);
if (interp) {
TclRegError(interp,
"couldn't compile regular expression pattern: ", status);
}
return NULL;
}
|
| ︙ | ︙ | |||
963 964 965 966 967 968 969 |
/*
* Allocate enough space for all of the subexpressions, plus one extra for
* the entire pattern.
*/
regexpPtr->matches =
| | | | | | 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 |
/*
* Allocate enough space for all of the subexpressions, plus one extra for
* the entire pattern.
*/
regexpPtr->matches =
Tcl_Alloc(sizeof(regmatch_t) * (regexpPtr->re.re_nsub + 1));
/*
* Initialize the refcount to one initially, since it is in the cache.
*/
regexpPtr->refCount = 1;
/*
* Free the last regexp, if necessary, and make room at the head of the
* list for the new regexp.
*/
if (tsdPtr->patterns[NUM_REGEXPS-1] != NULL) {
TclRegexp *oldRegexpPtr = tsdPtr->regexps[NUM_REGEXPS-1];
if (oldRegexpPtr->refCount-- <= 1) {
FreeRegexp(oldRegexpPtr);
}
Tcl_Free(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] = Tcl_Alloc(length + 1);
memcpy(tsdPtr->patterns[0], string, length + 1);
tsdPtr->patLengths[0] = length;
tsdPtr->regexps[0] = regexpPtr;
return regexpPtr;
}
/*
|
| ︙ | ︙ | |||
1022 1023 1024 1025 1026 1027 1028 |
TclRegexp *regexpPtr) /* Compiled regular expression to free. */
{
TclReFree(®expPtr->re);
if (regexpPtr->globObjPtr) {
TclDecrRefCount(regexpPtr->globObjPtr);
}
if (regexpPtr->matches) {
| | | | 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 |
TclRegexp *regexpPtr) /* Compiled regular expression to free. */
{
TclReFree(®expPtr->re);
if (regexpPtr->globObjPtr) {
TclDecrRefCount(regexpPtr->globObjPtr);
}
if (regexpPtr->matches) {
Tcl_Free(regexpPtr->matches);
}
Tcl_Free(regexpPtr);
}
/*
*----------------------------------------------------------------------
*
* FinalizeRegexp --
*
|
| ︙ | ︙ | |||
1056 1057 1058 1059 1060 1061 1062 |
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
for (i = 0; (i < NUM_REGEXPS) && (tsdPtr->patterns[i] != NULL); i++) {
regexpPtr = tsdPtr->regexps[i];
if (regexpPtr->refCount-- <= 1) {
FreeRegexp(regexpPtr);
}
| | | 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 |
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
for (i = 0; (i < NUM_REGEXPS) && (tsdPtr->patterns[i] != NULL); i++) {
regexpPtr = tsdPtr->regexps[i];
if (regexpPtr->refCount-- <= 1) {
FreeRegexp(regexpPtr);
}
Tcl_Free(tsdPtr->patterns[i]);
tsdPtr->patterns[i] = NULL;
}
/*
* We may find ourselves reinitialized if another finalization routine
* invokes regexps.
*/
|
| ︙ | ︙ |
Changes to generic/tclResolve.c.
| ︙ | ︙ | |||
97 98 99 100 101 102 103 |
}
/*
* Otherwise, this is a new scheme. Add it to the FRONT of the linked
* list, so that it overrides existing schemes.
*/
| | | | 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 |
}
/*
* Otherwise, this is a new scheme. Add it to the FRONT of the linked
* list, so that it overrides existing schemes.
*/
resPtr = Tcl_Alloc(sizeof(ResolverScheme));
len = strlen(name) + 1;
resPtr->name = Tcl_Alloc(len);
memcpy(resPtr->name, name, len);
resPtr->cmdResProc = cmdProc;
resPtr->varResProc = varProc;
resPtr->compiledVarResProc = compiledVarProc;
resPtr->nextPtr = iPtr->resolverPtr;
iPtr->resolverPtr = resPtr;
}
|
| ︙ | ︙ | |||
221 222 223 224 225 226 227 |
iPtr->compileEpoch++;
}
if (resPtr->cmdResProc) {
BumpCmdRefEpochs(iPtr->globalNsPtr);
}
*prevPtrPtr = resPtr->nextPtr;
| | | | 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 |
iPtr->compileEpoch++;
}
if (resPtr->cmdResProc) {
BumpCmdRefEpochs(iPtr->globalNsPtr);
}
*prevPtrPtr = resPtr->nextPtr;
Tcl_Free(resPtr->name);
Tcl_Free(resPtr);
return 1;
}
return 0;
}
/*
|
| ︙ | ︙ |
Changes to generic/tclResult.c.
| ︙ | ︙ | |||
70 71 72 73 74 75 76 |
Tcl_InterpState
Tcl_SaveInterpState(
Tcl_Interp *interp, /* Interpreter's state to be saved */
int status) /* status code for current operation */
{
Interp *iPtr = (Interp *) interp;
| | | 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 |
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 = Tcl_Alloc(sizeof(InterpState));
statePtr->status = status;
statePtr->flags = iPtr->flags & ERR_ALREADY_LOGGED;
statePtr->returnLevel = iPtr->returnLevel;
statePtr->returnCode = iPtr->returnCode;
statePtr->errorInfo = iPtr->errorInfo;
statePtr->errorStack = iPtr->errorStack;
|
| ︙ | ︙ | |||
200 201 202 203 204 205 206 |
if (statePtr->returnOpts) {
Tcl_DecrRefCount(statePtr->returnOpts);
}
if (statePtr->errorStack) {
Tcl_DecrRefCount(statePtr->errorStack);
}
Tcl_DecrRefCount(statePtr->objResult);
| | < < < < < < < < < < < < < < < < < < < < < < < < < < | 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 |
if (statePtr->returnOpts) {
Tcl_DecrRefCount(statePtr->returnOpts);
}
if (statePtr->errorStack) {
Tcl_DecrRefCount(statePtr->errorStack);
}
Tcl_DecrRefCount(statePtr->objResult);
Tcl_Free(statePtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_SetObjResult --
*
|
| ︙ | ︙ | |||
379 380 381 382 383 384 385 386 387 388 389 |
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;
if (Tcl_IsShared(iPtr->objResultPtr)) {
Tcl_SetObjResult(interp, Tcl_DuplicateObj(iPtr->objResultPtr));
}
| > | | | 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 |
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);
}
/*
|
| ︙ | ︙ | |||
508 509 510 511 512 513 514 |
TclDecrRefCount(objResultPtr);
TclNewObj(objResultPtr);
Tcl_IncrRefCount(objResultPtr);
iPtr->objResultPtr = objResultPtr;
} else {
if (objResultPtr->bytes != &tclEmptyString) {
if (objResultPtr->bytes) {
| | | 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 |
TclDecrRefCount(objResultPtr);
TclNewObj(objResultPtr);
Tcl_IncrRefCount(objResultPtr);
iPtr->objResultPtr = objResultPtr;
} else {
if (objResultPtr->bytes != &tclEmptyString) {
if (objResultPtr->bytes) {
Tcl_Free(objResultPtr->bytes);
}
objResultPtr->bytes = &tclEmptyString;
objResultPtr->length = 0;
}
TclFreeIntRep(objResultPtr);
}
}
|
| ︙ | ︙ | |||
772 773 774 775 776 777 778 |
if (iPtr->errorInfo) {
Tcl_DecrRefCount(iPtr->errorInfo);
iPtr->errorInfo = NULL;
}
Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORINFO],
&valuePtr);
if (valuePtr != NULL) {
| > > | | | 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 |
if (iPtr->errorInfo) {
Tcl_DecrRefCount(iPtr->errorInfo);
iPtr->errorInfo = NULL;
}
Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORINFO],
&valuePtr);
if (valuePtr != NULL) {
size_t length;
(void) TclGetStringFromObj(valuePtr, &length);
if (length) {
iPtr->errorInfo = valuePtr;
Tcl_IncrRefCount(iPtr->errorInfo);
iPtr->flags |= ERR_ALREADY_LOGGED;
}
}
Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORSTACK],
&valuePtr);
|
| ︙ | ︙ |
Changes to generic/tclScan.c.
| ︙ | ︙ | |||
98 99 100 101 102 103 104 |
while (ch != ']') {
if (ch == '-') {
nranges++;
}
end += TclUtfToUniChar(end, &ch);
}
| | | | 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 |
while (ch != ']') {
if (ch == '-') {
nranges++;
}
end += TclUtfToUniChar(end, &ch);
}
cset->chars = Tcl_Alloc(sizeof(Tcl_UniChar) * (end - format - 1));
if (nranges > 0) {
cset->ranges = Tcl_Alloc(sizeof(struct Range) * nranges);
} else {
cset->ranges = NULL;
}
/*
* Now build the character set.
*/
|
| ︙ | ︙ | |||
131 132 133 134 135 136 137 |
} else if (ch == '-') {
/*
* 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.
*/
| | | 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 |
} else if (ch == '-') {
/*
* 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) {
cset->chars[cset->nchars++] = start;
cset->chars[cset->nchars++] = ch;
} else {
format += TclUtfToUniChar(format, &ch);
/*
* Check to see if the range is in reverse order.
|
| ︙ | ︙ | |||
220 221 222 223 224 225 226 |
*----------------------------------------------------------------------
*/
static void
ReleaseCharSet(
CharSet *cset)
{
| | | | 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 |
*----------------------------------------------------------------------
*/
static void
ReleaseCharSet(
CharSet *cset)
{
Tcl_Free(cset->chars);
if (cset->ranges) {
Tcl_Free(cset->ranges);
}
}
/*
*----------------------------------------------------------------------
*
* ValidateFormat --
|
| ︙ | ︙ | |||
257 258 259 260 261 262 263 |
* required. */
{
int gotXpg, gotSequential, value, i, flags;
char *end;
Tcl_UniChar ch = 0;
int objIndex, xpgSize, nspace = numVars;
int *nassign = TclStackAlloc(interp, nspace * sizeof(int));
| | | 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 |
* required. */
{
int gotXpg, gotSequential, value, i, flags;
char *end;
Tcl_UniChar ch = 0;
int objIndex, xpgSize, nspace = numVars;
int *nassign = TclStackAlloc(interp, nspace * sizeof(int));
char buf[TCL_UTF_MAX + 1] = "";
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! */
/*
* Initialize an array that records the number of times a variable is
|
| ︙ | ︙ | |||
585 586 587 588 589 590 591 |
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv,
"string format ?varName ...?");
return TCL_ERROR;
}
| | | | | 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 |
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv,
"string format ?varName ...?");
return TCL_ERROR;
}
format = TclGetString(objv[2]);
numVars = objc-3;
/*
* Check for errors in the format string.
*/
if (ValidateFormat(interp, format, numVars, &totalVars) == TCL_ERROR) {
return TCL_ERROR;
}
/*
* Allocate space for the result objects.
*/
if (totalVars > 0) {
objs = Tcl_Alloc(sizeof(Tcl_Obj *) * totalVars);
for (i = 0; i < totalVars; i++) {
objs[i] = NULL;
}
}
string = TclGetString(objv[1]);
baseString = string;
/*
* Iterate over the format string filling in the result objects until we
* reach the end of input, the end of the format string, or there is a
* mismatch.
*/
|
| ︙ | ︙ | |||
715 716 717 718 719 720 721 |
/*
* Handle the various field types.
*/
switch (ch) {
case 'n':
if (!(flags & SCAN_SUPPRESS)) {
| | | 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 |
/*
* Handle the various field types.
*/
switch (ch) {
case 'n':
if (!(flags & SCAN_SUPPRESS)) {
objPtr = Tcl_NewWideIntObj(string - baseString);
Tcl_IncrRefCount(objPtr);
CLANG_ASSERT(objs);
objs[objIndex++] = objPtr;
}
nconversions++;
continue;
|
| ︙ | ︙ | |||
877 878 879 880 881 882 883 | case 'c': /* * Scan a single Unicode character. */ offset = TclUtfToUniChar(string, &sch); i = (int)sch; | | | | | | | 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 |
case 'c':
/*
* Scan a single Unicode character.
*/
offset = TclUtfToUniChar(string, &sch);
i = (int)sch;
#if TCL_UTF_MAX <= 4
if ((sch >= 0xD800) && (offset < 3)) {
offset += TclUtfToUniChar(string+offset, &sch);
i = (((i<<10) & 0x0FFC00) + 0x10000) + (sch & 0x3FF);
}
#endif
string += offset;
if (!(flags & SCAN_SUPPRESS)) {
objPtr = Tcl_NewWideIntObj(i);
Tcl_IncrRefCount(objPtr);
CLANG_ASSERT(objs);
objs[objIndex++] = objPtr;
}
break;
case 'i':
/*
* Scan an unsigned or signed integer.
*/
objPtr = Tcl_NewWideIntObj(0);
Tcl_IncrRefCount(objPtr);
if (width == 0) {
width = ~0;
}
if (TCL_OK != TclParseNumber(NULL, objPtr, NULL, string, width,
&end, TCL_PARSE_INTEGER_ONLY | parseFlag)) {
Tcl_DecrRefCount(objPtr);
|
| ︙ | ︙ | |||
922 923 924 925 926 927 928 |
string = end;
if (flags & SCAN_SUPPRESS) {
Tcl_DecrRefCount(objPtr);
break;
}
if (flags & SCAN_LONGER) {
if (Tcl_GetWideIntFromObj(NULL, objPtr, &wideValue) != TCL_OK) {
| | | | < | > > > > > | > > > > > > > | > | 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 |
string = end;
if (flags & SCAN_SUPPRESS) {
Tcl_DecrRefCount(objPtr);
break;
}
if (flags & SCAN_LONGER) {
if (Tcl_GetWideIntFromObj(NULL, objPtr, &wideValue) != TCL_OK) {
wideValue = WIDE_MAX;
if (TclGetString(objPtr)[0] == '-') {
wideValue = WIDE_MIN;
}
}
if ((flags & SCAN_UNSIGNED) && (wideValue < 0)) {
sprintf(buf, "%" TCL_LL_MODIFIER "u", wideValue);
Tcl_SetStringObj(objPtr, buf, -1);
} else {
TclSetIntObj(objPtr, wideValue);
}
} else if (flags & SCAN_BIG) {
if (flags & SCAN_UNSIGNED) {
mp_int big;
int code = Tcl_GetBignumFromObj(interp, objPtr, &big);
if (code == TCL_OK) {
if (big.sign != MP_ZPOS) {
code = TCL_ERROR;
}
mp_clear(&big);
}
if (code == 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 {
if (TclGetLongFromObj(NULL, objPtr, &value) != TCL_OK) {
if (TclGetString(objPtr)[0] == '-') {
value = LONG_MIN;
|
| ︙ | ︙ | |||
993 994 995 996 997 998 999 |
} else if (flags & SCAN_SUPPRESS) {
Tcl_DecrRefCount(objPtr);
string = end;
} else {
double dvalue;
if (Tcl_GetDoubleFromObj(NULL, objPtr, &dvalue) != TCL_OK) {
#ifdef ACCEPT_NAN
| > | > | | 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 |
} else if (flags & SCAN_SUPPRESS) {
Tcl_DecrRefCount(objPtr);
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;
} else
#endif
{
Tcl_DecrRefCount(objPtr);
goto done;
}
}
|
| ︙ | ︙ | |||
1058 1059 1060 1061 1062 1063 1064 |
*/
Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewObj());
}
}
}
if (objs != NULL) {
| | | | | 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 |
*/
Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewObj());
}
}
}
if (objs != NULL) {
Tcl_Free(objs);
}
if (code == TCL_OK) {
if (underflow && (nconversions == 0)) {
if (numVars) {
objPtr = Tcl_NewWideIntObj(-1);
} else {
if (objPtr) {
Tcl_SetListObj(objPtr, 0, NULL);
} else {
objPtr = Tcl_NewObj();
}
}
} else if (numVars) {
objPtr = Tcl_NewWideIntObj(result);
}
Tcl_SetObjResult(interp, objPtr);
}
return code;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclStrToD.c.
| ︙ | ︙ | |||
316 317 318 319 320 321 322 | static char * ShorteningQuickFormat(double, int, int, double, char *, int *); 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 *); | | | | | | | | | | 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 | static char * ShorteningQuickFormat(double, int, int, double, char *, int *); 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, int, int, int, int, int, int, int, int, int, int, int, int *, char **); static char * StrictInt64Conversion(Double *, Tcl_WideUInt, int, int, int, int, int, int, int, int, int *, char **); static int ShouldBankerRoundUpPowD(mp_int *, int, int); static int ShouldBankerRoundUpToNextPowD(mp_int *, mp_int *, int, int, mp_int *); static char * ShorteningBignumConversionPowD(Double *dPtr, Tcl_WideUInt bw, int b2, int b5, int m2plus, int m2minus, int m5, int sd, int k, int len, int ilim, int ilim1, int *decpt, char **endPtr); static char * StrictBignumConversionPowD(Double *dPtr, Tcl_WideUInt bw, int b2, int b5, int sd, int k, int len, int ilim, int ilim1, int *decpt, char **endPtr); static int ShouldBankerRoundUp(mp_int *, mp_int *, int); static int ShouldBankerRoundUpToNext(mp_int *, mp_int *, mp_int *, int); static char * ShorteningBignumConversion(Double *dPtr, Tcl_WideUInt bw, int b2, int m2plus, int m2minus, int s2, int s5, int k, int len, int ilim, int ilim1, int *decpt, char **endPtr); static char * StrictBignumConversion(Double *dPtr, Tcl_WideUInt bw, int b2, int s2, int s5, int k, int len, int ilim, int ilim1, int *decpt, char **endPtr); static double BignumToBiasedFrExp(const mp_int *big, int *machexp); static double Pow10TimesFrExp(int exponent, double fraction, int *machexp); |
| ︙ | ︙ | |||
470 471 472 473 474 475 476 |
Tcl_Interp *interp, /* Used for error reporting. May be NULL. */
Tcl_Obj *objPtr, /* Object to receive the internal rep. */
const char *expected, /* Description of the type of number the
* caller expects to be able to parse
* ("integer", "boolean value", etc.). */
const char *bytes, /* Pointer to the start of the string to
* scan. */
| | | 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 |
Tcl_Interp *interp, /* Used for error reporting. May be NULL. */
Tcl_Obj *objPtr, /* Object to receive the internal rep. */
const char *expected, /* Description of the type of number the
* caller expects to be able to parse
* ("integer", "boolean value", etc.). */
const char *bytes, /* Pointer to the start of the string to
* scan. */
size_t 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,
|
| ︙ | ︙ | |||
525 526 527 528 529 530 531 |
size_t acceptLen; /* Number of characters following that
* point. */
int status = TCL_OK; /* Status to return to caller. */
char d = 0; /* Last hexadecimal digit scanned; initialized
* to avoid a compiler warning. */
int shift = 0; /* Amount to shift when accumulating binary */
| | | | | 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 |
size_t acceptLen; /* Number of characters following that
* point. */
int status = TCL_OK; /* Status to return to caller. */
char d = 0; /* Last hexadecimal digit scanned; initialized
* to avoid a compiler warning. */
int shift = 0; /* Amount to shift when accumulating binary */
#define ALL_BITS ((Tcl_WideUInt)-1)
#define MOST_BITS (ALL_BITS >> 1)
/*
* Initialize bytes to start of the object's string rep if the caller
* didn't pass anything else.
*/
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;
}
}
|
| ︙ | ︙ | |||
700 701 702 703 704 705 706 | * too large shifts first. */ if ((octalSignificandWide != 0) && (((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideUInt)) || (octalSignificandWide > | | | 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 |
* too large shifts first.
*/
if ((octalSignificandWide != 0)
&& (((size_t)shift >=
CHAR_BIT*sizeof(Tcl_WideUInt))
|| (octalSignificandWide >
((Tcl_WideUInt)-1 >> shift)))) {
octalSignificandOverflow = 1;
TclInitBignumFromWideUInt(&octalSignificandBig,
octalSignificandWide);
}
}
if (!octalSignificandOverflow) {
octalSignificandWide =
|
| ︙ | ︙ | |||
765 766 767 768 769 770 771 | * Shifting by more bits than are in the value being * shifted is at least de facto nonportable. Check for too * large shifts first. */ if (significandWide != 0 && ((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideUInt) || | | | 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 |
* Shifting by more bits than are in the value being
* shifted is at least de facto nonportable. Check for too
* large shifts first.
*/
if (significandWide != 0 &&
((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideUInt) ||
significandWide > ((Tcl_WideUInt)-1 >> shift))) {
significandOverflow = 1;
TclInitBignumFromWideUInt(&significandBig,
significandWide);
}
}
if (!significandOverflow) {
significandWide = (significandWide << shift) + d;
|
| ︙ | ︙ | |||
806 807 808 809 810 811 812 | * Shifting by more bits than are in the value being * shifted is at least de facto nonportable. Check for too * large shifts first. */ if (significandWide != 0 && ((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideUInt) || | | | 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 |
* Shifting by more bits than are in the value being
* shifted is at least de facto nonportable. Check for too
* large shifts first.
*/
if (significandWide != 0 &&
((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideUInt) ||
significandWide > ((Tcl_WideUInt)-1 >> shift))) {
significandOverflow = 1;
TclInitBignumFromWideUInt(&significandBig,
significandWide);
}
}
if (!significandOverflow) {
significandWide = (significandWide << shift) + 1;
|
| ︙ | ︙ | |||
1107 1108 1109 1110 1111 1112 1113 |
while (len != 0 && TclIsSpaceProc(*p)) {
p++;
len--;
}
}
if (endPtrPtr == NULL) {
| | | 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 |
while (len != 0 && TclIsSpaceProc(*p)) {
p++;
len--;
}
}
if (endPtrPtr == NULL) {
if ((len != 0) && ((numBytes + 1 > 1) || (*p != '\0'))) {
status = TCL_ERROR;
}
} else {
*endPtrPtr = p;
}
}
|
| ︙ | ︙ | |||
1384 1385 1386 1387 1388 1389 1390 | /* * There's no need to multiply if the multiplicand is zero. */ *wideRepPtr = digit; return 0; } else if (numZeros >= maxpow10_wide | | | 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 |
/*
* There's no need to multiply if the multiplicand is zero.
*/
*wideRepPtr = digit;
return 0;
} else if (numZeros >= maxpow10_wide
|| w > ((Tcl_WideUInt)-1-digit)/pow10_wide[numZeros+1]) {
/*
* Wide multiplication will overflow. Expand the number to a
* bignum and fall through into the bignum case.
*/
TclInitBignumFromWideUInt(bignumRepPtr, w);
} else {
|
| ︙ | ︙ | |||
1782 1783 1784 1785 1786 1787 1788 |
* significand (the most significant) corresponds to the
* 2**(binExponent+M2 + 1) bit of 2*M2*v. Allocate enough digits to hold
* that quantity, then convert the significand to a large integer, scaled
* appropriately. Then multiply by the appropriate power of 5.
*/
msb = binExponent + M2; /* 1008 */
| | | | | 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 |
* significand (the most significant) corresponds to the
* 2**(binExponent+M2 + 1) bit of 2*M2*v. Allocate enough digits to hold
* that quantity, then convert the significand to a large integer, scaled
* appropriately. Then multiply by the appropriate power of 5.
*/
msb = binExponent + M2; /* 1008 */
nDigits = msb / MP_DIGIT_BIT + 1;
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);
}
}
|
| ︙ | ︙ | |||
2106 2107 2108 2109 2110 2111 2112 | * * FormatInfAndNaN -- * * Bailout for formatting infinities and Not-A-Number. * * Results: * Returns one of the strings 'Infinity' and 'NaN'. The string returned | | | | | 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 |
*
* FormatInfAndNaN --
*
* Bailout for formatting infinities and Not-A-Number.
*
* Results:
* Returns one of the strings 'Infinity' and 'NaN'. The string returned
* must be freed by the caller using 'Tcl_Free'.
*
* Side effects:
* Stores 9999 in *decpt, and sets '*endPtr' to designate the terminating
* NUL byte of the string if 'endPtr' is not NULL.
*
*----------------------------------------------------------------------
*/
static inline char *
FormatInfAndNaN(
Double *d, /* Exceptional number to format. */
int *decpt, /* Decimal point to set to a bogus value. */
char **endPtr) /* Pointer to the end of the formatted data */
{
char *retval;
*decpt = 9999;
if (!(d->w.word1) && !(d->w.word0 & HI_ORDER_SIG_MASK)) {
retval = Tcl_Alloc(9);
strcpy(retval, "Infinity");
if (endPtr) {
*endPtr = retval + 8;
}
} else {
retval = Tcl_Alloc(4);
strcpy(retval, "NaN");
if (endPtr) {
*endPtr = retval + 3;
}
}
return retval;
}
|
| ︙ | ︙ | |||
2162 2163 2164 2165 2166 2167 2168 |
*/
static inline char *
FormatZero(
int *decpt, /* Location of the decimal point. */
char **endPtr) /* Pointer to the end of the formatted data */
{
| | | 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 |
*/
static inline char *
FormatZero(
int *decpt, /* Location of the decimal point. */
char **endPtr) /* Pointer to the end of the formatted data */
{
char *retval = Tcl_Alloc(2);
strcpy(retval, "0");
if (endPtr) {
*endPtr = retval+1;
}
*decpt = 0;
return retval;
|
| ︙ | ︙ | |||
2343 2344 2345 2346 2347 2348 2349 | * one too high. * *---------------------------------------------------------------------- */ static inline void SetPrecisionLimits( | | | < | < < < < < < | | | | | 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 |
* one too high.
*
*----------------------------------------------------------------------
*/
static inline void
SetPrecisionLimits(
int flags, /* Type of conversion: TCL_DD_SHORTEST,
* TCL_DD_E_FMT, TCL_DD_F_FMT. */
int k, /* Floor(log10(number to convert)) */
int *ndigitsPtr, /* IN/OUT: Number of digits requested (will be
* adjusted if needed). */
int *iPtr, /* OUT: Maximum number of digits to return. */
int *iLimPtr, /* OUT: Number of digits of significance if
* the bignum method is used.*/
int *iLim1Ptr) /* OUT: Number of digits of significance if
* the quick method is used. */
{
switch (flags & TCL_DD_CONVERSION_TYPE_MASK) {
case TCL_DD_E_FORMAT:
if (*ndigitsPtr <= 0) {
*ndigitsPtr = 1;
}
*iLimPtr = *iLim1Ptr = *iPtr = *ndigitsPtr;
break;
case TCL_DD_F_FORMAT:
*iPtr = *ndigitsPtr + k + 1;
*iLimPtr = *iPtr;
*iLim1Ptr = *iPtr - 1;
if (*iPtr <= 0) {
*iPtr = 1;
}
break;
default:
*iLimPtr = *iLim1Ptr = -1;
*iPtr = 18;
*ndigitsPtr = 0;
break;
}
}
/*
*----------------------------------------------------------------------
*
* BumpUp --
|
| ︙ | ︙ | |||
2715 2716 2717 2718 2719 2720 2721 |
eps.d = ieps * d + 7.;
eps.w.word0 -= (FP_PRECISION-1) << EXP_SHIFT;
/*
* Handle the peculiar case where the result has no significant digits.
*/
| | | | | 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 |
eps.d = ieps * d + 7.;
eps.w.word0 -= (FP_PRECISION-1) << EXP_SHIFT;
/*
* Handle the peculiar case where the result has no significant digits.
*/
retval = Tcl_Alloc(len + 1);
if (ilim == 0) {
d -= 5.;
if (d > eps.d) {
*retval = '1';
*decpt = k;
return retval;
} else if (d < -eps.d) {
*decpt = k;
return retval;
} else {
Tcl_Free(retval);
return NULL;
}
}
/*
* Format the digit string.
*/
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);
return NULL;
}
*end = '\0';
if (endPtr != NULL) {
*endPtr = end;
}
return retval;
|
| ︙ | ︙ | |||
2810 2811 2812 2813 2814 2815 2816 |
*
*----------------------------------------------------------------------
*/
static inline char *
ShorteningInt64Conversion(
Double *dPtr, /* Original number to convert. */
| < < | | 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 |
*
*----------------------------------------------------------------------
*/
static inline char *
ShorteningInt64Conversion(
Double *dPtr, /* Original number to convert. */
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
* (will be different if bw == 1. */
int s2, int s5, /* Scale factors for the denominator. */
int k, /* Number of output digits before the decimal
* point. */
int len, /* Number of digits to allocate. */
int ilim, /* Number of digits to convert if b >= s */
int ilim1, /* Number of digits to convert if b < s */
int *decpt, /* OUTPUT: Position of the decimal point. */
char **endPtr) /* OUTPUT: Position of the terminal '\0' at
* the end of the returned string. */
{
char *retval = Tcl_Alloc(len + 1);
/* Output buffer. */
Tcl_WideUInt b = (bw * wuipow5[b5]) << b2;
/* Numerator of the fraction being
* converted. */
Tcl_WideUInt S = wuipow5[s5] << s2;
/* Denominator of the fraction being
* converted. */
|
| ︙ | ︙ | |||
2878 2879 2880 2881 2882 2883 2884 | /* * 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 | | | 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 |
/*
* 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)) {
/*
* Make sure we shouldn't be rounding *up* instead, in case the
* next number above is closer.
*/
if (2 * b > S || (2 * b == S && (digit & 1) != 0)) {
++digit;
|
| ︙ | ︙ | |||
2907 2908 2909 2910 2911 2912 2913 | /* * Does one plus the current digit put us within roundoff of the * number? */ if (b > S - mminus || (b == S - mminus | | | 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 |
/*
* 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)) {
if (digit == 9) {
*s++ = '9';
s = BumpUp(s, retval, &k);
break;
}
++digit;
*s++ = '0' + digit;
|
| ︙ | ︙ | |||
2979 2980 2981 2982 2983 2984 2985 |
*
*----------------------------------------------------------------------
*/
static inline char *
StrictInt64Conversion(
Double *dPtr, /* Original number to convert. */
| < < | | 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 |
*
*----------------------------------------------------------------------
*/
static inline char *
StrictInt64Conversion(
Double *dPtr, /* Original number to convert. */
Tcl_WideUInt bw, /* Integer significand. */
int b2, int b5, /* Scale factor for the significand in the
* numerator. */
int s2, int s5, /* Scale factors for the denominator. */
int k, /* Number of output digits before the decimal
* point. */
int len, /* Number of digits to allocate. */
int ilim, /* Number of digits to convert if b >= s */
int ilim1, /* Number of digits to convert if b < s */
int *decpt, /* OUTPUT: Position of the decimal point. */
char **endPtr) /* OUTPUT: Position of the terminal '\0' at
* the end of the returned string. */
{
char *retval = Tcl_Alloc(len + 1);
/* Output buffer. */
Tcl_WideUInt b = (bw * wuipow5[b5]) << b2;
/* Numerator of the fraction being
* converted. */
Tcl_WideUInt S = wuipow5[s5] << s2;
/* Denominator of the fraction being
* converted. */
|
| ︙ | ︙ | |||
3089 3090 3091 3092 3093 3094 3095 |
static inline int
ShouldBankerRoundUpPowD(
mp_int *b, /* Numerator of the fraction. */
int sd, /* Denominator is 2**(sd*DIGIT_BIT). */
int isodd) /* 1 if the digit is odd, 0 if even. */
{
int i;
| | | 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 |
static inline int
ShouldBankerRoundUpPowD(
mp_int *b, /* Numerator of the fraction. */
int sd, /* Denominator is 2**(sd*DIGIT_BIT). */
int isodd) /* 1 if the digit is odd, 0 if even. */
{
int i;
static const mp_digit topbit = ((mp_digit)1) << (MP_DIGIT_BIT - 1);
if (b->used < sd || (b->dp[sd-1] & topbit) == 0) {
return 0;
}
if (b->dp[sd-1] != topbit) {
return 1;
}
|
| ︙ | ︙ | |||
3125 3126 3127 3128 3129 3130 3131 |
*/
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*DIGIT_BIT). */
| < < < | 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 |
*/
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*DIGIT_BIT). */
int isodd, /* 1 if the integer significand is odd. */
mp_int *temp) /* Work area for the calculation. */
{
int i;
/*
* Compare B and S-m - which is the same as comparing B+m and S - which we
|
| ︙ | ︙ | |||
3153 3154 3155 3156 3157 3158 3159 |
}
for (i = sd-1; i >= 0; --i) {
/* Check for ==s */
if (temp->dp[i] != 0) { /* > s */
return 1;
}
}
| < < < < | 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 |
}
for (i = sd-1; i >= 0; --i) {
/* Check for ==s */
if (temp->dp[i] != 0) { /* > s */
return 1;
}
}
return isodd;
}
/*
*----------------------------------------------------------------------
*
* ShorteningBignumConversionPowD --
|
| ︙ | ︙ | |||
3186 3187 3188 3189 3190 3191 3192 |
*
*----------------------------------------------------------------------
*/
static inline char *
ShorteningBignumConversionPowD(
Double *dPtr, /* Original number to convert. */
| < < | | 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 |
*
*----------------------------------------------------------------------
*/
static inline char *
ShorteningBignumConversionPowD(
Double *dPtr, /* Original number to convert. */
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
* (will be different if bw == 1). */
int sd, /* Scale factor for the denominator. */
int k, /* Number of output digits before the decimal
* point. */
int len, /* Number of digits to allocate. */
int ilim, /* Number of digits to convert if b >= s */
int ilim1, /* Number of digits to convert if b < s */
int *decpt, /* OUTPUT: Position of the decimal point. */
char **endPtr) /* OUTPUT: Position of the terminal '\0' at
* the end of the returned string. */
{
char *retval = Tcl_Alloc(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. */
|
| ︙ | ︙ | |||
3273 3274 3275 3276 3277 3278 3279 | /* * Does the current digit put us on the low side of the exact value * but within within roundoff of being exact? */ r1 = mp_cmp_mag(&b, (m2plus > m2minus)? &mplus : &mminus); if (r1 == MP_LT || (r1 == MP_EQ | | | 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 |
/*
* Does the current digit put us on the low side of the exact value
* 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)) {
/*
* Make sure we shouldn't be rounding *up* instead, in case the
* next number above is closer.
*/
if (ShouldBankerRoundUpPowD(&b, sd, digit&1)) {
++digit;
|
| ︙ | ︙ | |||
3301 3302 3303 3304 3305 3306 3307 | } /* * Does one plus the current digit put us within roundoff of the * number? */ | | | 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 |
}
/*
* Does one plus the current digit put us within roundoff of the
* number?
*/
if (ShouldBankerRoundUpToNextPowD(&b, &mminus, sd,
dPtr->w.word1 & 1, &temp)) {
if (digit == 9) {
*s++ = '9';
s = BumpUp(s, retval, &k);
break;
}
++digit;
|
| ︙ | ︙ | |||
3379 3380 3381 3382 3383 3384 3385 |
*
*----------------------------------------------------------------------
*/
static inline char *
StrictBignumConversionPowD(
Double *dPtr, /* Original number to convert. */
| < < | < < | 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 |
*
*----------------------------------------------------------------------
*/
static inline char *
StrictBignumConversionPowD(
Double *dPtr, /* Original number to convert. */
Tcl_WideUInt bw, /* Integer significand. */
int b2, int b5, /* Scale factor for the significand in the
* numerator. */
int sd, /* Scale factor for the denominator. */
int k, /* Number of output digits before the decimal
* point. */
int len, /* Number of digits to allocate. */
int ilim, /* Number of digits to convert if b >= s */
int ilim1, /* Number of digits to convert if b < s */
int *decpt, /* OUTPUT: Position of the decimal point. */
char **endPtr) /* OUTPUT: Position of the terminal '\0' at
* the end of the returned string. */
{
char *retval = Tcl_Alloc(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. */
/*
* b = bw * 2**b2 * 5**b5
*/
TclInitBignumFromWideUInt(&b, bw);
MulPow5(&b, b5, &b);
mp_mul_2d(&b, b2, &b);
/*
* Adjust if the logarithm was guessed wrong.
*/
if (b.used <= sd) {
mp_mul_d(&b, 10, &b);
ilim = ilim1;
--k;
}
/*
* Loop through the digits. Do division and mod by s == 2**(sd*DIGIT_BIT)
* by mp_digit extraction.
*/
i = 1;
|
| ︙ | ︙ | |||
3469 3470 3471 3472 3473 3474 3475 |
}
/*
* Endgame - store the location of the decimal point and the end of the
* string.
*/
| | | 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 |
}
/*
* Endgame - store the location of the decimal point and the end of the
* string.
*/
mp_clear(&b);
*s = '\0';
*decpt = k;
if (endPtr) {
*endPtr = s;
}
return retval;
}
|
| ︙ | ︙ | |||
3533 3534 3535 3536 3537 3538 3539 |
static inline int
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. */
| < < < | < > > | | > < < < | < | 3509 3510 3511 3512 3513 3514 3515 3516 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 |
static inline int
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 r;
mp_int temp;
/*
* Compare b and S-m: this is the same as comparing B+m and S.
*/
mp_init(&temp);
mp_add(b, m, &temp);
r = mp_cmp_mag(&temp, S);
mp_clear(&temp);
switch(r) {
case MP_LT:
return 0;
case MP_EQ:
return isodd;
case MP_GT:
return 1;
}
Tcl_Panic("in ShouldBankerRoundUpToNext, trichotomy fails!");
return 0;
}
|
| ︙ | ︙ | |||
3584 3585 3586 3587 3588 3589 3590 |
*
*----------------------------------------------------------------------
*/
static inline char *
ShorteningBignumConversion(
Double *dPtr, /* Original number being converted. */
| < | < | 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 |
*
*----------------------------------------------------------------------
*/
static inline char *
ShorteningBignumConversion(
Double *dPtr, /* Original number being converted. */
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. */
int len, /* Size of the digit buffer to allocate. */
int ilim, /* Number of digits to convert if b >= s */
int ilim1, /* Number of digits to convert if b < s */
int *decpt, /* OUTPUT: Position of the decimal point. */
char **endPtr) /* OUTPUT: Pointer to the end of the number */
{
char *retval = Tcl_Alloc(len+1);
/* Buffer of digits to return. */
char *s = retval; /* Cursor in the return value. */
mp_int b; /* Numerator of the result. */
mp_int mminus; /* 1/2 ulp below the result. */
mp_int mplus; /* 1/2 ulp above the result. */
mp_int S; /* Denominator of the result. */
mp_int dig; /* Current digit of the result. */
int digit; /* Current digit of the result. */
int minit = 1; /* Fudge factor for when we misguess k. */
int i;
int r1;
/*
* b = bw * 2**b2 * 5**b5
* S = 2**s2 * 5*s5
|
| ︙ | ︙ | |||
3641 3642 3643 3644 3645 3646 3647 |
mp_init_set_int(&mminus, minit);
mp_mul_2d(&mminus, m2minus, &mminus);
if (m2plus > m2minus) {
mp_init_copy(&mplus, &mminus);
mp_mul_2d(&mplus, m2plus-m2minus, &mplus);
}
| < | < | | | 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 3629 3630 3631 3632 3633 3634 3635 3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 3652 3653 3654 3655 3656 3657 3658 3659 3660 3661 3662 3663 3664 |
mp_init_set_int(&mminus, minit);
mp_mul_2d(&mminus, m2minus, &mminus);
if (m2plus > m2minus) {
mp_init_copy(&mplus, &mminus);
mp_mul_2d(&mplus, m2plus-m2minus, &mplus);
}
/*
* Loop through the digits.
*/
mp_init(&dig);
i = 1;
for (;;) {
mp_div(&b, &S, &dig, &b);
if (dig.used > 1 || dig.dp[0] >= 10) {
Tcl_Panic("wrong digit!");
}
digit = dig.dp[0];
/*
* Does the current digit leave us with a remainder small enough to
* round to it?
*/
r1 = mp_cmp_mag(&b, (m2plus > m2minus)? &mplus : &mminus);
if (r1 == MP_LT || (r1 == MP_EQ && (dPtr->w.word1 & 1) == 0)) {
mp_mul_2d(&b, 1, &b);
if (ShouldBankerRoundUp(&b, &S, digit&1)) {
++digit;
if (digit == 10) {
*s++ = '9';
s = BumpUp(s, retval, &k);
break;
}
}
*s++ = '0' + digit;
break;
}
/*
* 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)) {
++digit;
if (digit == 10) {
*s++ = '9';
s = BumpUp(s, retval, &k);
break;
}
*s++ = '0' + digit;
|
| ︙ | ︙ | |||
3770 3771 3772 3773 3774 3775 3776 |
* Endgame - store the location of the decimal point and the end of the
* string.
*/
if (m2plus > m2minus) {
mp_clear(&mplus);
}
| | | 3737 3738 3739 3740 3741 3742 3743 3744 3745 3746 3747 3748 3749 3750 3751 |
* Endgame - store the location of the decimal point and the end of the
* string.
*/
if (m2plus > m2minus) {
mp_clear(&mplus);
}
mp_clear_multi(&b, &mminus, &dig, &S, NULL);
*s = '\0';
*decpt = k;
if (endPtr) {
*endPtr = s;
}
return retval;
}
|
| ︙ | ︙ | |||
3800 3801 3802 3803 3804 3805 3806 |
*
*----------------------------------------------------------------------
*/
static inline char *
StrictBignumConversion(
Double *dPtr, /* Original number being converted. */
| < | < | | 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 3782 3783 3784 3785 3786 3787 3788 3789 3790 3791 3792 3793 3794 3795 3796 3797 3798 3799 3800 3801 3802 3803 3804 3805 3806 |
*
*----------------------------------------------------------------------
*/
static inline char *
StrictBignumConversion(
Double *dPtr, /* Original number being converted. */
Tcl_WideUInt bw, /* Integer significand and exponent. */
int b2, /* Scale factor for the significand. */
int s2, int s5, /* Scale factors for denominator. */
int k, /* Guessed position of the decimal point. */
int len, /* Size of the digit buffer to allocate. */
int ilim, /* Number of digits to convert if b >= s */
int ilim1, /* Number of digits to convert if b < s */
int *decpt, /* OUTPUT: Position of the decimal point. */
char **endPtr) /* OUTPUT: Pointer to the end of the number */
{
char *retval = Tcl_Alloc(len+1);
/* Buffer of digits to return. */
char *s = retval; /* Cursor in the return value. */
mp_int b; /* Numerator of the result. */
mp_int S; /* Denominator of the result. */
mp_int dig; /* Current digit of the result. */
int digit; /* Current digit of the result. */
int g; /* Size of the current digit ground. */
int i, j;
/*
* b = bw * 2**b2 * 5**b5
* S = 2**s2 * 5*s5
*/
mp_init_multi(&dig, NULL);
TclInitBignumFromWideUInt(&b, bw);
mp_mul_2d(&b, b2, &b);
mp_init_set_int(&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.
|
| ︙ | ︙ | |||
3934 3935 3936 3937 3938 3939 3940 |
++s;
/*
* Endgame - store the location of the decimal point and the end of the
* string.
*/
| | | 3899 3900 3901 3902 3903 3904 3905 3906 3907 3908 3909 3910 3911 3912 3913 |
++s;
/*
* Endgame - store the location of the decimal point and the end of the
* string.
*/
mp_clear_multi(&b, &S, &dig, NULL);
*s = '\0';
*decpt = k;
if (endPtr) {
*endPtr = s;
}
return retval;
}
|
| ︙ | ︙ | |||
3970 3971 3972 3973 3974 3975 3976 | * 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 * 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. | < < < < < < < < < | 3935 3936 3937 3938 3939 3940 3941 3942 3943 3944 3945 3946 3947 3948 | * 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 * digits that will reconvert to the given number when scanned. * For floating point numbers that are exactly between two * decimal numbers, it resolves using the 'round to even' rule. * With this value, the 'ndigits' parameter is ignored. * TCL_DD_E_FORMAT - This value is used to prepare numbers for %e format * conversion. 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_SHORTEN_FLAG is supplied instead, it * also returns fewer digits if the shorter string will still |
| ︙ | ︙ | |||
4028 4029 4030 4031 4032 4033 4034 |
int flags, /* Conversion flags. */
int *decpt, /* OUTPUT: Position of the decimal point. */
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. */
{
| < < < < | 3984 3985 3986 3987 3988 3989 3990 3991 3992 3993 3994 3995 3996 3997 |
int flags, /* Conversion flags. */
int *decpt, /* OUTPUT: Position of the decimal point. */
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. */
{
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
* denormalized. */
int k; /* Estimate of floor(log10(d)). */
|
| ︙ | ︙ | |||
4099 4100 4101 4102 4103 4104 4105 |
ComputeScale(be, k, &b2, &b5, &s2, &s5);
/*
* 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
| | | | | | | 4051 4052 4053 4054 4055 4056 4057 4058 4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 4070 4071 4072 4073 4074 4075 4076 |
ComputeScale(be, k, &b2, &b5, &s2, &s5);
/*
* 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.
* ilim = The number of significant digits to convert if k has been
* guessed correctly. This is -1 for shortest (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
* format.
*/
SetPrecisionLimits(flags, k, &ndigits, &i, &ilim, &ilim1);
/*
* Try to do low-precision conversion in floating point rather than
* resorting to expensive multiprecision arithmetic.
*/
if (ilim >= 0 && ilim <= QUICK_MAX && !(flags & TCL_DD_NO_QUICK)) {
|
| ︙ | ︙ | |||
4183 4184 4185 4186 4187 4188 4189 | * If 10*2**s2*5**s5 == 2**(s2+1)+5**(s5+1) fits in a 64-bit word, * then all our intermediate calculations can be done using exact * 64-bit arithmetic with no need for expensive multiprecision * operations. (This will be true for all numbers in the range * [1.0e-3 .. 1.0e+24]). */ | | | | | | | | 4135 4136 4137 4138 4139 4140 4141 4142 4143 4144 4145 4146 4147 4148 4149 4150 4151 4152 4153 4154 4155 4156 4157 4158 4159 4160 4161 4162 4163 4164 4165 4166 4167 4168 4169 4170 4171 4172 4173 4174 4175 4176 4177 |
* If 10*2**s2*5**s5 == 2**(s2+1)+5**(s5+1) fits in a 64-bit word,
* then all our intermediate calculations can be done using exact
* 64-bit arithmetic with no need for expensive multiprecision
* operations. (This will be true for all numbers in the range
* [1.0e-3 .. 1.0e+24]).
*/
return ShorteningInt64Conversion(&d, bw, b2, b5, m2plus,
m2minus, m5, s2, s5, k, len, ilim, ilim1, decpt, endPtr);
} else if (s5 == 0) {
/*
* The denominator is a power of 2, so we can replace division by
* digit shifts. First we round up s2 to a multiple of DIGIT_BIT,
* and adjust m2 and b2 accordingly. Then we launch into a version
* of the comparison that's specialized for the 'power of mp_digit
* in the denominator' case.
*/
if (s2 % MP_DIGIT_BIT != 0) {
int delta = MP_DIGIT_BIT - (s2 % MP_DIGIT_BIT);
b2 += delta;
m2plus += delta;
m2minus += delta;
s2 += delta;
}
return ShorteningBignumConversionPowD(&d, 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,
m2minus, s2, s5, k, len, ilim, ilim1, decpt, endPtr);
}
} else {
/*
* Non-shortening conversion.
*/
|
| ︙ | ︙ | |||
4239 4240 4241 4242 4243 4244 4245 | /* * If 10*2**s2*5**s5 == 2**(s2+1)+5**(s5+1) fits in a 64-bit word, * then all our intermediate calculations can be done using exact * 64-bit arithmetic with no need for expensive multiprecision * operations. */ | | | | | | | | 4191 4192 4193 4194 4195 4196 4197 4198 4199 4200 4201 4202 4203 4204 4205 4206 4207 4208 4209 4210 4211 4212 4213 4214 4215 4216 4217 4218 4219 4220 4221 4222 4223 4224 4225 4226 4227 4228 4229 4230 4231 4232 |
/*
* If 10*2**s2*5**s5 == 2**(s2+1)+5**(s5+1) fits in a 64-bit word,
* then all our intermediate calculations can be done using exact
* 64-bit arithmetic with no need for expensive multiprecision
* operations.
*/
return StrictInt64Conversion(&d, 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 DIGIT_BIT,
* and adjust m2 and b2 accordingly. Then we launch into a version
* of the comparison that's specialized for the 'power of mp_digit
* in the denominator' case.
*/
if (s2 % MP_DIGIT_BIT != 0) {
int delta = MP_DIGIT_BIT - (s2 % MP_DIGIT_BIT);
b2 += delta;
s2 += delta;
}
return StrictBignumConversionPowD(&d, 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(&d, bw, b2, s2, s5, k,
len, ilim, ilim1, decpt, endPtr);
}
}
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
4318 4319 4320 4321 4322 4323 4324 |
/*
* Initialize table of powers of 10 expressed as wide integers.
*/
maxpow10_wide = (int)
floor(sizeof(Tcl_WideUInt) * CHAR_BIT * log(2.) / log(10.));
| | | 4270 4271 4272 4273 4274 4275 4276 4277 4278 4279 4280 4281 4282 4283 4284 |
/*
* Initialize table of powers of 10 expressed as wide integers.
*/
maxpow10_wide = (int)
floor(sizeof(Tcl_WideUInt) * CHAR_BIT * log(2.) / log(10.));
pow10_wide = Tcl_Alloc((maxpow10_wide + 1) * sizeof(Tcl_WideUInt));
u = 1;
for (i = 0; i < maxpow10_wide; ++i) {
pow10_wide[i] = u;
u *= 10;
}
pow10_wide[i] = u;
|
| ︙ | ︙ | |||
4382 4383 4384 4385 4386 4387 4388 |
* the significand of a double.
*/
maxDigits = (int) ((DBL_MAX_EXP * log((double) FLT_RADIX)
+ 0.5 * log(10.)) / log(10.));
minDigits = (int) floor((DBL_MIN_EXP - DBL_MANT_DIG)
* log((double) FLT_RADIX) / log(10.));
| | | 4334 4335 4336 4337 4338 4339 4340 4341 4342 4343 4344 4345 4346 4347 4348 |
* the significand of a double.
*/
maxDigits = (int) ((DBL_MAX_EXP * log((double) FLT_RADIX)
+ 0.5 * log(10.)) / log(10.));
minDigits = (int) floor((DBL_MIN_EXP - DBL_MANT_DIG)
* log((double) FLT_RADIX) / log(10.));
log10_DIGIT_MAX = (int) floor(MP_DIGIT_BIT * log(2.) / log(10.));
/*
* Nokia 770's software-emulated floating point is "middle endian": the
* bytes within a 32-bit word are little-endian (like the native
* integers), but the two words of a 'double' are presented most
* significant word first.
*/
|
| ︙ | ︙ | |||
4425 4426 4427 4428 4429 4430 4431 |
*/
void
TclFinalizeDoubleConversion(void)
{
int i;
| | | 4377 4378 4379 4380 4381 4382 4383 4384 4385 4386 4387 4388 4389 4390 4391 |
*/
void
TclFinalizeDoubleConversion(void)
{
int i;
Tcl_Free(pow10_wide);
for (i=0; i<9; ++i) {
mp_clear(pow5 + i);
}
for (i=0; i < 5; ++i) {
mp_clear(pow5_13 + i);
}
}
|
| ︙ | ︙ | |||
4475 4476 4477 4478 4479 4480 4481 |
Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1));
Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, NULL);
}
return TCL_ERROR;
}
| | | 4427 4428 4429 4430 4431 4432 4433 4434 4435 4436 4437 4438 4439 4440 4441 |
Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1));
Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, NULL);
}
return TCL_ERROR;
}
fract = frexp(d, &expt);
if (expt <= 0) {
mp_init(b);
mp_zero(b);
} else {
Tcl_WideInt w = (Tcl_WideInt) ldexp(fract, mantBits);
int shift = expt - mantBits;
|
| ︙ | ︙ | |||
4586 4587 4588 4589 4590 4591 4592 |
/*
* Accumulate the result, one mp_digit at a time.
*/
r = 0.0;
for (i=b.used-1 ; i>=0 ; --i) {
| | | 4538 4539 4540 4541 4542 4543 4544 4545 4546 4547 4548 4549 4550 4551 4552 |
/*
* Accumulate the result, one mp_digit at a time.
*/
r = 0.0;
for (i=b.used-1 ; i>=0 ; --i) {
r = ldexp(r, MP_DIGIT_BIT) + b.dp[i];
}
mp_clear(&b);
/*
* Scale the result to the correct number of bits.
*/
|
| ︙ | ︙ | |||
4629 4630 4631 4632 4633 4634 4635 |
TclCeil(
const mp_int *a) /* Integer to convert. */
{
double r = 0.0;
mp_int b;
mp_init(&b);
| | | | | 4581 4582 4583 4584 4585 4586 4587 4588 4589 4590 4591 4592 4593 4594 4595 4596 4597 4598 4599 4600 4601 4602 4603 4604 4605 4606 4607 4608 4609 4610 4611 4612 4613 4614 4615 4616 4617 4618 4619 4620 4621 |
TclCeil(
const mp_int *a) /* Integer to convert. */
{
double r = 0.0;
mp_int b;
mp_init(&b);
if (a->sign != MP_ZPOS) {
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 (shift > 0) {
mp_mul_2d(a, shift, &b);
} else if (shift < 0) {
mp_int d;
mp_init(&d);
mp_div_2d(a, -shift, &b, &d);
exact = d.used == 0;
mp_clear(&d);
} else {
mp_copy(a, &b);
}
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);
}
}
mp_clear(&b);
return r;
}
|
| ︙ | ︙ | |||
4686 4687 4688 4689 4690 4691 4692 |
TclFloor(
const mp_int *a) /* Integer to convert. */
{
double r = 0.0;
mp_int b;
mp_init(&b);
| | | | 4638 4639 4640 4641 4642 4643 4644 4645 4646 4647 4648 4649 4650 4651 4652 4653 4654 4655 4656 4657 4658 4659 4660 4661 4662 4663 4664 4665 4666 4667 4668 4669 4670 4671 |
TclFloor(
const mp_int *a) /* Integer to convert. */
{
double r = 0.0;
mp_int b;
mp_init(&b);
if (a->sign != MP_ZPOS) {
mp_neg(a, &b);
r = -TclCeil(&b);
} else {
int bits = mp_count_bits(a);
if (bits > DBL_MAX_EXP*log2FLT_RADIX) {
r = DBL_MAX;
} else {
int i, shift = mantBits - bits;
if (shift > 0) {
mp_mul_2d(a, shift, &b);
} else if (shift < 0) {
mp_div_2d(a, -shift, &b, NULL);
} else {
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);
}
}
mp_clear(&b);
return r;
}
|
| ︙ | ︙ | |||
4767 4768 4769 4770 4771 4772 4773 |
/*
* Accumulate the result, one mp_digit at a time.
*/
r = 0.0;
for (i=b.used-1; i>=0; --i) {
| | | 4719 4720 4721 4722 4723 4724 4725 4726 4727 4728 4729 4730 4731 4732 4733 |
/*
* Accumulate the result, one mp_digit at a time.
*/
r = 0.0;
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.
*/
|
| ︙ | ︙ | |||
4815 4816 4817 4818 4819 4820 4821 |
double retval = fraction;
if (exponent > 0) {
/*
* Multiply by 10**exponent.
*/
| | | 4767 4768 4769 4770 4771 4772 4773 4774 4775 4776 4777 4778 4779 4780 4781 |
double retval = fraction;
if (exponent > 0) {
/*
* Multiply by 10**exponent.
*/
retval = frexp(retval * pow10vals[exponent & 0xf], &j);
expt += j;
for (i=4; i<9; ++i) {
if (exponent & (1<<i)) {
retval = frexp(retval * pow_10_2_n[i], &j);
expt += j;
}
}
|
| ︙ | ︙ |
Changes to generic/tclStringObj.c.
| ︙ | ︙ | |||
137 138 139 140 141 142 143 |
char *ptr = NULL;
size_t attempt;
if (objPtr->bytes == &tclEmptyString) {
objPtr->bytes = NULL;
}
if (flag == 0 || stringPtr->allocated > 0) {
| < | | < | | < < | | < < < | | 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 |
char *ptr = NULL;
size_t attempt;
if (objPtr->bytes == &tclEmptyString) {
objPtr->bytes = NULL;
}
if (flag == 0 || stringPtr->allocated > 0) {
attempt = 2 * needed;
ptr = 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 = Tcl_AttemptRealloc(objPtr->bytes, attempt + 1);
}
}
if (ptr == NULL) {
/*
* First allocation - just big enough; or last chance fallback.
*/
attempt = needed;
ptr = 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.
*/
|
| ︙ | ︙ | |||
250 251 252 253 254 255 256 |
#ifdef TCL_MEM_DEBUG
#undef Tcl_NewStringObj
Tcl_Obj *
Tcl_NewStringObj(
const char *bytes, /* Points to the first of the length bytes
* used to initialize the new object. */
| | | | | < | | 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 |
#ifdef TCL_MEM_DEBUG
#undef Tcl_NewStringObj
Tcl_Obj *
Tcl_NewStringObj(
const char *bytes, /* Points to the first of the length bytes
* used to initialize the new object. */
size_t length) /* The number of bytes to copy from "bytes"
* when initializing the new object. If
* negative, use bytes up to the first NUL
* byte. */
{
return Tcl_DbNewStringObj(bytes, length, "unknown", 0);
}
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_NewStringObj(
const char *bytes, /* Points to the first of the length bytes
* used to initialize the new object. */
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_Obj *objPtr;
if (length == TCL_AUTO_LENGTH) {
length = (bytes? strlen(bytes) : 0);
}
TclNewStringObj(objPtr, bytes, length);
return objPtr;
}
#endif /* TCL_MEM_DEBUG */
|
| ︙ | ︙ | |||
311 312 313 314 315 316 317 |
*/
#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. */
| | | | < | | | | < | 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 |
*/
#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. */
const char *file, /* The name of the source file calling this
* function; used for debugging. */
int line) /* Line number in the source file; used for
* debugging. */
{
Tcl_Obj *objPtr;
if (length == TCL_AUTO_LENGTH) {
length = (bytes? strlen(bytes) : 0);
}
TclDbNewObj(objPtr, file, line);
TclInitStringRep(objPtr, bytes, length);
return objPtr;
}
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_DbNewStringObj(
const char *bytes, /* Points to the first of the length bytes
* used to initialize the new object. */
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. */
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);
}
|
| ︙ | ︙ | |||
370 371 372 373 374 375 376 |
*---------------------------------------------------------------------------
*/
Tcl_Obj *
Tcl_NewUnicodeObj(
const Tcl_UniChar *unicode, /* The unicode string used to initialize the
* new object. */
| | | 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 |
*---------------------------------------------------------------------------
*/
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
* string. */
{
Tcl_Obj *objPtr;
TclNewObj(objPtr);
SetUnicodeObj(objPtr, unicode, numChars);
return objPtr;
|
| ︙ | ︙ | |||
397 398 399 400 401 402 403 | * Side effects: * Frees old internal rep. Allocates memory for new "String" internal * rep. * *---------------------------------------------------------------------- */ | | | | 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 |
* Side effects:
* Frees old internal rep. Allocates memory for new "String" internal
* rep.
*
*----------------------------------------------------------------------
*/
size_t
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 */
|
| ︙ | ︙ | |||
426 427 428 429 430 431 432 |
* 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)) {
| < < | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > | | | > > | > > | > | | | > > | | > > > > > > > > | < < < < < < < < | < < | | | | < < < | > | < < < < | | 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 |
* 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_AUTO_LENGTH) {
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;
}
/*
*----------------------------------------------------------------------
*
* 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;
*
* Results:
* Returns the index'th Unicode character in the Object.
*
* Side effects:
* Fills unichar with the index'th Unicode character.
*
*----------------------------------------------------------------------
*/
int
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.
*/
SetStringFromAny(NULL, objPtr);
stringPtr = GET_STRING(objPtr);
if (stringPtr->hasUnicode == 0) {
/*
* If numChars is unknown, compute it.
*/
if (stringPtr->numChars == TCL_AUTO_LENGTH) {
TclNumUtfChars(stringPtr->numChars, objPtr->bytes, objPtr->length);
}
if (stringPtr->numChars == objPtr->length) {
return (Tcl_UniChar) objPtr->bytes[index];
}
FillUnicodeRep(objPtr);
stringPtr = GET_STRING(objPtr);
}
if (index >= stringPtr->numChars) {
return -1;
}
ch = stringPtr->unicode[index];
#if TCL_UTF_MAX <= 4
/* See: bug [11ae2be95dac9417] */
if ((ch & 0xF800) == 0xD800) {
if (ch & 0x400) {
if ((index > 0)
&& ((stringPtr->unicode[index-1] & 0xFC00) == 0xD800)) {
ch = -1; /* low surrogate preceded by high surrogate */
}
} else if ((++index < stringPtr->numChars)
&& ((stringPtr->unicode[index] & 0xFC00) == 0xDC00)) {
/* high surrogate followed by low surrogate */
ch = (((ch & 0x3FF) << 10) |
(stringPtr->unicode[index] & 0x3FF)) + 0x10000;
}
}
#endif
return ch;
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetUnicodeFromObj --
*
|
| ︙ | ︙ | |||
603 604 605 606 607 608 609 |
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
Tcl_GetRange(
Tcl_Obj *objPtr, /* The Tcl object to find the range of. */
| | | > > > > > > > > | > > > > > > | | | > > > > > > > > | > > > | | | | | | > | | | | | | 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 |
*
*----------------------------------------------------------------------
*/
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. */
{
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_AUTO_LENGTH) {
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 <= 4
/* 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);
}
/*
*----------------------------------------------------------------------
*
* Tcl_SetStringObj --
*
|
| ︙ | ︙ | |||
691 692 693 694 695 696 697 |
*/
void
Tcl_SetStringObj(
Tcl_Obj *objPtr, /* Object whose internal rep to init. */
const char *bytes, /* Points to the first of the length bytes
* used to initialize the object. */
| | | | | 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 |
*/
void
Tcl_SetStringObj(
Tcl_Obj *objPtr, /* Object whose internal rep to init. */
const char *bytes, /* Points to the first of the length bytes
* used to initialize the object. */
size_t length) /* The number of bytes to copy from "bytes"
* when initializing the object. If -1,
* use bytes up to the first NUL byte.*/
{
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_SetStringObj");
}
/*
* Set the type to NULL and free any internal rep for the old type.
*/
TclFreeIntRep(objPtr);
/*
* Free any old string rep, then set the string rep to a copy of the
* length bytes starting at "bytes".
*/
TclInvalidateStringRep(objPtr);
if (length == TCL_AUTO_LENGTH) {
length = (bytes? strlen(bytes) : 0);
}
TclInitStringRep(objPtr, bytes, length);
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
744 745 746 747 748 749 750 |
*----------------------------------------------------------------------
*/
void
Tcl_SetObjLength(
Tcl_Obj *objPtr, /* Pointer to object. This object must not
* currently be shared. */
| | < < < < < < < < < | | | | < < < < < | | 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 |
*----------------------------------------------------------------------
*/
void
Tcl_SetObjLength(
Tcl_Obj *objPtr, /* Pointer to object. This object must not
* currently be shared. */
size_t length) /* Number of bytes desired for string
* representation of object, not including
* terminating null byte. */
{
String *stringPtr;
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_SetObjLength");
}
if (objPtr->bytes && objPtr->length == length) {
return;
}
SetStringFromAny(NULL, objPtr);
stringPtr = GET_STRING(objPtr);
if (objPtr->bytes != NULL) {
/*
* Change length of an existing string rep.
*/
if (length > stringPtr->allocated) {
/*
* Need to enlarge the buffer.
*/
if (objPtr->bytes == &tclEmptyString) {
objPtr->bytes = Tcl_Alloc(length + 1);
} else {
objPtr->bytes = Tcl_Realloc(objPtr->bytes, length + 1);
}
stringPtr->allocated = length;
}
objPtr->length = length;
objPtr->bytes[length] = 0;
/*
* Invalidate the unicode data.
*/
stringPtr->numChars = TCL_AUTO_LENGTH;
stringPtr->hasUnicode = 0;
} else {
if (length > stringPtr->maxChars) {
stringPtr = stringRealloc(stringPtr, length);
SET_STRING(objPtr, stringPtr);
stringPtr->maxChars = length;
}
/*
* Mark the new end of the unicode string
|
| ︙ | ︙ | |||
849 850 851 852 853 854 855 |
*----------------------------------------------------------------------
*/
int
Tcl_AttemptSetObjLength(
Tcl_Obj *objPtr, /* Pointer to object. This object must not
* currently be shared. */
| | < < < < < < < < | | | | < < < | | 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 |
*----------------------------------------------------------------------
*/
int
Tcl_AttemptSetObjLength(
Tcl_Obj *objPtr, /* Pointer to object. This object must not
* currently be shared. */
size_t length) /* Number of bytes desired for string
* representation of object, not including
* terminating null byte. */
{
String *stringPtr;
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 = Tcl_AttemptAlloc(length + 1);
} else {
newBytes = Tcl_AttemptRealloc(objPtr->bytes, length + 1);
}
if (newBytes == NULL) {
return 0;
}
objPtr->bytes = newBytes;
stringPtr->allocated = length;
}
objPtr->length = length;
objPtr->bytes[length] = 0;
/*
* Invalidate the unicode data.
*/
stringPtr->numChars = TCL_AUTO_LENGTH;
stringPtr->hasUnicode = 0;
} else {
/*
* Changing length of pure unicode string.
*/
if (length > stringPtr->maxChars) {
stringPtr = stringAttemptRealloc(stringPtr, length);
if (stringPtr == NULL) {
return 0;
}
SET_STRING(objPtr, stringPtr);
stringPtr->maxChars = length;
}
|
| ︙ | ︙ | |||
959 960 961 962 963 964 965 |
*/
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. */
| | | < | < | 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 |
*/
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
* string. */
{
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_SetUnicodeObj");
}
TclFreeIntRep(objPtr);
SetUnicodeObj(objPtr, unicode, numChars);
}
static size_t
UnicodeLength(
const Tcl_UniChar *unicode)
{
size_t numChars = 0;
if (unicode) {
while ((numChars != TCL_AUTO_LENGTH) && (unicode[numChars] != 0)) {
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
* string. */
{
String *stringPtr;
if (numChars == TCL_AUTO_LENGTH) {
numChars = UnicodeLength(unicode);
}
/*
* Allocate enough space for the String structure + Unicode string.
*/
stringPtr = stringAlloc(numChars);
SET_STRING(objPtr, stringPtr);
objPtr->typePtr = &tclStringType;
stringPtr->maxChars = numChars;
memcpy(stringPtr->unicode, unicode, numChars * sizeof(Tcl_UniChar));
stringPtr->unicode[numChars] = 0;
|
| ︙ | ︙ | |||
1040 1041 1042 1043 1044 1045 1046 |
*/
void
Tcl_AppendLimitedToObj(
Tcl_Obj *objPtr, /* Points to the object to append to. */
const char *bytes, /* Points to the bytes to append to the
* object. */
| | | | | | | | | 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 |
*/
void
Tcl_AppendLimitedToObj(
Tcl_Obj *objPtr, /* Points to the object to append to. */
const char *bytes, /* Points to the bytes to append to the
* object. */
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
* 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;
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_AppendLimitedToObj");
}
if (length == TCL_AUTO_LENGTH) {
length = (bytes ? strlen(bytes) : 0);
}
if (length == 0) {
return;
}
if (length <= limit) {
toCopy = length;
} else {
if (ellipsis == NULL) {
ellipsis = "...";
}
toCopy = (bytes == NULL) ? limit
: (size_t)(Tcl_UtfPrev(bytes+limit+1-strlen(ellipsis), bytes) - bytes);
}
/*
* If objPtr has a valid Unicode rep, then append the Unicode conversion
* of "bytes" to the objPtr's Unicode rep, otherwise append "bytes" to
* objPtr's string rep.
*/
|
| ︙ | ︙ | |||
1122 1123 1124 1125 1126 1127 1128 |
*/
void
Tcl_AppendToObj(
Tcl_Obj *objPtr, /* Points to the object to append to. */
const char *bytes, /* Points to the bytes to append to the
* object. */
| | | | | 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 |
*/
void
Tcl_AppendToObj(
Tcl_Obj *objPtr, /* Points to the object to append to. */
const char *bytes, /* Points to the bytes to append to the
* object. */
size_t length) /* The number of bytes to append from "bytes".
* If -1, then append all bytes up to NUL
* byte. */
{
Tcl_AppendLimitedToObj(objPtr, bytes, length, TCL_AUTO_LENGTH, NULL);
}
/*
*----------------------------------------------------------------------
*
* Tcl_AppendUnicodeToObj --
*
|
| ︙ | ︙ | |||
1151 1152 1153 1154 1155 1156 1157 |
*/
void
Tcl_AppendUnicodeToObj(
Tcl_Obj *objPtr, /* Points to the object to append to. */
const Tcl_UniChar *unicode, /* The unicode string to append to the
* object. */
| | | 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 |
*/
void
Tcl_AppendUnicodeToObj(
Tcl_Obj *objPtr, /* Points to the object to append to. */
const Tcl_UniChar *unicode, /* The unicode string to append to the
* object. */
size_t length) /* Number of chars in "unicode". */
{
String *stringPtr;
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_AppendUnicodeToObj");
}
|
| ︙ | ︙ | |||
1205 1206 1207 1208 1209 1210 1211 |
void
Tcl_AppendObjToObj(
Tcl_Obj *objPtr, /* Points to the object to append to. */
Tcl_Obj *appendObjPtr) /* Object to append. */
{
String *stringPtr;
| | | | | < | | | | | | | | | | > > < | | | > | > > > | > > | | | 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 |
void
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_AUTO_LENGTH;
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;
}
|
| ︙ | ︙ | |||
1284 1285 1286 1287 1288 1289 1290 |
*/
if (stringPtr->hasUnicode) {
/*
* If appendObjPtr is not of the "String" type, don't convert it.
*/
| | | | > | | 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 |
*/
if (stringPtr->hasUnicode) {
/*
* If appendObjPtr is not of the "String" type, don't convert it.
*/
if (TclHasIntRep(appendObjPtr, &tclStringType)) {
Tcl_UniChar *unicode =
TclGetUnicodeFromObj(appendObjPtr, &numChars);
AppendUnicodeToUnicodeRep(objPtr, unicode, numChars);
} else {
bytes = TclGetStringFromObj(appendObjPtr, &length);
AppendUtfToUnicodeRep(objPtr, bytes, length);
}
return;
}
/*
* Append to objPtr's UTF string rep. If we know the number of characters
* in both objects before appending, then set the combined number of
* characters in the final (appended-to) object.
*/
bytes = TclGetStringFromObj(appendObjPtr, &length);
numChars = stringPtr->numChars;
if ((numChars != TCL_AUTO_LENGTH) && TclHasIntRep(appendObjPtr, &tclStringType)) {
String *appendStringPtr = GET_STRING(appendObjPtr);
appendNumChars = appendStringPtr->numChars;
}
AppendUtfToUtfRep(objPtr, bytes, length);
if ((numChars != TCL_AUTO_LENGTH) && (appendNumChars != TCL_AUTO_LENGTH)) {
stringPtr->numChars = numChars + appendNumChars;
}
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1343 1344 1345 1346 1347 1348 1349 |
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. */
{
String *stringPtr;
size_t numChars;
| | < | | | | | 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 |
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. */
{
String *stringPtr;
size_t numChars;
if (appendNumChars == TCL_AUTO_LENGTH) {
appendNumChars = UnicodeLength(unicode);
}
if (appendNumChars == 0) {
return;
}
SetStringFromAny(NULL, objPtr);
stringPtr = GET_STRING(objPtr);
/*
* If not enough space has been allocated for the unicode rep, reallocate
* the internal rep object with additional space. First try to double the
* required allocation; if that fails, try a more modest increase. See the
* "TCL STRING GROWTH ALGORITHM" comment at the top of this file for an
* explanation of this growth algorithm.
*/
numChars = stringPtr->numChars + appendNumChars;
if (numChars > stringPtr->maxChars) {
size_t index = TCL_INDEX_NONE;
/*
* Protect against case where unicode points into the existing
* stringPtr->unicode array. Force it to follow any relocations due to
* the reallocs below.
*/
if (unicode && unicode >= stringPtr->unicode
&& unicode <= stringPtr->unicode + stringPtr->maxChars) {
index = 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;
}
}
/*
* Copy the new string onto the end of the old string, then add the
* trailing null.
*/
|
| ︙ | ︙ | |||
1433 1434 1435 1436 1437 1438 1439 |
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);
| | | 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 |
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_AUTO_LENGTH) {
stringPtr->numChars += numChars;
}
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1515 1516 1517 1518 1519 1520 1521 |
*/
if (objPtr->bytes == NULL) {
objPtr->length = 0;
}
oldLength = objPtr->length;
newLength = numBytes + oldLength;
| < < < | | 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 |
*/
if (objPtr->bytes == NULL) {
objPtr->length = 0;
}
oldLength = objPtr->length;
newLength = numBytes + oldLength;
stringPtr = GET_STRING(objPtr);
if (newLength > stringPtr->allocated) {
size_t offset = TCL_AUTO_LENGTH;
/*
* Protect against case where unicode points into the existing
* stringPtr->unicode array. Force it to follow any relocations due to
* the reallocs below.
*/
|
| ︙ | ︙ | |||
1545 1546 1547 1548 1549 1550 1551 | GrowStringBuffer(objPtr, newLength, 0); /* * Relocate bytes if needed; see above. */ | | | | 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 |
GrowStringBuffer(objPtr, newLength, 0);
/*
* Relocate bytes if needed; see above.
*/
if (offset != TCL_AUTO_LENGTH) {
bytes = objPtr->bytes + offset;
}
}
/*
* Invalidate the unicode data.
*/
stringPtr->numChars = TCL_AUTO_LENGTH;
stringPtr->hasUnicode = 0;
if (bytes) {
memmove(objPtr->bytes + oldLength, bytes, numBytes);
}
objPtr->bytes[newLength] = 0;
objPtr->length = newLength;
|
| ︙ | ︙ | |||
1634 1635 1636 1637 1638 1639 1640 |
Tcl_Interp *interp,
Tcl_Obj *appendObj,
const char *format,
int objc,
Tcl_Obj *const objv[])
{
const char *span = format, *msg, *errCode;
| | | | | | > | 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 |
Tcl_Interp *interp,
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;
static const char *mixedXPG =
"cannot mix \"%\" and \"%n$\" conversion specifiers";
static const char *const badIndex[2] = {
"not enough arguments for all format specifiers",
"\"%n$\" argument index out of range"
};
static const char *overflow = "max size for a Tcl value exceeded";
if (Tcl_IsShared(appendObj)) {
Tcl_Panic("%s called with shared object", "Tcl_AppendFormatToObj");
}
(void)TclGetStringFromObj(appendObj, &originalLength);
limit = (size_t)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;
Tcl_Obj *segment;
int step = TclUtfToUniChar(format, &ch);
format += step;
if (ch != '%') {
numBytes += step;
continue;
|
| ︙ | ︙ | |||
1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 |
/*
* Step 3. Minimum field width.
*/
width = 0;
if (isdigit(UCHAR(ch))) {
width = strtoul(format, &end, 10);
format = end;
step = TclUtfToUniChar(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;
}
if (width < 0) {
width = -width;
gotMinus = 1;
}
objIndex++;
format += step;
step = TclUtfToUniChar(format, &ch);
}
| > > > > > | | 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 |
/*
* Step 3. Minimum field width.
*/
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);
} 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;
}
if (width < 0) {
width = -width;
gotMinus = 1;
}
objIndex++;
format += step;
step = TclUtfToUniChar(format, &ch);
}
if (width > (int) limit) {
msg = overflow;
errCode = "OVERFLOW";
goto errorMsg;
}
/*
* Step 4. Precision.
|
| ︙ | ︙ | |||
1866 1867 1868 1869 1870 1871 1872 |
} else if ((format[1] == '3') && (format[2] == '2')) {
format += (step + 2);
step = TclUtfToUniChar(format, &ch);
} else {
format += step;
step = TclUtfToUniChar(format, &ch);
}
| | > | 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 |
} 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;
}
format += step;
span = format;
|
| ︙ | ︙ | |||
1901 1902 1903 1904 1905 1906 1907 |
numChars = precision;
Tcl_IncrRefCount(segment);
allocSegment = 1;
}
}
break;
case 'c': {
| | > > > > | 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 |
numChars = precision;
Tcl_IncrRefCount(segment);
allocSegment = 1;
}
}
break;
case 'c': {
char buf[4] = "";
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':
|
| ︙ | ︙ | |||
1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 |
goto error;
}
cmpResult = mp_cmp_d(&big, 0);
isNegative = (cmpResult == MP_LT);
if (cmpResult == MP_EQ) gotHash = 0;
if (ch == 'u') {
if (isNegative) {
msg = "unsigned bignum format is invalid";
errCode = "BADUNSIGNED";
goto errorMsg;
} else {
ch = 'd';
}
}
#ifndef TCL_WIDE_INT_IS_LONG
} else if (useWide) {
| > | < < < | < < < < < < | < < < | < < < < < < | | 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 |
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
} else if (useWide) {
if (TclGetWideBitsFromObj(interp, segment, &w) != TCL_OK) {
goto error;
}
isNegative = (w < (Tcl_WideInt) 0);
if (w == (Tcl_WideInt) 0) gotHash = 0;
#endif
} else if (TclGetLongFromObj(NULL, segment, &l) != TCL_OK) {
if (TclGetWideBitsFromObj(interp, segment, &w) != TCL_OK) {
goto error;
} else {
l = (long) w;
}
if (useShort) {
s = (short) l;
isNegative = (s < (short) 0);
if (s == (short) 0) gotHash = 0;
} else {
isNegative = (l < (long) 0);
|
| ︙ | ︙ | |||
2031 2032 2033 2034 2035 2036 2037 |
segmentLimit -= 2;
break;
}
}
switch (ch) {
case 'd': {
| | | | | 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 |
segmentLimit -= 2;
break;
}
}
switch (ch) {
case 'd': {
size_t length;
Tcl_Obj *pure;
const char *bytes;
if (useShort) {
pure = Tcl_NewWideIntObj(s);
#ifndef TCL_WIDE_INT_IS_LONG
} else if (useWide) {
pure = Tcl_NewWideIntObj(w);
#endif
} else if (useBig) {
pure = Tcl_NewBignumObj(&big);
} else {
pure = Tcl_NewWideIntObj(l);
}
Tcl_IncrRefCount(pure);
bytes = TclGetStringFromObj(pure, &length);
/*
* Already did the sign above.
*/
|
| ︙ | ︙ | |||
2066 2067 2068 2069 2070 2071 2072 |
/*
* Canonical decimal string reps for integers are composed
* entirely of one-byte encoded characters, so "length" is the
* number of chars.
*/
if (gotPrecision) {
| | | | | | | | > | 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 |
/*
* Canonical decimal string reps for integers are composed
* entirely of one-byte encoded characters, so "length" is the
* number of chars.
*/
if (gotPrecision) {
if (length < (size_t)precision) {
segmentLimit -= precision - length;
}
while (length < (size_t)precision) {
Tcl_AppendToObj(segment, "0", 1);
length++;
}
gotZero = 0;
}
if (gotZero) {
length += Tcl_GetCharLength(segment);
if (length < (size_t)width) {
segmentLimit -= width - length;
}
while (length < (size_t)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;
Tcl_Obj *pure;
char *bytes;
if (ch == 'u') {
base = 10;
} else if (ch == 'o') {
base = 8;
|
| ︙ | ︙ | |||
2135 2136 2137 2138 2139 2140 2141 |
bits = uw;
while (uw) {
numDigits++;
uw /= base;
}
#endif
} else if (useBig && big.used) {
| | | | | 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 |
bits = uw;
while (uw) {
numDigits++;
uw /= base;
}
#endif
} 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);
while ((mask & big.dp[big.used-1]) == 0) {
numDigits--;
mask >>= numBits;
}
if (numDigits > INT_MAX) {
msg = overflow;
errCode = "OVERFLOW";
|
| ︙ | ︙ | |||
2167 2168 2169 2170 2171 2172 2173 |
* Need to be sure zero becomes "0", not "".
*/
if (numDigits == 0) {
numDigits = 1;
}
pure = Tcl_NewObj();
| | | | | | | | | | | 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 |
* Need to be sure zero becomes "0", not "".
*/
if (numDigits == 0) {
numDigits = 1;
}
pure = Tcl_NewObj();
Tcl_SetObjLength(pure, numDigits);
bytes = TclGetString(pure);
toAppend = length = numDigits;
while (numDigits--) {
int digitOffset;
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;
shift += MP_DIGIT_BIT;
}
shift -= numBits;
}
digitOffset = bits % base;
if (digitOffset > 9) {
if (ch == 'X') {
bytes[numDigits] = 'A' + digitOffset - 10;
} else {
bytes[numDigits] = 'a' + digitOffset - 10;
}
} else {
bytes[numDigits] = '0' + digitOffset;
}
bits /= base;
}
if (useBig) {
mp_clear(&big);
}
if (gotPrecision) {
if (length < (size_t)precision) {
segmentLimit -= precision - length;
}
while (length < (size_t)precision) {
Tcl_AppendToObj(segment, "0", 1);
length++;
}
gotZero = 0;
}
if (gotZero) {
length += Tcl_GetCharLength(segment);
if (length < (size_t)width) {
segmentLimit -= width - length;
}
while (length < (size_t)width) {
Tcl_AppendToObj(segment, "0", 1);
length++;
}
}
if (toAppend > segmentLimit) {
msg = overflow;
errCode = "OVERFLOW";
|
| ︙ | ︙ | |||
2330 2331 2332 2333 2334 2335 2336 |
}
while (numChars < width) {
Tcl_AppendToObj(appendObj, (gotZero ? "0" : " "), 1);
numChars++;
}
}
| | | 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 |
}
while (numChars < width) {
Tcl_AppendToObj(appendObj, (gotZero ? "0" : " "), 1);
numChars++;
}
}
(void)TclGetStringFromObj(segment, &segmentNumBytes);
if (segmentNumBytes > limit) {
if (allocSegment) {
Tcl_DecrRefCount(segment);
}
msg = overflow;
errCode = "OVERFLOW";
goto errorMsg;
|
| ︙ | ︙ | |||
2382 2383 2384 2385 2386 2387 2388 |
Tcl_SetObjLength(appendObj, originalLength);
return TCL_ERROR;
}
/*
*---------------------------------------------------------------------------
*
| | | 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 |
Tcl_SetObjLength(appendObj, originalLength);
return TCL_ERROR;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_Format --
*
* Results:
* A refcount zero Tcl_Obj.
*
* Side effects:
* None.
*
|
| ︙ | ︙ | |||
2473 2474 2475 2476 2477 2478 2479 | /* * Within that buffer, we trim both ends if needed so that we * copy only whole characters, and avoid copying any partial * multi-byte characters. */ q = Tcl_UtfPrev(end, bytes); | | | | | | | 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 |
/*
* Within that buffer, we trim both ends if needed so that we
* copy only whole characters, and avoid copying any partial
* multi-byte characters.
*/
q = Tcl_UtfPrev(end, bytes);
if (!Tcl_UtfCharComplete(q, (end - q))) {
end = q;
}
q = bytes + TCL_UTF_MAX;
while ((bytes < end) && (bytes < q)
&& ((*bytes & 0xC0) == 0x80)) {
bytes++;
}
Tcl_ListObjAppendElement(NULL, list,
Tcl_NewStringObj(bytes , (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)));
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:
|
| ︙ | ︙ | |||
2534 2535 2536 2537 2538 2539 2540 |
} else {
Tcl_ListObjAppendElement(NULL, list, Tcl_NewDoubleObj(
va_arg(argList, double)));
}
seekingConversion = 0;
break;
case '*':
| | | | | 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 |
} else {
Tcl_ListObjAppendElement(NULL, list, Tcl_NewDoubleObj(
va_arg(argList, double)));
}
seekingConversion = 0;
break;
case '*':
lastNum = va_arg(argList, int);
Tcl_ListObjAppendElement(NULL, list, Tcl_NewWideIntObj(lastNum));
p++;
break;
case '0': case '1': case '2': case '3': case '4':
case '5': case '6': case '7': case '8': case '9': {
char *end;
lastNum = strtoul(p, &end, 10);
p = end;
break;
}
case '.':
gotPrecision = 1;
p++;
break;
|
| ︙ | ︙ | |||
2593 2594 2595 2596 2597 2598 2599 |
} while (seekingConversion);
}
TclListObjGetElements(NULL, list, &objc, &objv);
code = Tcl_AppendFormatToObj(NULL, objPtr, format, objc, objv);
if (code != TCL_OK) {
Tcl_AppendPrintfToObj(objPtr,
"Unable to format \"%s\" with supplied arguments: %s",
| | | 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 |
} while (seekingConversion);
}
TclListObjGetElements(NULL, list, &objc, &objv);
code = Tcl_AppendFormatToObj(NULL, objPtr, format, objc, objv);
if (code != TCL_OK) {
Tcl_AppendPrintfToObj(objPtr,
"Unable to format \"%s\" with supplied arguments: %s",
format, TclGetString(list));
}
Tcl_DecrRefCount(list);
}
/*
*---------------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
2673 2674 2675 2676 2677 2678 2679 |
*
*---------------------------------------------------------------------------
*/
char *
TclGetStringStorage(
Tcl_Obj *objPtr,
| | | | | 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 |
*
*---------------------------------------------------------------------------
*/
char *
TclGetStringStorage(
Tcl_Obj *objPtr,
size_t *sizePtr)
{
String *stringPtr;
if (!TclHasIntRep(objPtr, &tclStringType) || objPtr->bytes == NULL) {
return TclGetStringFromObj(objPtr, sizePtr);
}
stringPtr = GET_STRING(objPtr);
*sizePtr = stringPtr->allocated;
return objPtr->bytes;
}
|
| ︙ | ︙ | |||
2707 2708 2709 2710 2711 2712 2713 |
*---------------------------------------------------------------------------
*/
Tcl_Obj *
TclStringRepeat(
Tcl_Interp *interp,
Tcl_Obj *objPtr,
| | | | | | | | 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 |
*---------------------------------------------------------------------------
*/
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;
}
|
| ︙ | ︙ | |||
2773 2774 2775 2776 2777 2778 2779 |
Tcl_AppendObjToObj(objResultPtr, objResultPtr);
done *= 2;
}
TclAppendBytesToByteArray(objResultPtr,
Tcl_GetByteArrayFromObj(objResultPtr, NULL),
(count - done) * length);
} else if (unichar) {
| > | > > | 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 |
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;
}
|
| ︙ | ︙ | |||
2799 2800 2801 2802 2803 2804 2805 |
while (count - done > done) {
Tcl_AppendObjToObj(objResultPtr, objResultPtr);
done *= 2;
}
Tcl_AppendUnicodeToObj(objResultPtr, Tcl_GetUnicode(objResultPtr),
(count - done) * length);
} else {
| > | > > | | | | 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 |
while (count - done > done) {
Tcl_AppendObjToObj(objResultPtr, objResultPtr);
done *= 2;
}
Tcl_AppendUnicodeToObj(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;
}
/*
*---------------------------------------------------------------------------
|
| ︙ | ︙ | |||
2851 2852 2853 2854 2855 2856 2857 |
TclStringCat(
Tcl_Interp *interp,
int objc,
Tcl_Obj * const objv[],
int flags)
{
Tcl_Obj *objResultPtr, * const *ov;
| | > | 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 |
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 ) */
|
| ︙ | ︙ | |||
2883 2884 2885 2886 2887 2888 2889 |
if (TclIsPureByteArray(objPtr)) {
allowUniChar = 0;
} else if (objPtr->bytes) {
/* Value has a string rep. */
if (objPtr->length) {
/*
| | | > | > | > > > | > > | > | > > | > < < > | > > | > | | < < | 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 |
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. */
|
| ︙ | ︙ | |||
2968 2969 2970 2971 2972 2973 2974 |
Tcl_Obj *objPtr = *ov++;
if (objPtr->bytes == NULL) {
/* No string rep; Take the chance we can avoid making it */
pendingPtr = objPtr;
} else {
| | | | | | | | | < | | | | | > | | 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 |
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;
}
}
|
| ︙ | ︙ | |||
3046 3047 3048 3049 3050 3051 3052 |
objv += first; objc = (last - first + 1);
if (binary) {
/* Efficiently produce a pure byte array result */
unsigned char *dst;
/*
| | | < > | | > > > > > | > | | | | | | 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 |
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)));
|
| ︙ | ︙ | |||
3115 3116 3117 3118 3119 3120 3121 |
}
dst = Tcl_GetUnicode(objResultPtr);
}
while (objc--) {
Tcl_Obj *objPtr = *objv++;
if ((objPtr->bytes == NULL) || (objPtr->length)) {
| | | | | | | | | | | > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | | | | > > > > | | | | > > > > | | | | | | < < < < < < < < < | | > > > > > > > > | | | > > > > > > > | | 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 3505 3506 3507 3508 3509 3510 3511 3512 3513 3514 3515 3516 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 3549 3550 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 3590 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 |
}
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 {
objResultPtr = Tcl_NewObj(); /* PANIC? */
if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) {
Tcl_DecrRefCount(objResultPtr);
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"concatenation failed: unable to alloc %" 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)Tcl_UniCharNcasecmp;
} 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) Tcl_UniCharNcmp;
}
}
}
} 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_AUTO_LENGTH) && !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_AUTO_LENGTH) {
/*
* 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, TCL_IO_FAILURE is returned.
*
* Side effects:
* needle and haystack may have their Tcl_ObjType changed.
*
*---------------------------------------------------------------------------
*/
size_t
TclStringFirst(
Tcl_Obj *needle,
Tcl_Obj *haystack,
size_t start)
{
size_t lh = 0, ln = Tcl_GetCharLength(needle);
if (start == TCL_AUTO_LENGTH) {
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. */
return TCL_IO_FAILURE;
}
if (TclIsPureByteArray(needle) && TclIsPureByteArray(haystack)) {
unsigned char *end, *try, *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 */
return TCL_IO_FAILURE;
}
end = bh + lh;
try = bh + start;
while (try + ln <= end) {
/*
* Look for the leading byte of the needle in the haystack
* starting at try and stopping when there's not enough room
* for the needle left.
*/
try = memchr(try, bn[0], (end + 1 - ln) - try);
if (try == NULL) {
/* Leading byte not found -> needle cannot be found. */
return TCL_IO_FAILURE;
}
/* Leading byte found, check rest of needle. */
if (0 == memcmp(try+1, bn+1, ln-1)) {
/* Checks! Return the successful index. */
return (try - bh);
}
/* Rest of needle match failed; Iterate to continue search. */
try++;
}
return TCL_IO_FAILURE;
}
/*
* 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.
*/
{
Tcl_UniChar *try, *end, *uh;
Tcl_UniChar *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 */
return TCL_IO_FAILURE;
}
end = uh + lh;
for (try = uh + start; try + ln <= end; try++) {
if ((*try == *un) && (0 ==
memcmp(try + 1, un + 1, (ln-1) * sizeof(Tcl_UniChar)))) {
return (try - uh);
}
}
return TCL_IO_FAILURE;
}
}
/*
*---------------------------------------------------------------------------
*
* 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, TCL_IO_FAILURE is returned.
*
* Side effects:
* needle and haystack may have their Tcl_ObjType changed.
*
*---------------------------------------------------------------------------
*/
size_t
TclStringLast(
Tcl_Obj *needle,
Tcl_Obj *haystack,
size_t last)
{
size_t lh = 0, ln = Tcl_GetCharLength(needle);
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.
*/
return TCL_IO_FAILURE;
}
if (TclIsPureByteArray(needle) && TclIsPureByteArray(haystack)) {
unsigned char *try, *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 */
return TCL_IO_FAILURE;
}
try = bh + last + 1 - ln;
while (try >= bh) {
if ((*try == bn[0])
&& (0 == memcmp(try+1, bn+1, ln-1))) {
return (try - bh);
}
try--;
}
return TCL_IO_FAILURE;
}
{
Tcl_UniChar *try, *uh = TclGetUnicodeFromObj(haystack, &lh);
Tcl_UniChar *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 */
return TCL_IO_FAILURE;
}
try = uh + last + 1 - ln;
while (try >= uh) {
if ((*try == un[0])
&& (0 == memcmp(try+1, un+1, (ln-1)*sizeof(Tcl_UniChar)))) {
return (try - uh);
}
try--;
}
return TCL_IO_FAILURE;
}
}
/*
*---------------------------------------------------------------------------
*
* TclStringReverse --
|
| ︙ | ︙ | |||
3374 3375 3376 3377 3378 3379 3380 |
*---------------------------------------------------------------------------
*/
static void
ReverseBytes(
unsigned char *to, /* Copy bytes into here... */
unsigned char *from, /* ...from here... */
| | > > | | | | 3625 3626 3627 3628 3629 3630 3631 3632 3633 3634 3635 3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 3652 3653 3654 3655 3656 3657 3658 3659 3660 3661 3662 3663 3664 3665 3666 3667 3668 3669 3670 |
*---------------------------------------------------------------------------
*/
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)
{
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);
return objPtr;
}
|
| ︙ | ︙ | |||
3434 3435 3436 3437 3438 3439 3440 |
objPtr = Tcl_NewUnicodeObj(&ch, 1);
Tcl_SetObjLength(objPtr, stringPtr->numChars);
to = Tcl_GetUnicode(objPtr);
while (--src >= from) {
*to++ = *src;
}
} else {
| > | > > | | | | | > | | | | | > | | 3687 3688 3689 3690 3691 3692 3693 3694 3695 3696 3697 3698 3699 3700 3701 3702 3703 3704 3705 3706 3707 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 3729 3730 3731 3732 3733 3734 3735 3736 3737 3738 3739 3740 3741 3742 3743 3744 |
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)) {
objPtr = Tcl_NewObj();
Tcl_SetObjLength(objPtr, numBytes);
}
to = objPtr->bytes;
if ((numChars == TCL_AUTO_LENGTH) || (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++;
|
| ︙ | ︙ | |||
3497 3498 3499 3500 3501 3502 3503 | } /* *--------------------------------------------------------------------------- * * TclStringReplace -- * | | > | | | < | | | | | | | | | < < < < | | | | 3755 3756 3757 3758 3759 3760 3761 3762 3763 3764 3765 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 3782 3783 3784 3785 3786 3787 3788 3789 3790 3791 3792 3793 3794 3795 3796 3797 3798 3799 3800 3801 3802 3803 3804 3805 3806 3807 3808 3809 3810 3811 3812 3813 3814 3815 3816 3817 3818 3819 3820 |
}
/*
*---------------------------------------------------------------------------
*
* 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 ) ;
|
| ︙ | ︙ | |||
3574 3575 3576 3577 3578 3579 3580 |
/* Replace everything */
if ((first == 0) && (count == numBytes)) {
return insertPtr;
}
if (TclIsPureByteArray(insertPtr)) {
| | | | > | | | | | | 3828 3829 3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 3846 3847 3848 3849 3850 3851 3852 3853 3854 3855 3856 3857 3858 3859 3860 3861 3862 3863 3864 3865 3866 3867 3868 3869 3870 3871 3872 3873 3874 3875 3876 3877 3878 3879 3880 3881 3882 3883 3884 3885 3886 3887 3888 3889 3890 3891 3892 3893 3894 3895 3896 |
/* 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) {
Tcl_AppendUnicodeToObj(result, ustring + first + count,
numChars - first - count);
}
return result;
}
}
|
| ︙ | ︙ | |||
3678 3679 3680 3681 3682 3683 3684 |
String *stringPtr = GET_STRING(objPtr);
size_t needed, numOrigChars = 0;
Tcl_UniChar *dst, unichar = 0;
if (stringPtr->hasUnicode) {
numOrigChars = stringPtr->numChars;
}
| | < | 3933 3934 3935 3936 3937 3938 3939 3940 3941 3942 3943 3944 3945 3946 3947 3948 3949 3950 |
String *stringPtr = GET_STRING(objPtr);
size_t needed, numOrigChars = 0;
Tcl_UniChar *dst, unichar = 0;
if (stringPtr->hasUnicode) {
numOrigChars = stringPtr->numChars;
}
if (numAppendChars == TCL_AUTO_LENGTH) {
TclNumUtfChars(numAppendChars, bytes, numBytes);
}
needed = numOrigChars + numAppendChars;
if (needed > stringPtr->maxChars) {
GrowUnicodeBuffer(objPtr, needed);
stringPtr = GET_STRING(objPtr);
}
stringPtr->hasUnicode = 1;
|
| ︙ | ︙ | |||
3730 3731 3732 3733 3734 3735 3736 |
* an internal rep of type "String". */
Tcl_Obj *copyPtr) /* Object with internal rep to set. Must not
* currently have an internal rep.*/
{
String *srcStringPtr = GET_STRING(srcPtr);
String *copyStringPtr = NULL;
| | | 3984 3985 3986 3987 3988 3989 3990 3991 3992 3993 3994 3995 3996 3997 3998 |
* an internal rep of type "String". */
Tcl_Obj *copyPtr) /* Object with internal rep to set. Must not
* currently have an internal rep.*/
{
String *srcStringPtr = GET_STRING(srcPtr);
String *copyStringPtr = NULL;
if (srcStringPtr->numChars == TCL_AUTO_LENGTH) {
/*
* 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;
|
| ︙ | ︙ | |||
3799 3800 3801 3802 3803 3804 3805 |
*/
static int
SetStringFromAny(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr) /* The object to convert. */
{
| | | | 4053 4054 4055 4056 4057 4058 4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 4070 4071 4072 4073 4074 4075 4076 4077 4078 4079 4080 4081 4082 |
*/
static int
SetStringFromAny(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
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;
}
return TCL_OK;
|
| ︙ | ︙ | |||
3859 3860 3861 3862 3863 3864 3865 |
* memory pointed to by that NULL pointer is clearly bogus, and
* needs a reset.
*/
stringPtr->allocated = 0;
if (stringPtr->numChars == 0) {
| | | | 4113 4114 4115 4116 4117 4118 4119 4120 4121 4122 4123 4124 4125 4126 4127 4128 4129 4130 4131 4132 4133 4134 4135 4136 4137 4138 4139 4140 4141 4142 4143 4144 4145 4146 4147 4148 |
* 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_AUTO_LENGTH) {
numChars = UnicodeLength(unicode);
}
if (numChars == 0) {
return 0;
}
|
| ︙ | ︙ | |||
3905 3906 3907 3908 3909 3910 3911 |
&& stringPtr->allocated >= size + numChars * TCL_UTF_MAX) {
goto copyBytes;
}
for (i = 0; i < numChars; i++) {
size += TclUtfCount(unicode[i]);
}
| < < < | | 4159 4160 4161 4162 4163 4164 4165 4166 4167 4168 4169 4170 4171 4172 4173 4174 4175 4176 4177 4178 4179 4180 4181 4182 4183 4184 4185 |
&& 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;
}
/*
|
| ︙ | ︙ | |||
3948 3949 3950 3951 3952 3953 3954 |
*----------------------------------------------------------------------
*/
static void
FreeStringInternalRep(
Tcl_Obj *objPtr) /* Object with internal rep to free. */
{
| | | 4199 4200 4201 4202 4203 4204 4205 4206 4207 4208 4209 4210 4211 4212 4213 4214 4215 4216 |
*----------------------------------------------------------------------
*/
static void
FreeStringInternalRep(
Tcl_Obj *objPtr) /* Object with internal rep to free. */
{
Tcl_Free(GET_STRING(objPtr));
objPtr->typePtr = NULL;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclStringRep.h.
| ︙ | ︙ | |||
27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 |
*
* Copyright (c) 1995-1997 Sun Microsystems, Inc.
* Copyright (c) 1999 by Scriptics Corporation.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
/*
* The following structure is the internal rep for a String object. It keeps
* track of how much memory has been used and how much has been allocated for
* the Unicode and UTF string to enable growing and shrinking of the UTF and
* Unicode reps of the String object with fewer mallocs. To optimize string
* length and indexing operations, this structure also stores the number of
* characters (same of UTF and Unicode!) once that value has been computed.
*
* Under normal configurations, what Tcl calls "Unicode" is actually UTF-16
* restricted to the Basic Multilingual Plane (i.e. U+00000 to U+0FFFF). This
* can be officially modified by altering the definition of Tcl_UniChar in
* tcl.h, but do not do that unless you are sure what you're doing!
*/
typedef struct {
| > > > > | < < < < < < < < < | | | | > > | 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 |
*
* 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[1]; /* The array of Unicode chars. The actual size
* of this field depends on the 'maxChars'
* field above. */
} String;
#define STRING_SIZE(numChars) \
(sizeof(String) + ((numChars) * 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:
*/
|
Changes to generic/tclStubInit.c.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 16 17 18 19 20 21 22 | * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #include "tclOOInt.h" #include "tommath.h" /* * The actual definition of the variable holding the TclOO stub table. */ MODULE_SCOPE const TclOOStubs tclOOStubs; MODULE_SCOPE const TclOOIntStubs tclOOIntStubs; | > > > > | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 | * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #include "tclOOInt.h" #include "tommath.h" #ifdef __CYGWIN__ # include <wchar.h> #endif /* * The actual definition of the variable holding the TclOO stub table. */ MODULE_SCOPE const TclOOStubs tclOOStubs; MODULE_SCOPE const TclOOIntStubs tclOOIntStubs; |
| ︙ | ︙ | |||
36 37 38 39 40 41 42 43 44 | #undef Tcl_NewByteArrayObj #undef Tcl_NewDoubleObj #undef Tcl_NewListObj #undef Tcl_NewLongObj #undef Tcl_DbNewLongObj #undef Tcl_NewObj #undef Tcl_NewStringObj #undef Tcl_DumpActiveMemory #undef Tcl_ValidateAllMemory | > | > | > | > > | | < < < < < | | | < | < | < < | < < < < < | | 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 |
#undef Tcl_NewByteArrayObj
#undef Tcl_NewDoubleObj
#undef Tcl_NewListObj
#undef Tcl_NewLongObj
#undef Tcl_DbNewLongObj
#undef Tcl_NewObj
#undef Tcl_NewStringObj
#undef Tcl_GetUnicode
#undef Tcl_DumpActiveMemory
#undef Tcl_ValidateAllMemory
#undef Tcl_SetExitProc
#undef Tcl_SetPanicProc
#undef TclpGetPid
#undef TclStaticPackage
#undef Tcl_BackgroundError
#define TclStaticPackage Tcl_StaticPackage
#ifdef TCL_MEM_DEBUG
# define Tcl_Alloc TclpAlloc
# define Tcl_Free TclpFree
# define Tcl_Realloc TclpRealloc
# undef Tcl_AttemptAlloc
# define Tcl_AttemptAlloc TclpAlloc
# undef Tcl_AttemptRealloc
# define Tcl_AttemptRealloc TclpRealloc
#endif
#ifdef _WIN32
# define TclUnixWaitForFile 0
# define TclUnixCopyFile 0
# define TclUnixOpenTemporaryFile 0
# define TclpIsAtty 0
#elif defined(__CYGWIN__)
# define TclpIsAtty TclPlatIsAtty
static void
doNothing(void)
{
/* dummy implementation, no need to do anything */
}
# define TclWinAddProcess (void (*) (void *, size_t)) doNothing
# define TclWinFlushDirtyChannels doNothing
static int
TclpIsAtty(int fd)
{
return isatty(fd);
}
|
| ︙ | ︙ | |||
107 108 109 110 111 112 113 |
if (*p == '\\') {
*p = '/';
}
}
return path;
}
| | | | < < < | < < < < < | > > | | | > | | > > < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < | | < < < < < | > > > > > > > > > | 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 |
if (*p == '\\') {
*p = '/';
}
}
return path;
}
size_t
TclpGetPid(Tcl_Pid pid)
{
return (size_t) pid;
}
char *
Tcl_WinUtfToTChar(
const char *string,
size_t len,
Tcl_DString *dsPtr)
{
Tcl_DStringInit(dsPtr);
if (!string) {
return NULL;
}
return (char *)TclUtfToWCharDString(string, len, dsPtr);
}
char *
Tcl_WinTCharToUtf(
const char *string,
size_t len,
Tcl_DString *dsPtr)
{
Tcl_DStringInit(dsPtr);
if (!string) {
return NULL;
}
if (len == TCL_AUTO_LENGTH) {
len = wcslen((wchar_t *)string);
} else {
len /= 2;
}
return TclWCharToUtfDString((const WCHAR *)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.
*/
static int exprInt(Tcl_Interp *interp, const char *expr, int *ptr){
long longValue;
int result = Tcl_ExprLong(interp, expr, &longValue);
if (result == TCL_OK) {
if ((longValue >= (long)(INT_MIN))
&& (longValue <= (long)(UINT_MAX))) {
*ptr = (int)longValue;
} else {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"integer value too large to represent as non-long integer", -1));
result = TCL_ERROR;
}
}
return result;
}
#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))
&& (longValue <= (long)(UINT_MAX))) {
*ptr = (int)longValue;
} else {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"integer value too large to represent as non-long integer", -1));
result = TCL_ERROR;
}
}
return result;
}
#define Tcl_ExprLongObj (int(*)(Tcl_Interp*,Tcl_Obj*,long*))exprIntObj
#endif
#endif /* __CYGWIN__ */
/*
* WARNING: The contents of this file is automatically generated by the
* tools/genStubs.tcl script. Any modifications to the function declarations
* below should be made in the generic/tcl.decls script.
*/
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 = {
TCL_STUB_MAGIC,
0,
0, /* 0 */
|
| ︙ | ︙ | |||
272 273 274 275 276 277 278 |
0, /* 27 */
TclpGetDefaultStdChannel, /* 28 */
0, /* 29 */
0, /* 30 */
TclGetExtension, /* 31 */
TclGetFrame, /* 32 */
0, /* 33 */
| | | 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 |
0, /* 27 */
TclpGetDefaultStdChannel, /* 28 */
0, /* 29 */
0, /* 30 */
TclGetExtension, /* 31 */
TclGetFrame, /* 32 */
0, /* 33 */
0, /* 34 */
0, /* 35 */
0, /* 36 */
TclGetLoadedPackages, /* 37 */
TclGetNamespaceForQualName, /* 38 */
TclGetObjInterpProc, /* 39 */
TclGetOpenMode, /* 40 */
TclGetOriginalCommand, /* 41 */
|
| ︙ | ︙ | |||
495 496 497 498 499 500 501 502 503 504 505 506 507 508 |
TclSetSlaveCancelFlags, /* 250 */
TclRegisterLiteral, /* 251 */
TclPtrGetVar, /* 252 */
TclPtrSetVar, /* 253 */
TclPtrIncrObjVar, /* 254 */
TclPtrObjMakeUpvar, /* 255 */
TclPtrUnsetVar, /* 256 */
};
static const TclIntPlatStubs tclIntPlatStubs = {
TCL_STUB_MAGIC,
0,
#if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */
TclGetAndDetachPids, /* 0 */
| > > | 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 |
TclSetSlaveCancelFlags, /* 250 */
TclRegisterLiteral, /* 251 */
TclPtrGetVar, /* 252 */
TclPtrSetVar, /* 253 */
TclPtrIncrObjVar, /* 254 */
TclPtrObjMakeUpvar, /* 255 */
TclPtrUnsetVar, /* 256 */
TclStaticPackage, /* 257 */
TclpCreateTemporaryDirectory, /* 258 */
};
static const TclIntPlatStubs tclIntPlatStubs = {
TCL_STUB_MAGIC,
0,
#if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */
TclGetAndDetachPids, /* 0 */
|
| ︙ | ︙ | |||
667 668 669 670 671 672 673 |
TclBN_mp_sub_d, /* 43 */
TclBN_mp_to_unsigned_bin, /* 44 */
TclBN_mp_to_unsigned_bin_n, /* 45 */
TclBN_mp_toradix_n, /* 46 */
TclBN_mp_unsigned_bin_size, /* 47 */
TclBN_mp_xor, /* 48 */
TclBN_mp_zero, /* 49 */
| | | | | | | | | | | | > > > > > > | 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 |
TclBN_mp_sub_d, /* 43 */
TclBN_mp_to_unsigned_bin, /* 44 */
TclBN_mp_to_unsigned_bin_n, /* 45 */
TclBN_mp_toradix_n, /* 46 */
TclBN_mp_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 */
TclBN_mp_init_set_int, /* 61 */
TclBN_mp_set_int, /* 62 */
TclBN_mp_cnt_lsb, /* 63 */
0, /* 64 */
0, /* 65 */
0, /* 66 */
TclBN_mp_expt_d_ex, /* 67 */
TclBN_mp_set_long_long, /* 68 */
TclBN_mp_get_long_long, /* 69 */
TclBN_mp_set_long, /* 70 */
TclBN_mp_get_long, /* 71 */
TclBN_mp_get_int, /* 72 */
0, /* 73 */
0, /* 74 */
0, /* 75 */
TclBN_mp_signed_rsh, /* 76 */
TclBN_mp_get_bit, /* 77 */
};
static const TclStubHooks tclStubHooks = {
&tclPlatStubs,
&tclIntStubs,
&tclIntPlatStubs,
&tclOOStubs,
|
| ︙ | ︙ | |||
748 749 750 751 752 753 754 |
Tcl_DbNewByteArrayObj, /* 23 */
Tcl_DbNewDoubleObj, /* 24 */
Tcl_DbNewListObj, /* 25 */
0, /* 26 */
Tcl_DbNewObj, /* 27 */
Tcl_DbNewStringObj, /* 28 */
Tcl_DuplicateObj, /* 29 */
| | | 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 |
Tcl_DbNewByteArrayObj, /* 23 */
Tcl_DbNewDoubleObj, /* 24 */
Tcl_DbNewListObj, /* 25 */
0, /* 26 */
Tcl_DbNewObj, /* 27 */
Tcl_DbNewStringObj, /* 28 */
Tcl_DuplicateObj, /* 29 */
0, /* 30 */
Tcl_GetBoolean, /* 31 */
Tcl_GetBooleanFromObj, /* 32 */
Tcl_GetByteArrayFromObj, /* 33 */
Tcl_GetDouble, /* 34 */
Tcl_GetDoubleFromObj, /* 35 */
0, /* 36 */
Tcl_GetInt, /* 37 */
|
| ︙ | ︙ | |||
794 795 796 797 798 799 800 |
Tcl_AppendElement, /* 69 */
Tcl_AppendResult, /* 70 */
Tcl_AsyncCreate, /* 71 */
Tcl_AsyncDelete, /* 72 */
Tcl_AsyncInvoke, /* 73 */
Tcl_AsyncMark, /* 74 */
Tcl_AsyncReady, /* 75 */
| | | 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 |
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_BadChannelOption, /* 78 */
Tcl_CallWhenDeleted, /* 79 */
Tcl_CancelIdleCall, /* 80 */
Tcl_Close, /* 81 */
Tcl_CommandComplete, /* 82 */
Tcl_Concat, /* 83 */
|
| ︙ | ︙ | |||
900 901 902 903 904 905 906 |
#endif /* MACOSX */
Tcl_GetPathType, /* 168 */
Tcl_Gets, /* 169 */
Tcl_GetsObj, /* 170 */
Tcl_GetServiceMode, /* 171 */
Tcl_GetSlave, /* 172 */
Tcl_GetStdChannel, /* 173 */
| | | 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 |
#endif /* MACOSX */
Tcl_GetPathType, /* 168 */
Tcl_Gets, /* 169 */
Tcl_GetsObj, /* 170 */
Tcl_GetServiceMode, /* 171 */
Tcl_GetSlave, /* 172 */
Tcl_GetStdChannel, /* 173 */
0, /* 174 */
0, /* 175 */
Tcl_GetVar2, /* 176 */
0, /* 177 */
0, /* 178 */
Tcl_HideCommand, /* 179 */
Tcl_Init, /* 180 */
Tcl_InitHashTable, /* 181 */
|
| ︙ | ︙ | |||
970 971 972 973 974 975 976 |
0, /* 237 */
Tcl_SetVar2, /* 238 */
Tcl_SignalId, /* 239 */
Tcl_SignalMsg, /* 240 */
Tcl_SourceRCFile, /* 241 */
Tcl_SplitList, /* 242 */
Tcl_SplitPath, /* 243 */
| | | | 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 |
0, /* 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_TraceVar2, /* 248 */
Tcl_TranslateFileName, /* 249 */
Tcl_Ungets, /* 250 */
Tcl_UnlinkVar, /* 251 */
Tcl_UnregisterChannel, /* 252 */
|
| ︙ | ︙ | |||
999 1000 1001 1002 1003 1004 1005 |
Tcl_ValidateAllMemory, /* 266 */
0, /* 267 */
0, /* 268 */
Tcl_HashStats, /* 269 */
Tcl_ParseVar, /* 270 */
0, /* 271 */
Tcl_PkgPresentEx, /* 272 */
| | | 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 |
Tcl_ValidateAllMemory, /* 266 */
0, /* 267 */
0, /* 268 */
Tcl_HashStats, /* 269 */
Tcl_ParseVar, /* 270 */
0, /* 271 */
Tcl_PkgPresentEx, /* 272 */
0, /* 273 */
0, /* 274 */
0, /* 275 */
0, /* 276 */
Tcl_WaitPid, /* 277 */
0, /* 278 */
Tcl_GetVersion, /* 279 */
Tcl_InitMemory, /* 280 */
|
| ︙ | ︙ | |||
1108 1109 1110 1111 1112 1113 1114 |
Tcl_UniCharIsPunct, /* 375 */
Tcl_RegExpExecObj, /* 376 */
Tcl_RegExpGetInfo, /* 377 */
Tcl_NewUnicodeObj, /* 378 */
Tcl_SetUnicodeObj, /* 379 */
Tcl_GetCharLength, /* 380 */
Tcl_GetUniChar, /* 381 */
| | | 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 |
Tcl_UniCharIsPunct, /* 375 */
Tcl_RegExpExecObj, /* 376 */
Tcl_RegExpGetInfo, /* 377 */
Tcl_NewUnicodeObj, /* 378 */
Tcl_SetUnicodeObj, /* 379 */
Tcl_GetCharLength, /* 380 */
Tcl_GetUniChar, /* 381 */
0, /* 382 */
Tcl_GetRange, /* 383 */
Tcl_AppendUnicodeToObj, /* 384 */
Tcl_RegExpMatchObj, /* 385 */
Tcl_SetNotifier, /* 386 */
Tcl_GetAllocMutex, /* 387 */
Tcl_GetChannelNames, /* 388 */
Tcl_GetChannelNamesEx, /* 389 */
|
| ︙ | ︙ | |||
1245 1246 1247 1248 1249 1250 1251 |
Tcl_GetCurrentNamespace, /* 512 */
Tcl_GetGlobalNamespace, /* 513 */
Tcl_FindNamespace, /* 514 */
Tcl_FindCommand, /* 515 */
Tcl_GetCommandFromObj, /* 516 */
Tcl_GetCommandFullName, /* 517 */
Tcl_FSEvalFileEx, /* 518 */
| | | 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 |
Tcl_GetCurrentNamespace, /* 512 */
Tcl_GetGlobalNamespace, /* 513 */
Tcl_FindNamespace, /* 514 */
Tcl_FindCommand, /* 515 */
Tcl_GetCommandFromObj, /* 516 */
Tcl_GetCommandFullName, /* 517 */
Tcl_FSEvalFileEx, /* 518 */
0, /* 519 */
Tcl_LimitAddHandler, /* 520 */
Tcl_LimitRemoveHandler, /* 521 */
Tcl_LimitReady, /* 522 */
Tcl_LimitCheck, /* 523 */
Tcl_LimitExceeded, /* 524 */
Tcl_LimitSetCommands, /* 525 */
Tcl_LimitSetTime, /* 526 */
|
| ︙ | ︙ | |||
1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 |
Tcl_NRExprObj, /* 625 */
Tcl_NRSubstObj, /* 626 */
Tcl_LoadFile, /* 627 */
Tcl_FindSymbol, /* 628 */
Tcl_FSUnloadFile, /* 629 */
Tcl_ZlibStreamSetCompressionDictionary, /* 630 */
Tcl_OpenTcpServerEx, /* 631 */
};
/* !END!: Do not edit above this line. */
| > > > > > > > > > > > > > > | 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 |
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 */
};
/* !END!: Do not edit above this line. */
|
Changes to generic/tclStubLib.c.
| ︙ | ︙ | |||
66 67 68 69 70 71 72 |
/*
* 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]
*/
| | | 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 |
/*
* 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 */
return NULL;
}
actualVersion = stubsPtr->tcl_PkgRequireEx(interp, "Tcl", version, 0, &pkgData);
if (actualVersion == NULL) {
|
| ︙ | ︙ |
Changes to generic/tclTest.c.
| ︙ | ︙ | |||
48 49 50 51 52 53 54 55 56 57 58 59 60 61 |
/*
* Dynamic string shared by TestdcallCmd and DelCallbackProc; used to collect
* the results of the various deletion callbacks.
*/
static Tcl_DString delString;
static Tcl_Interp *delInterp;
/*
* One of the following structures exists for each asynchronous handler
* created by the "testasync" command".
*/
typedef struct TestAsyncHandler {
| > | 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 |
/*
* Dynamic string shared by TestdcallCmd and DelCallbackProc; used to collect
* the results of the various deletion callbacks.
*/
static Tcl_DString delString;
static Tcl_Interp *delInterp;
static const Tcl_ObjType *properByteArrayType;
/*
* One of the following structures exists for each asynchronous handler
* created by the "testasync" command".
*/
typedef struct TestAsyncHandler {
|
| ︙ | ︙ | |||
155 156 157 158 159 160 161 | static TestChannel *firstDetached; /* * Forward declarations for procedures defined later in this file: */ | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > | | | | > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > < < | | | 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 | static TestChannel *firstDetached; /* * 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 int CmdProc1(void *clientData, Tcl_Interp *interp, int argc, const char **argv); static int CmdProc2(void *clientData, Tcl_Interp *interp, int argc, const char **argv); 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 int CreatedCommandProc( void *clientData, Tcl_Interp *interp, int argc, const char **argv); static int CreatedCommandProc2( void *clientData, Tcl_Interp *interp, int argc, const char **argv); static void DelCallbackProc(void *clientData, Tcl_Interp *interp); static int DelCmdProc(void *clientData, Tcl_Interp *interp, int argc, const char **argv); 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 int GetTimesObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static void MainLoop(void); static int NoopCmd(void *clientData, Tcl_Interp *interp, int argc, const char **argv); static int NoopObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); 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 int TestasyncCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); static int TestbytestringObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int TestpurebytesobjObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int TeststringbytesObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int TestcmdinfoCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); static int TestcmdtokenCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); static int TestcmdtraceCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); static int TestconcatobjCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); static int TestcreatecommandCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); static int TestdcallCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); static int TestdelCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); static int TestdelassocdataCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); static int TestdoubledigitsObjCmd(void *dummy, Tcl_Interp* interp, int objc, Tcl_Obj* const objv[]); static int TestdstringCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); static int TestencodingObjCmd(void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int TestevalexObjCmd(void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int TestevalobjvObjCmd(void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int TesteventObjCmd(void *unused, Tcl_Interp *interp, int argc, Tcl_Obj *const objv[]); static int TesteventProc(Tcl_Event *event, int flags); static int TesteventDeleteProc(Tcl_Event *event, void *clientData); static int TestexithandlerCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); static int TestexprlongCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); static int TestexprlongobjCmd(void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int TestexprdoubleCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); static int TestexprdoubleobjCmd(void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int TestexprparserObjCmd(void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int TestexprstringCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); static int TestfileCmd(void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int TestfilelinkCmd(void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int TestfeventCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); static int TestgetassocdataCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); static int TestgetintCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); static int TestlongsizeCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); static int TestgetplatformCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); static int TestgetvarfullnameCmd( void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int TestinterpdeleteCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); static int TestlinkCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); static int TestlinkarrayCmd(void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); static int TestlocaleCmd(void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int TestmainthreadCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); static int TestsetmainloopCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); static int TestexitmainloopCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); static int TestpanicCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); static int TestparseargsCmd(void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int TestparserObjCmd(void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int TestparsevarObjCmd(void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int TestparsevarnameObjCmd(void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int TestpreferstableObjCmd(void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int TestprintObjCmd(void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int TestregexpObjCmd(void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int TestreturnObjCmd(void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static void TestregexpXflags(const char *string, size_t length, int *cflagsPtr, int *eflagsPtr); static int TestsaveresultCmd(void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static void TestsaveresultFree(void *blockPtr); static int TestsetassocdataCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); static int TestsetCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); static int Testset2Cmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); static int TestseterrorcodeCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); static int TestsetobjerrorcodeCmd( void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int TestsetplatformCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); static int TeststaticpkgCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); static int TesttranslatefilenameCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); static int TestupvarCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); static int TestWrongNumArgsObjCmd( void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int TestGetIndexFromObjStructObjCmd( void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int TestChannelCmd(void *clientData, Tcl_Interp *interp, int argc, const char **argv); static int TestChannelEventCmd(void *clientData, Tcl_Interp *interp, int argc, const char **argv); static int TestSocketCmd(void *clientData, Tcl_Interp *interp, int argc, const char **argv); static int TestFilesystemObjCmd(void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int TestSimpleFilesystemObjCmd( void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static void TestReport(const char *cmd, Tcl_Obj *arg1, Tcl_Obj *arg2); static Tcl_Obj * TestReportGetNativePath(Tcl_Obj *pathPtr); static Tcl_FSStatProc TestReportStat; static Tcl_FSAccessProc TestReportAccess; static Tcl_FSOpenFileChannelProc TestReportOpenFileChannel; |
| ︙ | ︙ | |||
409 410 411 412 413 414 415 | static Tcl_FSStatProc SimpleStat; static Tcl_FSAccessProc SimpleAccess; static Tcl_FSOpenFileChannelProc SimpleOpenFileChannel; static Tcl_FSListVolumesProc SimpleListVolumes; static Tcl_FSPathInFilesystemProc SimplePathInFilesystem; static Tcl_Obj * SimpleRedirect(Tcl_Obj *pathPtr); static Tcl_FSMatchInDirectoryProc SimpleMatchInDirectory; | | | | | | | | | | 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 |
static Tcl_FSStatProc SimpleStat;
static Tcl_FSAccessProc SimpleAccess;
static Tcl_FSOpenFileChannelProc SimpleOpenFileChannel;
static Tcl_FSListVolumesProc SimpleListVolumes;
static Tcl_FSPathInFilesystemProc SimplePathInFilesystem;
static Tcl_Obj * SimpleRedirect(Tcl_Obj *pathPtr);
static Tcl_FSMatchInDirectoryProc SimpleMatchInDirectory;
static int TestNumUtfCharsCmd(void *clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
static int TestFindFirstCmd(void *clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
static int TestFindLastCmd(void *clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
static int TestHashSystemHashCmd(void *clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
static Tcl_NRPostProc NREUnwind_callback;
static int TestNREUnwind(void *clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
static int TestNRELevels(void *clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
static int TestInterpResolverCmd(void *clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
#if defined(HAVE_CPUID) || defined(_WIN32)
static int TestcpuidCmd(void *dummy,
Tcl_Interp* interp, int objc,
Tcl_Obj *const objv[]);
#endif
static const Tcl_Filesystem testReportingFilesystem = {
"reporting",
sizeof(Tcl_Filesystem),
|
| ︙ | ︙ | |||
543 544 545 546 547 548 549 |
*----------------------------------------------------------------------
*/
int
Tcltest_Init(
Tcl_Interp *interp) /* Interpreter for application. */
{
| < | | 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 |
*----------------------------------------------------------------------
*/
int
Tcltest_Init(
Tcl_Interp *interp) /* Interpreter for application. */
{
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) {
|
| ︙ | ︙ | |||
566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 |
}
/* TIP #268: Full patchlevel instead of just major.minor */
if (Tcl_PkgProvideEx(interp, "Tcltest", TCL_PATCH_LEVEL, NULL) == TCL_ERROR) {
return TCL_ERROR;
}
/*
* Create additional commands and math functions for testing Tcl.
*/
Tcl_CreateObjCommand(interp, "gettimes", GetTimesObjCmd, NULL, NULL);
Tcl_CreateCommand(interp, "noop", NoopCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "noop", NoopObjCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testbytestring", TestbytestringObjCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "teststringbytes", TeststringbytesObjCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testwrongnumargs", TestWrongNumArgsObjCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testfilesystem", TestFilesystemObjCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testsimplefilesystem", TestSimpleFilesystemObjCmd,
| > > > > > > | 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 |
}
/* TIP #268: Full patchlevel instead of just major.minor */
if (Tcl_PkgProvideEx(interp, "Tcltest", TCL_PATCH_LEVEL, NULL) == TCL_ERROR) {
return TCL_ERROR;
}
objPtr = Tcl_NewStringObj("abc", 3);
(void)Tcl_GetByteArrayFromObj(objPtr, &index);
properByteArrayType = objPtr->typePtr;
Tcl_DecrRefCount(objPtr);
/*
* Create additional commands and math functions for testing Tcl.
*/
Tcl_CreateObjCommand(interp, "gettimes", GetTimesObjCmd, NULL, NULL);
Tcl_CreateCommand(interp, "noop", NoopCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "noop", NoopObjCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testpurebytesobj", TestpurebytesobjObjCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testbytestring", TestbytestringObjCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "teststringbytes", TeststringbytesObjCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testwrongnumargs", TestWrongNumArgsObjCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testfilesystem", TestFilesystemObjCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testsimplefilesystem", TestSimpleFilesystemObjCmd,
|
| ︙ | ︙ | |||
640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 |
Tcl_CreateObjCommand(interp, "testfile", TestfileCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testhashsystemhash",
TestHashSystemHashCmd, NULL, NULL);
Tcl_CreateCommand(interp, "testgetassocdata", TestgetassocdataCmd,
NULL, NULL);
Tcl_CreateCommand(interp, "testgetint", TestgetintCmd,
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, "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,
| > > > | 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 |
Tcl_CreateObjCommand(interp, "testfile", TestfileCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testhashsystemhash",
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,
|
| ︙ | ︙ | |||
673 674 675 676 677 678 679 |
Tcl_CreateObjCommand(interp, "testsaveresult", TestsaveresultCmd,
NULL, NULL);
Tcl_CreateCommand(interp, "testsetassocdata", TestsetassocdataCmd,
NULL, NULL);
Tcl_CreateCommand(interp, "testsetnoerr", TestsetCmd,
NULL, NULL);
Tcl_CreateCommand(interp, "testseterr", TestsetCmd,
| | | < | < | | | | | | | 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 |
Tcl_CreateObjCommand(interp, "testsaveresult", TestsaveresultCmd,
NULL, NULL);
Tcl_CreateCommand(interp, "testsetassocdata", TestsetassocdataCmd,
NULL, NULL);
Tcl_CreateCommand(interp, "testsetnoerr", TestsetCmd,
NULL, NULL);
Tcl_CreateCommand(interp, "testseterr", TestsetCmd,
INT2PTR(TCL_LEAVE_ERR_MSG), NULL);
Tcl_CreateCommand(interp, "testset2", Testset2Cmd,
INT2PTR(TCL_LEAVE_ERR_MSG), NULL);
Tcl_CreateCommand(interp, "testseterrorcode", TestseterrorcodeCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testsetobjerrorcode",
TestsetobjerrorcodeCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testnumutfchars",
TestNumUtfCharsCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testfindfirst",
TestFindFirstCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testfindlast",
TestFindLastCmd, NULL, NULL);
Tcl_CreateCommand(interp, "testsetplatform", TestsetplatformCmd,
NULL, NULL);
Tcl_CreateCommand(interp, "testsocket", TestSocketCmd,
NULL, NULL);
Tcl_CreateCommand(interp, "teststaticpkg", TeststaticpkgCmd,
NULL, NULL);
Tcl_CreateCommand(interp, "testtranslatefilename",
TesttranslatefilenameCmd, NULL, NULL);
Tcl_CreateCommand(interp, "testupvar", TestupvarCmd, NULL, NULL);
Tcl_CreateCommand(interp, "testmainthread", TestmainthreadCmd, NULL,
NULL);
Tcl_CreateCommand(interp, "testsetmainloop", TestsetmainloopCmd,
NULL, NULL);
Tcl_CreateCommand(interp, "testexitmainloop", TestexitmainloopCmd,
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);
if (TclObjTest_Init(interp) != TCL_OK) {
return TCL_ERROR;
}
if (Procbodytest_Init(interp) != TCL_OK) {
return TCL_ERROR;
}
#if TCL_THREADS
if (TclThread_Init(interp) != TCL_OK) {
return TCL_ERROR;
}
#endif
/*
* Check for special options used in ../tests/main.test
*/
objPtr = Tcl_GetVar2Ex(interp, "argv", NULL, TCL_GLOBAL_ONLY);
if (objPtr != NULL) {
if (Tcl_ListObjGetElements(interp, objPtr, &objc, &objv) != TCL_OK) {
return TCL_ERROR;
}
if (objc && (Tcl_GetIndexFromObj(NULL, objv[0], specialOptions, NULL,
TCL_EXACT, &index) == TCL_OK)) {
switch (index) {
case 0:
return TCL_ERROR;
case 1:
Tcl_DeleteInterp(interp);
return TCL_ERROR;
case 2: {
|
| ︙ | ︙ | |||
815 816 817 818 819 820 821 | * *---------------------------------------------------------------------- */ /* ARGSUSED */ static int TestasyncCmd( | | | | | | | | 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 |
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
static int
TestasyncCmd(
void *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;
if (argc < 2) {
wrongNumArgs:
Tcl_AppendResult(interp, "wrong # args", NULL);
return TCL_ERROR;
}
if (strcmp(argv[1], "create") == 0) {
if (argc != 3) {
goto wrongNumArgs;
}
asyncPtr = Tcl_Alloc(sizeof(TestAsyncHandler));
asyncPtr->command = Tcl_Alloc(strlen(argv[2]) + 1);
strcpy(asyncPtr->command, argv[2]);
Tcl_MutexLock(&asyncTestMutex);
asyncPtr->id = nextId;
nextId++;
asyncPtr->handler = Tcl_AsyncCreate(AsyncHandlerProc,
INT2PTR(asyncPtr->id));
asyncPtr->nextPtr = firstHandler;
firstHandler = asyncPtr;
Tcl_MutexUnlock(&asyncTestMutex);
Tcl_SetObjResult(interp, Tcl_NewIntObj(asyncPtr->id));
} else if (strcmp(argv[1], "delete") == 0) {
if (argc == 2) {
Tcl_MutexLock(&asyncTestMutex);
while (firstHandler != NULL) {
asyncPtr = firstHandler;
firstHandler = asyncPtr->nextPtr;
Tcl_AsyncDelete(asyncPtr->handler);
Tcl_Free(asyncPtr->command);
Tcl_Free(asyncPtr);
}
Tcl_MutexUnlock(&asyncTestMutex);
return TCL_OK;
}
if (argc != 3) {
goto wrongNumArgs;
}
|
| ︙ | ︙ | |||
876 877 878 879 880 881 882 |
}
if (prevPtr == NULL) {
firstHandler = asyncPtr->nextPtr;
} else {
prevPtr->nextPtr = asyncPtr->nextPtr;
}
Tcl_AsyncDelete(asyncPtr->handler);
| | | | 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 |
}
if (prevPtr == NULL) {
firstHandler = asyncPtr->nextPtr;
} else {
prevPtr->nextPtr = asyncPtr->nextPtr;
}
Tcl_AsyncDelete(asyncPtr->handler);
Tcl_Free(asyncPtr->command);
Tcl_Free(asyncPtr);
break;
}
Tcl_MutexUnlock(&asyncTestMutex);
} else if (strcmp(argv[1], "mark") == 0) {
if (argc != 5) {
goto wrongNumArgs;
}
|
| ︙ | ︙ | |||
900 901 902 903 904 905 906 | Tcl_AsyncMark(asyncPtr->handler); break; } } Tcl_SetObjResult(interp, Tcl_NewStringObj(argv[3], -1)); Tcl_MutexUnlock(&asyncTestMutex); return code; | | | 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 |
Tcl_AsyncMark(asyncPtr->handler);
break;
}
}
Tcl_SetObjResult(interp, Tcl_NewStringObj(argv[3], -1));
Tcl_MutexUnlock(&asyncTestMutex);
return code;
#if TCL_THREADS
} else if (strcmp(argv[1], "marklater") == 0) {
if (argc != 3) {
goto wrongNumArgs;
}
if (Tcl_GetInt(interp, argv[2], &id) != TCL_OK) {
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
940 941 942 943 944 945 946 |
#endif
}
return TCL_OK;
}
static int
AsyncHandlerProc(
| | | > | | > > | | | | | 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 |
#endif
}
return TCL_OK;
}
static int
AsyncHandlerProc(
void *clientData, /* If of TestAsyncHandler structure.
* in global list. */
Tcl_Interp *interp, /* Interpreter in which command was
* executed, or NULL. */
int code) /* Current return code from command. */
{
TestAsyncHandler *asyncPtr;
int id = PTR2INT(clientData);
const char *listArgv[4];
char *cmd;
char string[TCL_INTEGER_SPACE];
Tcl_MutexLock(&asyncTestMutex);
for (asyncPtr = firstHandler; asyncPtr != NULL;
asyncPtr = asyncPtr->nextPtr) {
if (asyncPtr->id == id) {
break;
}
}
Tcl_MutexUnlock(&asyncTestMutex);
if (!asyncPtr) {
/* Woops - this one was deleted between the AsyncMark and now */
return TCL_OK;
}
TclFormatInt(string, code);
listArgv[0] = asyncPtr->command;
listArgv[1] = Tcl_GetStringResult(interp);
listArgv[2] = string;
listArgv[3] = NULL;
cmd = Tcl_Merge(3, listArgv);
if (interp != NULL) {
code = Tcl_EvalEx(interp, cmd, -1, 0);
} else {
/*
* this should not happen, but by definition of how async handlers are
* invoked, it's possible. Better error checking is needed here.
*/
}
Tcl_Free(cmd);
return code;
}
/*
*----------------------------------------------------------------------
*
* AsyncThreadProc --
*
* Delivers an asynchronous event to a handler in another thread.
*
* Results:
* None.
*
* Side effects:
* Invokes Tcl_AsyncMark on the handler
*
*----------------------------------------------------------------------
*/
#if TCL_THREADS
static Tcl_ThreadCreateType
AsyncThreadProc(
void *clientData) /* Parameter is the id of a
* TestAsyncHandler, defined above. */
{
TestAsyncHandler *asyncPtr;
int id = PTR2INT(clientData);
Tcl_Sleep(1);
Tcl_MutexLock(&asyncTestMutex);
|
| ︙ | ︙ | |||
1042 1043 1044 1045 1046 1047 1048 | * *---------------------------------------------------------------------- */ /* ARGSUSED */ static int TestcmdinfoCmd( | | | | 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 |
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
static int
TestcmdinfoCmd(
void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
Tcl_CmdInfo info;
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",
CmdDelProc1);
} else if (strcmp(argv[1], "delete") == 0) {
Tcl_DStringInit(&delString);
Tcl_DeleteCommand(interp, argv[2]);
Tcl_DStringResult(interp, &delString);
} else if (strcmp(argv[1], "get") == 0) {
if (Tcl_GetCommandInfo(interp, argv[2], &info) ==0) {
|
| ︙ | ︙ | |||
1092 1093 1094 1095 1096 1097 1098 |
if (info.isNativeObjectProc) {
Tcl_AppendResult(interp, " nativeObjectProc", NULL);
} else {
Tcl_AppendResult(interp, " stringProc", NULL);
}
} else if (strcmp(argv[1], "modify") == 0) {
info.proc = CmdProc2;
| | | | | | | | | | 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 |
if (info.isNativeObjectProc) {
Tcl_AppendResult(interp, " nativeObjectProc", NULL);
} else {
Tcl_AppendResult(interp, " stringProc", NULL);
}
} else if (strcmp(argv[1], "modify") == 0) {
info.proc = CmdProc2;
info.clientData = (void *) "new_command_data";
info.objProc = NULL;
info.objClientData = NULL;
info.deleteProc = CmdDelProc2;
info.deleteData = (void *) "new_delete_data";
if (Tcl_SetCommandInfo(interp, argv[2], &info) == 0) {
Tcl_SetObjResult(interp, Tcl_NewIntObj(0));
} else {
Tcl_SetObjResult(interp, Tcl_NewIntObj(1));
}
} else {
Tcl_AppendResult(interp, "bad option \"", argv[1],
"\": must be create, delete, get, or modify", NULL);
return TCL_ERROR;
}
return TCL_OK;
}
/*ARGSUSED*/
static int
CmdProc1(
void *clientData, /* String to return. */
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
Tcl_AppendResult(interp, "CmdProc1 ", (char *) clientData, NULL);
return TCL_OK;
}
/*ARGSUSED*/
static int
CmdProc2(
void *clientData, /* String to return. */
Tcl_Interp *interp, /* Current interpreter. */
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. */
{
Tcl_DStringInit(&delString);
Tcl_DStringAppend(&delString, "CmdDelProc1 ", -1);
Tcl_DStringAppend(&delString, (char *) clientData, -1);
}
static void
CmdDelProc2(
void *clientData) /* String to save. */
{
Tcl_DStringInit(&delString);
Tcl_DStringAppend(&delString, "CmdDelProc2 ", -1);
Tcl_DStringAppend(&delString, (char *) clientData, -1);
}
/*
|
| ︙ | ︙ | |||
1172 1173 1174 1175 1176 1177 1178 | * *---------------------------------------------------------------------- */ /* ARGSUSED */ static int TestcmdtokenCmd( | | | | 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 |
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
static int
TestcmdtokenCmd(
void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
Tcl_Command token;
int *l;
char buf[30];
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" option arg\"", NULL);
return TCL_ERROR;
}
if (strcmp(argv[1], "create") == 0) {
token = Tcl_CreateCommand(interp, argv[2], CmdProc1,
(void *) "original", NULL);
sprintf(buf, "%p", (void *)token);
Tcl_AppendResult(interp, buf, NULL);
} 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],
|
| ︙ | ︙ | |||
1236 1237 1238 1239 1240 1241 1242 | * *---------------------------------------------------------------------- */ /* ARGSUSED */ static int TestcmdtraceCmd( | | | 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 |
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
static int
TestcmdtraceCmd(
void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
Tcl_DString buffer;
int result;
|
| ︙ | ︙ | |||
1292 1293 1294 1295 1296 1297 1298 | */ static int deleteCalled; deleteCalled = 0; cmdTrace = Tcl_CreateObjTrace(interp, 50000, TCL_ALLOW_INLINE_COMPILATION, ObjTraceProc, | | | 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 |
*/
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);
Tcl_DeleteTrace(interp, cmdTrace);
if (!deleteCalled) {
Tcl_AppendResult(interp, "Delete wasn't called", NULL);
return TCL_ERROR;
} else {
return result;
|
| ︙ | ︙ | |||
1325 1326 1327 1328 1329 1330 1331 |
return TCL_ERROR;
}
return TCL_OK;
}
static void
CmdTraceProc(
| | | | | | | 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 |
return TCL_ERROR;
}
return TCL_OK;
}
static void
CmdTraceProc(
void *clientData, /* Pointer to buffer in which the
* command and arguments are appended.
* Accumulates test result. */
Tcl_Interp *interp, /* Current interpreter. */
int level, /* Current trace level. */
char *command, /* The command being traced (after
* substitutions). */
Tcl_CmdProc *cmdProc, /* Points to command's command procedure. */
void *cmdClientData, /* Client data associated with command
* procedure. */
int argc, /* Number of arguments. */
const char *argv[]) /* Argument strings. */
{
Tcl_DString *bufPtr = (Tcl_DString *) clientData;
int i;
Tcl_DStringAppendElement(bufPtr, command);
Tcl_DStringStartSublist(bufPtr);
for (i = 0; i < argc; i++) {
Tcl_DStringAppendElement(bufPtr, argv[i]);
}
Tcl_DStringEndSublist(bufPtr);
}
static void
CmdTraceDeleteProc(
void *clientData, /* Unused. */
Tcl_Interp *interp, /* Current interpreter. */
int level, /* Current trace level. */
char *command, /* The command being traced (after
* substitutions). */
Tcl_CmdProc *cmdProc, /* Points to command's command procedure. */
void *cmdClientData, /* Client data associated with command
* procedure. */
int argc, /* Number of arguments. */
const 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
* reference freed memory.
*/
Tcl_DeleteTrace(interp, cmdTrace);
}
static int
ObjTraceProc(
void *clientData, /* unused */
Tcl_Interp *interp, /* Tcl interpreter */
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 */
{
|
| ︙ | ︙ | |||
1402 1403 1404 1405 1406 1407 1408 |
} else {
return TCL_OK;
}
}
static void
ObjTraceDeleteProc(
| | | 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 |
} else {
return TCL_OK;
}
}
static void
ObjTraceDeleteProc(
void *clientData)
{
int *intPtr = (int *) clientData;
*intPtr = 1; /* Record that the trace was deleted */
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
1431 1432 1433 1434 1435 1436 1437 | * and "value:at:"). * *---------------------------------------------------------------------- */ static int TestcreatecommandCmd( | | | 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 |
* and "value:at:").
*
*----------------------------------------------------------------------
*/
static int
TestcreatecommandCmd(
void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
if (argc != 2) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" option\"", NULL);
|
| ︙ | ︙ | |||
1461 1462 1463 1464 1465 1466 1467 |
return TCL_ERROR;
}
return TCL_OK;
}
static int
CreatedCommandProc(
| | | 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 |
return TCL_ERROR;
}
return TCL_OK;
}
static int
CreatedCommandProc(
void *clientData, /* String to return. */
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
Tcl_CmdInfo info;
int found;
|
| ︙ | ︙ | |||
1483 1484 1485 1486 1487 1488 1489 |
Tcl_AppendResult(interp, "CreatedCommandProc in ",
info.namespacePtr->fullName, NULL);
return TCL_OK;
}
static int
CreatedCommandProc2(
| | | 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 |
Tcl_AppendResult(interp, "CreatedCommandProc in ",
info.namespacePtr->fullName, NULL);
return TCL_OK;
}
static int
CreatedCommandProc2(
void *clientData, /* String to return. */
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
Tcl_CmdInfo info;
int found;
|
| ︙ | ︙ | |||
1522 1523 1524 1525 1526 1527 1528 | * *---------------------------------------------------------------------- */ /* ARGSUSED */ static int TestdcallCmd( | | | | | | 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 |
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
static int
TestdcallCmd(
void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
int i, id;
delInterp = Tcl_CreateInterp();
Tcl_DStringInit(&delString);
for (i = 1; i < argc; i++) {
if (Tcl_GetInt(interp, argv[i], &id) != TCL_OK) {
return TCL_ERROR;
}
if (id < 0) {
Tcl_DontCallWhenDeleted(delInterp, DelCallbackProc,
INT2PTR(-id));
} else {
Tcl_CallWhenDeleted(delInterp, DelCallbackProc,
INT2PTR(id));
}
}
Tcl_DeleteInterp(delInterp);
Tcl_DStringResult(interp, &delString);
return TCL_OK;
}
/*
* The deletion callback used by TestdcallCmd:
*/
static void
DelCallbackProc(
void *clientData, /* Numerical value to append to delString. */
Tcl_Interp *interp) /* Interpreter being deleted. */
{
int id = PTR2INT(clientData);
char buffer[TCL_INTEGER_SPACE];
TclFormatInt(buffer, id);
Tcl_DStringAppendElement(&delString, buffer);
|
| ︙ | ︙ | |||
1587 1588 1589 1590 1591 1592 1593 | * *---------------------------------------------------------------------- */ /* ARGSUSED */ static int TestdelCmd( | | | | | | | | | | | | 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 |
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
static int
TestdelCmd(
void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
DelCmd *dPtr;
Tcl_Interp *slave;
if (argc != 4) {
Tcl_AppendResult(interp, "wrong # args", NULL);
return TCL_ERROR;
}
slave = Tcl_GetSlave(interp, argv[1]);
if (slave == NULL) {
return TCL_ERROR;
}
dPtr = Tcl_Alloc(sizeof(DelCmd));
dPtr->interp = interp;
dPtr->deleteCmd = Tcl_Alloc(strlen(argv[3]) + 1);
strcpy(dPtr->deleteCmd, argv[3]);
Tcl_CreateCommand(slave, argv[2], DelCmdProc, dPtr,
DelDeleteProc);
return TCL_OK;
}
static int
DelCmdProc(
void *clientData, /* String result to return. */
Tcl_Interp *interp, /* Current interpreter. */
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);
return TCL_OK;
}
static void
DelDeleteProc(
void *clientData) /* String command to evaluate. */
{
DelCmd *dPtr = clientData;
Tcl_EvalEx(dPtr->interp, dPtr->deleteCmd, -1, 0);
Tcl_ResetResult(dPtr->interp);
Tcl_Free(dPtr->deleteCmd);
Tcl_Free(dPtr);
}
/*
*----------------------------------------------------------------------
*
* TestdelassocdataCmd --
*
|
| ︙ | ︙ | |||
1662 1663 1664 1665 1666 1667 1668 | * interpreter. * *---------------------------------------------------------------------- */ static int TestdelassocdataCmd( | | | 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 |
* interpreter.
*
*----------------------------------------------------------------------
*/
static int
TestdelassocdataCmd(
void *clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
if (argc != 2) {
Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
" data_key\"", NULL);
|
| ︙ | ︙ | |||
1691 1692 1693 1694 1695 1696 1697 | * * Usage: * testdoubledigits fpval ndigits type ?shorten" * * Parameters: * fpval - Floating-point value to format. * ndigits - Digit count to request from Tcl_DoubleDigits | | | < < | 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 |
*
* Usage:
* 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'
* shorten - Indicates that the 'shorten' flag should be passed in.
*
*-----------------------------------------------------------------------------
*/
static int
TestdoubledigitsObjCmd(void *unused,
/* NULL */
Tcl_Interp* interp,
/* Tcl interpreter */
int objc,
/* Parameter count */
Tcl_Obj* const objv[])
/* Parameter vector */
{
static const char* options[] = {
"shortest",
"e",
"f",
NULL
};
static const int types[] = {
TCL_DD_SHORTEST,
TCL_DD_E_FORMAT,
TCL_DD_F_FORMAT
};
const Tcl_ObjType* doubleType;
double d;
int status;
|
| ︙ | ︙ | |||
1740 1741 1742 1743 1744 1745 1746 |
if (objc < 4 || objc > 5) {
Tcl_WrongNumArgs(interp, 1, objv, "fpval ndigits type ?shorten?");
return TCL_ERROR;
}
status = Tcl_GetDoubleFromObj(interp, objv[1], &d);
if (status != TCL_OK) {
doubleType = Tcl_GetObjType("double");
| | | | | | | | 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 |
if (objc < 4 || objc > 5) {
Tcl_WrongNumArgs(interp, 1, objv, "fpval ndigits type ?shorten?");
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)) {
status = TCL_OK;
memcpy(&d, &(objv[1]->internalRep.doubleValue), sizeof(double));
}
}
if (status != TCL_OK
|| Tcl_GetIntFromObj(interp, objv[2], &ndigits) != TCL_OK
|| Tcl_GetIndexFromObj(interp, objv[3], options, "conversion type",
TCL_EXACT, &type) != TCL_OK) {
fprintf(stderr, "bad value? %g\n", d);
return TCL_ERROR;
}
type = types[type];
if (objc > 4) {
if (strcmp(Tcl_GetString(objv[4]), "shorten")) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("bad flag", -1));
return TCL_ERROR;
}
type |= TCL_DD_SHORTEN_FLAG;
}
str = TclDoubleDigits(d, ndigits, type, &decpt, &signum, &endPtr);
strObj = Tcl_NewStringObj(str, endPtr-str);
Tcl_Free(str);
retval = Tcl_NewListObj(1, &strObj);
Tcl_ListObjAppendElement(NULL, retval, Tcl_NewIntObj(decpt));
strObj = Tcl_NewStringObj(signum ? "-" : "+", 1);
Tcl_ListObjAppendElement(NULL, retval, strObj);
Tcl_SetObjResult(interp, retval);
return TCL_OK;
}
/*
|
| ︙ | ︙ | |||
1792 1793 1794 1795 1796 1797 1798 | * *---------------------------------------------------------------------- */ /* ARGSUSED */ static int TestdstringCmd( | | | 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 |
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
static int
TestdstringCmd(
void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
int count;
if (argc < 2) {
|
| ︙ | ︙ | |||
1841 1842 1843 1844 1845 1846 1847 |
goto wrongNumArgs;
}
if (strcmp(argv[2], "staticsmall") == 0) {
Tcl_AppendResult(interp, "short", NULL);
} else if (strcmp(argv[2], "staticlarge") == 0) {
Tcl_AppendResult(interp, "first0 first1 first2 first3 first4 first5 first6 first7 first8 first9\nsecond0 second1 second2 second3 second4 second5 second6 second7 second8 second9\nthird0 third1 third2 third3 third4 third5 third6 third7 third8 third9\nfourth0 fourth1 fourth2 fourth3 fourth4 fourth5 fourth6 fourth7 fourth8 fourth9\nfifth0 fifth1 fifth2 fifth3 fifth4 fifth5 fifth6 fifth7 fifth8 fifth9\nsixth0 sixth1 sixth2 sixth3 sixth4 sixth5 sixth6 sixth7 sixth8 sixth9\nseventh0 seventh1 seventh2 seventh3 seventh4 seventh5 seventh6 seventh7 seventh8 seventh9\n", NULL);
} else if (strcmp(argv[2], "free") == 0) {
| | | | | 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 |
goto wrongNumArgs;
}
if (strcmp(argv[2], "staticsmall") == 0) {
Tcl_AppendResult(interp, "short", NULL);
} else if (strcmp(argv[2], "staticlarge") == 0) {
Tcl_AppendResult(interp, "first0 first1 first2 first3 first4 first5 first6 first7 first8 first9\nsecond0 second1 second2 second3 second4 second5 second6 second7 second8 second9\nthird0 third1 third2 third3 third4 third5 third6 third7 third8 third9\nfourth0 fourth1 fourth2 fourth3 fourth4 fourth5 fourth6 fourth7 fourth8 fourth9\nfifth0 fifth1 fifth2 fifth3 fifth4 fifth5 fifth6 fifth7 fifth8 fifth9\nsixth0 sixth1 sixth2 sixth3 sixth4 sixth5 sixth6 sixth7 sixth8 sixth9\nseventh0 seventh1 seventh2 seventh3 seventh4 seventh5 seventh6 seventh7 seventh8 seventh9\n", NULL);
} else if (strcmp(argv[2], "free") == 0) {
char *s = Tcl_Alloc(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;
strcpy(s, "This is a specially-allocated string");
Tcl_SetResult(interp, s, SpecialFree);
} else {
Tcl_AppendResult(interp, "bad gresult option \"", argv[2],
"\": must be staticsmall, staticlarge, free, or special",
NULL);
return TCL_ERROR;
}
Tcl_DStringGetResult(interp, &dstring);
} else if (strcmp(argv[1], "length") == 0) {
if (argc != 2) {
goto wrongNumArgs;
}
Tcl_SetObjResult(interp, Tcl_NewIntObj(Tcl_DStringLength(&dstring)));
} else if (strcmp(argv[1], "result") == 0) {
if (argc != 2) {
goto wrongNumArgs;
}
Tcl_DStringResult(interp, &dstring);
} else if (strcmp(argv[1], "trunc") == 0) {
if (argc != 3) {
|
| ︙ | ︙ | |||
1894 1895 1896 1897 1898 1899 1900 | /* * The procedure below is used as a special freeProc to test how well * Tcl_DStringGetResult handles freeProc's other than free. */ static void SpecialFree(blockPtr) | | | | 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 |
/*
* The procedure below is used as a special freeProc to test how well
* Tcl_DStringGetResult handles freeProc's other than free.
*/
static void SpecialFree(blockPtr)
void *blockPtr; /* Block to free. */
{
Tcl_Free(((char *)blockPtr) - 16);
}
/*
*----------------------------------------------------------------------
*
* TestencodingCmd --
*
|
| ︙ | ︙ | |||
1919 1920 1921 1922 1923 1924 1925 | * *---------------------------------------------------------------------- */ /* ARGSUSED */ static int TestencodingObjCmd( | | | | | | | | | | | 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 |
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
static int
TestencodingObjCmd(
void *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[] = {
"create", "delete", NULL
};
enum options {
ENC_CREATE, ENC_DELETE
};
if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0,
&index) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum options) index) {
case ENC_CREATE: {
Tcl_EncodingType type;
if (objc != 5) {
return TCL_ERROR;
}
encodingPtr = Tcl_Alloc(sizeof(TclEncoding));
encodingPtr->interp = interp;
string = Tcl_GetStringFromObj(objv[3], &length);
encodingPtr->toUtfCmd = Tcl_Alloc(length + 1);
memcpy(encodingPtr->toUtfCmd, string, length + 1);
string = Tcl_GetStringFromObj(objv[4], &length);
encodingPtr->fromUtfCmd = Tcl_Alloc(length + 1);
memcpy(encodingPtr->fromUtfCmd, string, length + 1);
string = Tcl_GetStringFromObj(objv[2], &length);
type.encodingName = string;
type.toUtfProc = EncodingToUtfProc;
type.fromUtfProc = EncodingFromUtfProc;
type.freeProc = EncodingFreeProc;
type.clientData = encodingPtr;
type.nullSize = 1;
Tcl_CreateEncoding(&type);
break;
}
case ENC_DELETE:
if (objc != 3) {
|
| ︙ | ︙ | |||
1987 1988 1989 1990 1991 1992 1993 |
break;
}
return TCL_OK;
}
static int
EncodingToUtfProc(
| | | | | | | | | | 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 |
break;
}
return TCL_OK;
}
static int
EncodingToUtfProc(
void *clientData, /* TclEncoding structure. */
const char *src, /* Source string in specified encoding. */
int srcLen, /* Source string length in bytes. */
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. */
{
int len;
TclEncoding *encodingPtr;
encodingPtr = (TclEncoding *) clientData;
Tcl_EvalEx(encodingPtr->interp, encodingPtr->toUtfCmd, -1, TCL_EVAL_GLOBAL);
len = strlen(Tcl_GetStringResult(encodingPtr->interp));
if (len > dstLen) {
len = dstLen;
}
memcpy(dst, Tcl_GetStringResult(encodingPtr->interp), len);
Tcl_ResetResult(encodingPtr->interp);
*srcReadPtr = srcLen;
*dstWrotePtr = len;
*dstCharsPtr = len;
return TCL_OK;
}
static int
EncodingFromUtfProc(
void *clientData, /* TclEncoding structure. */
const char *src, /* Source string in specified encoding. */
int srcLen, /* Source string length in bytes. */
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. */
{
int len;
TclEncoding *encodingPtr;
encodingPtr = (TclEncoding *) clientData;
Tcl_EvalEx(encodingPtr->interp, encodingPtr->fromUtfCmd, -1, TCL_EVAL_GLOBAL);
len = strlen(Tcl_GetStringResult(encodingPtr->interp));
if (len > dstLen) {
len = dstLen;
}
memcpy(dst, Tcl_GetStringResult(encodingPtr->interp), len);
Tcl_ResetResult(encodingPtr->interp);
*srcReadPtr = srcLen;
*dstWrotePtr = len;
*dstCharsPtr = len;
return TCL_OK;
}
static void
EncodingFreeProc(
void *clientData) /* ClientData associated with type. */
{
TclEncoding *encodingPtr = clientData;
Tcl_Free(encodingPtr->toUtfCmd);
Tcl_Free(encodingPtr->fromUtfCmd);
Tcl_Free(encodingPtr);
}
/*
*----------------------------------------------------------------------
*
* TestevalexObjCmd --
*
|
| ︙ | ︙ | |||
2079 2080 2081 2082 2083 2084 2085 | * None. * *---------------------------------------------------------------------- */ static int TestevalexObjCmd( | | | | 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestevalexObjCmd(
void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int length, flags;
const char *script;
flags = 0;
if (objc == 3) {
const char *global = Tcl_GetString(objv[2]);
if (strcmp(global, "global") != 0) {
Tcl_AppendResult(interp, "bad value \"", global,
"\": must be global", NULL);
return TCL_ERROR;
}
flags = TCL_EVAL_GLOBAL;
} else if (objc != 2) {
|
| ︙ | ︙ | |||
2124 2125 2126 2127 2128 2129 2130 | * None. * *---------------------------------------------------------------------- */ static int TestevalobjvObjCmd( | | | 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestevalobjvObjCmd(
void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int evalGlobal;
if (objc < 3) {
|
| ︙ | ︙ | |||
2173 2174 2175 2176 2177 2178 2179 | * Manipulates the event queue as directed. * *---------------------------------------------------------------------- */ static int TesteventObjCmd( | | | 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 |
* Manipulates the event queue as directed.
*
*----------------------------------------------------------------------
*/
static int
TesteventObjCmd(
void *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 */
"queue", "delete", NULL
};
|
| ︙ | ︙ | |||
2198 2199 2200 2201 2202 2203 2204 |
};
TestEvent *ev; /* Event to be queued */
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?arg ...?");
return TCL_ERROR;
}
| | | | | | | 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 |
};
TestEvent *ev; /* Event to be queued */
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?arg ...?");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], subcommands, "subcommand",
TCL_EXACT, &subCmdIndex) != TCL_OK) {
return TCL_ERROR;
}
switch (subCmdIndex) {
case 0: /* queue */
if (objc != 5) {
Tcl_WrongNumArgs(interp, 2, objv, "name position script");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[3], positions,
"position specifier", TCL_EXACT, &posIndex) != TCL_OK) {
return TCL_ERROR;
}
ev = Tcl_Alloc(sizeof(TestEvent));
ev->header.proc = TesteventProc;
ev->header.nextPtr = NULL;
ev->interp = interp;
ev->command = objv[4];
Tcl_IncrRefCount(ev->command);
ev->tag = objv[2];
Tcl_IncrRefCount(ev->tag);
|
| ︙ | ︙ | |||
2270 2271 2272 2273 2274 2275 2276 |
int result = Tcl_EvalObjEx(interp, command,
TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT);
int retval;
if (result != TCL_OK) {
Tcl_AddErrorInfo(interp,
" (command bound to \"testevent\" callback)");
| | | | 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 |
int result = Tcl_EvalObjEx(interp, command,
TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT);
int retval;
if (result != TCL_OK) {
Tcl_AddErrorInfo(interp,
" (command bound to \"testevent\" callback)");
Tcl_BackgroundException(interp, TCL_ERROR);
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);
return 1;
}
if (retval) {
Tcl_DecrRefCount(ev->tag);
Tcl_DecrRefCount(ev->command);
}
|
| ︙ | ︙ | |||
2309 2310 2311 2312 2313 2314 2315 |
*
*----------------------------------------------------------------------
*/
static int
TesteventDeleteProc(
Tcl_Event *event, /* Event to examine */
| | | 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 |
*
*----------------------------------------------------------------------
*/
static int
TesteventDeleteProc(
Tcl_Event *event, /* Event to examine */
void *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 */
const char *targetNameStr;
|
| ︙ | ︙ | |||
2352 2353 2354 2355 2356 2357 2358 | * None. * *---------------------------------------------------------------------- */ static int TestexithandlerCmd( | | | | | | | | | 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestexithandlerCmd(
void *clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
int value;
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
" create|delete value\"", NULL);
return TCL_ERROR;
}
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));
} else if (strcmp(argv[1], "delete") == 0) {
Tcl_DeleteExitHandler((value & 1) ? ExitProcOdd : ExitProcEven,
INT2PTR(value));
} else {
Tcl_AppendResult(interp, "bad option \"", argv[1],
"\": must be create or delete", NULL);
return TCL_ERROR;
}
return TCL_OK;
}
static void
ExitProcOdd(
void *clientData) /* Integer value to print. */
{
char buf[16 + TCL_INTEGER_SPACE];
size_t len;
sprintf(buf, "odd %" TCL_Z_MODIFIER "d\n", (size_t)PTR2INT(clientData));
len = strlen(buf);
if (len != (size_t) write(1, buf, len)) {
Tcl_Panic("ExitProcOdd: unable to write to stdout");
}
}
static void
ExitProcEven(
void *clientData) /* Integer value to print. */
{
char buf[16 + TCL_INTEGER_SPACE];
size_t len;
sprintf(buf, "even %" TCL_Z_MODIFIER "d\n", (size_t)PTR2INT(clientData));
len = strlen(buf);
if (len != (size_t) write(1, buf, len)) {
Tcl_Panic("ExitProcEven: unable to write to stdout");
}
}
/*
|
| ︙ | ︙ | |||
2428 2429 2430 2431 2432 2433 2434 | * None. * *---------------------------------------------------------------------- */ static int TestexprlongCmd( | | | 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestexprlongCmd(
void *clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
long exprResult;
char buf[4 + TCL_INTEGER_SPACE];
int result;
|
| ︙ | ︙ | |||
2471 2472 2473 2474 2475 2476 2477 | * None. * *---------------------------------------------------------------------- */ static int TestexprlongobjCmd( | | | 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestexprlongobjCmd(
void *clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Argument objects. */
{
long exprResult;
char buf[4 + TCL_INTEGER_SPACE];
int result;
|
| ︙ | ︙ | |||
2513 2514 2515 2516 2517 2518 2519 | * None. * *---------------------------------------------------------------------- */ static int TestexprdoubleCmd( | | | 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestexprdoubleCmd(
void *clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
double exprResult;
char buf[4 + TCL_DOUBLE_SPACE];
int result;
|
| ︙ | ︙ | |||
2557 2558 2559 2560 2561 2562 2563 | * None. * *---------------------------------------------------------------------- */ static int TestexprdoubleobjCmd( | | | 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestexprdoubleobjCmd(
void *clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Argument objects. */
{
double exprResult;
char buf[4 + TCL_DOUBLE_SPACE];
int result;
|
| ︙ | ︙ | |||
2599 2600 2601 2602 2603 2604 2605 | * None. * *---------------------------------------------------------------------- */ static int TestexprstringCmd( | | | 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestexprstringCmd(
void *clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
if (argc != 2) {
Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
" expression\"", NULL);
|
| ︙ | ︙ | |||
2631 2632 2633 2634 2635 2636 2637 | * May create a link on disk. * *---------------------------------------------------------------------- */ static int TestfilelinkCmd( | | | 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 |
* May create a link on disk.
*
*----------------------------------------------------------------------
*/
static int
TestfilelinkCmd(
void *clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
Tcl_Obj *contents;
if (objc < 2 || objc > 3) {
|
| ︙ | ︙ | |||
2698 2699 2700 2701 2702 2703 2704 | * None. * *---------------------------------------------------------------------- */ static int TestgetassocdataCmd( | | | 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestgetassocdataCmd(
void *clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
char *res;
if (argc != 2) {
|
| ︙ | ︙ | |||
2736 2737 2738 2739 2740 2741 2742 | * None. * *---------------------------------------------------------------------- */ static int TestgetplatformCmd( | | | 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestgetplatformCmd(
void *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" };
TclPlatformType *platform;
|
| ︙ | ︙ | |||
2777 2778 2779 2780 2781 2782 2783 | * *---------------------------------------------------------------------- */ /* ARGSUSED */ static int TestinterpdeleteCmd( | | | 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 |
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
static int
TestinterpdeleteCmd(
void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
Tcl_Interp *slaveToDelete;
if (argc != 2) {
|
| ︙ | ︙ | |||
2818 2819 2820 2821 2822 2823 2824 | * *---------------------------------------------------------------------- */ /* ARGSUSED */ static int TestlinkCmd( | | | | | 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 |
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
static int
TestlinkCmd(
void *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 char *stringVar = NULL;
static char charVar = '@';
static unsigned char ucharVar = 130;
static short shortVar = 3000;
static unsigned short ushortVar = 60000;
static unsigned int uintVar = 0xbeeffeed;
static long longVar = 123456789L;
static unsigned long ulongVar = 3456789012UL;
static float floatVar = 4.5;
static Tcl_WideUInt uwideVar = 123;
static int created = 0;
char buffer[2*TCL_DOUBLE_SPACE];
int writable, flag;
Tcl_Obj *tmp;
if (argc < 2) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
|
| ︙ | ︙ | |||
3026 3027 3028 3029 3030 3031 3032 | Tcl_AppendElement(interp, buffer); TclFormatInt(buffer, (int) shortVar); Tcl_AppendElement(interp, buffer); TclFormatInt(buffer, (int) ushortVar); Tcl_AppendElement(interp, buffer); TclFormatInt(buffer, (int) uintVar); Tcl_AppendElement(interp, buffer); | | | | 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 | Tcl_AppendElement(interp, buffer); TclFormatInt(buffer, (int) shortVar); Tcl_AppendElement(interp, buffer); TclFormatInt(buffer, (int) ushortVar); Tcl_AppendElement(interp, buffer); TclFormatInt(buffer, (int) uintVar); Tcl_AppendElement(interp, buffer); tmp = Tcl_NewWideIntObj(longVar); Tcl_AppendElement(interp, Tcl_GetString(tmp)); Tcl_DecrRefCount(tmp); tmp = Tcl_NewWideIntObj((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); Tcl_AppendElement(interp, Tcl_GetString(tmp)); Tcl_DecrRefCount(tmp); |
| ︙ | ︙ | |||
3065 3066 3067 3068 3069 3070 3071 |
if (argv[4][0] != 0) {
if (Tcl_GetInt(interp, argv[4], &boolVar) != TCL_OK) {
return TCL_ERROR;
}
}
if (argv[5][0] != 0) {
if (stringVar != NULL) {
| | | | 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 |
if (argv[4][0] != 0) {
if (Tcl_GetInt(interp, argv[4], &boolVar) != TCL_OK) {
return TCL_ERROR;
}
}
if (argv[5][0] != 0) {
if (stringVar != NULL) {
Tcl_Free(stringVar);
}
if (strcmp(argv[5], "-") == 0) {
stringVar = NULL;
} else {
stringVar = Tcl_Alloc(strlen(argv[5]) + 1);
strcpy(stringVar, argv[5]);
}
}
if (argv[6][0] != 0) {
tmp = Tcl_NewStringObj(argv[6], -1);
if (Tcl_GetWideIntFromObj(interp, tmp, &wideVar) != TCL_OK) {
Tcl_DecrRefCount(tmp);
|
| ︙ | ︙ | |||
3172 3173 3174 3175 3176 3177 3178 |
if (Tcl_GetInt(interp, argv[4], &boolVar) != TCL_OK) {
return TCL_ERROR;
}
Tcl_UpdateLinkedVar(interp, "bool");
}
if (argv[5][0] != 0) {
if (stringVar != NULL) {
| | | | 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 |
if (Tcl_GetInt(interp, argv[4], &boolVar) != TCL_OK) {
return TCL_ERROR;
}
Tcl_UpdateLinkedVar(interp, "bool");
}
if (argv[5][0] != 0) {
if (stringVar != NULL) {
Tcl_Free(stringVar);
}
if (strcmp(argv[5], "-") == 0) {
stringVar = NULL;
} else {
stringVar = Tcl_Alloc(strlen(argv[5]) + 1);
strcpy(stringVar, argv[5]);
}
Tcl_UpdateLinkedVar(interp, "string");
}
if (argv[6][0] != 0) {
tmp = Tcl_NewStringObj(argv[6], -1);
if (Tcl_GetWideIntFromObj(interp, tmp, &wideVar) != TCL_OK) {
|
| ︙ | ︙ | |||
3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 |
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestlocaleCmd --
*
* This procedure implements the "testlocale" command. It is used
* to test the effects of setting different locales in Tcl.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Modifies the current C locale.
*
*----------------------------------------------------------------------
*/
static int
TestlocaleCmd(
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 |
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* 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(
ClientData dummy, /* Not used. */
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 LinkOption { 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 LinkOption) optionIndex) {
case LINK_UPDATE:
for (i=2; i<objc; i++) {
Tcl_UpdateLinkedVar(interp, Tcl_GetString(objv[i]));
}
return TCL_OK;
case LINK_REMOVE:
for (i=2; i<objc; i++) {
Tcl_UnlinkVar(interp, Tcl_GetString(objv[i]));
}
return TCL_OK;
case LINK_CREATE:
if (objc < 4) {
goto wrongArgs;
}
readonly = 0;
i = 2;
/*
* test on switch -r...
*/
arg = Tcl_GetStringFromObj(objv[i], &length);
if (length < 2) {
goto wrongArgs;
}
if (arg[0] == '-') {
if (arg[1] != 'r') {
goto wrongArgs;
}
readonly = TCL_LINK_READ_ONLY;
i++;
}
if (Tcl_GetIndexFromObj(interp, objv[i++], LinkType, "type", 0,
&typeIndex) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetIntFromObj(interp, objv[i++], &size) == TCL_ERROR) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("wrong size value", -1));
return TCL_ERROR;
}
name = Tcl_GetString(objv[i++]);
/*
* If no address is given request one in the underlying function
*/
if (i < objc) {
if (Tcl_GetWideIntFromObj(interp, objv[i], &addr) == TCL_ERROR) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"wrong address value", -1));
return TCL_ERROR;
}
} else {
addr = 0;
}
return Tcl_LinkArray(interp, name, INT2PTR(addr),
LinkTypes[typeIndex] | readonly, size);
}
return TCL_OK;
wrongArgs:
Tcl_WrongNumArgs(interp, 2, objv, "?-readonly? type size name ?address?");
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* TestlocaleCmd --
*
* This procedure implements the "testlocale" command. It is used
* to test the effects of setting different locales in Tcl.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Modifies the current C locale.
*
*----------------------------------------------------------------------
*/
static int
TestlocaleCmd(
void *clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
int index;
const char *locale;
|
| ︙ | ︙ | |||
3312 3313 3314 3315 3316 3317 3318 |
*/
if (objc < 2 || objc > 3) {
Tcl_WrongNumArgs(interp, 1, objv, "category ?locale?");
return TCL_ERROR;
}
| | | | 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 |
*/
if (objc < 2 || objc > 3) {
Tcl_WrongNumArgs(interp, 1, objv, "category ?locale?");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0,
&index) != TCL_OK) {
return TCL_ERROR;
}
if (objc == 3) {
locale = Tcl_GetString(objv[2]);
} else {
locale = NULL;
|
| ︙ | ︙ | |||
3348 3349 3350 3351 3352 3353 3354 | * Releases storage. * *---------------------------------------------------------------------- */ /* ARGSUSED */ static void CleanupTestSetassocdataTests( | | | | 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 |
* Releases storage.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
static void
CleanupTestSetassocdataTests(
void *clientData, /* Data to be released. */
Tcl_Interp *interp) /* Interpreter being deleted. */
{
Tcl_Free(clientData);
}
/*
*----------------------------------------------------------------------
*
* TestparserObjCmd --
*
|
| ︙ | ︙ | |||
3373 3374 3375 3376 3377 3378 3379 | * None. * *---------------------------------------------------------------------- */ static int TestparserObjCmd( | | | 3506 3507 3508 3509 3510 3511 3512 3513 3514 3515 3516 3517 3518 3519 3520 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestparserObjCmd(
void *clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
const char *script;
int length, dummy;
Tcl_Parse parse;
|
| ︙ | ︙ | |||
3429 3430 3431 3432 3433 3434 3435 | * None. * *---------------------------------------------------------------------- */ static int TestexprparserObjCmd( | | | 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestexprparserObjCmd(
void *clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
const char *script;
int length, dummy;
Tcl_Parse parse;
|
| ︙ | ︙ | |||
3510 3511 3512 3513 3514 3515 3516 |
parsePtr->commentSize));
} else {
Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewStringObj("-", 1));
}
Tcl_ListObjAppendElement(NULL, objPtr,
Tcl_NewStringObj(parsePtr->commandStart, parsePtr->commandSize));
Tcl_ListObjAppendElement(NULL, objPtr,
| | | 3643 3644 3645 3646 3647 3648 3649 3650 3651 3652 3653 3654 3655 3656 3657 |
parsePtr->commentSize));
} else {
Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewStringObj("-", 1));
}
Tcl_ListObjAppendElement(NULL, objPtr,
Tcl_NewStringObj(parsePtr->commandStart, parsePtr->commandSize));
Tcl_ListObjAppendElement(NULL, objPtr,
Tcl_NewIntObj(parsePtr->numWords));
for (i = 0; i < parsePtr->numTokens; i++) {
tokenPtr = &parsePtr->tokenPtr[i];
switch (tokenPtr->type) {
case TCL_TOKEN_EXPAND_WORD:
typeString = "expand";
break;
case TCL_TOKEN_WORD:
|
| ︙ | ︙ | |||
3550 3551 3552 3553 3554 3555 3556 | break; } Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewStringObj(typeString, -1)); Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewStringObj(tokenPtr->start, tokenPtr->size)); Tcl_ListObjAppendElement(NULL, objPtr, | | | 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 3695 3696 3697 |
break;
}
Tcl_ListObjAppendElement(NULL, objPtr,
Tcl_NewStringObj(typeString, -1));
Tcl_ListObjAppendElement(NULL, objPtr,
Tcl_NewStringObj(tokenPtr->start, tokenPtr->size));
Tcl_ListObjAppendElement(NULL, objPtr,
Tcl_NewIntObj(tokenPtr->numComponents));
}
Tcl_ListObjAppendElement(NULL, objPtr,
Tcl_NewStringObj(parsePtr->commandStart + parsePtr->commandSize,
-1));
}
/*
|
| ︙ | ︙ | |||
3576 3577 3578 3579 3580 3581 3582 | * None. * *---------------------------------------------------------------------- */ static int TestparsevarObjCmd( | | | 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestparsevarObjCmd(
void *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;
if (objc != 2) {
|
| ︙ | ︙ | |||
3617 3618 3619 3620 3621 3622 3623 | * None. * *---------------------------------------------------------------------- */ static int TestparsevarnameObjCmd( | | | 3750 3751 3752 3753 3754 3755 3756 3757 3758 3759 3760 3761 3762 3763 3764 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestparsevarnameObjCmd(
void *clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
const char *script;
int append, length, dummy;
Tcl_Parse parse;
|
| ︙ | ︙ | |||
3680 3681 3682 3683 3684 3685 3686 | * None. * *---------------------------------------------------------------------- */ static int TestpreferstableObjCmd( | | | 3813 3814 3815 3816 3817 3818 3819 3820 3821 3822 3823 3824 3825 3826 3827 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestpreferstableObjCmd(
void *clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
Interp *iPtr = (Interp *) interp;
iPtr->packagePrefer = PKG_PREFER_STABLE;
return TCL_OK;
|
| ︙ | ︙ | |||
3709 3710 3711 3712 3713 3714 3715 | * None. * *---------------------------------------------------------------------- */ static int TestprintObjCmd( | | | 3842 3843 3844 3845 3846 3847 3848 3849 3850 3851 3852 3853 3854 3855 3856 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestprintObjCmd(
void *clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
Tcl_WideInt argv1 = 0;
size_t argv2;
|
| ︙ | ︙ | |||
3751 3752 3753 3754 3755 3756 3757 | * *---------------------------------------------------------------------- */ /* ARGSUSED */ static int TestregexpObjCmd( | | | > | 3884 3885 3886 3887 3888 3889 3890 3891 3892 3893 3894 3895 3896 3897 3898 3899 3900 3901 3902 3903 3904 |
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
static int
TestregexpObjCmd(
void *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 hasxflags, cflags, eflags;
Tcl_RegExp regExpr;
const char *string;
Tcl_Obj *objPtr;
Tcl_RegExpInfo info;
static const char *const options[] = {
"-indices", "-nocase", "-about", "-expanded",
|
| ︙ | ︙ | |||
3789 3790 3791 3792 3793 3794 3795 |
const char *name;
int index;
name = Tcl_GetString(objv[i]);
if (name[0] != '-') {
break;
}
| | | | 3923 3924 3925 3926 3927 3928 3929 3930 3931 3932 3933 3934 3935 3936 3937 3938 |
const char *name;
int index;
name = Tcl_GetString(objv[i]);
if (name[0] != '-') {
break;
}
if (Tcl_GetIndexFromObj(interp, objv[i], options, "switch", TCL_EXACT,
&index) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum options) index) {
case REGEXP_INDICES:
indices = 1;
break;
case REGEXP_NOCASE:
|
| ︙ | ︙ | |||
3865 3866 3867 3868 3869 3870 3871 |
}
if (match == 0) {
/*
* Set the interpreter's object result to an integer object w/
* value 0.
*/
| | | | | | | | | | | | | | | | 3999 4000 4001 4002 4003 4004 4005 4006 4007 4008 4009 4010 4011 4012 4013 4014 4015 4016 4017 4018 4019 4020 4021 4022 4023 4024 4025 4026 4027 4028 4029 4030 4031 4032 4033 4034 4035 4036 4037 4038 4039 4040 4041 4042 4043 4044 4045 4046 4047 4048 4049 4050 4051 4052 4053 4054 4055 4056 4057 4058 4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 4070 4071 4072 4073 4074 4075 4076 4077 4078 4079 4080 4081 4082 4083 4084 4085 4086 4087 4088 4089 4090 4091 4092 4093 4094 4095 4096 4097 4098 4099 4100 4101 4102 4103 4104 4105 4106 4107 4108 4109 |
}
if (match == 0) {
/*
* Set the interpreter's object result to an integer object w/
* value 0.
*/
Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
if (objc > 2 && (cflags®_EXPECT) && indices) {
const char *varName;
const char *value;
size_t start, end;
char resinfo[TCL_INTEGER_SPACE * 2];
varName = Tcl_GetString(objv[2]);
TclRegExpRangeUniChar(regExpr, -1, &start, &end);
sprintf(resinfo, "%" TCL_LL_MODIFIER "d %" TCL_LL_MODIFIER "d", TclWideIntFromSize(start), TclWideIntFromSize(end-1));
value = Tcl_SetVar2(interp, varName, NULL, resinfo, 0);
if (value == NULL) {
Tcl_AppendResult(interp, "couldn't set variable \"",
varName, "\"", NULL);
return TCL_ERROR;
}
} else if (cflags & TCL_REG_CANMATCH) {
const char *varName;
const char *value;
char resinfo[TCL_INTEGER_SPACE * 2];
Tcl_RegExpGetInfo(regExpr, &info);
varName = Tcl_GetString(objv[2]);
sprintf(resinfo, "%" TCL_LL_MODIFIER "d", TclWideIntFromSize(info.extendStart));
value = Tcl_SetVar2(interp, varName, NULL, resinfo, 0);
if (value == NULL) {
Tcl_AppendResult(interp, "couldn't set variable \"",
varName, "\"", NULL);
return TCL_ERROR;
}
}
return TCL_OK;
}
/*
* If additional variable names have been specified, return
* index information in those variables.
*/
objc -= 2;
objv += 2;
Tcl_RegExpGetInfo(regExpr, &info);
for (i = 0; i < objc; i++) {
size_t start, end;
Tcl_Obj *newPtr, *varPtr, *valuePtr;
varPtr = objv[i];
ii = ((cflags®_EXPECT) && i == objc-1) ? TCL_INDEX_NONE : (size_t)i;
if (indices) {
Tcl_Obj *objs[2];
if (ii == TCL_INDEX_NONE) {
TclRegExpRangeUniChar(regExpr, ii, &start, &end);
} else if (ii > info.nsubs) {
start = TCL_INDEX_NONE;
end = TCL_INDEX_NONE;
} else {
start = info.matches[ii].start;
end = info.matches[ii].end;
}
/*
* Adjust index so it refers to the last character in the match
* instead of the first character after the match.
*/
if (end != TCL_INDEX_NONE) {
end--;
}
objs[0] = TclNewWideIntObjFromSize(start);
objs[1] = TclNewWideIntObjFromSize(end);
newPtr = Tcl_NewListObj(2, objs);
} else {
if (ii == TCL_INDEX_NONE) {
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);
if (valuePtr == NULL) {
return TCL_ERROR;
}
}
/*
* Set the interpreter's object result to an integer object w/ value 1.
*/
Tcl_SetIntObj(Tcl_GetObjResult(interp), 1);
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
* TestregexpXflags --
|
| ︙ | ︙ | |||
3985 3986 3987 3988 3989 3990 3991 |
*
*----------------------------------------------------------------------
*/
static void
TestregexpXflags(
const char *string, /* The string of flags. */
| | > | | 4119 4120 4121 4122 4123 4124 4125 4126 4127 4128 4129 4130 4131 4132 4133 4134 4135 4136 4137 4138 |
*
*----------------------------------------------------------------------
*/
static void
TestregexpXflags(
const char *string, /* The string of flags. */
size_t length, /* The length of the string in bytes. */
int *cflagsPtr, /* compile flags word */
int *eflagsPtr) /* exec flags word */
{
size_t i;
int cflags, eflags;
cflags = *cflagsPtr;
eflags = *eflagsPtr;
for (i = 0; i < length; i++) {
switch (string[i]) {
case 'a':
cflags |= REG_ADVF;
|
| ︙ | ︙ | |||
4075 4076 4077 4078 4079 4080 4081 | * *---------------------------------------------------------------------- */ /* ARGSUSED */ static int TestreturnObjCmd( | | | 4210 4211 4212 4213 4214 4215 4216 4217 4218 4219 4220 4221 4222 4223 4224 |
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
static int
TestreturnObjCmd(
void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
return TCL_RETURN;
}
|
| ︙ | ︙ | |||
4103 4104 4105 4106 4107 4108 4109 | * data for this interpreter. * *---------------------------------------------------------------------- */ static int TestsetassocdataCmd( | | | | | < | 4238 4239 4240 4241 4242 4243 4244 4245 4246 4247 4248 4249 4250 4251 4252 4253 4254 4255 4256 4257 4258 4259 4260 4261 4262 4263 4264 4265 4266 4267 4268 4269 4270 4271 4272 4273 4274 4275 4276 4277 4278 4279 |
* data for this interpreter.
*
*----------------------------------------------------------------------
*/
static int
TestsetassocdataCmd(
void *clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
char *buf, *oldData;
Tcl_InterpDeleteProc *procPtr;
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
" data_key data_item\"", NULL);
return TCL_ERROR;
}
buf = Tcl_Alloc(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);
}
Tcl_SetAssocData(interp, argv[1], CleanupTestSetassocdataTests, buf);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestsetplatformCmd --
|
| ︙ | ︙ | |||
4155 4156 4157 4158 4159 4160 4161 | * Sets the tclPlatform global variable. * *---------------------------------------------------------------------- */ static int TestsetplatformCmd( | | | 4289 4290 4291 4292 4293 4294 4295 4296 4297 4298 4299 4300 4301 4302 4303 |
* Sets the tclPlatform global variable.
*
*----------------------------------------------------------------------
*/
static int
TestsetplatformCmd(
void *clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
size_t length;
TclPlatformType *platform;
|
| ︙ | ︙ | |||
4204 4205 4206 4207 4208 4209 4210 | * variable "x" in that interpreter is set to "loaded". * *---------------------------------------------------------------------- */ static int TeststaticpkgCmd( | | | | 4338 4339 4340 4341 4342 4343 4344 4345 4346 4347 4348 4349 4350 4351 4352 4353 4354 4355 4356 4357 4358 4359 4360 4361 4362 4363 4364 4365 4366 4367 4368 4369 4370 |
* variable "x" in that interpreter is set to "loaded".
*
*----------------------------------------------------------------------
*/
static int
TeststaticpkgCmd(
void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
int safe, loaded;
if (argc != 4) {
Tcl_AppendResult(interp, "wrong # arguments: should be \"",
argv[0], " pkgName safe loaded\"", NULL);
return TCL_ERROR;
}
if (Tcl_GetInt(interp, argv[2], &safe) != TCL_OK) {
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);
return TCL_OK;
}
static int
StaticInitProc(
Tcl_Interp *interp) /* Interpreter in which package is supposedly
|
| ︙ | ︙ | |||
4255 4256 4257 4258 4259 4260 4261 | * None. * *---------------------------------------------------------------------- */ static int TesttranslatefilenameCmd( | | | 4389 4390 4391 4392 4393 4394 4395 4396 4397 4398 4399 4400 4401 4402 4403 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TesttranslatefilenameCmd(
void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
Tcl_DString buffer;
const char *result;
|
| ︙ | ︙ | |||
4282 4283 4284 4285 4286 4287 4288 | } /* *---------------------------------------------------------------------- * * TestupvarCmd -- * | | | | 4416 4417 4418 4419 4420 4421 4422 4423 4424 4425 4426 4427 4428 4429 4430 4431 4432 4433 4434 4435 4436 4437 4438 4439 4440 4441 4442 4443 4444 4445 |
}
/*
*----------------------------------------------------------------------
*
* TestupvarCmd --
*
* This procedure implements the "testupvar" command. It is used
* to test Tcl_UpVar and Tcl_UpVar2.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Creates or modifies an "upvar" reference.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
static int
TestupvarCmd(
void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
int flags = 0;
if ((argc != 5) && (argc != 6)) {
|
| ︙ | ︙ | |||
4350 4351 4352 4353 4354 4355 4356 | * *---------------------------------------------------------------------- */ /* ARGSUSED */ static int TestseterrorcodeCmd( | | | 4484 4485 4486 4487 4488 4489 4490 4491 4492 4493 4494 4495 4496 4497 4498 |
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
static int
TestseterrorcodeCmd(
void *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);
return TCL_ERROR;
|
| ︙ | ︙ | |||
4403 4404 4405 4406 4407 4408 4409 | * *---------------------------------------------------------------------- */ /* ARGSUSED */ static int TestsetobjerrorcodeCmd( | | | 4537 4538 4539 4540 4541 4542 4543 4544 4545 4546 4547 4548 4549 4550 4551 |
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
static int
TestsetobjerrorcodeCmd(
void *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));
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
4432 4433 4434 4435 4436 4437 4438 | * *---------------------------------------------------------------------- */ /* ARGSUSED */ static int TestfeventCmd( | | | 4566 4567 4568 4569 4570 4571 4572 4573 4574 4575 4576 4577 4578 4579 4580 |
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
static int
TestfeventCmd(
void *clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
static Tcl_Interp *interp2 = NULL;
int code;
Tcl_Channel chan;
|
| ︙ | ︙ | |||
4504 4505 4506 4507 4508 4509 4510 | * May exit application. * *---------------------------------------------------------------------- */ static int TestpanicCmd( | | | | | 4638 4639 4640 4641 4642 4643 4644 4645 4646 4647 4648 4649 4650 4651 4652 4653 4654 4655 4656 4657 4658 4659 4660 4661 4662 4663 4664 4665 4666 4667 4668 4669 4670 4671 4672 4673 |
* May exit application.
*
*----------------------------------------------------------------------
*/
static int
TestpanicCmd(
void *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
*/
argString = Tcl_Merge(argc-1, argv+1);
Tcl_Panic("%s", argString);
Tcl_Free(argString);
return TCL_OK;
}
static int
TestfileCmd(
void *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;
Tcl_Obj *error = NULL;
const char *subcmd;
|
| ︙ | ︙ | |||
4607 4608 4609 4610 4611 4612 4613 | * None. * *---------------------------------------------------------------------- */ static int TestgetvarfullnameCmd( | | | 4741 4742 4743 4744 4745 4746 4747 4748 4749 4750 4751 4752 4753 4754 4755 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestgetvarfullnameCmd(
void *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;
|
| ︙ | ︙ | |||
4681 4682 4683 4684 4685 4686 4687 | * Allocates and frees memory, sets a variable "a" in the interpreter. * *---------------------------------------------------------------------- */ static int GetTimesObjCmd( | | | | | | | | 4815 4816 4817 4818 4819 4820 4821 4822 4823 4824 4825 4826 4827 4828 4829 4830 4831 4832 4833 4834 4835 4836 4837 4838 4839 4840 4841 4842 4843 4844 4845 4846 4847 4848 4849 4850 4851 4852 4853 4854 4855 4856 4857 4858 4859 4860 4861 4862 4863 4864 4865 4866 4867 4868 |
* Allocates and frees memory, sets a variable "a" in the interpreter.
*
*----------------------------------------------------------------------
*/
static int
GetTimesObjCmd(
void *unused, /* Unused. */
Tcl_Interp *interp, /* The current interpreter. */
int notused1, /* Number of arguments. */
Tcl_Obj *const notused2[]) /* The argument objects. */
{
Interp *iPtr = (Interp *) interp;
int i, n;
double timePer;
Tcl_Time start, stop;
Tcl_Obj *objPtr, **objv;
const char *s;
char newString[TCL_INTEGER_SPACE];
/* alloc & free 100000 times */
fprintf(stderr, "alloc & free 100000 6 word items\n");
Tcl_GetTime(&start);
for (i = 0; i < 100000; i++) {
objPtr = Tcl_Alloc(sizeof(Tcl_Obj));
Tcl_Free(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_Alloc(5000 * sizeof(Tcl_Obj *));
Tcl_GetTime(&start);
for (i = 0; i < 5000; i++) {
objv[i] = Tcl_Alloc(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]);
}
Tcl_GetTime(&stop);
timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
fprintf(stderr, " %.3f usec per free\n", timePer/5000);
/* Tcl_NewObj 5000 times */
fprintf(stderr, "Tcl_NewObj 5000 times\n");
|
| ︙ | ︙ | |||
4746 4747 4748 4749 4750 4751 4752 |
for (i = 0; i < 5000; i++) {
objPtr = objv[i];
Tcl_DecrRefCount(objPtr);
}
Tcl_GetTime(&stop);
timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
fprintf(stderr, " %.3f usec per Tcl_DecrRefCount\n", timePer/5000);
| | | 4880 4881 4882 4883 4884 4885 4886 4887 4888 4889 4890 4891 4892 4893 4894 |
for (i = 0; i < 5000; i++) {
objPtr = objv[i];
Tcl_DecrRefCount(objPtr);
}
Tcl_GetTime(&stop);
timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
fprintf(stderr, " %.3f usec per Tcl_DecrRefCount\n", timePer/5000);
Tcl_Free(objv);
/* TclGetString 100000 times */
fprintf(stderr, "TclGetStringFromObj of \"12345\" 100000 times\n");
objPtr = Tcl_NewStringObj("12345", -1);
Tcl_GetTime(&start);
for (i = 0; i < 100000; i++) {
(void) TclGetString(objPtr);
|
| ︙ | ︙ | |||
4860 4861 4862 4863 4864 4865 4866 | * None. * *---------------------------------------------------------------------- */ static int NoopCmd( | | | 4994 4995 4996 4997 4998 4999 5000 5001 5002 5003 5004 5005 5006 5007 5008 |
* None.
*
*----------------------------------------------------------------------
*/
static int
NoopCmd(
void *unused, /* Unused. */
Tcl_Interp *interp, /* The current interpreter. */
int argc, /* The number of arguments. */
const char **argv) /* The argument strings. */
{
return TCL_OK;
}
|
| ︙ | ︙ | |||
4887 4888 4889 4890 4891 4892 4893 | * None. * *---------------------------------------------------------------------- */ static int NoopObjCmd( | | | 5021 5022 5023 5024 5025 5026 5027 5028 5029 5030 5031 5032 5033 5034 5035 |
* None.
*
*----------------------------------------------------------------------
*/
static int
NoopObjCmd(
void *unused, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
return TCL_OK;
}
|
| ︙ | ︙ | |||
4912 4913 4914 4915 4916 4917 4918 | * None. * *---------------------------------------------------------------------- */ static int TeststringbytesObjCmd( | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | > > > > | 5046 5047 5048 5049 5050 5051 5052 5053 5054 5055 5056 5057 5058 5059 5060 5061 5062 5063 5064 5065 5066 5067 5068 5069 5070 5071 5072 5073 5074 5075 5076 5077 5078 5079 5080 5081 5082 5083 5084 5085 5086 5087 5088 5089 5090 5091 5092 5093 5094 5095 5096 5097 5098 5099 5100 5101 5102 5103 5104 5105 5106 5107 5108 5109 5110 5111 5112 5113 5114 5115 5116 5117 5118 5119 5120 5121 5122 5123 5124 5125 5126 5127 5128 5129 5130 5131 5132 5133 5134 5135 5136 5137 5138 5139 5140 5141 5142 5143 5144 5145 5146 5147 5148 5149 5150 5151 5152 5153 5154 5155 5156 5157 5158 5159 5160 5161 5162 5163 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TeststringbytesObjCmd(
void *unused, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
int n;
const unsigned char *p;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "value");
return TCL_ERROR;
}
p = (const unsigned char *)Tcl_GetStringFromObj(objv[1], &n);
Tcl_SetObjResult(interp, Tcl_NewByteArrayObj(p, n));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* 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(
ClientData unused, /* Not used. */
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 = Tcl_Alloc(objPtr->length + 1);
memcpy(objPtr->bytes, s, objPtr->length);
objPtr->bytes[objPtr->length] = 0;
}
Tcl_SetObjResult(interp, objPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestbytestringObjCmd --
*
* This object-based procedure constructs a string which can
* possibly contain invalid UTF-8 bytes.
*
* Results:
* Returns the TCL_OK result code.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
TestbytestringObjCmd(
void *unused, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
int n = 0;
const char *p;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "bytearray");
return TCL_ERROR;
}
p = (const char *)Tcl_GetByteArrayFromObj(objv[1], &n);
if ((p == NULL) || !Tcl_FetchIntRep(objv[1], properByteArrayType)) {
Tcl_AppendResult(interp, "testbytestring expects bytes", NULL);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewStringObj(p, n));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
4985 4986 4987 4988 4989 4990 4991 | * *---------------------------------------------------------------------- */ /* ARGSUSED */ static int TestsetCmd( | | | 5174 5175 5176 5177 5178 5179 5180 5181 5182 5183 5184 5185 5186 5187 5188 |
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
static int
TestsetCmd(
void *data, /* Additional flags for Get/SetVar2. */
register Tcl_Interp *interp,/* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
int flags = PTR2INT(data);
const char *value;
|
| ︙ | ︙ | |||
5017 5018 5019 5020 5021 5022 5023 |
Tcl_AppendResult(interp, "wrong # args: should be \"",
argv[0], " varName ?newValue?\"", NULL);
return TCL_ERROR;
}
}
static int
Testset2Cmd(
| | | 5206 5207 5208 5209 5210 5211 5212 5213 5214 5215 5216 5217 5218 5219 5220 |
Tcl_AppendResult(interp, "wrong # args: should be \"",
argv[0], " varName ?newValue?\"", NULL);
return TCL_ERROR;
}
}
static int
Testset2Cmd(
void *data, /* Additional flags for Get/SetVar2. */
register Tcl_Interp *interp,/* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
int flags = PTR2INT(data);
const char *value;
|
| ︙ | ︙ | |||
5068 5069 5070 5071 5072 5073 5074 | * *---------------------------------------------------------------------- */ /* ARGSUSED */ static int TestsaveresultCmd( | | | 5257 5258 5259 5260 5261 5262 5263 5264 5265 5266 5267 5268 5269 5270 5271 |
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
static int
TestsaveresultCmd(
void *dummy, /* Not used. */
register Tcl_Interp *interp,/* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
int discard, result, index;
Tcl_SavedResult state;
Tcl_Obj *objPtr;
|
| ︙ | ︙ | |||
5091 5092 5093 5094 5095 5096 5097 |
* Parse arguments
*/
if (objc != 4) {
Tcl_WrongNumArgs(interp, 1, objv, "type script discard");
return TCL_ERROR;
}
| | | | | 5280 5281 5282 5283 5284 5285 5286 5287 5288 5289 5290 5291 5292 5293 5294 5295 5296 5297 5298 5299 5300 5301 5302 5303 5304 5305 5306 5307 5308 5309 5310 5311 5312 |
* Parse arguments
*/
if (objc != 4) {
Tcl_WrongNumArgs(interp, 1, objv, "type script discard");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0,
&index) != TCL_OK) {
return TCL_ERROR;
}
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);
break;
case RESULT_APPEND:
Tcl_AppendResult(interp, "append result", NULL);
break;
case RESULT_FREE: {
char *buf = Tcl_Alloc(200);
strcpy(buf, "free result");
Tcl_SetResult(interp, buf, TCL_DYNAMIC);
break;
}
case RESULT_DYNAMIC:
Tcl_SetResult(interp, (char *)"dynamic result", TestsaveresultFree);
|
| ︙ | ︙ | |||
5171 5172 5173 5174 5175 5176 5177 | * Increments the freeCount. * *---------------------------------------------------------------------- */ static void TestsaveresultFree( | | | 5360 5361 5362 5363 5364 5365 5366 5367 5368 5369 5370 5371 5372 5373 5374 |
* Increments the freeCount.
*
*----------------------------------------------------------------------
*/
static void
TestsaveresultFree(
void *blockPtr)
{
freeCount++;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
5195 5196 5197 5198 5199 5200 5201 | * None. * *---------------------------------------------------------------------- */ static int TestmainthreadCmd( | | | 5384 5385 5386 5387 5388 5389 5390 5391 5392 5393 5394 5395 5396 5397 5398 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestmainthreadCmd(
void *dummy, /* Not used. */
register Tcl_Interp *interp,/* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
if (argc == 1) {
Tcl_Obj *idObj = Tcl_NewWideIntObj((Tcl_WideInt)(size_t)Tcl_GetCurrentThread());
|
| ︙ | ︙ | |||
5256 5257 5258 5259 5260 5261 5262 | * None. * *---------------------------------------------------------------------- */ static int TestsetmainloopCmd( | | | 5445 5446 5447 5448 5449 5450 5451 5452 5453 5454 5455 5456 5457 5458 5459 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestsetmainloopCmd(
void *dummy, /* Not used. */
register Tcl_Interp *interp,/* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
exitMainLoop = 0;
Tcl_SetMainLoop(MainLoop);
return TCL_OK;
|
| ︙ | ︙ | |||
5285 5286 5287 5288 5289 5290 5291 | * None. * *---------------------------------------------------------------------- */ static int TestexitmainloopCmd( | | | 5474 5475 5476 5477 5478 5479 5480 5481 5482 5483 5484 5485 5486 5487 5488 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestexitmainloopCmd(
void *dummy, /* Not used. */
register Tcl_Interp *interp,/* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
exitMainLoop = 1;
return TCL_OK;
}
|
| ︙ | ︙ | |||
5314 5315 5316 5317 5318 5319 5320 | * *---------------------------------------------------------------------- */ /* ARGSUSED */ static int TestChannelCmd( | | | 5503 5504 5505 5506 5507 5508 5509 5510 5511 5512 5513 5514 5515 5516 5517 |
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
static int
TestChannelCmd(
void *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. */
Tcl_HashTable *hTblPtr; /* Hash table of channels. */
Tcl_HashSearch hSearch; /* Search variable. */
|
| ︙ | ︙ | |||
5358 5359 5360 5361 5362 5363 5364 |
curPtr != NULL;
nextPtrPtr = &(curPtr->nextPtr), curPtr = curPtr->nextPtr) {
if (strcmp(argv[2], Tcl_GetChannelName(curPtr->chan)) == 0) {
*nextPtrPtr = curPtr->nextPtr;
curPtr->nextPtr = NULL;
chan = curPtr->chan;
| | | 5547 5548 5549 5550 5551 5552 5553 5554 5555 5556 5557 5558 5559 5560 5561 |
curPtr != NULL;
nextPtrPtr = &(curPtr->nextPtr), curPtr = curPtr->nextPtr) {
if (strcmp(argv[2], Tcl_GetChannelName(curPtr->chan)) == 0) {
*nextPtrPtr = curPtr->nextPtr;
curPtr->nextPtr = NULL;
chan = curPtr->chan;
Tcl_Free(curPtr);
break;
}
}
} else {
chan = Tcl_GetChannel(interp, argv[2], &mode);
}
if (chan == (Tcl_Channel) NULL) {
|
| ︙ | ︙ | |||
5428 5429 5430 5431 5432 5433 5434 | Tcl_RegisterChannel(NULL, chan); /* prevent closing */ Tcl_UnregisterChannel(interp, chan); Tcl_CutChannel(chan); /* Remember the channel in the pool of detached channels */ | | | 5617 5618 5619 5620 5621 5622 5623 5624 5625 5626 5627 5628 5629 5630 5631 |
Tcl_RegisterChannel(NULL, chan); /* prevent closing */
Tcl_UnregisterChannel(interp, chan);
Tcl_CutChannel(chan);
/* Remember the channel in the pool of detached channels */
det = Tcl_Alloc(sizeof(TestChannel));
det->chan = chan;
det->nextPtr = firstDetached;
firstDetached = det;
return TCL_OK;
}
|
| ︙ | ︙ | |||
5783 5784 5785 5786 5787 5788 5789 | * *---------------------------------------------------------------------- */ /* ARGSUSED */ static int TestChannelEventCmd( | | | 5972 5973 5974 5975 5976 5977 5978 5979 5980 5981 5982 5983 5984 5985 5986 |
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
static int
TestChannelEventCmd(
void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
Tcl_Obj *resultListPtr;
Channel *chanPtr;
ChannelState *statePtr; /* state info for channel */
|
| ︙ | ︙ | |||
5808 5809 5810 5811 5812 5813 5814 |
if (chanPtr == NULL) {
return TCL_ERROR;
}
statePtr = chanPtr->state;
cmd = argv[2];
len = strlen(cmd);
| | | | | | 5997 5998 5999 6000 6001 6002 6003 6004 6005 6006 6007 6008 6009 6010 6011 6012 6013 6014 6015 6016 6017 6018 6019 6020 6021 6022 6023 6024 6025 6026 6027 6028 6029 6030 6031 6032 6033 6034 6035 6036 6037 6038 6039 6040 6041 6042 6043 6044 6045 |
if (chanPtr == NULL) {
return TCL_ERROR;
}
statePtr = chanPtr->state;
cmd = argv[2];
len = strlen(cmd);
if ((cmd[0] == 'a') && (strncmp(cmd, "add", len) == 0)) {
if (argc != 5) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" channelName add eventSpec script\"", NULL);
return TCL_ERROR;
}
if (strcmp(argv[3], "readable") == 0) {
mask = TCL_READABLE;
} else if (strcmp(argv[3], "writable") == 0) {
mask = TCL_WRITABLE;
} else if (strcmp(argv[3], "none") == 0) {
mask = 0;
} else {
Tcl_AppendResult(interp, "bad event name \"", argv[3],
"\": must be readable, writable, or none", NULL);
return TCL_ERROR;
}
esPtr = Tcl_Alloc(sizeof(EventScriptRecord));
esPtr->nextPtr = statePtr->scriptRecordPtr;
statePtr->scriptRecordPtr = esPtr;
esPtr->chanPtr = chanPtr;
esPtr->interp = interp;
esPtr->mask = mask;
esPtr->scriptPtr = Tcl_NewStringObj(argv[4], -1);
Tcl_IncrRefCount(esPtr->scriptPtr);
Tcl_CreateChannelHandler((Tcl_Channel) chanPtr, mask,
TclChannelEventScriptInvoker, esPtr);
return TCL_OK;
}
if ((cmd[0] == 'd') && (strncmp(cmd, "delete", len) == 0)) {
if (argc != 4) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" channelName delete index\"", NULL);
return TCL_ERROR;
}
if (Tcl_GetInt(interp, argv[3], &index) == TCL_ERROR) {
return TCL_ERROR;
|
| ︙ | ︙ | |||
5881 5882 5883 5884 5885 5886 5887 |
}
if (prevEsPtr == NULL) {
Tcl_Panic("TestChannelEventCmd: damaged event script list");
}
prevEsPtr->nextPtr = esPtr->nextPtr;
}
Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr,
| | | | | 6070 6071 6072 6073 6074 6075 6076 6077 6078 6079 6080 6081 6082 6083 6084 6085 6086 6087 6088 6089 6090 6091 |
}
if (prevEsPtr == NULL) {
Tcl_Panic("TestChannelEventCmd: damaged event script list");
}
prevEsPtr->nextPtr = esPtr->nextPtr;
}
Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr,
TclChannelEventScriptInvoker, esPtr);
Tcl_DecrRefCount(esPtr->scriptPtr);
Tcl_Free(esPtr);
return TCL_OK;
}
if ((cmd[0] == 'l') && (strncmp(cmd, "list", len) == 0)) {
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" channelName list\"", NULL);
return TCL_ERROR;
}
resultListPtr = Tcl_GetObjResult(interp);
for (esPtr = statePtr->scriptRecordPtr;
|
| ︙ | ︙ | |||
5911 5912 5913 5914 5915 5916 5917 |
}
Tcl_ListObjAppendElement(interp, resultListPtr, esPtr->scriptPtr);
}
Tcl_SetObjResult(interp, resultListPtr);
return TCL_OK;
}
| | | | | | 6100 6101 6102 6103 6104 6105 6106 6107 6108 6109 6110 6111 6112 6113 6114 6115 6116 6117 6118 6119 6120 6121 6122 6123 6124 6125 6126 6127 6128 6129 6130 6131 6132 6133 |
}
Tcl_ListObjAppendElement(interp, resultListPtr, esPtr->scriptPtr);
}
Tcl_SetObjResult(interp, resultListPtr);
return TCL_OK;
}
if ((cmd[0] == 'r') && (strncmp(cmd, "removeall", len) == 0)) {
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" channelName removeall\"", NULL);
return TCL_ERROR;
}
for (esPtr = statePtr->scriptRecordPtr;
esPtr != NULL;
esPtr = nextEsPtr) {
nextEsPtr = esPtr->nextPtr;
Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr,
TclChannelEventScriptInvoker, esPtr);
Tcl_DecrRefCount(esPtr->scriptPtr);
Tcl_Free(esPtr);
}
statePtr->scriptRecordPtr = NULL;
return TCL_OK;
}
if ((cmd[0] == 's') && (strncmp(cmd, "set", len) == 0)) {
if (argc != 5) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" channelName delete index event\"", NULL);
return TCL_ERROR;
}
if (Tcl_GetInt(interp, argv[3], &index) == TCL_ERROR) {
return TCL_ERROR;
|
| ︙ | ︙ | |||
5968 5969 5970 5971 5972 5973 5974 |
} else {
Tcl_AppendResult(interp, "bad event name \"", argv[4],
"\": must be readable, writable, or none", NULL);
return TCL_ERROR;
}
esPtr->mask = mask;
Tcl_CreateChannelHandler((Tcl_Channel) chanPtr, mask,
| | | 6157 6158 6159 6160 6161 6162 6163 6164 6165 6166 6167 6168 6169 6170 6171 |
} else {
Tcl_AppendResult(interp, "bad event name \"", argv[4],
"\": must be readable, writable, or none", NULL);
return TCL_ERROR;
}
esPtr->mask = mask;
Tcl_CreateChannelHandler((Tcl_Channel) chanPtr, mask,
TclChannelEventScriptInvoker, esPtr);
return TCL_OK;
}
Tcl_AppendResult(interp, "bad command ", cmd, ", must be one of "
"add, delete, list, set, or removeall", NULL);
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
5996 5997 5998 5999 6000 6001 6002 | * *---------------------------------------------------------------------- */ /* ARGSUSED */ static int TestSocketCmd( | | | 6185 6186 6187 6188 6189 6190 6191 6192 6193 6194 6195 6196 6197 6198 6199 |
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
static int
TestSocketCmd(
void *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. */
size_t len; /* Length of subcommand string. */
|
| ︙ | ︙ | |||
6063 6064 6065 6066 6067 6068 6069 | * Sets interpreter result. * *---------------------------------------------------------------------- */ static int TestWrongNumArgsObjCmd( | | | 6252 6253 6254 6255 6256 6257 6258 6259 6260 6261 6262 6263 6264 6265 6266 |
* Sets interpreter result.
*
*----------------------------------------------------------------------
*/
static int
TestWrongNumArgsObjCmd(
void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int i, length;
const char *msg;
|
| ︙ | ︙ | |||
6119 6120 6121 6122 6123 6124 6125 | * Sets interpreter result. * *---------------------------------------------------------------------- */ static int TestGetIndexFromObjStructObjCmd( | | | 6308 6309 6310 6311 6312 6313 6314 6315 6316 6317 6318 6319 6320 6321 6322 |
* Sets interpreter result.
*
*----------------------------------------------------------------------
*/
static int
TestGetIndexFromObjStructObjCmd(
void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *const ary[] = {
"a", "b", "c", "d", "e", "f", NULL, NULL
};
|
| ︙ | ︙ | |||
6173 6174 6175 6176 6177 6178 6179 | * Inserts or removes a filesystem from Tcl's stack. * *---------------------------------------------------------------------- */ static int TestFilesystemObjCmd( | | | | | 6362 6363 6364 6365 6366 6367 6368 6369 6370 6371 6372 6373 6374 6375 6376 6377 6378 6379 6380 6381 6382 6383 6384 6385 6386 6387 6388 6389 6390 6391 6392 6393 6394 6395 6396 6397 6398 6399 6400 6401 6402 6403 6404 6405 |
* Inserts or removes a filesystem from Tcl's stack.
*
*----------------------------------------------------------------------
*/
static int
TestFilesystemObjCmd(
void *dummy,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
int res, boolVal;
const char *msg;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "boolean");
return TCL_ERROR;
}
if (Tcl_GetBooleanFromObj(interp, objv[1], &boolVal) != TCL_OK) {
return TCL_ERROR;
}
if (boolVal) {
res = Tcl_FSRegister(interp, &testReportingFilesystem);
msg = (res == TCL_OK) ? "registered" : "failed";
} else {
res = Tcl_FSUnregister(&testReportingFilesystem);
msg = (res == TCL_OK) ? "unregistered" : "failed";
}
Tcl_SetObjResult(interp, Tcl_NewStringObj(msg , -1));
return res;
}
static int
TestReportInFilesystem(
Tcl_Obj *pathPtr,
void **clientDataPtr)
{
static Tcl_Obj *lastPathPtr = NULL;
Tcl_Obj *newPathPtr;
if (pathPtr == lastPathPtr) {
/* Reject all files second time around */
return -1;
|
| ︙ | ︙ | |||
6224 6225 6226 6227 6228 6229 6230 |
if (Tcl_FSGetFileSystemForPath(newPathPtr) == NULL) {
/* Nothing claimed it. Therefore we don't either */
Tcl_DecrRefCount(newPathPtr);
lastPathPtr = NULL;
return -1;
}
lastPathPtr = NULL;
| | | | | 6413 6414 6415 6416 6417 6418 6419 6420 6421 6422 6423 6424 6425 6426 6427 6428 6429 6430 6431 6432 6433 6434 6435 6436 6437 6438 6439 6440 6441 6442 6443 6444 6445 6446 6447 6448 6449 6450 6451 6452 6453 6454 6455 6456 6457 |
if (Tcl_FSGetFileSystemForPath(newPathPtr) == NULL) {
/* Nothing claimed it. Therefore we don't either */
Tcl_DecrRefCount(newPathPtr);
lastPathPtr = NULL;
return -1;
}
lastPathPtr = NULL;
*clientDataPtr = newPathPtr;
return TCL_OK;
}
/*
* Simple helper function to extract the native vfs representation of a path
* object, or NULL if no such representation exists.
*/
static Tcl_Obj *
TestReportGetNativePath(
Tcl_Obj *pathPtr)
{
return (Tcl_Obj*) Tcl_FSGetInternalRep(pathPtr, &testReportingFilesystem);
}
static void
TestReportFreeInternalRep(
void *clientData)
{
Tcl_Obj *nativeRep = (Tcl_Obj *) clientData;
if (nativeRep != NULL) {
/* Free the path */
Tcl_DecrRefCount(nativeRep);
}
}
static ClientData
TestReportDupInternalRep(
void *clientData)
{
Tcl_Obj *original = (Tcl_Obj *) clientData;
Tcl_IncrRefCount(original);
return clientData;
}
|
| ︙ | ︙ | |||
6520 6521 6522 6523 6524 6525 6526 |
TestReport("normalizepath", pathPtr, NULL);
return nextCheckpoint;
}
static int
SimplePathInFilesystem(
Tcl_Obj *pathPtr,
| | | 6709 6710 6711 6712 6713 6714 6715 6716 6717 6718 6719 6720 6721 6722 6723 |
TestReport("normalizepath", pathPtr, NULL);
return nextCheckpoint;
}
static int
SimplePathInFilesystem(
Tcl_Obj *pathPtr,
void **clientDataPtr)
{
const char *str = Tcl_GetString(pathPtr);
if (strncmp(str, "simplefs:/", 10)) {
return -1;
}
return TCL_OK;
|
| ︙ | ︙ | |||
6549 6550 6551 6552 6553 6554 6555 | * Please do not consider this filesystem a model of how things are to be * done. It is quite the opposite! But, it does allow us to test some * important features. */ static int TestSimpleFilesystemObjCmd( | | | | 6738 6739 6740 6741 6742 6743 6744 6745 6746 6747 6748 6749 6750 6751 6752 6753 6754 6755 6756 6757 6758 6759 6760 6761 6762 6763 6764 6765 6766 6767 6768 |
* Please do not consider this filesystem a model of how things are to be
* done. It is quite the opposite! But, it does allow us to test some
* important features.
*/
static int
TestSimpleFilesystemObjCmd(
void *dummy,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
int res, boolVal;
const char *msg;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "boolean");
return TCL_ERROR;
}
if (Tcl_GetBooleanFromObj(interp, objv[1], &boolVal) != TCL_OK) {
return TCL_ERROR;
}
if (boolVal) {
res = Tcl_FSRegister(interp, &simpleFilesystem);
msg = (res == TCL_OK) ? "registered" : "failed";
} else {
res = Tcl_FSUnregister(&simpleFilesystem);
msg = (res == TCL_OK) ? "unregistered" : "failed";
}
Tcl_SetObjResult(interp, Tcl_NewStringObj(msg , -1));
return res;
|
| ︙ | ︙ | |||
6709 6710 6711 6712 6713 6714 6715 | /* * Used to check correct string-length determining in Tcl_NumUtfChars */ static int TestNumUtfCharsCmd( | | | | | 6898 6899 6900 6901 6902 6903 6904 6905 6906 6907 6908 6909 6910 6911 6912 6913 6914 6915 6916 6917 6918 6919 6920 6921 6922 6923 6924 6925 6926 6927 6928 6929 6930 6931 6932 6933 6934 6935 |
/*
* Used to check correct string-length determining in Tcl_NumUtfChars
*/
static int
TestNumUtfCharsCmd(
void *clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
if (objc > 1) {
int len = -1;
if (objc > 2) {
(void) Tcl_GetIntFromObj(interp, objv[2], &len);
}
len = Tcl_NumUtfChars(Tcl_GetString(objv[1]), len);
Tcl_SetObjResult(interp, Tcl_NewIntObj(len));
}
return TCL_OK;
}
/*
* Used to check correct operation of Tcl_UtfFindFirst
*/
static int
TestFindFirstCmd(
void *clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
if (objc > 1) {
int len = -1;
|
| ︙ | ︙ | |||
6754 6755 6756 6757 6758 6759 6760 | /* * Used to check correct operation of Tcl_UtfFindLast */ static int TestFindLastCmd( | | | 6943 6944 6945 6946 6947 6948 6949 6950 6951 6952 6953 6954 6955 6956 6957 |
/*
* Used to check correct operation of Tcl_UtfFindLast
*/
static int
TestFindLastCmd(
void *clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
if (objc > 1) {
int len = -1;
|
| ︙ | ︙ | |||
6796 6797 6798 6799 6800 6801 6802 | * None. * *---------------------------------------------------------------------- */ static int TestcpuidCmd( | | | 6985 6986 6987 6988 6989 6990 6991 6992 6993 6994 6995 6996 6997 6998 6999 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestcpuidCmd(
void *dummy,
Tcl_Interp* interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const * objv) /* Parameter vector */
{
int status, index, i;
int regs[4];
Tcl_Obj *regsObjs[4];
|
| ︙ | ︙ | |||
6819 6820 6821 6822 6823 6824 6825 |
status = TclWinCPUID(index, regs);
if (status != TCL_OK) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("operation not available", -1));
return status;
}
for (i=0 ; i<4 ; ++i) {
| | | | 7008 7009 7010 7011 7012 7013 7014 7015 7016 7017 7018 7019 7020 7021 7022 7023 7024 7025 7026 7027 7028 7029 7030 7031 7032 7033 7034 7035 |
status = TclWinCPUID(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]);
}
Tcl_SetObjResult(interp, Tcl_NewListObj(4, regsObjs));
return TCL_OK;
}
#endif
/*
* Used to do basic checks of the TCL_HASH_KEY_SYSTEM_HASH flag
*/
static int
TestHashSystemHashCmd(
void *clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
static const Tcl_HashKeyType hkType = {
TCL_HASH_KEY_TYPE_VERSION, TCL_HASH_KEY_SYSTEM_HASH,
NULL, NULL, NULL, NULL
|
| ︙ | ︙ | |||
6860 6861 6862 6863 6864 6865 6866 |
Tcl_DeleteHashTable(&hash);
return TCL_ERROR;
}
for (i=0 ; i<limit ; i++) {
hPtr = Tcl_CreateHashEntry(&hash, INT2PTR(i), &isNew);
if (!isNew) {
| | | | | 7049 7050 7051 7052 7053 7054 7055 7056 7057 7058 7059 7060 7061 7062 7063 7064 7065 7066 7067 7068 7069 7070 7071 7072 7073 7074 7075 7076 7077 7078 7079 7080 7081 7082 7083 7084 7085 7086 |
Tcl_DeleteHashTable(&hash);
return TCL_ERROR;
}
for (i=0 ; i<limit ; i++) {
hPtr = Tcl_CreateHashEntry(&hash, INT2PTR(i), &isNew);
if (!isNew) {
Tcl_SetObjResult(interp, Tcl_NewIntObj(i));
Tcl_AppendToObj(Tcl_GetObjResult(interp)," creation problem",-1);
Tcl_DeleteHashTable(&hash);
return TCL_ERROR;
}
Tcl_SetHashValue(hPtr, INT2PTR(i+42));
}
if (hash.numEntries != (size_t)limit) {
Tcl_AppendResult(interp, "unexpected maximal size", NULL);
Tcl_DeleteHashTable(&hash);
return TCL_ERROR;
}
for (i=0 ; i<limit ; i++) {
hPtr = Tcl_FindHashEntry(&hash, (char *) INT2PTR(i));
if (hPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_NewIntObj(i));
Tcl_AppendToObj(Tcl_GetObjResult(interp)," lookup problem",-1);
Tcl_DeleteHashTable(&hash);
return TCL_ERROR;
}
if (PTR2INT(Tcl_GetHashValue(hPtr)) != i+42) {
Tcl_SetObjResult(interp, Tcl_NewIntObj(i));
Tcl_AppendToObj(Tcl_GetObjResult(interp)," value problem",-1);
Tcl_DeleteHashTable(&hash);
return TCL_ERROR;
}
Tcl_DeleteHashEntry(hPtr);
}
|
| ︙ | ︙ | |||
6908 6909 6910 6911 6912 6913 6914 | /* * Used for testing Tcl_GetInt which is no longer used directly by the * core very much. */ static int TestgetintCmd( | | | > > > > > > > > > > > > > > > > > > | | | | | | | | | | | | | 7097 7098 7099 7100 7101 7102 7103 7104 7105 7106 7107 7108 7109 7110 7111 7112 7113 7114 7115 7116 7117 7118 7119 7120 7121 7122 7123 7124 7125 7126 7127 7128 7129 7130 7131 7132 7133 7134 7135 7136 7137 7138 7139 7140 7141 7142 7143 7144 7145 7146 7147 7148 7149 7150 7151 7152 7153 7154 7155 7156 7157 7158 7159 7160 7161 7162 7163 7164 7165 7166 7167 7168 7169 7170 7171 7172 7173 7174 7175 7176 7177 7178 7179 7180 7181 7182 7183 7184 7185 7186 7187 7188 7189 7190 7191 7192 7193 7194 7195 7196 7197 7198 7199 7200 7201 7202 7203 7204 7205 7206 7207 7208 7209 7210 7211 7212 7213 7214 7215 7216 7217 7218 7219 7220 7221 7222 7223 7224 7225 7226 7227 |
/*
* Used for testing Tcl_GetInt which is no longer used directly by the
* core very much.
*/
static int
TestgetintCmd(
void *dummy,
Tcl_Interp *interp,
int argc,
const char **argv)
{
if (argc < 2) {
Tcl_AppendResult(interp, "wrong # args", NULL);
return TCL_ERROR;
} else {
int val, i, total=0;
for (i=1 ; i<argc ; i++) {
if (Tcl_GetInt(interp, argv[i], &val) != TCL_OK) {
return TCL_ERROR;
}
total += val;
}
Tcl_SetObjResult(interp, Tcl_NewIntObj(total));
return TCL_OK;
}
}
/*
* Used for determining sizeof(long) at script level.
*/
static int
TestlongsizeCmd(
void *dummy,
Tcl_Interp *interp,
int argc,
const char **argv)
{
if (argc != 1) {
Tcl_AppendResult(interp, "wrong # args", NULL);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewIntObj(sizeof(long)));
return TCL_OK;
}
static int
NREUnwind_callback(
void *data[],
Tcl_Interp *interp,
int result)
{
int none;
if (data[0] == INT2PTR(-1)) {
Tcl_NRAddCallback(interp, NREUnwind_callback, &none, INT2PTR(-1),
INT2PTR(-1), NULL);
} else if (data[1] == INT2PTR(-1)) {
Tcl_NRAddCallback(interp, NREUnwind_callback, data[0], &none,
INT2PTR(-1), NULL);
} else if (data[2] == INT2PTR(-1)) {
Tcl_NRAddCallback(interp, NREUnwind_callback, data[0], data[1],
&none, NULL);
} else {
Tcl_Obj *idata[3];
idata[0] = Tcl_NewIntObj(((char *) data[1] - (char *) data[0]));
idata[1] = Tcl_NewIntObj(((char *) data[2] - (char *) data[0]));
idata[2] = Tcl_NewIntObj(((char *) &none - (char *) data[0]));
Tcl_SetObjResult(interp, Tcl_NewListObj(3, idata));
}
return TCL_OK;
}
static int
TestNREUnwind(
void *clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
/*
* Insure that callbacks effectively run at the proper level during the
* unwinding of the NRE stack.
*/
Tcl_NRAddCallback(interp, NREUnwind_callback, INT2PTR(-1), INT2PTR(-1),
INT2PTR(-1), NULL);
return TCL_OK;
}
static int
TestNRELevels(
void *clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Interp *iPtr = (Interp *) interp;
static ptrdiff_t *refDepth = NULL;
ptrdiff_t depth;
Tcl_Obj *levels[6];
int i = 0;
NRE_callback *cbPtr = iPtr->execEnvPtr->callbackPtr;
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;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
7033 7034 7035 7036 7037 7038 7039 | * None. * *---------------------------------------------------------------------- */ static int TestconcatobjCmd( | | < | < < < | < < | 7240 7241 7242 7243 7244 7245 7246 7247 7248 7249 7250 7251 7252 7253 7254 7255 7256 7257 7258 7259 7260 7261 7262 7263 7264 7265 7266 7267 7268 7269 7270 7271 7272 7273 7274 7275 7276 7277 7278 7279 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestconcatobjCmd(
void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
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];
/*
* Set the start of the error message as obj result; it will be cleared at
* the end if no errors were found.
*/
Tcl_SetObjResult(interp,
Tcl_NewStringObj("Tcl_ConcatObj is unsafe:", -1));
emptyPtr = Tcl_NewObj();
list1Ptr = Tcl_NewStringObj("foo bar sum", -1);
Tcl_ListObjLength(NULL, list1Ptr, &len);
Tcl_InvalidateStringRep(list1Ptr);
list2Ptr = Tcl_NewStringObj("eeny meeny", -1);
Tcl_ListObjLength(NULL, list2Ptr, &len);
Tcl_InvalidateStringRep(list2Ptr);
/*
* Verify that concat'ing a list obj with one or more empty strings does
* return a fresh Tcl_Obj (see also [Bug 2055782]).
*/
tmpPtr = Tcl_DuplicateObj(list1Ptr);
|
| ︙ | ︙ | |||
7336 7337 7338 7339 7340 7341 7342 | * None. * *---------------------------------------------------------------------- */ static int TestparseargsCmd( | | | | | | 7537 7538 7539 7540 7541 7542 7543 7544 7545 7546 7547 7548 7549 7550 7551 7552 7553 7554 7555 7556 7557 7558 7559 7560 7561 7562 7563 7564 7565 7566 7567 7568 7569 7570 7571 7572 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestparseargsCmd(
void *dummy, /* Not used. */
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.
*/
|
| ︙ | ︙ | |||
7484 7485 7486 7487 7488 7489 7490 |
} MyResolvedVarInfo;
static inline void
HashVarFree(
Tcl_Var var)
{
if (VarHashRefCount(var) < 2) {
| | | | | 7685 7686 7687 7688 7689 7690 7691 7692 7693 7694 7695 7696 7697 7698 7699 7700 7701 7702 7703 7704 7705 7706 7707 7708 7709 7710 7711 7712 7713 7714 7715 7716 7717 7718 7719 |
} 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;
|
| ︙ | ︙ | |||
7543 7544 7545 7546 7547 7548 7549 |
var = (Tcl_Var) TclVarHashGetValue(hPtr);
} else {
var = NULL;
}
resVarInfo->var = var;
/*
| | | | | 7744 7745 7746 7747 7748 7749 7750 7751 7752 7753 7754 7755 7756 7757 7758 7759 7760 7761 7762 7763 7764 7765 7766 7767 7768 7769 7770 7771 7772 7773 7774 7775 7776 7777 7778 7779 7780 7781 7782 7783 7784 7785 7786 7787 7788 7789 7790 |
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_Interp *interp,
const char *name,
int length,
Tcl_Namespace *context,
Tcl_ResolvedVarInfo **rPtr)
{
if (*name == 'T') {
MyResolvedVarInfo *resVarInfo = 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(
void *clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
static const char *const table[] = {
"down", "up", NULL
};
|
| ︙ | ︙ | |||
7597 7598 7599 7600 7601 7602 7603 |
if (objc == 3) {
interp = Tcl_GetSlave(interp, Tcl_GetString(objv[2]));
if (interp == NULL) {
Tcl_AppendResult(interp, "provided interpreter not found", NULL);
return TCL_ERROR;
}
}
| | | | 7798 7799 7800 7801 7802 7803 7804 7805 7806 7807 7808 7809 7810 7811 7812 7813 |
if (objc == 3) {
interp = Tcl_GetSlave(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;
|
| ︙ | ︙ |
Changes to generic/tclTestObj.c.
| ︙ | ︙ | |||
55 56 57 58 59 60 61 |
{
register 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);
| | | 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 |
{
register 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);
|
| ︙ | ︙ | |||
95 96 97 98 99 100 101 |
/*
* 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;
| | | 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 |
/*
* 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);
for (i = 0; i < NUMBER_OF_OBJECT_VARS; i++) {
varPtr[i] = NULL;
}
|
| ︙ | ︙ | |||
163 164 165 166 167 168 169 |
mp_int bignumValue, newValue;
Tcl_Obj **varPtr;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
return TCL_ERROR;
}
| | | | 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 |
mp_int bignumValue, newValue;
Tcl_Obj **varPtr;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], subcmds, "option", 0,
&index) != TCL_OK) {
return TCL_ERROR;
}
string = Tcl_GetString(objv[2]);
if (GetVariableIndex(interp, string, &varIndex) != TCL_OK) {
return TCL_ERROR;
}
varPtr = GetVarPtr(interp);
|
| ︙ | ︙ | |||
286 287 288 289 290 291 292 |
return TCL_ERROR;
}
if (Tcl_GetBignumFromObj(interp, varPtr[varIndex],
&bignumValue) != TCL_OK) {
return TCL_ERROR;
}
if (!Tcl_IsShared(varPtr[varIndex])) {
| | | | 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 |
return TCL_ERROR;
}
if (Tcl_GetBignumFromObj(interp, varPtr[varIndex],
&bignumValue) != TCL_OK) {
return TCL_ERROR;
}
if (!Tcl_IsShared(varPtr[varIndex])) {
Tcl_SetIntObj(varPtr[varIndex], !mp_isodd(&bignumValue));
} else {
SetVarToObj(varPtr, varIndex, Tcl_NewIntObj(!mp_isodd(&bignumValue)));
}
mp_clear(&bignumValue);
break;
case BIGNUM_RADIXSIZE:
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "varIndex");
|
| ︙ | ︙ | |||
381 382 383 384 385 386 387 |
* has ref count 1 (i.e. the object is unshared) we can modify that
* object directly. Otherwise, if RC>1 (i.e. the object is shared),
* 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])) {
| | | | 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 |
* has ref count 1 (i.e. the object is unshared) we can modify that
* object directly. Otherwise, if RC>1 (i.e. the object is shared),
* 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);
} else {
SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(boolValue != 0));
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else if (strcmp(subCmd, "get") == 0) {
if (objc != 3) {
goto wrongNumArgs;
}
if (CheckIfVarUnset(interp, varPtr,varIndex)) {
|
| ︙ | ︙ | |||
406 407 408 409 410 411 412 |
return TCL_ERROR;
}
if (Tcl_GetBooleanFromObj(interp, varPtr[varIndex],
&boolValue) != TCL_OK) {
return TCL_ERROR;
}
if (!Tcl_IsShared(varPtr[varIndex])) {
| | | | 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 |
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);
} else {
SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(boolValue == 0));
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"bad option \"", Tcl_GetString(objv[1]),
"\": must be set, get, or not", NULL);
return TCL_ERROR;
|
| ︙ | ︙ | |||
572 573 574 575 576 577 578 |
const char **argv;
static const char *const tablePtr[] = {"a", "b", "check", NULL};
/*
* Keep this structure declaration in sync with tclIndexObj.c
*/
struct IndexRep {
void *tablePtr; /* Pointer to the table of strings. */
| | | | < | | | | | < | > | | | 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 |
const char **argv;
static const char *const tablePtr[] = {"a", "b", "check", NULL};
/*
* Keep this structure declaration in sync with tclIndexObj.c
*/
struct IndexRep {
void *tablePtr; /* Pointer to the table of strings. */
size_t offset; /* Offset between table entries. */
size_t index; /* Selected index into table. */
};
struct IndexRep *indexRep;
if ((objc == 3) && (strcmp(Tcl_GetString(objv[1]),
"check") == 0)) {
/*
* This code checks to be sure that the results of Tcl_GetIndexFromObj
* are properly cached in the object and returned on subsequent
* lookups.
*/
if (Tcl_GetIntFromObj(interp, objv[2], &index2) != TCL_OK) {
return TCL_ERROR;
}
Tcl_GetIndexFromObj(NULL, objv[1], tablePtr, "token", 0, &index);
indexRep = objv[1]->internalRep.twoPtrValue.ptr1;
indexRep->index = index2;
result = Tcl_GetIndexFromObj(NULL, objv[1],
tablePtr, "token", 0, &index);
if (result == TCL_OK) {
Tcl_SetIntObj(Tcl_GetObjResult(interp), index);
}
return result;
}
if (objc < 5) {
Tcl_AppendToObj(Tcl_GetObjResult(interp), "wrong # args", -1);
return TCL_ERROR;
}
if (Tcl_GetBooleanFromObj(interp, objv[1], &setError) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetBooleanFromObj(interp, objv[2], &allowAbbrev) != TCL_OK) {
return TCL_ERROR;
}
argv = Tcl_Alloc((objc-3) * sizeof(char *));
for (i = 4; i < objc; i++) {
argv[i-4] = Tcl_GetString(objv[i]);
}
argv[objc-4] = NULL;
result = Tcl_GetIndexFromObj((setError? interp : NULL), objv[3],
argv, "token", INDEX_TEMP_TABLE|(allowAbbrev? 0 : TCL_EXACT),
&index);
Tcl_Free((void *)argv);
if (result == TCL_OK) {
Tcl_SetIntObj(Tcl_GetObjResult(interp), index);
}
return result;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
655 656 657 658 659 660 661 |
TestintobjCmd(
ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int intValue, varIndex, i;
| | | 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 |
TestintobjCmd(
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;
if (objc < 3) {
wrongNumArgs:
Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?");
return TCL_ERROR;
|
| ︙ | ︙ | |||
691 692 693 694 695 696 697 |
* has ref count 1 (i.e. the object is unshared) we can modify that
* object directly. Otherwise, if RC>1 (i.e. the object is shared), 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])) {
| | | | | | | | | | | | | | | | 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 |
* has ref count 1 (i.e. the object is unshared) we can modify that
* object directly. Otherwise, if RC>1 (i.e. the object is shared), 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_SetIntObj(varPtr[varIndex], intValue);
} else {
SetVarToObj(varPtr, varIndex, Tcl_NewIntObj(intValue));
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else if (strcmp(subCmd, "set2") == 0) { /* doesn't set result */
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_SetIntObj(varPtr[varIndex], intValue);
} else {
SetVarToObj(varPtr, varIndex, Tcl_NewIntObj(intValue));
}
} else if (strcmp(subCmd, "setint") == 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);
} else {
SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(intValue));
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else if (strcmp(subCmd, "setmax") == 0) {
Tcl_WideInt maxWide = WIDE_MAX;
if (objc != 3) {
goto wrongNumArgs;
}
if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
Tcl_SetWideIntObj(varPtr[varIndex], maxWide);
} else {
SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(maxWide));
}
} else if (strcmp(subCmd, "ismax") == 0) {
if (objc != 3) {
goto wrongNumArgs;
}
if (CheckIfVarUnset(interp, varPtr,varIndex)) {
return TCL_ERROR;
}
if (Tcl_GetWideIntFromObj(interp, varPtr[varIndex], &wideValue) != TCL_OK) {
return TCL_ERROR;
}
Tcl_AppendToObj(Tcl_GetObjResult(interp),
((wideValue == WIDE_MAX)? "1" : "0"), -1);
} else if (strcmp(subCmd, "get") == 0) {
if (objc != 3) {
goto wrongNumArgs;
}
if (CheckIfVarUnset(interp, varPtr,varIndex)) {
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
779 780 781 782 783 784 785 |
if (objc != 3) {
goto wrongNumArgs;
}
#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])) {
| | | | | | | | 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 |
if (objc != 3) {
goto wrongNumArgs;
}
#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);
} else {
SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(LONG_MAX));
}
if (Tcl_GetIntFromObj(interp, varPtr[varIndex], &i) != TCL_OK) {
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp), "1", -1);
return TCL_OK;
}
Tcl_AppendToObj(Tcl_GetObjResult(interp), "0", -1);
#endif
} else if (strcmp(subCmd, "mult10") == 0) {
if (objc != 3) {
goto wrongNumArgs;
}
if (CheckIfVarUnset(interp, varPtr,varIndex)) {
return TCL_ERROR;
}
if (Tcl_GetIntFromObj(interp, varPtr[varIndex],
&intValue) != TCL_OK) {
return TCL_ERROR;
}
if (!Tcl_IsShared(varPtr[varIndex])) {
Tcl_SetIntObj(varPtr[varIndex], intValue * 10);
} else {
SetVarToObj(varPtr, 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)) {
return TCL_ERROR;
}
if (Tcl_GetIntFromObj(interp, varPtr[varIndex],
&intValue) != TCL_OK) {
return TCL_ERROR;
}
if (!Tcl_IsShared(varPtr[varIndex])) {
Tcl_SetIntObj(varPtr[varIndex], intValue / 10);
} else {
SetVarToObj(varPtr, varIndex, Tcl_NewIntObj(intValue / 10));
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"bad option \"", Tcl_GetString(objv[1]),
"\": must be set, get, get2, mult10, or div10", NULL);
return TCL_ERROR;
|
| ︙ | ︙ | |||
886 887 888 889 890 891 892 |
return TCL_ERROR;
}
varPtr = GetVarPtr(interp);
index = Tcl_GetString(objv[2]);
if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
return TCL_ERROR;
}
| | | | 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 |
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",
0, &cmdIndex) != TCL_OK) {
return TCL_ERROR;
}
switch(cmdIndex) {
case LISTOBJ_SET:
if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
Tcl_SetListObj(varPtr[varIndex], objc-3, objv+3);
} else {
|
| ︙ | ︙ | |||
990 991 992 993 994 995 996 |
SetVarToObj(varPtr, destIndex, varPtr[varIndex]);
Tcl_SetObjResult(interp, varPtr[destIndex]);
} else if (strcmp(subCmd, "bug3598580") == 0) {
Tcl_Obj *listObjPtr, *elemObjPtr;
if (objc != 2) {
goto wrongNumArgs;
}
| | | 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 |
SetVarToObj(varPtr, destIndex, varPtr[varIndex]);
Tcl_SetObjResult(interp, varPtr[destIndex]);
} else if (strcmp(subCmd, "bug3598580") == 0) {
Tcl_Obj *listObjPtr, *elemObjPtr;
if (objc != 2) {
goto wrongNumArgs;
}
elemObjPtr = Tcl_NewIntObj(123);
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;
|
| ︙ | ︙ | |||
1191 1192 1193 1194 1195 1196 1197 |
varPtr = GetVarPtr(interp);
index = Tcl_GetString(objv[2]);
if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
return TCL_ERROR;
}
| | | | 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 |
varPtr = GetVarPtr(interp);
index = Tcl_GetString(objv[2]);
if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0, &option)
!= TCL_OK) {
return TCL_ERROR;
}
switch (option) {
case 0: /* append */
if (objc != 5) {
goto wrongNumArgs;
}
|
| ︙ | ︙ | |||
1270 1271 1272 1273 1274 1275 1276 |
string = Tcl_GetString(varPtr[varIndex]);
Tcl_AppendToObj(Tcl_GetObjResult(interp), string, -1);
break;
case 4: /* length */
if (objc != 3) {
goto wrongNumArgs;
}
| | | | | 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 |
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);
break;
case 5: /* length2 */
if (objc != 3) {
goto wrongNumArgs;
}
if (varPtr[varIndex] != NULL) {
Tcl_ConvertToType(NULL, varPtr[varIndex],
Tcl_GetObjType("string"));
strPtr = varPtr[varIndex]->internalRep.twoPtrValue.ptr1;
length = (int) strPtr->allocated;
} else {
length = -1;
}
Tcl_SetIntObj(Tcl_GetObjResult(interp), length);
break;
case 6: /* set */
if (objc != 4) {
goto wrongNumArgs;
}
/*
|
| ︙ | ︙ | |||
1339 1340 1341 1342 1343 1344 1345 |
Tcl_ConvertToType(NULL, varPtr[varIndex],
Tcl_GetObjType("string"));
strPtr = varPtr[varIndex]->internalRep.twoPtrValue.ptr1;
length = strPtr->maxChars;
} else {
length = -1;
}
| | | | 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 |
Tcl_ConvertToType(NULL, varPtr[varIndex],
Tcl_GetObjType("string"));
strPtr = varPtr[varIndex]->internalRep.twoPtrValue.ptr1;
length = strPtr->maxChars;
} else {
length = -1;
}
Tcl_SetIntObj(Tcl_GetObjResult(interp), length);
break;
case 10: /* getunicode */
if (objc != 3) {
goto wrongNumArgs;
}
Tcl_GetUnicode(varPtr[varIndex]);
break;
case 11: /* appendself */
if (objc != 4) {
goto wrongNumArgs;
}
if (varPtr[varIndex] == NULL) {
SetVarToObj(varPtr, varIndex, Tcl_NewObj());
|
| ︙ | ︙ |
Changes to generic/tclTestProcBodyObj.c.
| ︙ | ︙ | |||
17 18 19 20 21 22 23 | #include "tclInt.h" /* * name and version of this package */ static const char packageName[] = "procbodytest"; | | > > > > > | 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 |
#include "tclInt.h"
/*
* name and version of this package
*/
static const char packageName[] = "procbodytest";
static const char packageVersion[] = "1.1";
/*
* 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 */
Tcl_ObjCmdProc *proc; /* command proc */
int exportIt; /* if 1, export the command */
} CmdTable;
/*
* Declarations for functions defined in this file.
*/
static int ProcBodyTestProcObjCmd(ClientData dummy,
Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
static int ProcBodyTestCheckObjCmd(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 *namespace, const CmdTable *cmdTablePtr);
/*
* List of commands to create when the package is loaded; must go after the
* declarations of the enable command procedure.
*/
static const CmdTable commands[] = {
{ procCommand, ProcBodyTestProcObjCmd, 1 },
{ checkCommand, ProcBodyTestCheckObjCmd, 1 },
{ 0, 0, 0 }
};
static const CmdTable safeCommands[] = {
{ procCommand, ProcBodyTestProcObjCmd, 1 },
{ checkCommand, ProcBodyTestCheckObjCmd, 1 },
{ 0, 0, 0 }
};
/*
*----------------------------------------------------------------------
*
* Procbodytest_Init --
|
| ︙ | ︙ | |||
295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 |
myobjv[4] = NULL;
result = Tcl_ProcObjCmd(NULL, interp, objc, myobjv);
Tcl_DecrRefCount(bodyObjPtr);
return result;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 |
myobjv[4] = NULL;
result = Tcl_ProcObjCmd(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(
ClientData dummy, /* context; not used */
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:
*/
|
Changes to generic/tclThread.c.
| ︙ | ︙ | |||
36 37 38 39 40 41 42 | * Prototypes of functions used only in this file. */ static void ForgetSyncObject(void *objPtr, SyncObjRecord *recPtr); static void RememberSyncObject(void *objPtr, SyncObjRecord *recPtr); | < < < < < < < < < < < < < < < | 36 37 38 39 40 41 42 43 44 45 46 47 48 49 | * Prototypes of functions used only in this file. */ static void ForgetSyncObject(void *objPtr, SyncObjRecord *recPtr); static void RememberSyncObject(void *objPtr, SyncObjRecord *recPtr); /* *---------------------------------------------------------------------- * * Tcl_GetThreadData -- * * This function allocates and initializes a chunk of thread local * storage. |
| ︙ | ︙ | |||
72 73 74 75 76 77 78 |
*
*----------------------------------------------------------------------
*/
void *
Tcl_GetThreadData(
Tcl_ThreadDataKey *keyPtr, /* Identifier for the data chunk */
| | | | | | | | 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 |
*
*----------------------------------------------------------------------
*/
void *
Tcl_GetThreadData(
Tcl_ThreadDataKey *keyPtr, /* Identifier for the data chunk */
size_t size) /* Size of storage block */
{
void *result;
#if TCL_THREADS
/*
* Initialize the key for this thread.
*/
result = TclThreadStorageKeyGet(keyPtr);
if (result == NULL) {
result = Tcl_Alloc(size);
memset(result, 0, size);
TclThreadStorageKeySet(keyPtr, result);
}
#else /* TCL_THREADS */
if (*keyPtr == NULL) {
result = Tcl_Alloc(size);
memset(result, 0, size);
*keyPtr = result;
RememberSyncObject(keyPtr, &keyRecord);
} else {
result = *keyPtr;
}
#endif /* TCL_THREADS */
return result;
|
| ︙ | ︙ | |||
122 123 124 125 126 127 128 |
*/
void *
TclThreadDataKeyGet(
Tcl_ThreadDataKey *keyPtr) /* Identifier for the data chunk. */
{
| | | 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 |
*/
void *
TclThreadDataKeyGet(
Tcl_ThreadDataKey *keyPtr) /* Identifier for the data chunk. */
{
#if TCL_THREADS
return TclThreadStorageKeyGet(keyPtr);
#else /* TCL_THREADS */
return *keyPtr;
#endif /* TCL_THREADS */
}
/*
|
| ︙ | ︙ | |||
175 176 177 178 179 180 181 |
/*
* Grow the list of pointers if necessary, copying only non-NULL
* pointers to the new list.
*/
if (recPtr->num >= recPtr->max) {
recPtr->max += 8;
| | | | 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 |
/*
* Grow the list of pointers if necessary, copying only non-NULL
* pointers to the new list.
*/
if (recPtr->num >= recPtr->max) {
recPtr->max += 8;
newList = Tcl_Alloc(recPtr->max * sizeof(void *));
for (i=0,j=0 ; i<recPtr->num ; i++) {
if (recPtr->list[i] != NULL) {
newList[j++] = recPtr->list[i];
}
}
if (recPtr->list != NULL) {
Tcl_Free(recPtr->list);
}
recPtr->list = newList;
recPtr->num = j;
}
recPtr->list[recPtr->num] = objPtr;
recPtr->num++;
|
| ︙ | ︙ | |||
265 266 267 268 269 270 271 272 273 274 275 |
*
* Side effects:
* Remove the mutex from the list.
*
*----------------------------------------------------------------------
*/
void
Tcl_MutexFinalize(
Tcl_Mutex *mutexPtr)
{
| > | | 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 |
*
* Side effects:
* Remove the mutex from the list.
*
*----------------------------------------------------------------------
*/
#undef Tcl_MutexFinalize
void
Tcl_MutexFinalize(
Tcl_Mutex *mutexPtr)
{
#if TCL_THREADS
TclpFinalizeMutex(mutexPtr);
#endif
TclpMasterLock();
ForgetSyncObject(mutexPtr, &mutexRecord);
TclpMasterUnlock();
}
|
| ︙ | ︙ | |||
318 319 320 321 322 323 324 325 326 327 328 |
*
* Side effects:
* Remove the condition variable from the list.
*
*----------------------------------------------------------------------
*/
void
Tcl_ConditionFinalize(
Tcl_Condition *condPtr)
{
| > | | 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 |
*
* Side effects:
* Remove the condition variable from the list.
*
*----------------------------------------------------------------------
*/
#undef Tcl_ConditionFinalize
void
Tcl_ConditionFinalize(
Tcl_Condition *condPtr)
{
#if TCL_THREADS
TclpFinalizeCondition(condPtr);
#endif
TclpMasterLock();
ForgetSyncObject(condPtr, &condRecord);
TclpMasterUnlock();
}
|
| ︙ | ︙ | |||
352 353 354 355 356 357 358 |
*----------------------------------------------------------------------
*/
void
TclFinalizeThreadData(int quick)
{
TclFinalizeThreadDataThread();
| | | 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 |
*----------------------------------------------------------------------
*/
void
TclFinalizeThreadData(int quick)
{
TclFinalizeThreadDataThread();
#if TCL_THREADS && defined(USE_THREAD_ALLOC)
if (!quick) {
/*
* Quick exit principle makes it useless to terminate allocators
*/
TclFinalizeThreadAllocThread();
}
#endif
|
| ︙ | ︙ | |||
385 386 387 388 389 390 391 |
void
TclFinalizeSynchronization(void)
{
int i;
void *blockPtr;
Tcl_ThreadDataKey *keyPtr;
| | | | | | | | 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 |
void
TclFinalizeSynchronization(void)
{
int i;
void *blockPtr;
Tcl_ThreadDataKey *keyPtr;
#if TCL_THREADS
Tcl_Mutex *mutexPtr;
Tcl_Condition *condPtr;
TclpMasterLock();
#endif
/*
* If we're running unthreaded, the TSD blocks are simply stored inside
* their thread data keys. Free them here.
*/
if (keyRecord.list != NULL) {
for (i=0 ; i<keyRecord.num ; i++) {
keyPtr = (Tcl_ThreadDataKey *) keyRecord.list[i];
blockPtr = *keyPtr;
Tcl_Free(blockPtr);
}
Tcl_Free(keyRecord.list);
keyRecord.list = NULL;
}
keyRecord.max = 0;
keyRecord.num = 0;
#if TCL_THREADS
/*
* Call thread storage master cleanup.
*/
TclFinalizeThreadStorage();
for (i=0 ; i<mutexRecord.num ; i++) {
mutexPtr = (Tcl_Mutex *)mutexRecord.list[i];
if (mutexPtr != NULL) {
TclpFinalizeMutex(mutexPtr);
}
}
if (mutexRecord.list != NULL) {
Tcl_Free(mutexRecord.list);
mutexRecord.list = NULL;
}
mutexRecord.max = 0;
mutexRecord.num = 0;
for (i=0 ; i<condRecord.num ; i++) {
condPtr = (Tcl_Condition *) condRecord.list[i];
if (condPtr != NULL) {
TclpFinalizeCondition(condPtr);
}
}
if (condRecord.list != NULL) {
Tcl_Free(condRecord.list);
condRecord.list = NULL;
}
condRecord.max = 0;
condRecord.num = 0;
TclpMasterUnlock();
#endif /* TCL_THREADS */
|
| ︙ | ︙ | |||
469 470 471 472 473 474 475 |
*/
void
Tcl_ExitThread(
int status)
{
Tcl_FinalizeThread();
| < < | | 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 |
*/
void
Tcl_ExitThread(
int status)
{
Tcl_FinalizeThread();
TclpThreadExit(status);
}
#if !TCL_THREADS
/*
*----------------------------------------------------------------------
*
* Tcl_ConditionWait, et al. --
*
* These noop functions are provided so the stub table does not have to
|
| ︙ | ︙ |
Changes to generic/tclThreadAlloc.c.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 | * Portions created by AOL are Copyright (C) 1999 America Online, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" | | | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 | * Portions created by AOL are Copyright (C) 1999 America Online, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #if TCL_THREADS && defined(USE_THREAD_ALLOC) /* * If range checking is enabled, an additional byte will be allocated to store * the magic number at the end of the requested memory. */ #ifndef RCHECK |
| ︙ | ︙ | |||
81 82 83 84 85 86 87 |
* The following structure defines a bucket of blocks with various accounting
* and statistics information.
*/
typedef struct {
Block *firstPtr; /* First block available */
Block *lastPtr; /* End of block list */
| | | | | | | | 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 |
* The following structure defines a bucket of blocks with various accounting
* and statistics information.
*/
typedef struct {
Block *firstPtr; /* First block available */
Block *lastPtr; /* End of block list */
size_t numFree; /* Number of blocks available */
/* All fields below for accounting only */
size_t numRemoves; /* Number of removes from bucket */
size_t numInserts; /* Number of inserts into bucket */
size_t numWaits; /* Number of waits to acquire a lock */
size_t numLocks; /* Number of locks acquired */
size_t totalAssigned; /* Total space assigned to bucket */
} Bucket;
/*
* The following structure defines a cache of buckets and objs, of which there
* will be (at most) one per thread. Any changes need to be reflected in the
* struct AllocCache defined in tclInt.h, possibly also in the initialisation
* code in Tcl_CreateInterp().
|
| ︙ | ︙ | |||
116 117 118 119 120 121 122 |
/*
* The following array specifies various per-bucket limits and locks. The
* values are statically initialized to avoid calculating them repeatedly.
*/
static struct {
size_t blockSize; /* Bucket blocksize. */
| | | | 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 |
/*
* The following array specifies various per-bucket limits and locks. The
* values are statically initialized to avoid calculating them repeatedly.
*/
static struct {
size_t blockSize; /* Bucket blocksize. */
size_t maxBlocks; /* Max blocks before move to share. */
size_t numMove; /* Num blocks to move to share. */
Tcl_Mutex *lockPtr; /* Share bucket lock. */
} bucketInfo[NBUCKETS];
/*
* Static functions defined in this file.
*/
|
| ︙ | ︙ | |||
295 296 297 298 299 300 301 | * * Side effects: * May allocate more blocks for a bucket. * *---------------------------------------------------------------------- */ | | | < < < < < < < < < < < < < | 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 |
*
* Side effects:
* May allocate more blocks for a bucket.
*
*----------------------------------------------------------------------
*/
void *
TclpAlloc(
size_t reqSize)
{
Cache *cachePtr;
Block *blockPtr;
register int bucket;
size_t size;
GETCACHE(cachePtr);
/*
* Increment the requested size to include room for the Block structure.
* Call TclpSysAlloc() directly if the required amount is greater than the
* largest block, otherwise pop the smallest block large enough,
* allocating more blocks if necessary.
|
| ︙ | ︙ | |||
374 375 376 377 378 379 380 | * May move blocks to shared cache. * *---------------------------------------------------------------------- */ void TclpFree( | | | 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 |
* May move blocks to shared cache.
*
*----------------------------------------------------------------------
*/
void
TclpFree(
void *ptr)
{
Cache *cachePtr;
Block *blockPtr;
int bucket;
if (ptr == NULL) {
return;
|
| ︙ | ︙ | |||
431 432 433 434 435 436 437 | * * Side effects: * Previous memory, if any, may be freed. * *---------------------------------------------------------------------- */ | | | | < < < < < < < < < < < < < | 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 |
*
* Side effects:
* Previous memory, if any, may be freed.
*
*----------------------------------------------------------------------
*/
void *
TclpRealloc(
void *ptr,
size_t reqSize)
{
Cache *cachePtr;
Block *blockPtr;
void *newPtr;
size_t size, min;
int bucket;
if (ptr == NULL) {
return TclpAlloc(reqSize);
}
GETCACHE(cachePtr);
/*
* If the block is not a system block and fits in place, simply return the
* existing pointer. Otherwise, if the block is a system block and the new
* size would also require a system block, call TclpSysRealloc() directly.
*/
|
| ︙ | ︙ | |||
667 668 669 670 671 672 673 |
if (cachePtr == sharedPtr) {
Tcl_DStringAppendElement(dsPtr, "shared");
} else {
sprintf(buf, "thread%p", cachePtr->owner);
Tcl_DStringAppendElement(dsPtr, buf);
}
for (n = 0; n < NBUCKETS; ++n) {
| | | | 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 |
if (cachePtr == sharedPtr) {
Tcl_DStringAppendElement(dsPtr, "shared");
} else {
sprintf(buf, "thread%p", cachePtr->owner);
Tcl_DStringAppendElement(dsPtr, buf);
}
for (n = 0; n < NBUCKETS; ++n) {
sprintf(buf, "%" 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,
cachePtr->buckets[n].numFree,
cachePtr->buckets[n].numRemoves,
cachePtr->buckets[n].numInserts,
cachePtr->buckets[n].totalAssigned,
cachePtr->buckets[n].numLocks,
cachePtr->buckets[n].numWaits);
Tcl_DStringAppendElement(dsPtr, buf);
|
| ︙ | ︙ | |||
957 958 959 960 961 962 963 |
static int
GetBlocks(
Cache *cachePtr,
int bucket)
{
register Block *blockPtr;
| | | 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 |
static int
GetBlocks(
Cache *cachePtr,
int bucket)
{
register Block *blockPtr;
register size_t n;
/*
* First, atttempt to move blocks from the shared cache. Note the
* potentially dirty read of numFree before acquiring the lock which is a
* slight performance enhancement. The value is verified after the lock is
* actually acquired.
*/
|
| ︙ | ︙ | |||
1012 1013 1014 1015 1016 1017 1018 | * 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; /* lint */ | | | 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 |
* 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; /* lint */
while (--n > (size_t)bucket) {
if (cachePtr->buckets[n].numFree > 0) {
size = bucketInfo[n].blockSize;
blockPtr = cachePtr->buckets[n].firstPtr;
cachePtr->buckets[n].firstPtr = blockPtr->nextBlock;
cachePtr->buckets[n].numFree--;
break;
}
|
| ︙ | ︙ | |||
1078 1079 1080 1081 1082 1083 1084 |
{
unsigned int i;
listLockPtr = TclpNewAllocMutex();
objLockPtr = TclpNewAllocMutex();
for (i = 0; i < NBUCKETS; ++i) {
bucketInfo[i].blockSize = MINALLOC << i;
| | | 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 |
{
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();
}
|
| ︙ | ︙ |
Changes to generic/tclThreadJoin.c.
| ︙ | ︙ | |||
197 198 199 200 201 202 203 |
* the structure and return.
*/
*result = threadPtr->result;
Tcl_ConditionFinalize(&threadPtr->cond);
Tcl_MutexFinalize(&threadPtr->threadMutex);
| | | 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 |
* the structure and return.
*/
*result = threadPtr->result;
Tcl_ConditionFinalize(&threadPtr->cond);
Tcl_MutexFinalize(&threadPtr->threadMutex);
Tcl_Free(threadPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
226 227 228 229 230 231 232 |
void
TclRememberJoinableThread(
Tcl_ThreadId id) /* The thread to remember as joinable */
{
JoinableThread *threadPtr;
| | | 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 |
void
TclRememberJoinableThread(
Tcl_ThreadId id) /* The thread to remember as joinable */
{
JoinableThread *threadPtr;
threadPtr = Tcl_Alloc(sizeof(JoinableThread));
threadPtr->id = id;
threadPtr->done = 0;
threadPtr->waitedUpon = 0;
threadPtr->threadMutex = (Tcl_Mutex) NULL;
threadPtr->cond = (Tcl_Condition) NULL;
Tcl_MutexLock(&joinMutex);
|
| ︙ | ︙ |
Changes to generic/tclThreadStorage.c.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 | * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" | | | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 | * * 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 <signal.h> /* * 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 |
| ︙ | ︙ | |||
113 114 115 116 117 118 119 |
for (i=0 ; i<tsdTablePtr->allocated ; i++) {
if (tsdTablePtr->tablePtr[i] != NULL) {
/*
* These values were allocated in Tcl_GetThreadData in tclThread.c
* and must now be deallocated or they will leak.
*/
| | | 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 |
for (i=0 ; i<tsdTablePtr->allocated ; i++) {
if (tsdTablePtr->tablePtr[i] != NULL) {
/*
* These values were allocated in Tcl_GetThreadData in tclThread.c
* and must now be deallocated or they will leak.
*/
Tcl_Free(tsdTablePtr->tablePtr[i]);
}
}
TclpSysFree(tsdTablePtr->tablePtr);
TclpSysFree(tsdTablePtr);
}
|
| ︙ | ︙ |
Changes to generic/tclThreadTest.c.
| ︙ | ︙ | |||
14 15 16 17 18 19 20 | */ #ifndef USE_TCL_STUBS # define USE_TCL_STUBS #endif #include "tclInt.h" | | | 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 | */ #ifndef USE_TCL_STUBS # define USE_TCL_STUBS #endif #include "tclInt.h" #if 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. * * The main interpreter is the one that will process any messages received by |
| ︙ | ︙ | |||
58 59 60 61 62 63 64 |
/*
* 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.
*/
typedef struct ThreadCtrl {
| | | 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 |
/*
* 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.
*/
typedef struct ThreadCtrl {
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. */
Tcl_Condition condWait; /* This condition variable is used to
* synchronize the parent and child threads.
|
| ︙ | ︙ | |||
170 171 172 173 174 175 176 |
mainThreadId = Tcl_GetCurrentThread();
}
Tcl_MutexUnlock(&threadMutex);
Tcl_CreateObjCommand(interp, "testthread", ThreadObjCmd, NULL, NULL);
return TCL_OK;
}
| < | 170 171 172 173 174 175 176 177 178 179 180 181 182 183 |
mainThreadId = Tcl_GetCurrentThread();
}
Tcl_MutexUnlock(&threadMutex);
Tcl_CreateObjCommand(interp, "testthread", ThreadObjCmd, NULL, NULL);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ThreadObjCmd --
*
* This procedure is invoked to process the "testthread" Tcl command. See
|
| ︙ | ︙ | |||
225 226 227 228 229 230 231 |
THREAD_WAIT, THREAD_ERRORPROC
};
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
return TCL_ERROR;
}
| | | | 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 |
THREAD_WAIT, THREAD_ERRORPROC
};
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], threadOptions, "option", 0,
&option) != TCL_OK) {
return TCL_ERROR;
}
/*
* Make sure the initial thread is on the list before doing anything.
*/
|
| ︙ | ︙ | |||
291 292 293 294 295 296 297 | * Possibly -joinable, then no special script, no joinable, then * its a script. */ script = Tcl_GetStringFromObj(objv[2], &len); if ((len > 1) && (script[0] == '-') && (script[1] == 'j') && | | | | 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 |
* Possibly -joinable, then no special script, no joinable, then
* its a script.
*/
script = Tcl_GetStringFromObj(objv[2], &len);
if ((len > 1) && (script[0] == '-') && (script[1] == 'j') &&
(0 == strncmp(script, "-joinable", len))) {
joinable = 1;
script = "testthread wait"; /* Just enter event loop */
} else {
/*
* Remember the script
*/
joinable = 0;
}
} else if (objc == 4) {
/*
* Definitely a script available, but is the flag -joinable?
*/
script = Tcl_GetStringFromObj(objv[2], &len);
joinable = ((len > 1) && (script[0] == '-') && (script[1] == 'j')
&& (0 == strncmp(script, "-joinable", len)));
script = Tcl_GetString(objv[3]);
} else {
Tcl_WrongNumArgs(interp, 2, objv, "?-joinable? ?script?");
return TCL_ERROR;
}
return ThreadCreate(interp, script, joinable);
}
|
| ︙ | ︙ | |||
364 365 366 367 368 369 370 |
}
if (Tcl_GetWideIntFromObj(interp, objv[2], &id) != TCL_OK) {
return TCL_ERROR;
}
result = Tcl_JoinThread((Tcl_ThreadId)(size_t)id, &status);
if (result == TCL_OK) {
| | | 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 |
}
if (Tcl_GetWideIntFromObj(interp, objv[2], &id) != TCL_OK) {
return TCL_ERROR;
}
result = Tcl_JoinThread((Tcl_ThreadId)(size_t)id, &status);
if (result == TCL_OK) {
Tcl_SetIntObj(Tcl_GetObjResult(interp), status);
} else {
char buf[20];
sprintf(buf, "%" TCL_LL_MODIFIER "d", id);
Tcl_AppendResult(interp, "cannot join thread ", buf, NULL);
}
return result;
|
| ︙ | ︙ | |||
411 412 413 414 415 416 417 |
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;
}
| | | | | 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 |
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_NewIntObj(
Tcl_DoOneEvent(TCL_ALL_EVENTS | TCL_DONT_WAIT)));
return TCL_OK;
}
case THREAD_ERRORPROC: {
/*
* Arrange for this proc to handle thread death errors.
*/
const char *proc;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "proc");
return TCL_ERROR;
}
Tcl_MutexLock(&threadMutex);
errorThreadId = Tcl_GetCurrentThread();
if (errorProcString) {
Tcl_Free(errorProcString);
}
proc = Tcl_GetString(objv[2]);
errorProcString = Tcl_Alloc(strlen(proc) + 1);
strcpy(errorProcString, proc);
Tcl_MutexUnlock(&threadMutex);
return TCL_OK;
}
case THREAD_WAIT:
if (objc > 2) {
Tcl_WrongNumArgs(interp, 2, objv, "");
|
| ︙ | ︙ | |||
505 506 507 508 509 510 511 |
ctrl.script = script;
ctrl.condWait = NULL;
ctrl.flags = 0;
joinable = joinable ? TCL_THREAD_JOINABLE : TCL_THREAD_NOFLAGS;
Tcl_MutexLock(&threadMutex);
| | | 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 |
ctrl.script = script;
ctrl.condWait = NULL;
ctrl.flags = 0;
joinable = joinable ? TCL_THREAD_JOINABLE : TCL_THREAD_NOFLAGS;
Tcl_MutexLock(&threadMutex);
if (Tcl_CreateThread(&id, NewTestThread, &ctrl,
TCL_THREAD_STACK_DEFAULT, joinable) != TCL_OK) {
Tcl_MutexUnlock(&threadMutex);
Tcl_AppendResult(interp, "can't create a new thread", NULL);
return TCL_ERROR;
}
/*
|
| ︙ | ︙ | |||
592 593 594 595 596 597 598 |
ListUpdateInner(tsdPtr);
/*
* We need to keep a pointer to the alloc'ed mem of the script we are
* eval'ing, for the case that we exit during evaluation
*/
| | | 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 |
ListUpdateInner(tsdPtr);
/*
* We need to keep a pointer to the alloc'ed mem of the script we are
* eval'ing, for the case that we exit during evaluation
*/
threadEvalScript = Tcl_Alloc(strlen(ctrlPtr->script) + 1);
strcpy(threadEvalScript, ctrlPtr->script);
Tcl_CreateThreadExitHandler(ThreadExitProc, threadEvalScript);
/*
* Notify the parent we are alive.
*/
|
| ︙ | ︙ | |||
667 668 669 670 671 672 673 |
Tcl_WriteChars(errChannel, "\n", 1);
} else {
argv[0] = errorProcString;
argv[1] = buf;
argv[2] = errorInfo;
script = Tcl_Merge(3, argv);
ThreadSend(interp, errorThreadId, script, 0);
| | | 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 |
Tcl_WriteChars(errChannel, "\n", 1);
} else {
argv[0] = errorProcString;
argv[1] = buf;
argv[2] = errorInfo;
script = Tcl_Merge(3, argv);
ThreadSend(interp, errorThreadId, script, 0);
Tcl_Free(script);
}
}
/*
*------------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
837 838 839 840 841 842 843 |
return Tcl_EvalEx(interp, script,-1,TCL_EVAL_GLOBAL);
}
/*
* Create the event for its event queue.
*/
| | | | | 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 |
return Tcl_EvalEx(interp, script,-1,TCL_EVAL_GLOBAL);
}
/*
* Create the event for its event queue.
*/
threadEventPtr = Tcl_Alloc(sizeof(ThreadEvent));
threadEventPtr->script = Tcl_Alloc(strlen(script) + 1);
strcpy(threadEventPtr->script, script);
if (!wait) {
resultPtr = threadEventPtr->resultPtr = NULL;
} else {
resultPtr = Tcl_Alloc(sizeof(ThreadEventResult));
threadEventPtr->resultPtr = resultPtr;
/*
* Initialize the result fields.
*/
resultPtr->done = NULL;
|
| ︙ | ︙ | |||
915 916 917 918 919 920 921 |
resultPtr->prevPtr = NULL;
Tcl_MutexUnlock(&threadMutex);
if (resultPtr->code != TCL_OK) {
if (resultPtr->errorCode) {
Tcl_SetErrorCode(interp, resultPtr->errorCode, NULL);
| | | | | | 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 |
resultPtr->prevPtr = NULL;
Tcl_MutexUnlock(&threadMutex);
if (resultPtr->code != TCL_OK) {
if (resultPtr->errorCode) {
Tcl_SetErrorCode(interp, resultPtr->errorCode, NULL);
Tcl_Free(resultPtr->errorCode);
}
if (resultPtr->errorInfo) {
Tcl_AddErrorInfo(interp, resultPtr->errorInfo);
Tcl_Free(resultPtr->errorInfo);
}
}
Tcl_AppendResult(interp, resultPtr->result, NULL);
Tcl_ConditionFinalize(&resultPtr->done);
code = resultPtr->code;
Tcl_Free(resultPtr->result);
Tcl_Free(resultPtr);
return code;
}
/*
*------------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1035 1036 1037 1038 1039 1040 1041 |
errorCode = Tcl_GetVar2(interp, "errorCode", NULL, TCL_GLOBAL_ONLY);
errorInfo = Tcl_GetVar2(interp, "errorInfo", NULL, TCL_GLOBAL_ONLY);
} else {
errorCode = errorInfo = NULL;
}
result = Tcl_GetStringResult(interp);
}
| | | | | | 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 |
errorCode = Tcl_GetVar2(interp, "errorCode", NULL, TCL_GLOBAL_ONLY);
errorInfo = Tcl_GetVar2(interp, "errorInfo", NULL, TCL_GLOBAL_ONLY);
} else {
errorCode = errorInfo = NULL;
}
result = Tcl_GetStringResult(interp);
}
Tcl_Free(threadEventPtr->script);
if (resultPtr) {
Tcl_MutexLock(&threadMutex);
resultPtr->code = code;
resultPtr->result = Tcl_Alloc(strlen(result) + 1);
strcpy(resultPtr->result, result);
if (errorCode != NULL) {
resultPtr->errorCode = Tcl_Alloc(strlen(errorCode) + 1);
strcpy(resultPtr->errorCode, errorCode);
}
if (errorInfo != NULL) {
resultPtr->errorInfo = Tcl_Alloc(strlen(errorInfo) + 1);
strcpy(resultPtr->errorInfo, errorInfo);
}
Tcl_ConditionNotify(&resultPtr->done);
Tcl_MutexUnlock(&threadMutex);
}
if (interp != NULL) {
Tcl_Release(interp);
|
| ︙ | ︙ | |||
1081 1082 1083 1084 1085 1086 1087 |
/* ARGSUSED */
static void
ThreadFreeProc(
ClientData clientData)
{
if (clientData) {
| | | 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 |
/* ARGSUSED */
static void
ThreadFreeProc(
ClientData clientData)
{
if (clientData) {
Tcl_Free(clientData);
}
}
/*
*------------------------------------------------------------------------
*
* ThreadDeleteEvent --
|
| ︙ | ︙ | |||
1109 1110 1111 1112 1113 1114 1115 |
/* ARGSUSED */
static int
ThreadDeleteEvent(
Tcl_Event *eventPtr, /* Really ThreadEvent */
ClientData clientData) /* dummy */
{
if (eventPtr->proc == ThreadEventProc) {
| | | 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 |
/* ARGSUSED */
static int
ThreadDeleteEvent(
Tcl_Event *eventPtr, /* Really ThreadEvent */
ClientData clientData) /* dummy */
{
if (eventPtr->proc == ThreadEventProc) {
Tcl_Free(((ThreadEvent *) eventPtr)->script);
return 1;
}
/*
* If it was NULL, we were in the middle of servicing the event and it
* should be removed
*/
|
| ︙ | ︙ | |||
1153 1154 1155 1156 1157 1158 1159 1160 1161 |
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (tsdPtr->interp != NULL) {
ListRemove(tsdPtr);
}
Tcl_MutexLock(&threadMutex);
if (threadEvalScript) {
| > > > > > > > > | | 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 |
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);
threadEvalScript = NULL;
}
Tcl_DeleteEvents((Tcl_EventDeleteProc *) ThreadDeleteEvent, NULL);
for (resultPtr = resultList ; resultPtr ; resultPtr = nextPtr) {
nextPtr = resultPtr->nextPtr;
if (resultPtr->srcThreadId == self) {
|
| ︙ | ︙ | |||
1178 1179 1180 1181 1182 1183 1184 |
resultList = resultPtr->nextPtr;
}
if (resultPtr->nextPtr) {
resultPtr->nextPtr->prevPtr = resultPtr->prevPtr;
}
resultPtr->nextPtr = resultPtr->prevPtr = 0;
resultPtr->eventPtr->resultPtr = NULL;
| | | | 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 |
resultList = resultPtr->nextPtr;
}
if (resultPtr->nextPtr) {
resultPtr->nextPtr->prevPtr = resultPtr->prevPtr;
}
resultPtr->nextPtr = resultPtr->prevPtr = 0;
resultPtr->eventPtr->resultPtr = NULL;
Tcl_Free(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 = Tcl_Alloc(strlen(msg) + 1);
strcpy(resultPtr->result, msg);
resultPtr->code = TCL_ERROR;
Tcl_ConditionNotify(&resultPtr->done);
}
}
Tcl_MutexUnlock(&threadMutex);
}
|
| ︙ | ︙ |
Changes to generic/tclTimer.c.
| ︙ | ︙ | |||
218 219 220 221 222 223 224 |
Tcl_DeleteEventSource(TimerSetupProc, TimerCheckProc, NULL);
if (tsdPtr != NULL) {
register TimerHandler *timerHandlerPtr;
timerHandlerPtr = tsdPtr->firstTimerHandlerPtr;
while (timerHandlerPtr != NULL) {
tsdPtr->firstTimerHandlerPtr = timerHandlerPtr->nextPtr;
| | | 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 |
Tcl_DeleteEventSource(TimerSetupProc, TimerCheckProc, NULL);
if (tsdPtr != NULL) {
register TimerHandler *timerHandlerPtr;
timerHandlerPtr = tsdPtr->firstTimerHandlerPtr;
while (timerHandlerPtr != NULL) {
tsdPtr->firstTimerHandlerPtr = timerHandlerPtr->nextPtr;
Tcl_Free(timerHandlerPtr);
timerHandlerPtr = tsdPtr->firstTimerHandlerPtr;
}
}
}
/*
*--------------------------------------------------------------
|
| ︙ | ︙ | |||
293 294 295 296 297 298 299 |
Tcl_Time *timePtr,
Tcl_TimerProc *proc,
ClientData clientData)
{
register TimerHandler *timerHandlerPtr, *tPtr2, *prevPtr;
ThreadSpecificData *tsdPtr = InitTimer();
| | | | | 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 |
Tcl_Time *timePtr,
Tcl_TimerProc *proc,
ClientData clientData)
{
register TimerHandler *timerHandlerPtr, *tPtr2, *prevPtr;
ThreadSpecificData *tsdPtr = InitTimer();
timerHandlerPtr = Tcl_Alloc(sizeof(TimerHandler));
/*
* Fill in fields for the event.
*/
memcpy(&timerHandlerPtr->time, 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).
*/
for (tPtr2 = tsdPtr->firstTimerHandlerPtr, prevPtr = NULL; tPtr2 != NULL;
prevPtr = tPtr2, tPtr2 = tPtr2->nextPtr) {
if (TCL_TIME_BEFORE(timerHandlerPtr->time, tPtr2->time)) {
break;
}
|
| ︙ | ︙ | |||
369 370 371 372 373 374 375 |
continue;
}
if (prevPtr == NULL) {
tsdPtr->firstTimerHandlerPtr = timerHandlerPtr->nextPtr;
} else {
prevPtr->nextPtr = timerHandlerPtr->nextPtr;
}
| | | 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 |
continue;
}
if (prevPtr == NULL) {
tsdPtr->firstTimerHandlerPtr = timerHandlerPtr->nextPtr;
} else {
prevPtr->nextPtr = timerHandlerPtr->nextPtr;
}
Tcl_Free(timerHandlerPtr);
return;
}
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
484 485 486 487 488 489 490 |
/*
* If the first timer has expired, stick an event on the queue.
*/
if (blockTime.sec == 0 && blockTime.usec == 0 &&
!tsdPtr->timerPending) {
tsdPtr->timerPending = 1;
| | | 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 |
/*
* If the first timer has expired, stick an event on the queue.
*/
if (blockTime.sec == 0 && blockTime.usec == 0 &&
!tsdPtr->timerPending) {
tsdPtr->timerPending = 1;
timerEvPtr = Tcl_Alloc(sizeof(Tcl_Event));
timerEvPtr->proc = TimerHandlerEventProc;
Tcl_QueueEvent(timerEvPtr, TCL_QUEUE_TAIL);
}
}
}
/*
|
| ︙ | ︙ | |||
587 588 589 590 591 592 593 | /* * Remove the handler from the queue before invoking it, to avoid * potential reentrancy problems. */ *nextPtrPtr = timerHandlerPtr->nextPtr; timerHandlerPtr->proc(timerHandlerPtr->clientData); | | | 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 |
/*
* Remove the handler from the queue before invoking it, to avoid
* potential reentrancy problems.
*/
*nextPtrPtr = timerHandlerPtr->nextPtr;
timerHandlerPtr->proc(timerHandlerPtr->clientData);
Tcl_Free(timerHandlerPtr);
}
TimerSetupProc(NULL, TCL_TIMER_EVENTS);
return 1;
}
/*
*--------------------------------------------------------------
|
| ︙ | ︙ | |||
621 622 623 624 625 626 627 |
Tcl_IdleProc *proc, /* Function to invoke. */
ClientData clientData) /* Arbitrary value to pass to proc. */
{
register IdleHandler *idlePtr;
Tcl_Time blockTime;
ThreadSpecificData *tsdPtr = InitTimer();
| | | 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 |
Tcl_IdleProc *proc, /* Function to invoke. */
ClientData clientData) /* Arbitrary value to pass to proc. */
{
register IdleHandler *idlePtr;
Tcl_Time blockTime;
ThreadSpecificData *tsdPtr = InitTimer();
idlePtr = Tcl_Alloc(sizeof(IdleHandler));
idlePtr->proc = proc;
idlePtr->clientData = clientData;
idlePtr->generation = tsdPtr->idleGeneration;
idlePtr->nextPtr = NULL;
if (tsdPtr->lastIdlePtr == NULL) {
tsdPtr->idleList = idlePtr;
} else {
|
| ︙ | ︙ | |||
670 671 672 673 674 675 676 |
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;
| | | 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 |
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);
idlePtr = nextPtr;
if (prevPtr == NULL) {
tsdPtr->idleList = idlePtr;
} else {
prevPtr->nextPtr = idlePtr;
}
if (idlePtr == NULL) {
|
| ︙ | ︙ | |||
745 746 747 748 749 750 751 |
&& ((oldGeneration - idlePtr->generation) >= 0));
idlePtr = tsdPtr->idleList) {
tsdPtr->idleList = idlePtr->nextPtr;
if (tsdPtr->idleList == NULL) {
tsdPtr->lastIdlePtr = NULL;
}
idlePtr->proc(idlePtr->clientData);
| | | 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 |
&& ((oldGeneration - idlePtr->generation) >= 0));
idlePtr = tsdPtr->idleList) {
tsdPtr->idleList = idlePtr->nextPtr;
if (tsdPtr->idleList == NULL) {
tsdPtr->lastIdlePtr = NULL;
}
idlePtr->proc(idlePtr->clientData);
Tcl_Free(idlePtr);
}
if (tsdPtr->idleList) {
blockTime.sec = 0;
blockTime.usec = 0;
Tcl_SetMaxBlockTime(&blockTime);
}
return 1;
|
| ︙ | ︙ | |||
784 785 786 787 788 789 790 |
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_WideInt ms = 0; /* Number of milliseconds to wait */
Tcl_Time wakeup;
AfterInfo *afterPtr;
AfterAssocData *assocPtr;
| | | | < < < < < | > > | | 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 |
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_WideInt ms = 0; /* Number of milliseconds to wait */
Tcl_Time wakeup;
AfterInfo *afterPtr;
AfterAssocData *assocPtr;
size_t length;
int index = -1;
static const char *const afterSubCmds[] = {
"cancel", "idle", "info", NULL
};
enum afterSubCmds {AFTER_CANCEL, AFTER_IDLE, AFTER_INFO};
ThreadSpecificData *tsdPtr = InitTimer();
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
return TCL_ERROR;
}
/*
* Create the "after" information associated for this interpreter, if it
* doesn't already exist.
*/
assocPtr = Tcl_GetAssocData(interp, "tclAfter", NULL);
if (assocPtr == NULL) {
assocPtr = Tcl_Alloc(sizeof(AfterAssocData));
assocPtr->interp = interp;
assocPtr->firstAfterPtr = NULL;
Tcl_SetAssocData(interp, "tclAfter", AfterCleanupProc, assocPtr);
}
/*
* First lets see if the command was passed a number as the first argument.
*/
if (Tcl_GetWideIntFromObj(NULL, objv[1], &ms) != TCL_OK) {
if (Tcl_GetIndexFromObj(NULL, objv[1], afterSubCmds, "", 0, &index)
!= TCL_OK) {
const char *arg = 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);
return TCL_ERROR;
|
| ︙ | ︙ | |||
844 845 846 847 848 849 850 |
case -1: {
if (ms < 0) {
ms = 0;
}
if (objc == 2) {
return AfterDelay(interp, ms);
}
| | | 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 |
case -1: {
if (ms < 0) {
ms = 0;
}
if (objc == 2) {
return AfterDelay(interp, ms);
}
afterPtr = Tcl_Alloc(sizeof(AfterInfo));
afterPtr->assocPtr = assocPtr;
if (objc == 3) {
afterPtr->commandPtr = objv[2];
} else {
afterPtr->commandPtr = Tcl_ConcatObj(objc-2, objv+2);
}
Tcl_IncrRefCount(afterPtr->commandPtr);
|
| ︙ | ︙ | |||
882 883 884 885 886 887 888 |
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;
| | | | 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 |
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;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 2, objv, "id|command");
return TCL_ERROR;
}
if (objc == 3) {
commandPtr = objv[2];
} else {
commandPtr = Tcl_ConcatObj(objc-2, objv+2);;
}
command = TclGetStringFromObj(commandPtr, &length);
for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL;
afterPtr = afterPtr->nextPtr) {
tempCommand = TclGetStringFromObj(afterPtr->commandPtr,
&tempLength);
if ((length == tempLength)
&& !memcmp(command, tempCommand, length)) {
break;
}
}
if (afterPtr == NULL) {
afterPtr = GetAfterEvent(assocPtr, commandPtr);
}
if (objc != 3) {
|
| ︙ | ︙ | |||
924 925 926 927 928 929 930 |
break;
}
case AFTER_IDLE:
if (objc < 3) {
Tcl_WrongNumArgs(interp, 2, objv, "script ?script ...?");
return TCL_ERROR;
}
| | | 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 |
break;
}
case AFTER_IDLE:
if (objc < 3) {
Tcl_WrongNumArgs(interp, 2, objv, "script ?script ...?");
return TCL_ERROR;
}
afterPtr = Tcl_Alloc(sizeof(AfterInfo));
afterPtr->assocPtr = assocPtr;
if (objc == 3) {
afterPtr->commandPtr = objv[2];
} else {
afterPtr->commandPtr = Tcl_ConcatObj(objc-2, objv+2);
}
Tcl_IncrRefCount(afterPtr->commandPtr);
|
| ︙ | ︙ | |||
1012 1013 1014 1015 1016 1017 1018 |
Interp *iPtr = (Interp *) interp;
Tcl_Time endTime, now;
Tcl_WideInt diff;
Tcl_GetTime(&now);
endTime = now;
| | | | 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 |
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;
if (endTime.usec >= 1000000) {
endTime.sec++;
endTime.usec -= 1000000;
}
do {
if (Tcl_AsyncReady()) {
|
| ︙ | ︙ | |||
1041 1042 1043 1044 1045 1046 1047 |
}
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;
}
| | | | | | | | | | | 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 |
}
if (iPtr->limit.timeEvent == NULL
|| TCL_TIME_BEFORE(endTime, iPtr->limit.time)) {
diff = TCL_TIME_DIFF_MS_CEILING(endTime, now);
if (diff > TCL_TIME_MAXIMUM_SLICE) {
diff = TCL_TIME_MAXIMUM_SLICE;
}
if (diff == 0 && TCL_TIME_BEFORE(now, endTime)) {
diff = 1;
}
if (diff > 0) {
Tcl_Sleep((long) diff);
if (diff < SLEEP_OFFLOAD_GETTIMEOFDAY) {
break;
}
} else {
break;
}
} else {
diff = TCL_TIME_DIFF_MS(iPtr->limit.time, now);
if (diff > TCL_TIME_MAXIMUM_SLICE) {
diff = TCL_TIME_MAXIMUM_SLICE;
}
if (diff > 0) {
Tcl_Sleep((int) diff);
|
| ︙ | ︙ | |||
1189 1190 1191 1192 1193 1194 1195 |
Tcl_Release(interp);
/*
* Free the memory for the callback.
*/
Tcl_DecrRefCount(afterPtr->commandPtr);
| | | 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 |
Tcl_Release(interp);
/*
* Free the memory for the callback.
*/
Tcl_DecrRefCount(afterPtr->commandPtr);
Tcl_Free(afterPtr);
}
/*
*----------------------------------------------------------------------
*
* FreeAfterPtr --
*
|
| ︙ | ︙ | |||
1227 1228 1229 1230 1231 1232 1233 |
for (prevPtr = assocPtr->firstAfterPtr; prevPtr->nextPtr != afterPtr;
prevPtr = prevPtr->nextPtr) {
/* Empty loop body. */
}
prevPtr->nextPtr = afterPtr->nextPtr;
}
Tcl_DecrRefCount(afterPtr->commandPtr);
| | | 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 |
for (prevPtr = assocPtr->firstAfterPtr; prevPtr->nextPtr != afterPtr;
prevPtr = prevPtr->nextPtr) {
/* Empty loop body. */
}
prevPtr->nextPtr = afterPtr->nextPtr;
}
Tcl_DecrRefCount(afterPtr->commandPtr);
Tcl_Free(afterPtr);
}
/*
*----------------------------------------------------------------------
*
* AfterCleanupProc --
*
|
| ︙ | ︙ | |||
1266 1267 1268 1269 1270 1271 1272 |
assocPtr->firstAfterPtr = afterPtr->nextPtr;
if (afterPtr->token != NULL) {
Tcl_DeleteTimerHandler(afterPtr->token);
} else {
Tcl_CancelIdleCall(AfterProc, afterPtr);
}
Tcl_DecrRefCount(afterPtr->commandPtr);
| | | | 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 |
assocPtr->firstAfterPtr = afterPtr->nextPtr;
if (afterPtr->token != NULL) {
Tcl_DeleteTimerHandler(afterPtr->token);
} else {
Tcl_CancelIdleCall(AfterProc, afterPtr);
}
Tcl_DecrRefCount(afterPtr->commandPtr);
Tcl_Free(afterPtr);
}
Tcl_Free(assocPtr);
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* tab-width: 8
* indent-tabs-mode: nil
* End:
*/
|
Changes to generic/tclTomMath.decls.
| ︙ | ︙ | |||
170 171 172 173 174 175 176 |
}
declare 48 {
int TclBN_mp_xor(const mp_int *a, const mp_int *b, mp_int *c)
}
declare 49 {
void TclBN_mp_zero(mp_int *a)
}
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 170 171 172 173 174 175 176 177 178 179 180 181 182 183 |
}
declare 48 {
int TclBN_mp_xor(const mp_int *a, const mp_int *b, mp_int *c)
}
declare 49 {
void TclBN_mp_zero(mp_int *a)
}
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 {
|
| ︙ | ︙ | |||
249 250 251 252 253 254 255 256 257 258 259 |
}
declare 70 {
int TclBN_mp_set_long(mp_int *a, unsigned long i)
}
declare 71 {
unsigned long TclBN_mp_get_long(const mp_int *a)
}
# Local Variables:
# mode: tcl
# End:
| > > > > > > > > > > > > > > > > > > > > > > > > | 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 |
}
declare 70 {
int TclBN_mp_set_long(mp_int *a, unsigned long i)
}
declare 71 {
unsigned long TclBN_mp_get_long(const mp_int *a)
}
declare 72 {
unsigned long TclBN_mp_get_int(const mp_int *a)
}
# 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 {
int TclBN_mp_signed_rsh(const mp_int *a, int b, mp_int *c)
}
declare 77 {
int TclBN_mp_get_bit(const mp_int *a, int b)
}
# Local Variables:
# mode: tcl
# End:
|
Changes to generic/tclTomMath.h.
|
| | | < < | < < < < < < < < < | | > > | > > > > | | | | | < < < < < < < < < < | | < < < < < < < < < < < < < < < > > | > | | | | > | < < < | < < < < < < < > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > < < < < > | > | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 |
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
#ifndef BN_H_
#define BN_H_
#include "tclTomMathDecls.h"
#ifndef MODULE_SCOPE
#define MODULE_SCOPE extern
#endif
#ifdef __cplusplus
extern "C" {
#endif
/* MS Visual C++ doesn't have a 128bit type for words, so fall back to 32bit MPI's (where words are 64bit) */
#if defined(_WIN32) || defined(__LLP64__) || defined(__e2k__) || defined(__LCC__)
# define MP_32BIT
#endif
/* detect 64-bit mode if possible */
#if defined(NEVER)
# if !(defined(MP_32BIT) || defined(MP_16BIT) || defined(MP_8BIT))
# if defined(__GNUC__)
/* we support 128bit integers only via: __attribute__((mode(TI))) */
# define MP_64BIT
# else
/* otherwise we fall back to MP_32BIT even on 64bit platforms */
# define MP_32BIT
# endif
# endif
#endif
/* 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
#ifndef MP_WORD_DECLARED
typedef unsigned short mp_word;
#define MP_WORD_DECLARED
#endif
# define MP_SIZEOF_MP_DIGIT 1
# ifdef DIGIT_BIT
# error You must not define DIGIT_BIT when using MP_8BIT
# endif
#elif defined(MP_16BIT)
#ifndef MP_DIGIT_DECLARED
typedef unsigned short mp_digit;
#define MP_DIGIT_DECLARED
#endif
#ifndef MP_WORD_DECLARED
typedef unsigned int mp_word;
#define MP_WORD_DECLARED
#endif
# define MP_SIZEOF_MP_DIGIT 2
# ifdef DIGIT_BIT
# error You must not define DIGIT_BIT when using MP_16BIT
# endif
#elif defined(MP_64BIT)
/* for GCC only on supported platforms */
#ifndef MP_DIGIT_DECLARED
typedef unsigned long 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 MP_DIGIT_DECLARED
typedef unsigned int mp_digit;
#define MP_DIGIT_DECLARED
#endif
#ifndef MP_WORD_DECLARED
typedef unsigned long long mp_word;
#define MP_WORD_DECLARED
#endif
# 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
/* otherwise the bits per digit is calculated automatically from the size of a mp_digit */
#ifndef DIGIT_BIT
# define DIGIT_BIT (((CHAR_BIT * MP_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 */
/* 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 (1u << (((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);
*/
|
| ︙ | ︙ | |||
267 268 269 270 271 272 273 | */ /* set a platform dependent unsigned long value */ /* int mp_set_long(mp_int *a, unsigned long b); */ | | | | | | 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 | */ /* 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(const mp_int *a); */ /* get a platform dependent unsigned long value */ /* unsigned long mp_get_long(const mp_int *a); */ /* get a platform dependent unsigned long long value */ /* unsigned long long mp_get_long_long(const mp_int *a); */ /* initialize and set a digit */ /* int mp_init_set(mp_int *a, mp_digit b); */ |
| ︙ | ︙ | |||
371 372 373 374 375 376 377 | /* Counts the number of lsbs which are zero before the first zero bit */ /* int mp_cnt_lsb(const mp_int *a); */ /* I Love Earth! */ | | > > > > > > > > > > > > > > > > > > > > > > > | 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 | /* Counts the number of lsbs which are zero before the first zero bit */ /* int mp_cnt_lsb(const mp_int *a); */ /* I Love Earth! */ /* makes a pseudo-random mp_int of a given size */ /* int mp_rand(mp_int *a, int digits); */ /* makes a pseudo-random small int of a given size */ /* int mp_rand_digit(mp_digit *r); */ #ifdef MP_PRNG_ENABLE_LTM_RNG /* A last resort to provide random data on systems without any of the other * implemented ways to gather entropy. * It is compatible with `rng_get_bytes()` from libtomcrypt so you could * provide that one and then set `ltm_rng = rng_get_bytes;` */ extern unsigned long (*ltm_rng)(unsigned char *out, unsigned long outlen, void (*callback)(void)); extern void (*ltm_rng_callback)(void); #endif /* ---> binary operations <--- */ /* c = a XOR b */ /* int mp_xor(const mp_int *a, const mp_int *b, mp_int *c); */ /* c = a OR b */ /* int mp_or(const mp_int *a, const mp_int *b, mp_int *c); */ /* c = a AND b */ /* int mp_and(const mp_int *a, const mp_int *b, mp_int *c); */ /* right shift (two complement) */ /* int mp_signed_rsh(const mp_int *a, int b, mp_int *c); */ /* ---> Basic arithmetic <--- */ /* b = ~a */ /* int mp_complement(const mp_int *a, mp_int *b); */ /* b = -a */ /* int mp_neg(const mp_int *a, mp_int *b); */ /* b = |a| */ |
| ︙ | ︙ | |||
683 684 685 686 687 688 689 | /* 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); */ | | | > > > > > > > | 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 | /* 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 random rounds of Miller-Rabin on "a" additional to * bases 2 and 3. Also performs an initial sieve of trial * division. Determines if "a" is prime with probability * of error no more than (1/4)**t. * Both a strong Lucas-Selfridge to complete the BPSW test * and a separate Frobenius test are available at compile time. * With t<0 a deterministic test is run for primes up to * 318665857834031151167461. With t<13 (abs(t)-13) additional * tests with sequential small primes are run starting at 43. * Is Fips 186.4 compliant if called with t as computed by * mp_prime_rabin_miller_trials(); * * Sets result to 1 if probably prime, 0 otherwise */ /* int mp_prime_is_prime(const mp_int *a, int t, int *result); */ |
| ︙ | ︙ |
Changes to generic/tclTomMathDecls.h.
| ︙ | ︙ | |||
25 26 27 28 29 30 31 32 33 |
#define TCLTOMMATH_REVISION 0
#define Tcl_TomMath_InitStubs(interp,version) \
(TclTomMathInitializeStubs((interp),(version),\
TCLTOMMATH_EPOCH,TCLTOMMATH_REVISION))
/* Define custom memory allocation for libtommath */
/* MODULE_SCOPE void* TclBNAlloc( size_t ); */
| > | | | < < | | | | < < < < < > > > | 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 |
#define TCLTOMMATH_REVISION 0
#define Tcl_TomMath_InitStubs(interp,version) \
(TclTomMathInitializeStubs((interp),(version),\
TCLTOMMATH_EPOCH,TCLTOMMATH_REVISION))
/* Define custom memory allocation for libtommath */
/* MODULE_SCOPE void* TclBNAlloc( size_t ); */
#define TclBNAlloc(s) ((void*)Tcl_Alloc((size_t)(s)))
/* MODULE_SCOPE void* TclBNRealloc( void*, size_t ); */
#define TclBNRealloc(x,s) ((void*)Tcl_Realloc((char*)(x),(size_t)(s)))
/* MODULE_SCOPE void TclBNFree( void* ); */
#define TclBNFree(x) (Tcl_Free((char*)(x)))
#define XMALLOC(size) TclBNAlloc(size)
#define XFREE(mem, size) TclBNFree(mem)
#define XREALLOC(mem, oldsize, newsize) TclBNRealloc(mem, newsize)
/* Rename the global symbols in libtommath to avoid linkage conflicts */
#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
#define mp_clear_multi TclBN_mp_clear_multi
#define mp_cmp TclBN_mp_cmp
|
| ︙ | ︙ | |||
74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 | #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_get_int TclBN_mp_get_int #define mp_get_long TclBN_mp_get_long #define mp_get_long_long TclBN_mp_get_long_long #define mp_grow TclBN_mp_grow #define mp_init TclBN_mp_init #define mp_init_copy TclBN_mp_init_copy #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_karatsuba_mul TclBN_mp_karatsuba_mul #define 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_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 | > > > > < > > > > > > > > > > > > > > > > > > > > > | 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 | #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_get_int TclBN_mp_get_int #define mp_get_long TclBN_mp_get_long #define mp_get_long_long TclBN_mp_get_long_long #define mp_grow TclBN_mp_grow #define s_mp_get_bit TclBN_mp_get_bit #define mp_grow TclBN_mp_grow #define mp_init TclBN_mp_init #define mp_init_copy TclBN_mp_init_copy #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_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_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_set TclBN_mp_set #define mp_set_int TclBN_mp_set_int #define mp_set_long TclBN_mp_set_long #define mp_set_long_long TclBN_mp_set_long_long #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_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_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_mul_digs TclBN_s_mp_mul_digs #define s_mp_sqr TclBN_s_mp_sqr #define s_mp_sub TclBN_s_mp_sub MODULE_SCOPE void TclBN_reverse(unsigned char *s, int len); MODULE_SCOPE int TclBN_fast_s_mp_mul_digs(const mp_int *a, const mp_int *b, mp_int *c, int digs); MODULE_SCOPE int TclBN_fast_s_mp_sqr(const mp_int *a, mp_int *b); MODULE_SCOPE int TclBN_mp_karatsuba_mul(const mp_int *a, const mp_int *b, mp_int *c); MODULE_SCOPE int TclBN_mp_karatsuba_sqr(const mp_int *a, mp_int *b); MODULE_SCOPE int TclBN_mp_toom_mul(const mp_int *a, const mp_int *b, mp_int *c); MODULE_SCOPE int TclBN_mp_toom_sqr(const mp_int *a, mp_int *b); MODULE_SCOPE int TclBN_s_mp_add(const mp_int *a, const mp_int *b, mp_int *c); MODULE_SCOPE int TclBN_s_mp_mul_digs(const mp_int *a, const mp_int *b, mp_int *c, int digs); MODULE_SCOPE int TclBN_s_mp_sqr(const mp_int *a, mp_int *b); MODULE_SCOPE int TclBN_s_mp_sub(const mp_int *a, const mp_int *b, mp_int *c); /* * 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. */ |
| ︙ | ︙ | |||
253 254 255 256 257 258 259 | /* 47 */ TCLAPI int TclBN_mp_unsigned_bin_size(const mp_int *a); /* 48 */ TCLAPI int TclBN_mp_xor(const mp_int *a, const mp_int *b, mp_int *c); /* 49 */ TCLAPI void TclBN_mp_zero(mp_int *a); | | < | < < | < | < < | < | < < | < | < < | < < | < | < < > > > > > > > > > > | 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 |
/* 47 */
TCLAPI int TclBN_mp_unsigned_bin_size(const mp_int *a);
/* 48 */
TCLAPI int TclBN_mp_xor(const mp_int *a, const mp_int *b,
mp_int *c);
/* 49 */
TCLAPI 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 */
/* 61 */
TCLAPI int TclBN_mp_init_set_int(mp_int *a, unsigned long i);
/* 62 */
TCLAPI int TclBN_mp_set_int(mp_int *a, unsigned long i);
/* 63 */
TCLAPI int TclBN_mp_cnt_lsb(const mp_int *a);
/* Slot 64 is reserved */
/* Slot 65 is reserved */
/* Slot 66 is reserved */
/* 67 */
TCLAPI int TclBN_mp_expt_d_ex(const mp_int *a, mp_digit b,
mp_int *c, int fast);
/* 68 */
TCLAPI int TclBN_mp_set_long_long(mp_int *a, Tcl_WideUInt i);
/* 69 */
TCLAPI Tcl_WideUInt TclBN_mp_get_long_long(const mp_int *a);
/* 70 */
TCLAPI int TclBN_mp_set_long(mp_int *a, unsigned long i);
/* 71 */
TCLAPI unsigned long TclBN_mp_get_long(const mp_int *a);
/* 72 */
TCLAPI unsigned long TclBN_mp_get_int(const mp_int *a);
/* Slot 73 is reserved */
/* Slot 74 is reserved */
/* Slot 75 is reserved */
/* 76 */
TCLAPI int TclBN_mp_signed_rsh(const mp_int *a, int b,
mp_int *c);
/* 77 */
TCLAPI int TclBN_mp_get_bit(const mp_int *a, int b);
typedef struct TclTomMathStubs {
int magic;
void *hooks;
int (*tclBN_epoch) (void); /* 0 */
int (*tclBN_revision) (void); /* 1 */
|
| ︙ | ︙ | |||
356 357 358 359 360 361 362 |
int (*tclBN_mp_sub_d) (const mp_int *a, mp_digit b, mp_int *c); /* 43 */
int (*tclBN_mp_to_unsigned_bin) (const mp_int *a, unsigned char *b); /* 44 */
int (*tclBN_mp_to_unsigned_bin_n) (const mp_int *a, unsigned char *b, unsigned long *outlen); /* 45 */
int (*tclBN_mp_toradix_n) (const mp_int *a, char *str, int radix, int maxlen); /* 46 */
int (*tclBN_mp_unsigned_bin_size) (const 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 */
| | | | | | | | | | | | > > > > > > | 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 |
int (*tclBN_mp_sub_d) (const mp_int *a, mp_digit b, mp_int *c); /* 43 */
int (*tclBN_mp_to_unsigned_bin) (const mp_int *a, unsigned char *b); /* 44 */
int (*tclBN_mp_to_unsigned_bin_n) (const mp_int *a, unsigned char *b, unsigned long *outlen); /* 45 */
int (*tclBN_mp_toradix_n) (const mp_int *a, char *str, int radix, int maxlen); /* 46 */
int (*tclBN_mp_unsigned_bin_size) (const 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);
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) (const mp_int *a); /* 63 */
void (*reserved64)(void);
void (*reserved65)(void);
void (*reserved66)(void);
int (*tclBN_mp_expt_d_ex) (const mp_int *a, mp_digit b, mp_int *c, int fast); /* 67 */
int (*tclBN_mp_set_long_long) (mp_int *a, Tcl_WideUInt i); /* 68 */
Tcl_WideUInt (*tclBN_mp_get_long_long) (const mp_int *a); /* 69 */
int (*tclBN_mp_set_long) (mp_int *a, unsigned long i); /* 70 */
unsigned long (*tclBN_mp_get_long) (const mp_int *a); /* 71 */
unsigned long (*tclBN_mp_get_int) (const mp_int *a); /* 72 */
void (*reserved73)(void);
void (*reserved74)(void);
void (*reserved75)(void);
int (*tclBN_mp_signed_rsh) (const mp_int *a, int b, mp_int *c); /* 76 */
int (*tclBN_mp_get_bit) (const mp_int *a, int b); /* 77 */
} TclTomMathStubs;
extern const TclTomMathStubs *tclTomMathStubsPtr;
#ifdef __cplusplus
}
#endif
|
| ︙ | ︙ | |||
492 493 494 495 496 497 498 | (tclTomMathStubsPtr->tclBN_mp_toradix_n) /* 46 */ #define TclBN_mp_unsigned_bin_size \ (tclTomMathStubsPtr->tclBN_mp_unsigned_bin_size) /* 47 */ #define TclBN_mp_xor \ (tclTomMathStubsPtr->tclBN_mp_xor) /* 48 */ #define TclBN_mp_zero \ (tclTomMathStubsPtr->tclBN_mp_zero) /* 49 */ | | | | | | | | | | | | < < < < < < < < < < < > > > > > > > > > | 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 | (tclTomMathStubsPtr->tclBN_mp_toradix_n) /* 46 */ #define TclBN_mp_unsigned_bin_size \ (tclTomMathStubsPtr->tclBN_mp_unsigned_bin_size) /* 47 */ #define TclBN_mp_xor \ (tclTomMathStubsPtr->tclBN_mp_xor) /* 48 */ #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 */ #define TclBN_mp_init_set_int \ (tclTomMathStubsPtr->tclBN_mp_init_set_int) /* 61 */ #define TclBN_mp_set_int \ (tclTomMathStubsPtr->tclBN_mp_set_int) /* 62 */ #define TclBN_mp_cnt_lsb \ (tclTomMathStubsPtr->tclBN_mp_cnt_lsb) /* 63 */ /* Slot 64 is reserved */ /* Slot 65 is reserved */ /* Slot 66 is reserved */ #define TclBN_mp_expt_d_ex \ (tclTomMathStubsPtr->tclBN_mp_expt_d_ex) /* 67 */ #define TclBN_mp_set_long_long \ (tclTomMathStubsPtr->tclBN_mp_set_long_long) /* 68 */ #define TclBN_mp_get_long_long \ (tclTomMathStubsPtr->tclBN_mp_get_long_long) /* 69 */ #define TclBN_mp_set_long \ (tclTomMathStubsPtr->tclBN_mp_set_long) /* 70 */ #define TclBN_mp_get_long \ (tclTomMathStubsPtr->tclBN_mp_get_long) /* 71 */ #define TclBN_mp_get_int \ (tclTomMathStubsPtr->tclBN_mp_get_int) /* 72 */ /* Slot 73 is reserved */ /* Slot 74 is reserved */ /* Slot 75 is reserved */ #define TclBN_mp_signed_rsh \ (tclTomMathStubsPtr->tclBN_mp_signed_rsh) /* 76 */ #define TclBN_mp_get_bit \ (tclTomMathStubsPtr->tclBN_mp_get_bit) /* 77 */ #endif /* defined(USE_TCL_STUBS) */ /* !END!: Do not edit above this line. */ #endif /* _TCLINTDECLS */ |
Changes to generic/tclTomMathInterface.c.
| ︙ | ︙ | |||
89 90 91 92 93 94 95 |
{
return TCLTOMMATH_REVISION;
}
/*
*----------------------------------------------------------------------
*
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 |
{
return TCLTOMMATH_REVISION;
}
/*
*----------------------------------------------------------------------
*
* TclInitBignumFromWideInt --
*
* Allocate and initialize a 'bignum' from a Tcl_WideInt
*
* Results:
* None.
*
* Side effects:
* The 'bignum' is constructed.
*
*----------------------------------------------------------------------
*/
void
TclInitBignumFromWideInt(
mp_int *a, /* Bignum to initialize */
Tcl_WideInt v) /* Initial value */
{
if (mp_init(a) != MP_OKAY) {
Tcl_Panic("initialization failure in TclInitBignumFromWideInt");
}
if (v < (Tcl_WideInt)0) {
mp_set_long_long(a, (Tcl_WideUInt)(-v));
mp_neg(a, a);
} else {
mp_set_long_long(a, (Tcl_WideUInt)v);
|
| ︙ | ︙ | |||
171 172 173 174 175 176 177 |
*/
void
TclInitBignumFromWideUInt(
mp_int *a, /* Bignum to initialize */
Tcl_WideUInt v) /* Initial value */
{
| | | 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 |
*/
void
TclInitBignumFromWideUInt(
mp_int *a, /* Bignum to initialize */
Tcl_WideUInt v) /* Initial value */
{
if (mp_init(a) != MP_OKAY) {
Tcl_Panic("initialization failure in TclInitBignumFromWideUInt");
}
mp_set_long_long(a, v);
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclTomMathStubLib.c.
| ︙ | ︙ | |||
51 52 53 54 55 56 57 |
packageName, version, exact, &stubsPtr);
if (actualVersion == NULL) {
return NULL;
}
if (stubsPtr == NULL) {
errMsg = "missing stub table pointer";
| | | | 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 |
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,
|
| ︙ | ︙ |
Changes to generic/tclTrace.c.
| ︙ | ︙ | |||
117 118 119 120 121 122 123 | }; /* * Declarations for local functions to this file: */ static int CallTraceFunction(Tcl_Interp *interp, Trace *tracePtr, | | | 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 | }; /* * Declarations for local functions to this file: */ static int CallTraceFunction(Tcl_Interp *interp, Trace *tracePtr, Command *cmdPtr, const char *command, size_t numChars, int objc, Tcl_Obj *const objv[]); static char * TraceVarProc(ClientData clientData, Tcl_Interp *interp, const char *name1, const char *name2, int flags); static void TraceCommandProc(ClientData clientData, Tcl_Interp *interp, const char *oldName, const char *newName, int flags); static Tcl_CmdObjTraceProc TraceExecutionProc; |
| ︙ | ︙ | |||
187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 |
Tcl_TraceObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int optionIndex;
const char *name;
const char *flagOps, *p;
/* Main sub commands to 'trace' */
static const char *const traceOptions[] = {
"add", "info", "remove",
#ifndef TCL_REMOVE_OBSOLETE_TRACES
"variable", "vdelete", "vinfo",
#endif
NULL
| > > | 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 |
Tcl_TraceObjCmd(
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;
#endif
/* Main sub commands to 'trace' */
static const char *const traceOptions[] = {
"add", "info", "remove",
#ifndef TCL_REMOVE_OBSOLETE_TRACES
"variable", "vdelete", "vinfo",
#endif
NULL
|
| ︙ | ︙ | |||
265 266 267 268 269 270 271 |
}
#ifndef TCL_REMOVE_OBSOLETE_TRACES
case TRACE_OLD_VARIABLE:
case TRACE_OLD_VDELETE: {
Tcl_Obj *copyObjv[6];
Tcl_Obj *opsList;
| | > | 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 |
}
#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;
if (objc != 5) {
Tcl_WrongNumArgs(interp, 2, objv, "name ops command");
return TCL_ERROR;
}
opsList = Tcl_NewObj();
|
| ︙ | ︙ | |||
317 318 319 320 321 322 323 |
Tcl_Obj *resultListPtr, *pairObjPtr, *elemObjPtr;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "name");
return TCL_ERROR;
}
resultListPtr = Tcl_NewObj();
| | | 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 |
Tcl_Obj *resultListPtr, *pairObjPtr, *elemObjPtr;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "name");
return TCL_ERROR;
}
resultListPtr = Tcl_NewObj();
name = TclGetString(objv[2]);
FOREACH_VAR_TRACE(interp, name, clientData) {
TraceVarInfo *tvarPtr = clientData;
char *q = ops;
pairObjPtr = Tcl_NewListObj(0, NULL);
if (tvarPtr->flags & TCL_TRACE_READS) {
*q = 'r';
|
| ︙ | ︙ | |||
361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 |
Tcl_SetObjResult(interp, resultListPtr);
break;
}
#endif /* TCL_REMOVE_OBSOLETE_TRACES */
}
return TCL_OK;
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);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* TraceExecutionObjCmd --
*
| > > | 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 |
Tcl_SetObjResult(interp, resultListPtr);
break;
}
#endif /* TCL_REMOVE_OBSOLETE_TRACES */
}
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);
return TCL_ERROR;
#endif
}
/*
*----------------------------------------------------------------------
*
* TraceExecutionObjCmd --
*
|
| ︙ | ︙ | |||
395 396 397 398 399 400 401 |
static int
TraceExecutionObjCmd(
Tcl_Interp *interp, /* Current interpreter. */
int optionIndex, /* Add, info or remove */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
| | | | 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 |
static int
TraceExecutionObjCmd(
Tcl_Interp *interp, /* Current interpreter. */
int optionIndex, /* Add, info or remove */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int index;
const char *name, *command;
size_t commandLength, length;
enum traceOptions {
TRACE_ADD, TRACE_INFO, TRACE_REMOVE
};
static const char *const opStrings[] = {
"enter", "leave", "enterstep", "leavestep", NULL
};
enum operations {
|
| ︙ | ︙ | |||
459 460 461 462 463 464 465 | break; case TRACE_EXEC_LEAVE_STEP: flags |= TCL_TRACE_LEAVE_DURING_EXEC; break; } } command = TclGetStringFromObj(objv[5], &commandLength); | | | | | | | | < | < | | | 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 |
break;
case TRACE_EXEC_LEAVE_STEP:
flags |= TCL_TRACE_LEAVE_DURING_EXEC;
break;
}
}
command = TclGetStringFromObj(objv[5], &commandLength);
length = commandLength;
if ((enum traceOptions) optionIndex == TRACE_ADD) {
TraceCommandInfo *tcmdPtr = Tcl_Alloc(
offsetof(TraceCommandInfo, command) + 1 + length);
tcmdPtr->flags = flags;
tcmdPtr->stepTrace = NULL;
tcmdPtr->startLevel = 0;
tcmdPtr->startCmd = NULL;
tcmdPtr->length = length;
tcmdPtr->refCount = 1;
flags |= TCL_TRACE_DELETE;
if (flags & (TCL_TRACE_ENTER_DURING_EXEC |
TCL_TRACE_LEAVE_DURING_EXEC)) {
flags |= (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC);
}
memcpy(tcmdPtr->command, command, length+1);
name = TclGetString(objv[3]);
if (Tcl_TraceCommand(interp, name, flags, TraceCommandProc,
tcmdPtr) != TCL_OK) {
Tcl_Free(tcmdPtr);
return TCL_ERROR;
}
} else {
/*
* Search through all of our traces on this command to see if
* there's one with the given command. If so, then delete the
* first one that matches.
*/
ClientData clientData;
/*
* First ensure the name given is valid.
*/
name = 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 = clientData;
/*
* In checking the 'flags' field we must remove any extraneous
* flags which may have been temporarily added by various
* pieces of the trace mechanism.
*/
if ((tcmdPtr->length == length)
&& ((tcmdPtr->flags & (TCL_TRACE_ANY_EXEC |
TCL_TRACE_RENAME | TCL_TRACE_DELETE)) == flags)
&& (strncmp(command, tcmdPtr->command,
length) == 0)) {
flags |= TCL_TRACE_DELETE;
if (flags & (TCL_TRACE_ENTER_DURING_EXEC |
TCL_TRACE_LEAVE_DURING_EXEC)) {
flags |= (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC);
}
Tcl_UntraceCommand(interp, name, flags,
TraceCommandProc, clientData);
if (tcmdPtr->stepTrace != NULL) {
/*
* We need to remove the interpreter-wide trace which
* we created to allow 'step' traces.
*/
Tcl_DeleteTrace(interp, tcmdPtr->stepTrace);
tcmdPtr->stepTrace = NULL;
Tcl_Free(tcmdPtr->startCmd);
}
if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) {
/*
* Postpone deletion.
*/
tcmdPtr->flags = 0;
}
if (tcmdPtr->refCount-- <= 1) {
Tcl_Free(tcmdPtr);
}
break;
}
}
}
break;
}
case TRACE_INFO: {
ClientData clientData;
Tcl_Obj *resultListPtr;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 3, objv, "name");
return TCL_ERROR;
}
name = TclGetString(objv[3]);
/*
* First ensure the name given is valid.
*/
if (Tcl_FindCommand(interp, name, NULL, TCL_LEAVE_ERR_MSG) == NULL) {
return TCL_ERROR;
|
| ︙ | ︙ | |||
645 646 647 648 649 650 651 |
static int
TraceCommandObjCmd(
Tcl_Interp *interp, /* Current interpreter. */
int optionIndex, /* Add, info or remove */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
| | | | 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 |
static int
TraceCommandObjCmd(
Tcl_Interp *interp, /* Current interpreter. */
int optionIndex, /* Add, info or remove */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int index;
const char *name, *command;
size_t commandLength, length;
enum traceOptions { TRACE_ADD, TRACE_INFO, TRACE_REMOVE };
static const char *const opStrings[] = { "delete", "rename", NULL };
enum operations { TRACE_CMD_DELETE, TRACE_CMD_RENAME };
switch ((enum traceOptions) optionIndex) {
case TRACE_ADD:
case TRACE_REMOVE: {
|
| ︙ | ︙ | |||
698 699 700 701 702 703 704 | case TRACE_CMD_DELETE: flags |= TCL_TRACE_DELETE; break; } } command = TclGetStringFromObj(objv[5], &commandLength); | | | | | | | | | | | 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 |
case TRACE_CMD_DELETE:
flags |= TCL_TRACE_DELETE;
break;
}
}
command = TclGetStringFromObj(objv[5], &commandLength);
length = commandLength;
if ((enum traceOptions) optionIndex == TRACE_ADD) {
TraceCommandInfo *tcmdPtr = Tcl_Alloc(
offsetof(TraceCommandInfo, command) + 1 + length);
tcmdPtr->flags = flags;
tcmdPtr->stepTrace = NULL;
tcmdPtr->startLevel = 0;
tcmdPtr->startCmd = NULL;
tcmdPtr->length = length;
tcmdPtr->refCount = 1;
flags |= TCL_TRACE_DELETE;
memcpy(tcmdPtr->command, command, length+1);
name = TclGetString(objv[3]);
if (Tcl_TraceCommand(interp, name, flags, TraceCommandProc,
tcmdPtr) != TCL_OK) {
Tcl_Free(tcmdPtr);
return TCL_ERROR;
}
} else {
/*
* Search through all of our traces on this command to see if
* there's one with the given command. If so, then delete the
* first one that matches.
*/
ClientData clientData;
/*
* First ensure the name given is valid.
*/
name = 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 = clientData;
if ((tcmdPtr->length == length) && (tcmdPtr->flags == flags)
&& (strncmp(command, tcmdPtr->command,
length) == 0)) {
Tcl_UntraceCommand(interp, name, flags | TCL_TRACE_DELETE,
TraceCommandProc, clientData);
tcmdPtr->flags |= TCL_TRACE_DESTROYED;
if (tcmdPtr->refCount-- <= 1) {
Tcl_Free(tcmdPtr);
}
break;
}
}
}
break;
}
case TRACE_INFO: {
ClientData clientData;
Tcl_Obj *resultListPtr;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 3, objv, "name");
return TCL_ERROR;
}
/*
* First ensure the name given is valid.
*/
name = 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) {
int numOps = 0;
|
| ︙ | ︙ | |||
839 840 841 842 843 844 845 |
static int
TraceVariableObjCmd(
Tcl_Interp *interp, /* Current interpreter. */
int optionIndex, /* Add, info or remove */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
| | | | 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 |
static int
TraceVariableObjCmd(
Tcl_Interp *interp, /* Current interpreter. */
int optionIndex, /* Add, info or remove */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int index;
const char *name, *command;
size_t commandLength, length;
ClientData clientData;
enum traceOptions { TRACE_ADD, TRACE_INFO, TRACE_REMOVE };
static const char *const opStrings[] = {
"array", "read", "unset", "write", NULL
};
enum operations {
TRACE_VAR_ARRAY, TRACE_VAR_READ, TRACE_VAR_UNSET, TRACE_VAR_WRITE
|
| ︙ | ︙ | |||
901 902 903 904 905 906 907 | break; case TRACE_VAR_WRITE: flags |= TCL_TRACE_WRITES; break; } } command = TclGetStringFromObj(objv[5], &commandLength); | | | | > > | | | | > > > > | | | 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 |
break;
case TRACE_VAR_WRITE:
flags |= TCL_TRACE_WRITES;
break;
}
}
command = TclGetStringFromObj(objv[5], &commandLength);
length = commandLength;
if ((enum traceOptions) optionIndex == TRACE_ADD) {
CombinedTraceVarInfo *ctvarPtr = Tcl_Alloc(
offsetof(CombinedTraceVarInfo, traceCmdInfo.command)
+ 1 + length);
ctvarPtr->traceCmdInfo.flags = flags;
#ifndef TCL_REMOVE_OBSOLETE_TRACES
if (objv[0] == NULL) {
ctvarPtr->traceCmdInfo.flags |= TCL_TRACE_OLD_STYLE;
}
#endif
ctvarPtr->traceCmdInfo.length = length;
flags |= TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT;
memcpy(ctvarPtr->traceCmdInfo.command, command, length+1);
ctvarPtr->traceInfo.traceProc = TraceVarProc;
ctvarPtr->traceInfo.clientData = &ctvarPtr->traceCmdInfo;
ctvarPtr->traceInfo.flags = flags;
name = TclGetString(objv[3]);
if (TraceVarEx(interp, name, NULL, (VarTrace *) ctvarPtr)
!= TCL_OK) {
Tcl_Free(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 = clientData;
if ((tvarPtr->length == length)
&& ((tvarPtr->flags
#ifndef TCL_REMOVE_OBSOLETE_TRACES
& ~TCL_TRACE_OLD_STYLE
#endif
)==flags)
&& (strncmp(command, tvarPtr->command,
length) == 0)) {
Tcl_UntraceVar2(interp, name, NULL,
flags | TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT,
TraceVarProc, clientData);
break;
}
}
}
break;
}
case TRACE_INFO: {
Tcl_Obj *resultListPtr;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 3, objv, "name");
return TCL_ERROR;
}
resultListPtr = Tcl_NewObj();
name = TclGetString(objv[3]);
FOREACH_VAR_TRACE(interp, name, clientData) {
Tcl_Obj *opObjPtr, *eachTraceObjPtr, *elemObjPtr;
TraceVarInfo *tvarPtr = 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
|
| ︙ | ︙ | |||
1114 1115 1116 1117 1118 1119 1120 |
return TCL_ERROR;
}
/*
* Set up trace information.
*/
| | | 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 |
return TCL_ERROR;
}
/*
* Set up trace information.
*/
tracePtr = Tcl_Alloc(sizeof(CommandTrace));
tracePtr->traceProc = proc;
tracePtr->clientData = clientData;
tracePtr->flags = flags &
(TCL_TRACE_RENAME | TCL_TRACE_DELETE | TCL_TRACE_ANY_EXEC);
tracePtr->nextPtr = cmdPtr->tracePtr;
tracePtr->refCount = 1;
cmdPtr->tracePtr = tracePtr;
|
| ︙ | ︙ | |||
1220 1221 1222 1223 1224 1225 1226 |
cmdPtr->tracePtr = tracePtr->nextPtr;
} else {
prevPtr->nextPtr = tracePtr->nextPtr;
}
tracePtr->flags = 0;
if (tracePtr->refCount-- <= 1) {
| | | 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 |
cmdPtr->tracePtr = tracePtr->nextPtr;
} else {
prevPtr->nextPtr = tracePtr->nextPtr;
}
tracePtr->flags = 0;
if (tracePtr->refCount-- <= 1) {
Tcl_Free(tracePtr);
}
if (hasExecTraces) {
for (tracePtr = cmdPtr->tracePtr, prevPtr = NULL; tracePtr != NULL ;
prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) {
if (tracePtr->flags & TCL_TRACE_ANY_EXEC) {
return;
|
| ︙ | ︙ | |||
1293 1294 1295 1296 1297 1298 1299 |
&& !Tcl_LimitExceeded(interp)) {
/*
* Generate a command to execute by appending list elements for the
* old and new command name and the operation.
*/
Tcl_DStringInit(&cmd);
| | | 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 |
&& !Tcl_LimitExceeded(interp)) {
/*
* Generate a command to execute by appending list elements for the
* old and new command name and the operation.
*/
Tcl_DStringInit(&cmd);
Tcl_DStringAppend(&cmd, tcmdPtr->command, tcmdPtr->length);
Tcl_DStringAppendElement(&cmd, oldName);
Tcl_DStringAppendElement(&cmd, (newName ? newName : ""));
if (flags & TCL_TRACE_RENAME) {
TclDStringAppendLiteral(&cmd, " rename");
} else if (flags & TCL_TRACE_DELETE) {
TclDStringAppendLiteral(&cmd, " delete");
}
|
| ︙ | ︙ | |||
1335 1336 1337 1338 1339 1340 1341 |
if (flags & (TCL_TRACE_DESTROYED | TCL_TRACE_DELETE)) {
int untraceFlags = tcmdPtr->flags;
Tcl_InterpState state;
if (tcmdPtr->stepTrace != NULL) {
Tcl_DeleteTrace(interp, tcmdPtr->stepTrace);
tcmdPtr->stepTrace = NULL;
| < | < | 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 |
if (flags & (TCL_TRACE_DESTROYED | TCL_TRACE_DELETE)) {
int untraceFlags = tcmdPtr->flags;
Tcl_InterpState state;
if (tcmdPtr->stepTrace != NULL) {
Tcl_DeleteTrace(interp, tcmdPtr->stepTrace);
tcmdPtr->stepTrace = NULL;
Tcl_Free(tcmdPtr->startCmd);
}
if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) {
/*
* Postpone deletion, until exec trace returns.
*/
tcmdPtr->flags = 0;
|
| ︙ | ︙ | |||
1379 1380 1381 1382 1383 1384 1385 |
state = Tcl_SaveInterpState(interp, TCL_OK);
Tcl_UntraceCommand(interp, oldName, untraceFlags,
TraceCommandProc, clientData);
Tcl_RestoreInterpState(interp, state);
tcmdPtr->refCount--;
}
if (tcmdPtr->refCount-- <= 1) {
| | | 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 |
state = Tcl_SaveInterpState(interp, TCL_OK);
Tcl_UntraceCommand(interp, oldName, untraceFlags,
TraceCommandProc, clientData);
Tcl_RestoreInterpState(interp, state);
tcmdPtr->refCount--;
}
if (tcmdPtr->refCount-- <= 1) {
Tcl_Free(tcmdPtr);
}
}
/*
*----------------------------------------------------------------------
*
* TclCheckExecutionTraces --
|
| ︙ | ︙ | |||
1413 1414 1415 1416 1417 1418 1419 |
*/
int
TclCheckExecutionTraces(
Tcl_Interp *interp, /* The current interpreter. */
const char *command, /* Pointer to beginning of the current command
* string. */
| | | 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 |
*/
int
TclCheckExecutionTraces(
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
* 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. */
{
|
| ︙ | ︙ | |||
1471 1472 1473 1474 1475 1476 1477 |
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) {
| | | 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 |
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);
}
}
}
if (active.nextTracePtr) {
lastTracePtr = active.nextTracePtr->nextPtr;
}
}
|
| ︙ | ︙ | |||
1519 1520 1521 1522 1523 1524 1525 |
*/
int
TclCheckInterpTraces(
Tcl_Interp *interp, /* The current interpreter. */
const char *command, /* Pointer to beginning of the current command
* string. */
| | | 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 |
*/
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
* 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. */
{
|
| ︙ | ︙ | |||
1666 1667 1668 1669 1670 1671 1672 |
static int
CallTraceFunction(
Tcl_Interp *interp, /* The current interpreter. */
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. */
| | | | | 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 |
static int
CallTraceFunction(
Tcl_Interp *interp, /* The current interpreter. */
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
* source. */
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;
/*
* Copy the command characters into a new string.
*/
commandCopy = TclStackAlloc(interp, numChars + 1);
memcpy(commandCopy, command, numChars);
commandCopy[numChars] = '\0';
/*
* Call the trace function then free allocated storage.
*/
traceCode = tracePtr->proc(tracePtr->clientData, (Tcl_Interp *) iPtr,
|
| ︙ | ︙ | |||
1718 1719 1720 1721 1722 1723 1724 |
static void
CommandObjTraceDeleted(
ClientData clientData)
{
TraceCommandInfo *tcmdPtr = clientData;
if (tcmdPtr->refCount-- <= 1) {
| | | 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 |
static void
CommandObjTraceDeleted(
ClientData clientData)
{
TraceCommandInfo *tcmdPtr = clientData;
if (tcmdPtr->refCount-- <= 1) {
Tcl_Free(tcmdPtr);
}
}
/*
*----------------------------------------------------------------------
*
* TraceExecutionProc --
|
| ︙ | ︙ | |||
1800 1801 1802 1803 1804 1805 1806 |
*/
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;
| < | < | | | 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 |
*/
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);
}
/*
* Second, create the tcl callback, if required.
*/
if (call) {
Tcl_DString cmd, sub;
int i, saveInterpFlags;
Tcl_DStringInit(&cmd);
Tcl_DStringAppend(&cmd, tcmdPtr->command, tcmdPtr->length);
/*
* Append command with arguments.
*/
Tcl_DStringInit(&sub);
for (i = 0; i < objc; i++) {
Tcl_DStringAppendElement(&sub, TclGetString(objv[i]));
}
Tcl_DStringAppendElement(&cmd, Tcl_DStringValue(&sub));
Tcl_DStringFree(&sub);
if (flags & TCL_TRACE_ENTER_EXEC) {
/*
* Append trace operation.
|
| ︙ | ︙ | |||
1846 1847 1848 1849 1850 1851 1852 | const char *resultCodeStr; /* * Append result code. */ resultCode = Tcl_NewLongObj(code); | | | 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 | const char *resultCodeStr; /* * Append result code. */ resultCode = Tcl_NewLongObj(code); resultCodeStr = TclGetString(resultCode); Tcl_DStringAppendElement(&cmd, resultCodeStr); Tcl_DecrRefCount(resultCode); /* * Append result string. */ |
| ︙ | ︙ | |||
1915 1916 1917 1918 1919 1920 1921 |
if ((flags & TCL_TRACE_ENTER_EXEC) && (tcmdPtr->stepTrace == NULL)
&& (tcmdPtr->flags & (TCL_TRACE_ENTER_DURING_EXEC |
TCL_TRACE_LEAVE_DURING_EXEC))) {
register unsigned len = strlen(command) + 1;
tcmdPtr->startLevel = level;
| | < | < | | 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 |
if ((flags & TCL_TRACE_ENTER_EXEC) && (tcmdPtr->stepTrace == NULL)
&& (tcmdPtr->flags & (TCL_TRACE_ENTER_DURING_EXEC |
TCL_TRACE_LEAVE_DURING_EXEC))) {
register unsigned len = strlen(command) + 1;
tcmdPtr->startLevel = level;
tcmdPtr->startCmd = Tcl_Alloc(len);
memcpy(tcmdPtr->startCmd, command, len);
tcmdPtr->refCount++;
tcmdPtr->stepTrace = Tcl_CreateObjTrace(interp, 0,
(tcmdPtr->flags & TCL_TRACE_ANY_EXEC) >> 2,
TraceExecutionProc, tcmdPtr, CommandObjTraceDeleted);
}
}
if (flags & TCL_TRACE_DESTROYED) {
if (tcmdPtr->stepTrace != NULL) {
Tcl_DeleteTrace(interp, tcmdPtr->stepTrace);
tcmdPtr->stepTrace = NULL;
Tcl_Free(tcmdPtr->startCmd);
}
}
if (call) {
if (tcmdPtr->refCount-- <= 1) {
Tcl_Free(tcmdPtr);
}
}
return traceCode;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
1985 1986 1987 1988 1989 1990 1991 |
* 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)) {
| | | | 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 |
* 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) {
/*
* 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_DStringAppendElement(&cmd, name1);
Tcl_DStringAppendElement(&cmd, (name2 ? name2 : ""));
#ifndef TCL_REMOVE_OBSOLETE_TRACES
if (tvarPtr->flags & TCL_TRACE_OLD_STYLE) {
if (flags & TCL_TRACE_ARRAY) {
TclDStringAppendLiteral(&cmd, " a");
} else if (flags & TCL_TRACE_READS) {
|
| ︙ | ︙ | |||
2161 2162 2163 2164 2165 2166 2167 |
iPtr->compileEpoch++;
iPtr->flags |= DONT_COMPILE_CMDS_INLINE;
}
iPtr->tracesForbiddingInline++;
}
| | | 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 |
iPtr->compileEpoch++;
iPtr->flags |= DONT_COMPILE_CMDS_INLINE;
}
iPtr->tracesForbiddingInline++;
}
tracePtr = Tcl_Alloc(sizeof(Trace));
tracePtr->level = level;
tracePtr->proc = proc;
tracePtr->clientData = clientData;
tracePtr->delProc = delProc;
tracePtr->nextPtr = iPtr->tracePtr;
tracePtr->flags = flags;
iPtr->tracePtr = tracePtr;
|
| ︙ | ︙ | |||
2224 2225 2226 2227 2228 2229 2230 |
Tcl_Interp *interp, /* Interpreter in which to create trace. */
int level, /* Only call proc for commands at nesting
* level<=argument level (1=>top level). */
Tcl_CmdTraceProc *proc, /* Function to call before executing each
* command. */
ClientData clientData) /* Arbitrary value word to pass to proc. */
{
| | | 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 |
Tcl_Interp *interp, /* Interpreter in which to create trace. */
int level, /* Only call proc for commands at nesting
* level<=argument level (1=>top level). */
Tcl_CmdTraceProc *proc, /* Function to call before executing each
* command. */
ClientData clientData) /* Arbitrary value word to pass to proc. */
{
StringTraceData *data = Tcl_Alloc(sizeof(StringTraceData));
data->clientData = clientData;
data->proc = proc;
return Tcl_CreateObjTrace(interp, level, 0, StringTraceProc,
data, StringTraceDeleteProc);
}
|
| ︙ | ︙ | |||
2269 2270 2271 2272 2273 2274 2275 |
/*
* This is a bit messy because we have to emulate the old trace interface,
* which uses strings for everything.
*/
argv = (const char **) TclStackAlloc(interp,
| | | | 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 |
/*
* This is a bit messy because we have to emulate the old trace interface,
* which uses strings for everything.
*/
argv = (const char **) TclStackAlloc(interp,
(objc + 1) * sizeof(const char *));
for (i = 0; i < objc; i++) {
argv[i] = TclGetString(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.
|
| ︙ | ︙ | |||
2308 2309 2310 2311 2312 2313 2314 |
*----------------------------------------------------------------------
*/
static void
StringTraceDeleteProc(
ClientData clientData)
{
| | | 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 |
*----------------------------------------------------------------------
*/
static void
StringTraceDeleteProc(
ClientData clientData)
{
Tcl_Free(clientData);
}
/*
*----------------------------------------------------------------------
*
* Tcl_DeleteTrace --
*
|
| ︙ | ︙ | |||
2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 |
if (TclIsVarUndefined(varPtr)) {
TclCleanupVar(varPtr, arrayPtr);
return NULL;
}
return varPtr;
}
/*
*----------------------------------------------------------------------
*
* TclCallVarTraces --
*
* This function is invoked to find and invoke relevant trace functions
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 |
if (TclIsVarUndefined(varPtr)) {
TclCleanupVar(varPtr, arrayPtr);
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 --
*
* This function is invoked to find and invoke relevant trace functions
|
| ︙ | ︙ | |||
2733 2734 2735 2736 2737 2738 2739 |
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,
| | | 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 |
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));
} else {
TclVarErrMsg((Tcl_Interp *) iPtr, part1, part2, verb, result);
}
iPtr->flags &= ~(ERR_ALREADY_LOGGED);
Tcl_DiscardInterpState(state);
} else {
Tcl_RestoreInterpState((Tcl_Interp *) iPtr, state);
|
| ︙ | ︙ | |||
2792 2793 2794 2795 2796 2797 2798 |
DisposeTraceResult(
int flags, /* Indicates type of result to determine
* proper disposal method. */
char *result) /* The result returned from a trace function
* to be disposed. */
{
if (flags & TCL_TRACE_RESULT_DYNAMIC) {
| | | 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 |
DisposeTraceResult(
int flags, /* Indicates type of result to determine
* proper disposal method. */
char *result) /* The result returned from a trace function
* to be disposed. */
{
if (flags & TCL_TRACE_RESULT_DYNAMIC) {
Tcl_Free(result);
} else if (flags & TCL_TRACE_RESULT_OBJECT) {
Tcl_DecrRefCount((Tcl_Obj *) result);
}
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
3038 3039 3040 3041 3042 3043 3044 |
Tcl_VarTraceProc *proc, /* Function to call when specified ops are
* invoked upon varName. */
ClientData clientData) /* Arbitrary argument to pass to proc. */
{
register VarTrace *tracePtr;
int result;
| | | | 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 |
Tcl_VarTraceProc *proc, /* Function to call when specified ops are
* invoked upon varName. */
ClientData clientData) /* Arbitrary argument to pass to proc. */
{
register VarTrace *tracePtr;
int result;
tracePtr = Tcl_Alloc(sizeof(VarTrace));
tracePtr->traceProc = proc;
tracePtr->clientData = clientData;
tracePtr->flags = flags;
result = TraceVarEx(interp, part1, part2, tracePtr);
if (result != TCL_OK) {
Tcl_Free(tracePtr);
}
return result;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
3082 3083 3084 3085 3086 3087 3088 |
* 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. */
register VarTrace *tracePtr)/* Structure containing flags, traceProc and
* clientData fields. Others should be left
| | | 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 |
* 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. */
register VarTrace *tracePtr)/* Structure containing flags, traceProc and
* clientData fields. Others should be left
* blank. Will be Tcl_Free()d (eventually) if
* this function returns TCL_OK, and up to
* caller to free if this function returns
* TCL_ERROR. */
{
Interp *iPtr = (Interp *) interp;
Var *varPtr, *arrayPtr;
int flagMask, isNew;
|
| ︙ | ︙ |
Changes to generic/tclUniData.c.
| ︙ | ︙ | |||
38 39 40 41 42 43 44 |
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, 1824, 1824, 5120, 5152, 5184, 5216, 5248, 5280,
| | | | | | | | | | | | | | | | | | 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 |
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, 1824, 1824, 5120, 5152, 5184, 5216, 5248, 5280,
1344, 5312, 1344, 5344, 5376, 5408, 5440, 5472, 5504, 5536, 5568, 5600,
5632, 5664, 5696, 5632, 704, 5728, 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, 1824, 7936, 4928, 4928, 7968, 4928, 4928, 4928,
4928, 4928, 4928, 8000, 8032, 8064, 8096, 3232, 1344, 8128, 4192, 1344,
8160, 8192, 8224, 1344, 1344, 8256, 8288, 4928, 8320, 8352, 8384, 8416,
4928, 8384, 8448, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928,
4928, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
|
| ︙ | ︙ | |||
126 127 128 129 130 131 132 |
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
| | | | | | 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 |
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
8480, 8512, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 8544, 4928, 8576, 5408, 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, 9280, 1952, 9312, 9344, 9376, 1344, 9408, 9440,
9472, 1344, 9504, 9536, 9568, 9600, 9632, 9664, 9696, 9728, 9728, 1344,
9760, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
|
| ︙ | ︙ | |||
191 192 193 194 195 196 197 |
9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920,
9920, 9920, 9920, 9920, 9920, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 9952, 1344, 1344, 9984, 1824, 10016, 10048,
10080, 1344, 1344, 10112, 10144, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 10176, 10208, 1344, 10240, 1344, 10272, 10304,
10336, 10368, 10400, 10432, 1344, 1344, 1344, 10464, 10496, 64, 10528,
10560, 10592, 4736, 10624, 10656
| | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | > > > > > > > > | | > > > > > > > > > > > > > > > > > > | | | | | > > > > > > > > > > > > > > > > > > | | | > > > > > | > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 |
9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920,
9920, 9920, 9920, 9920, 9920, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 9952, 1344, 1344, 9984, 1824, 10016, 10048,
10080, 1344, 1344, 10112, 10144, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 10176, 10208, 1344, 10240, 1344, 10272, 10304,
10336, 10368, 10400, 10432, 1344, 1344, 1344, 10464, 10496, 64, 10528,
10560, 10592, 4736, 10624, 10656
#if TCL_UTF_MAX > 3 || TCL_MAJOR_VERSION > 8 || TCL_MINOR_VERSION > 6
,10688, 10720, 10752, 1824, 1344, 1344, 1344, 8288, 10784, 10816, 10848,
10880, 10912, 10944, 10976, 11008, 1824, 1824, 1824, 1824, 9280, 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, 7776, 4704, 10272, 1824, 1824, 1824, 1824,
11552, 11584, 11616, 11648, 4736, 11680, 1824, 11712, 11744, 11776,
1824, 1824, 1344, 11808, 11840, 6880, 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, 1824,
1824, 1824, 1824, 12000, 12480, 12512, 1824, 1824, 1824, 1824, 7776,
12544, 12576, 12608, 12640, 5248, 12672, 12704, 12736, 12768, 12800,
12832, 12864, 5248, 12896, 12928, 12960, 12992, 13024, 1824, 1824,
13056, 13088, 13120, 13152, 13184, 13216, 13248, 13280, 1824, 1824,
1824, 1824, 1344, 13312, 13344, 1824, 1344, 13376, 13408, 1824, 1824,
1824, 1824, 1824, 1344, 13440, 13472, 1824, 1344, 13504, 13536, 13568,
1344, 13600, 13632, 1824, 4032, 13664, 1824, 1824, 1824, 1824, 1824,
1824, 1344, 13696, 1824, 1824, 1824, 13728, 13760, 13792, 1824, 1824,
1824, 1824, 1824, 13824, 13856, 13888, 13920, 13952, 13984, 1344, 14016,
14048, 1344, 4608, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
14080, 14112, 14144, 14176, 14208, 14240, 1824, 1824, 14272, 14304,
14336, 14368, 14400, 13632, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 14432, 1824, 1824, 1824, 1824, 1824, 1824, 14464, 14496,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 9984, 1824, 1824, 1824, 10848, 10848, 10848,
14528, 1344, 1344, 1344, 1344, 1344, 1344, 14560, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 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, 14592, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 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, 14624, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 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, 14656,
1824, 1824, 10208, 14688, 1344, 14720, 14752, 14784, 8480, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 13728, 13760, 14816, 1824,
1824, 1824, 1344, 1344, 14848, 14880, 14912, 1824, 1824, 14944, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 14976,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 15008,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 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, 15040, 15072, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 9856, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 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,
15104, 15136, 15168, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 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, 8000, 4928, 15200,
4928, 15232, 15264, 15296, 4928, 15328, 4928, 4928, 15360, 1824, 1824,
1824, 1824, 15392, 4928, 4928, 15424, 15456, 1824, 1824, 1824, 1824,
15488, 15520, 15552, 15584, 15616, 15648, 15680, 15712, 15744, 15776,
15808, 15840, 15872, 15488, 15520, 15904, 15584, 15936, 15968, 16000,
15712, 16032, 16064, 16096, 16128, 16160, 16192, 16224, 16256, 16288,
16320, 16352, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928,
4928, 4928, 4928, 4928, 4928, 4928, 4928, 704, 16384, 704, 16416, 16448,
16480, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 16512, 16544, 1824,
1824, 1824, 1824, 1824, 1824, 1344, 16576, 16608, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1344, 16640, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 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, 16672, 1824,
16704, 16736, 16768, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 16800, 6880, 16832, 1824, 1824, 16864, 16896,
1824, 1824, 1824, 1824, 1824, 1824, 16928, 16960, 16992, 17024, 17056,
17088, 1824, 17120, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
4928, 17152, 4928, 4928, 7968, 17184, 17216, 8000, 17248, 4928, 4928,
17280, 4928, 17312, 1824, 17344, 17376, 17408, 17440, 17472, 1824,
1824, 1824, 1824, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 17504,
4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928,
4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 8000, 17536,
4928, 4928, 4928, 7968, 4928, 4928, 17568, 17600, 17152, 4928, 17632,
4928, 17664, 17696, 1824, 1824, 17728, 4928, 4928, 17760, 4928, 17792,
17824, 4928, 4928, 4928, 7968, 17856, 17888, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 7776, 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, 17920, 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, 17952, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 17984, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 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
#endif /* TCL_UTF_MAX > 3 */
};
/*
* The groupMap is indexed by combining the alternate page number with
* the page offset and returns a group number that identifies a unique
* set of character attributes.
|
| ︙ | ︙ | |||
577 578 579 580 581 582 583 |
24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24,
21, 48, 49, 50, 23, 24, 52, 53, 23, 24, 23, 24, 23, 24, 23, 24, 54,
21, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24,
23, 24, 21, 21, 21, 21, 21, 21, 55, 23, 24, 56, 57, 58, 58, 23, 24,
59, 60, 61, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 62, 63, 64, 65,
66, 21, 67, 67, 21, 68, 21, 69, 70, 21, 21, 21, 67, 71, 21, 72, 21,
73, 74, 21, 75, 76, 74, 77, 78, 21, 21, 76, 21, 79, 80, 21, 21, 81,
| | | | | | | | | | | | | | | | | | | | | | | | | | | < < < | > > > | < < > > | | | | | | | < > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > > > > > > | | < < < < < < < | | | | | | | > > | > > > > > < < < < < < < | < > | | | < > | | | | | | | | | | | | | | | | | | | | | | | | | | | > | | | | < | | | > | < | > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > > | < > | | | | | | | < | | | > | | | | | | | | | < | | > | | | | | | | | | | | | | | | | | | | | | | | | 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 |
24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24,
21, 48, 49, 50, 23, 24, 52, 53, 23, 24, 23, 24, 23, 24, 23, 24, 54,
21, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24,
23, 24, 21, 21, 21, 21, 21, 21, 55, 23, 24, 56, 57, 58, 58, 23, 24,
59, 60, 61, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 62, 63, 64, 65,
66, 21, 67, 67, 21, 68, 21, 69, 70, 21, 21, 21, 67, 71, 21, 72, 21,
73, 74, 21, 75, 76, 74, 77, 78, 21, 21, 76, 21, 79, 80, 21, 21, 81,
21, 21, 21, 21, 21, 21, 21, 82, 21, 21, 83, 21, 84, 83, 21, 21, 21,
85, 83, 86, 87, 87, 88, 21, 21, 21, 21, 21, 89, 21, 15, 21, 21, 21,
21, 21, 21, 21, 21, 90, 91, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92,
92, 92, 92, 92, 92, 92, 92, 92, 11, 11, 11, 11, 92, 92, 92, 92, 92,
92, 92, 92, 92, 92, 92, 92, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11,
11, 11, 11, 11, 92, 92, 92, 92, 92, 11, 11, 11, 11, 11, 11, 11, 92,
11, 92, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11,
11, 11, 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, 94, 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, 23, 24, 23,
24, 92, 11, 23, 24, 0, 0, 92, 42, 42, 42, 3, 95, 0, 0, 0, 0, 11, 11,
96, 3, 97, 97, 97, 0, 98, 0, 99, 99, 21, 10, 10, 10, 10, 10, 10, 10,
10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 0, 10, 10, 10, 10, 10, 10,
10, 10, 10, 100, 101, 101, 101, 21, 13, 13, 13, 13, 13, 13, 13, 13,
13, 13, 13, 13, 13, 13, 13, 13, 13, 102, 13, 13, 13, 13, 13, 13, 13,
13, 13, 103, 104, 104, 105, 106, 107, 108, 108, 108, 109, 110, 111,
23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23,
24, 23, 24, 23, 24, 23, 24, 112, 113, 114, 115, 116, 117, 7, 23, 24,
118, 23, 24, 21, 54, 54, 54, 119, 119, 119, 119, 119, 119, 119, 119,
119, 119, 119, 119, 119, 119, 119, 119, 10, 10, 10, 10, 10, 10, 10,
10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10,
10, 10, 10, 10, 10, 10, 10, 10, 13, 13, 13, 13, 13, 13, 13, 13, 13,
13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13,
13, 13, 13, 13, 13, 13, 113, 113, 113, 113, 113, 113, 113, 113, 113,
113, 113, 113, 113, 113, 113, 113, 23, 24, 14, 93, 93, 93, 93, 93,
120, 120, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23,
24, 23, 24, 23, 24, 23, 24, 121, 23, 24, 23, 24, 23, 24, 23, 24, 23,
24, 23, 24, 23, 24, 122, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23,
24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24,
23, 24, 23, 24, 0, 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, 0, 92, 3, 3, 3, 3, 3, 3, 21, 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, 21, 21, 3, 8, 0, 0, 14, 14, 4, 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, 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,
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,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 3, 15, 93, 93, 93, 93, 93, 93, 93, 17, 14, 93, 93, 93, 93,
93, 93, 92, 92, 93, 93, 14, 93, 93, 93, 93, 15, 15, 9, 9, 9, 9, 9,
9, 9, 9, 9, 9, 15, 15, 15, 14, 14, 15, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3,
3, 3, 3, 3, 0, 17, 15, 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, 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, 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, 93, 93, 93, 93, 93, 93, 93, 93, 15,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9,
9, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
93, 93, 93, 93, 93, 93, 93, 93, 93, 92, 92, 14, 3, 3, 3, 92, 0, 0,
93, 4, 4, 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, 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, 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, 93, 17,
93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93,
93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 125, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 93, 125, 93, 15, 125, 125, 125, 93, 93, 93, 93, 93, 93, 93,
93, 125, 125, 125, 125, 93, 125, 125, 15, 93, 93, 93, 93, 93, 93, 93,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 93, 93, 3, 3, 9, 9, 9, 9, 9,
9, 9, 9, 9, 9, 3, 92, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 93, 125, 125, 0, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0,
15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 0, 15,
0, 0, 0, 15, 15, 15, 15, 0, 0, 93, 15, 125, 125, 125, 93, 93, 93, 93,
0, 0, 125, 125, 0, 0, 125, 125, 93, 15, 0, 0, 0, 0, 0, 0, 0, 0, 125,
0, 0, 0, 0, 15, 15, 0, 15, 15, 15, 93, 93, 0, 0, 9, 9, 9, 9, 9, 9,
9, 9, 9, 9, 15, 15, 4, 4, 18, 18, 18, 18, 18, 18, 14, 4, 15, 3, 93,
0, 0, 93, 93, 125, 0, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 15, 15, 0,
0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 0,
15, 15, 0, 15, 15, 0, 0, 93, 0, 125, 125, 125, 93, 93, 0, 0, 0, 0,
93, 93, 0, 0, 93, 93, 93, 0, 0, 0, 93, 0, 0, 0, 0, 0, 0, 0, 15, 15,
15, 15, 0, 15, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 93,
93, 15, 15, 15, 93, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 93, 93, 125, 0,
15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 0, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 0, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 0, 15, 15, 15, 15, 15,
0, 0, 93, 15, 125, 125, 125, 93, 93, 93, 93, 93, 0, 93, 93, 125, 0,
125, 125, 93, 0, 0, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
15, 15, 93, 93, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 3, 4, 0, 0, 0,
0, 0, 0, 0, 15, 93, 93, 93, 93, 93, 93, 0, 93, 125, 125, 0, 15, 15,
15, 15, 15, 15, 15, 15, 0, 0, 15, 15, 0, 0, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0,
15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 0, 15, 15, 15, 15, 15, 0, 0,
93, 15, 125, 93, 125, 93, 93, 93, 93, 0, 0, 125, 125, 0, 0, 125, 125,
93, 0, 0, 0, 0, 0, 0, 0, 0, 93, 125, 0, 0, 0, 0, 15, 15, 0, 15, 15,
15, 93, 93, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 14, 15, 18, 18, 18,
18, 18, 18, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 93, 15, 0, 15, 15, 15, 15,
15, 15, 0, 0, 0, 15, 15, 15, 0, 15, 15, 15, 15, 0, 0, 0, 15, 15, 0,
15, 0, 15, 15, 0, 0, 0, 15, 15, 0, 0, 0, 15, 15, 15, 0, 0, 0, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 125, 125, 93, 125,
125, 0, 0, 0, 125, 125, 125, 0, 125, 125, 125, 93, 0, 0, 15, 0, 0,
0, 0, 0, 0, 125, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9,
9, 9, 9, 9, 9, 9, 9, 18, 18, 18, 14, 14, 14, 14, 14, 14, 4, 14, 0,
0, 0, 0, 0, 93, 125, 125, 125, 93, 15, 15, 15, 15, 15, 15, 15, 15,
0, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 15, 93, 93, 93, 125,
125, 125, 125, 0, 93, 93, 93, 0, 93, 93, 93, 93, 0, 0, 0, 0, 0, 0,
0, 93, 93, 0, 15, 15, 15, 0, 0, 0, 0, 0, 15, 15, 93, 93, 0, 0, 9, 9,
9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 0, 3, 18, 18, 18, 18, 18,
18, 18, 14, 15, 93, 125, 125, 3, 15, 15, 15, 15, 15, 15, 15, 15, 0,
15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 0, 0, 93, 15, 125, 93, 125,
125, 125, 125, 125, 0, 93, 125, 125, 0, 125, 125, 93, 93, 0, 0, 0,
0, 0, 0, 0, 125, 125, 0, 0, 0, 0, 0, 0, 0, 15, 0, 15, 15, 93, 93, 0,
0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 93, 93, 125, 125, 0, 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, 0, 125, 125, 0, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15,
0, 15, 0, 0, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 93, 0, 0, 0, 0, 125,
125, 125, 93, 93, 93, 0, 93, 0, 125, 125, 125, 125, 125, 125, 125,
125, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 125, 125,
3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 93, 15, 15, 93, 93, 93, 93, 93, 93, 93,
0, 0, 0, 0, 4, 15, 15, 15, 15, 15, 15, 92, 93, 93, 93, 93, 93, 93,
93, 93, 3, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 3, 3, 0, 0, 0, 0, 0, 15, 15,
0, 15, 0, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15,
0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 93, 15, 15, 93, 93, 93,
93, 93, 93, 93, 93, 93, 15, 0, 0, 15, 15, 15, 15, 15, 0, 92, 0, 93,
93, 93, 93, 93, 93, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 15, 15,
15, 15, 15, 14, 14, 14, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3,
14, 3, 14, 14, 14, 93, 93, 14, 14, 14, 14, 14, 14, 9, 9, 9, 9, 9, 9,
9, 9, 9, 9, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 14, 93, 14, 93,
14, 93, 5, 6, 5, 6, 125, 125, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 0, 0, 0, 0, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93,
93, 125, 93, 93, 93, 93, 93, 3, 93, 93, 15, 15, 15, 15, 15, 93, 93,
93, 93, 93, 93, 93, 93, 93, 93, 93, 0, 93, 93, 93, 93, 93, 93, 93,
93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93,
93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 0, 14, 14, 14, 14,
14, 14, 14, 14, 93, 14, 14, 14, 14, 14, 14, 0, 14, 14, 3, 3, 3, 3,
3, 14, 14, 14, 14, 3, 3, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 125, 125, 93, 93, 93, 93, 125, 93, 93, 93, 93, 93,
93, 125, 93, 93, 125, 125, 93, 93, 15, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9,
3, 3, 3, 3, 3, 3, 15, 15, 15, 15, 15, 15, 125, 125, 93, 93, 15, 15,
15, 15, 93, 93, 93, 15, 125, 125, 125, 15, 15, 125, 125, 125, 125,
125, 125, 125, 15, 15, 15, 93, 93, 93, 93, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 93, 125, 125, 93, 93, 125, 125, 125, 125,
125, 125, 93, 15, 125, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 125, 125, 125,
93, 14, 14, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126,
126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126,
126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 0,
126, 0, 0, 0, 0, 0, 126, 0, 0, 127, 127, 127, 127, 127, 127, 127, 127,
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,
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,
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, 0, 93,
93, 93, 93, 125, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
93, 125, 93, 93, 93, 93, 93, 125, 93, 125, 125, 125, 125, 125, 93,
125, 125, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9,
9, 9, 9, 9, 3, 3, 3, 3, 3, 3, 3, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 93, 93, 93, 93, 93, 93, 93, 93, 93, 14, 14, 14, 14, 14, 14, 14,
14, 14, 0, 0, 0, 93, 93, 125, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 125, 93, 93, 93, 93, 125, 125, 93, 93, 125, 93, 93, 93,
15, 15, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 93, 125, 93, 93, 125, 125, 125, 93, 125, 93, 93, 93,
125, 125, 0, 0, 0, 0, 0, 0, 0, 0, 3, 3, 3, 3, 15, 15, 15, 15, 125,
125, 125, 125, 125, 125, 125, 125, 93, 93, 93, 93, 93, 93, 93, 93,
125, 125, 93, 93, 0, 0, 0, 3, 3, 3, 3, 3, 9, 9, 9, 9, 9, 9, 9, 9, 9,
9, 0, 0, 0, 15, 15, 15, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 92, 92, 92, 92, 92, 92, 3, 3, 130,
131, 132, 133, 133, 134, 135, 136, 137, 0, 0, 0, 0, 0, 0, 0, 138, 138,
138, 138, 138, 138, 138, 138, 138, 138, 138, 138, 138, 138, 138, 138,
138, 138, 138, 138, 138, 138, 138, 138, 138, 138, 138, 138, 138, 138,
138, 138, 138, 138, 138, 138, 138, 138, 138, 138, 138, 138, 138, 0,
0, 138, 138, 138, 3, 3, 3, 3, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 93,
93, 93, 3, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 125,
93, 93, 93, 93, 93, 93, 93, 15, 15, 15, 15, 93, 15, 15, 15, 15, 15,
15, 93, 15, 15, 125, 93, 93, 15, 0, 0, 0, 0, 0, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92,
92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92,
92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92,
92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 92, 139, 21, 21,
21, 140, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 141, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 92, 92, 92,
92, 92, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93,
93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 0, 93, 93, 93, 93, 93,
23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23,
24, 23, 24, 23, 24, 21, 21, 21, 21, 21, 142, 21, 21, 143, 21, 144,
144, 144, 144, 144, 144, 144, 144, 145, 145, 145, 145, 145, 145, 145,
145, 144, 144, 144, 144, 144, 144, 0, 0, 145, 145, 145, 145, 145, 145,
0, 0, 144, 144, 144, 144, 144, 144, 144, 144, 145, 145, 145, 145, 145,
145, 145, 145, 144, 144, 144, 144, 144, 144, 144, 144, 145, 145, 145,
145, 145, 145, 145, 145, 144, 144, 144, 144, 144, 144, 0, 0, 145, 145,
145, 145, 145, 145, 0, 0, 21, 144, 21, 144, 21, 144, 21, 144, 0, 145,
0, 145, 0, 145, 0, 145, 144, 144, 144, 144, 144, 144, 144, 144, 145,
145, 145, 145, 145, 145, 145, 145, 146, 146, 147, 147, 147, 147, 148,
148, 149, 149, 150, 150, 151, 151, 0, 0, 144, 144, 144, 144, 144, 144,
144, 144, 152, 152, 152, 152, 152, 152, 152, 152, 144, 144, 144, 144,
144, 144, 144, 144, 152, 152, 152, 152, 152, 152, 152, 152, 144, 144,
144, 144, 144, 144, 144, 144, 152, 152, 152, 152, 152, 152, 152, 152,
144, 144, 21, 153, 21, 0, 21, 21, 145, 145, 154, 154, 155, 11, 156,
11, 11, 11, 21, 153, 21, 0, 21, 21, 157, 157, 157, 157, 155, 11, 11,
11, 144, 144, 21, 21, 0, 0, 21, 21, 145, 145, 158, 158, 0, 11, 11,
11, 144, 144, 21, 21, 21, 114, 21, 21, 145, 145, 159, 159, 118, 11,
11, 11, 0, 0, 21, 153, 21, 0, 21, 21, 160, 160, 161, 161, 155, 11,
11, 0, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 17, 17, 17, 17, 17, 8, 8, 8,
8, 8, 8, 3, 3, 16, 20, 5, 16, 16, 20, 5, 16, 3, 3, 3, 3, 3, 3, 3, 3,
162, 163, 17, 17, 17, 17, 17, 2, 3, 3, 3, 3, 3, 3, 3, 3, 3, 16, 20,
3, 3, 3, 3, 12, 12, 3, 3, 3, 7, 5, 6, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3,
3, 7, 3, 12, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 2, 17, 17, 17, 17, 17, 0,
17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 18, 92, 0, 0, 18, 18, 18, 18,
18, 18, 7, 7, 7, 5, 6, 92, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
7, 7, 7, 5, 6, 0, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92,
0, 0, 0, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4,
4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93,
120, 120, 120, 120, 93, 120, 120, 120, 93, 93, 93, 93, 93, 93, 93,
93, 93, 93, 93, 93, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14,
14, 108, 14, 14, 14, 14, 108, 14, 14, 21, 108, 108, 108, 21, 21, 108,
108, 108, 21, 14, 108, 14, 14, 7, 108, 108, 108, 108, 108, 14, 14,
14, 14, 14, 14, 108, 14, 164, 14, 108, 14, 165, 166, 108, 108, 14,
21, 108, 108, 167, 108, 21, 15, 15, 15, 15, 21, 14, 14, 21, 21, 108,
108, 7, 7, 7, 7, 7, 108, 21, 21, 21, 21, 14, 7, 14, 14, 168, 14, 18,
18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 169, 169,
169, 169, 169, 169, 169, 169, 169, 169, 169, 169, 169, 169, 169, 169,
170, 170, 170, 170, 170, 170, 170, 170, 170, 170, 170, 170, 170, 170,
170, 170, 129, 129, 129, 23, 24, 129, 129, 129, 129, 18, 14, 14, 0,
0, 0, 0, 7, 7, 7, 7, 7, 14, 14, 14, 14, 14, 7, 7, 14, 14, 14, 14, 7,
14, 14, 7, 14, 14, 7, 14, 14, 14, 14, 14, 14, 14, 7, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 7, 7, 14, 14, 7, 14, 7, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 7, 7, 7, 7, 7,
7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
|
| ︙ | ︙ | |||
936 937 938 939 940 941 942 |
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,
| | | | | | | 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 |
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,
|
| ︙ | ︙ | |||
966 967 968 969 970 971 972 |
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, 0, 14, 14, 14,
| | < < < < < < < < | > > > | | | | < < < > > > | | | | | | | | | | | | | | | | | | | | | | | > | | > | | | | | | | | | | | | | | | | | > | | | | > | < | | | | | | | | | > | | < | | | | < < | < > > > | | | | | | | | > | | > > > > | | | | < < < < | < | | | | < < < < > > > > | | | | | | | | | | | | | | | | | | | | | | > | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | > | < | | > > > | | > > > | < > | | | | | | | | | | | | | | | | | | | < < < | | > > | > < > | | | | | > | > | | > | | | < | | | | | | | | | | < > | | > | | < | | | | | | | | > | > | | > > > > | | < | > > > > | > | | < | | | | | > | | > > | > | | < < < > > > | | | | | | | | | | | | < < < > > > | < > | < | | | > > > | | | > > | | | | | | | | | > > | | | < < > > | | < > | | > | < | | < > | | < < > | < < | | < | | < > | > | | | > | < < | > | < | > > > | < < < | > | < | | < > | | < > | | > > | > | | | | | | | | > > > > | | | | > > > > > > > > > > | > | < | | | < < | | < < | < | > > | > | | | | | | | | < < < | > > | > | | | | | | | | | | | < | | | > > > | | | | > | | | > > > | | | | | < > | | | | | | | > | | | | | | | | | | 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 |
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, 0, 14, 14, 14,
14, 14, 14, 14, 14, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123,
123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123,
123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123,
123, 123, 123, 123, 123, 123, 123, 123, 123, 0, 124, 124, 124, 124,
124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124,
124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124,
124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124,
124, 0, 23, 24, 173, 174, 175, 176, 177, 23, 24, 23, 24, 23, 24, 178,
179, 180, 181, 21, 23, 24, 21, 23, 24, 21, 21, 21, 21, 21, 92, 92,
182, 182, 23, 24, 23, 24, 21, 14, 14, 14, 14, 14, 14, 23, 24, 23, 24,
93, 93, 93, 23, 24, 0, 0, 0, 0, 0, 3, 3, 3, 3, 18, 3, 3, 183, 183,
183, 183, 183, 183, 183, 183, 183, 183, 183, 183, 183, 183, 183, 183,
183, 183, 183, 183, 183, 183, 183, 183, 183, 183, 183, 183, 183, 183,
183, 183, 183, 183, 183, 183, 183, 183, 0, 183, 0, 0, 0, 0, 0, 183,
0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 92, 3, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 93, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0,
0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15,
15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15,
0, 3, 3, 16, 20, 16, 20, 3, 3, 3, 16, 20, 3, 16, 20, 3, 3, 3, 3, 3,
3, 3, 3, 3, 8, 3, 3, 8, 3, 16, 20, 3, 3, 16, 20, 5, 6, 5, 6, 5, 6,
5, 6, 3, 3, 3, 3, 3, 92, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 8, 8, 3, 3,
3, 3, 8, 3, 5, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 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,
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, 15, 15, 15, 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, 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, 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, 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, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 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, 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, 0, 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, 0, 0, 0, 0, 0, 0, 0, 0, 199, 199, 199, 199, 199, 199, 199,
199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199,
199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199,
199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 15,
15, 15, 125, 125, 93, 125, 125, 93, 125, 125, 3, 125, 93, 0, 0, 9,
9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0,
200, 200, 200, 200, 200, 200, 200, 200, 200, 200, 200, 200, 200, 200,
200, 200, 200, 200, 200, 200, 200, 200, 200, 200, 200, 200, 200, 200,
200, 200, 200, 200, 201, 201, 201, 201, 201, 201, 201, 201, 201, 201,
201, 201, 201, 201, 201, 201, 201, 201, 201, 201, 201, 201, 201, 201,
201, 201, 201, 201, 201, 201, 201, 201, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0,
0, 0, 0, 0, 0, 21, 21, 21, 21, 21, 21, 21, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 21, 21, 21, 21, 21, 0, 0, 0, 0, 0, 15, 93, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 7, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 0, 15, 0, 15, 15, 0, 15, 15,
0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 11, 11, 11, 11, 11, 11,
11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 6, 5, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 4, 14, 0, 0, 93, 93, 93, 93, 93, 93, 93, 93, 93,
93, 93, 93, 93, 93, 93, 93, 3, 3, 3, 3, 3, 3, 3, 5, 6, 3, 0, 0, 0,
0, 0, 0, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93,
93, 3, 8, 8, 12, 12, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6,
3, 3, 5, 6, 3, 3, 3, 3, 12, 12, 12, 3, 3, 3, 0, 3, 3, 3, 3, 8, 5, 6,
5, 6, 5, 6, 3, 3, 3, 7, 8, 7, 7, 7, 0, 3, 4, 3, 3, 0, 0, 0, 0, 15,
15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 17, 0, 3, 3, 3, 4, 3,
3, 3, 5, 6, 3, 7, 3, 8, 3, 3, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 3, 3, 7,
7, 7, 3, 11, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13,
13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 5, 7, 6, 7, 5, 6, 3,
5, 6, 3, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 92, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 92, 92, 0, 0, 15, 15, 15, 15, 15, 15,
0, 0, 15, 15, 15, 15, 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 0, 0, 15,
15, 15, 0, 0, 0, 4, 4, 7, 11, 14, 4, 4, 0, 14, 7, 7, 7, 7, 14, 14,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 17, 17, 17, 14, 14, 0, 0
#if TCL_UTF_MAX > 3 || TCL_MAJOR_VERSION > 8 || TCL_MINOR_VERSION > 6
,15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 0, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 0, 0, 3, 3, 3, 0, 0, 0, 0, 18, 18, 18,
18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
18, 18, 18, 18, 18, 18, 18, 18, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14,
14, 14, 129, 129, 129, 129, 129, 129, 129, 129, 129, 129, 129, 129,
129, 129, 129, 129, 129, 129, 129, 129, 129, 129, 129, 129, 129, 129,
129, 129, 129, 129, 129, 129, 129, 129, 129, 129, 129, 129, 129, 129,
129, 129, 129, 129, 129, 129, 129, 129, 129, 129, 129, 129, 129, 18,
18, 18, 18, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 18, 18, 14, 14, 14, 0, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 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, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 93, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 93,
18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 0, 0, 0, 0, 18, 18, 18, 18,
0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 129, 15, 15, 15, 15, 15, 15,
15, 15, 129, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 93, 93, 93, 93, 93, 0,
0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0,
3, 15, 15, 15, 15, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 3, 129,
129, 129, 129, 129, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 202, 202, 202, 202,
202, 202, 202, 202, 202, 202, 202, 202, 202, 202, 202, 202, 202, 202,
202, 202, 202, 202, 202, 202, 202, 202, 202, 202, 202, 202, 202, 202,
202, 202, 202, 202, 202, 202, 202, 202, 203, 203, 203, 203, 203, 203,
203, 203, 203, 203, 203, 203, 203, 203, 203, 203, 203, 203, 203, 203,
203, 203, 203, 203, 203, 203, 203, 203, 203, 203, 203, 203, 203, 203,
203, 203, 203, 203, 203, 203, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 202,
202, 202, 202, 202, 202, 202, 202, 202, 202, 202, 202, 202, 202, 202,
202, 202, 202, 202, 202, 202, 202, 202, 202, 202, 202, 202, 202, 202,
202, 202, 202, 202, 202, 202, 202, 0, 0, 0, 0, 203, 203, 203, 203,
203, 203, 203, 203, 203, 203, 203, 203, 203, 203, 203, 203, 203, 203,
203, 203, 203, 203, 203, 203, 203, 203, 203, 203, 203, 203, 203, 203,
203, 203, 203, 203, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 0,
0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15,
15, 0, 0, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15,
0, 0, 0, 15, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 3, 18, 18, 18, 18, 18,
18, 18, 18, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 14, 14, 18, 18, 18, 18, 18, 18,
18, 0, 0, 0, 0, 0, 0, 0, 18, 18, 18, 18, 18, 18, 18, 18, 18, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 0, 0, 0,
0, 0, 18, 18, 18, 18, 18, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 18, 18, 18, 18, 18, 18,
0, 0, 0, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 3, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 18, 18, 15, 15, 18, 18, 18, 18,
18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 0, 0, 18, 18, 18, 18,
18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 15, 93, 93, 93, 0, 93, 93,
0, 0, 0, 0, 0, 93, 93, 93, 93, 15, 15, 15, 15, 0, 15, 15, 15, 0, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 93, 93, 93, 0, 0,
0, 0, 93, 18, 18, 18, 18, 18, 18, 18, 18, 18, 0, 0, 0, 0, 0, 0, 0,
3, 3, 3, 3, 3, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 18, 18, 3, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 18, 18, 18, 15, 15, 15, 15, 15, 15, 15, 15, 14,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 93, 93, 0, 0, 0, 0, 18,
18, 18, 18, 18, 3, 3, 3, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 0, 0, 0, 3, 3, 3, 3, 3, 3, 3, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0,
0, 18, 18, 18, 18, 18, 18, 18, 18, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 18, 18,
18, 18, 18, 18, 18, 18, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 3, 3, 3, 3, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 18, 18, 18, 18, 18, 18, 18, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15,
15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98,
98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98,
98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98,
98, 98, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 103, 103, 103, 103,
103, 103, 103, 103, 103, 103, 103, 103, 103, 103, 103, 103, 103, 103,
103, 103, 103, 103, 103, 103, 103, 103, 103, 103, 103, 103, 103, 103,
103, 103, 103, 103, 103, 103, 103, 103, 103, 103, 103, 103, 103, 103,
103, 103, 103, 103, 103, 0, 0, 0, 0, 0, 0, 0, 18, 18, 18, 18, 18, 18,
15, 15, 15, 15, 93, 93, 93, 93, 0, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9,
9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 18, 18, 18, 18, 18, 18, 18, 18,
18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
18, 18, 18, 18, 18, 18, 0, 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, 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, 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, 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, 0, 0, 9, 9, 9, 9, 9, 9,
9, 9, 9, 9, 15, 3, 15, 3, 3, 3, 0, 18, 18, 18, 18, 18, 18, 18, 18,
18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 125, 125, 125,
93, 93, 93, 125, 125, 93, 125, 93, 93, 3, 3, 3, 3, 3, 3, 93, 0, 15,
15, 15, 15, 15, 15, 15, 0, 15, 0, 15, 15, 15, 15, 0, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 3, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 93, 125, 125, 125, 93, 93, 93, 93, 93, 93,
93, 93, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0,
0, 93, 93, 125, 125, 0, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 15, 15,
0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 0,
15, 15, 15, 15, 15, 0, 93, 93, 15, 125, 125, 93, 125, 125, 125, 125,
0, 0, 125, 125, 0, 0, 125, 125, 125, 0, 0, 15, 0, 0, 0, 0, 0, 0, 125,
0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 125, 125, 0, 0, 93, 93, 93, 93,
93, 93, 93, 0, 0, 0, 93, 93, 93, 93, 93, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 125, 125, 125, 93, 93, 93, 93, 93, 93, 93, 93,
125, 125, 93, 93, 93, 125, 93, 15, 15, 15, 15, 3, 3, 3, 3, 3, 9, 9,
9, 9, 9, 9, 9, 9, 9, 9, 0, 3, 0, 3, 93, 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, 125, 93, 125, 125, 125, 125, 93, 93, 125, 93, 93, 15, 15,
3, 15, 0, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0,
0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 125, 125, 125, 93, 93, 93, 93, 0, 0, 125, 125, 125, 125, 93, 93,
125, 93, 93, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3,
3, 3, 3, 3, 3, 15, 15, 15, 15, 93, 93, 0, 0, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 125, 125, 125, 93, 93, 93,
93, 93, 93, 93, 93, 125, 125, 93, 125, 93, 93, 3, 3, 3, 15, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0,
0, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 93, 125, 93, 125, 125, 93, 93, 93, 93, 93, 93, 125, 93, 15, 0,
0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 125, 125, 93, 93, 93,
93, 125, 93, 93, 93, 93, 93, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9,
9, 18, 18, 3, 3, 3, 14, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 125, 125, 125, 93, 93, 93, 93, 93, 93, 93, 93, 93, 125, 93, 93,
3, 0, 0, 0, 0, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10,
10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10,
10, 10, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13,
13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13,
9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 18, 18, 18, 18, 18, 18, 18, 18, 18, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15,
0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 125, 125, 125, 93, 93, 93, 93, 0, 0, 93, 93,
125, 125, 125, 125, 93, 15, 3, 15, 125, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 93, 93, 93,
93, 93, 93, 93, 93, 93, 93, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 93, 93, 93, 93,
93, 93, 125, 15, 93, 93, 93, 93, 3, 3, 3, 3, 3, 3, 3, 3, 93, 0, 0,
0, 0, 0, 0, 0, 0, 15, 93, 93, 93, 93, 93, 93, 125, 125, 93, 93, 93,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 93, 93, 93,
93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 125, 93, 93, 3, 3, 3, 15, 3,
3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 125, 93, 93, 93, 93, 93, 93, 93, 0, 93, 93, 93, 93, 93,
93, 125, 93, 15, 3, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 9, 9,
9, 9, 9, 9, 9, 9, 9, 9, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
18, 18, 18, 18, 18, 18, 18, 18, 0, 0, 0, 3, 3, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 93, 93, 93, 93, 93, 93, 93, 93,
93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 0, 125, 93,
93, 93, 93, 93, 93, 93, 125, 93, 93, 125, 93, 93, 0, 0, 0, 0, 0, 0,
0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 0, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
93, 93, 93, 93, 93, 93, 0, 0, 0, 93, 0, 93, 93, 0, 93, 93, 93, 93,
93, 93, 93, 15, 93, 0, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9,
9, 9, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 0, 15, 15, 0, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 125, 125, 125,
125, 125, 0, 93, 93, 0, 125, 125, 93, 125, 93, 15, 0, 0, 0, 0, 0, 0,
0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 93, 93, 125, 125, 3, 3, 0, 0, 0, 0, 0, 0, 0, 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, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
18, 18, 18, 18, 18, 18, 18, 18, 3, 3, 3, 3, 0, 0, 0, 0, 0, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 93, 15, 125, 125, 125,
125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125,
125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125,
125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125,
125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 0, 0, 0, 0, 0, 0,
0, 93, 93, 93, 93, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92,
92, 92, 92, 3, 92, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0,
0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 0, 0, 0,
0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0,
0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 15,
15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 0, 0, 14, 93, 93, 3, 17, 17, 17, 17, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 0, 0, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 125, 125, 93, 93, 93, 14, 14, 14, 125, 125, 125,
125, 125, 125, 17, 17, 17, 17, 17, 17, 17, 17, 93, 93, 93, 93, 93,
93, 93, 93, 14, 14, 93, 93, 93, 93, 93, 93, 93, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 93, 93, 93, 93, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 14, 14, 93, 93, 93, 14, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 18, 18, 18, 18,
18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0,
0, 0, 0, 0, 0, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 0, 0, 0, 0, 0, 0, 0,
108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108,
108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 108, 108, 108, 108, 108, 108, 108, 108,
108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108,
108, 108, 108, 108, 21, 21, 21, 21, 21, 21, 21, 0, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 108, 108, 108,
108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108,
108, 108, 108, 108, 108, 108, 108, 108, 108, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 108, 0, 108, 108, 0, 0, 108, 0, 0, 108, 108, 0, 0, 108,
108, 108, 108, 0, 108, 108, 108, 108, 108, 108, 108, 108, 21, 21, 21,
21, 0, 21, 0, 21, 21, 21, 21, 21, 21, 21, 0, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108,
108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108,
108, 108, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 108, 108, 0, 108, 108,
108, 108, 0, 0, 108, 108, 108, 108, 108, 108, 108, 108, 0, 108, 108,
108, 108, 108, 108, 108, 0, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 108,
108, 0, 108, 108, 108, 108, 0, 108, 108, 108, 108, 108, 0, 108, 0,
0, 0, 108, 108, 108, 108, 108, 108, 108, 0, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108,
108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108,
108, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 108, 108, 108, 108, 108, 108,
108, 108, 108, 108, 108, 108, 108, 108, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 108, 108, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108,
108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108,
108, 108, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 108, 108, 108, 108, 108,
108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 21, 21, 21,
21, 21, 21, 0, 0, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108,
108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108,
108, 7, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 7, 21, 21, 21, 21, 21, 21,
108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108,
108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 7, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 7, 21, 21, 21, 21, 21, 21, 108, 108, 108, 108,
108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108,
108, 108, 108, 108, 108, 108, 108, 7, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
7, 21, 21, 21, 21, 21, 21, 108, 108, 108, 108, 108, 108, 108, 108,
108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108,
108, 108, 108, 7, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 7, 21, 21, 21, 21,
21, 21, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108,
108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 7,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 7, 21, 21, 21, 21, 21, 21, 108, 21,
0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9,
9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9,
9, 9, 9, 9, 9, 9, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93,
93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 14, 14, 14, 14, 93, 93, 93,
93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 14, 14,
14, 14, 14, 14, 14, 14, 93, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 93, 14, 14, 3, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 93, 93, 93, 93, 93, 0, 93, 93, 93, 93, 93, 93,
93, 93, 93, 93, 93, 93, 93, 93, 93, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 93, 93, 93, 93, 93, 93, 93, 0, 93, 93, 93, 93, 93, 93,
93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 0, 0, 93, 93, 93, 93, 93,
93, 93, 0, 93, 93, 0, 93, 93, 93, 93, 93, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 0, 0, 0, 93, 93, 93, 93, 93, 93, 93, 92, 92, 92,
92, 92, 92, 92, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 15,
14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 93, 93, 93, 93, 9, 9, 9, 9, 9, 9, 9,
9, 9, 9, 0, 0, 0, 0, 0, 4, 15, 15, 15, 15, 15, 0, 0, 18, 18, 18, 18,
18, 18, 18, 18, 18, 93, 93, 93, 93, 93, 93, 93, 0, 0, 0, 0, 0, 0, 0,
0, 0, 204, 204, 204, 204, 204, 204, 204, 204, 204, 204, 204, 204, 204,
204, 204, 204, 204, 204, 204, 204, 204, 204, 204, 204, 204, 204, 204,
204, 204, 204, 204, 204, 204, 204, 205, 205, 205, 205, 205, 205, 205,
205, 205, 205, 205, 205, 205, 205, 205, 205, 205, 205, 205, 205, 205,
205, 205, 205, 205, 205, 205, 205, 205, 205, 205, 205, 205, 205, 93,
93, 93, 93, 93, 93, 93, 92, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9,
9, 0, 0, 0, 0, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 14, 18, 18, 18, 4, 18,
18, 18, 18, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 18, 18, 18, 18, 18,
18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
18, 18, 18, 18, 18, 18, 14, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
18, 18, 18, 18, 18, 0, 0, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 0, 15, 15, 0, 15, 0, 0, 15, 0, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 0, 15, 0, 15, 0, 0, 0, 0, 0,
0, 15, 0, 0, 0, 0, 15, 0, 15, 0, 15, 0, 15, 15, 15, 0, 15, 15, 0, 15,
0, 0, 15, 0, 15, 0, 15, 0, 15, 0, 15, 0, 15, 15, 0, 15, 0, 0, 15, 15,
15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 0, 15, 15,
15, 15, 0, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0,
0, 0, 15, 15, 15, 0, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 7, 7, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0,
0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 18, 18, 18, 18, 18,
18, 18, 18, 18, 18, 18, 18, 18, 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, 14, 14, 14, 14, 14, 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, 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, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0,
0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 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, 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, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 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, 0, 0, 0, 14, 14, 14, 14,
14, 14, 14, 14, 14, 0, 0, 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, 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, 14, 0, 0, 14, 14, 14, 14, 0, 0,
0, 0, 14, 14, 14, 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, 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, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0
#endif /* TCL_UTF_MAX > 3 */
};
/*
* Each group represents a unique set of character attributes. The attributes
* are encoded into a 32-bit value as follows:
*
* Bits 0-4 Character category: see the constants listed below.
*
* Bits 5-7 Case delta type: 000 = identity
* 010 = add delta for lower
* 011 = add delta for lower, add 1 for title
* 100 = subtract delta for title/upper
* 101 = sub delta for upper, sub 1 for title
* 110 = sub delta for upper, add delta for lower
* 111 = subtract delta for upper
*
* Bits 8-31 Case delta: delta for case conversions. This should be the
* highest field so we can easily sign extend.
*/
static const int groups[] = {
0, 15, 12, 25, 27, 21, 22, 26, 20, 9, 8257, 28, 19, 8322, 29,
5, 23, 16, 11, -190078, 24, 2, -30846, 321, 386, -50879, 59522,
-30911, 76930, -49790, 53825, 52801, 52545, 20289, 51777, 52033,
53057, -24702, 54081, 53569, -41598, 54593, -33150, 54849, 55873,
55617, 56129, -14206, 609, 451, 674, 20354, -24767, -14271, -33215,
2763585, -41663, 2762817, -2768510, -49855, 17729, 18241, -2760318,
-2759550, -2760062, 53890, 52866, 52610, 51842, 52098, -10833534,
-10832510, 53122, -10823550, -10830718, 53634, 54146, -2750078,
-10829950, -2751614, 54658, 54914, -2745982, 55938, -10830462,
-10824062, 17794, 55682, 18306, 56194, -10818686, -10817918, 4,
6, -21370, 29761, 9793, 9537, 16449, 16193, 9858, 9602, 8066,
16514, 16258, 2113, 16002, 14722, 1, 12162, 13954, 2178, 22146,
20610, -1662, 29826, -15295, 24706, -1727, 20545, 7, 3905, 3970,
12353, 12418, 8, 1859649, -769822, 9949249, 10, 1601154, 1600898,
1598594, 1598082, 1598338, 1596546, 1582466, -9027966, -769983,
-9044862, -976254, -9058174, 15234, -1949375, -1918, -1983, -18814,
-21886, -25470, -32638, -28542, -32126, -1981, -2174, -18879,
-2237, 1844610, -21951, -25535, -28607, -32703, -32191, 13, 14,
-1924287, -2145983, -2115007, 7233, 7298, 4170, 4234, 6749, 6813,
-2750143, -976319, -2746047, 2763650, 2762882, -2759615, -2751679,
-2760383, -2760127, -2768575, 1859714, -9044927, -10823615, -12158,
-10830783, -10833599, -10832575, -10830015, -10817983, -10824127,
-10818751, 237633, -12223, -10830527, -9058239, 237698, 9949314,
18, 17, 10305, 10370, 8769, 8834
};
#if TCL_UTF_MAX > 3 || TCL_MAJOR_VERSION > 8 || TCL_MINOR_VERSION > 6
# define UNICODE_OUT_OF_RANGE(ch) (((ch) & 0x1fffff) >= 0x2fa20)
#else
# define UNICODE_OUT_OF_RANGE(ch) (((ch) & 0x1f0000) != 0)
#endif
/*
* The following constants are used to determine the category of a
|
| ︙ | ︙ | |||
1621 1622 1623 1624 1625 1626 1627 | #define GetDelta(info) ((info) >> 8) /* * This macro extracts the information about a character from the * Unicode character tables. */ | | | 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 | #define GetDelta(info) ((info) >> 8) /* * This macro extracts the information about a character from the * Unicode character tables. */ #if TCL_UTF_MAX > 3 || TCL_MAJOR_VERSION > 8 || TCL_MINOR_VERSION > 6 # define GetUniCharInfo(ch) (groups[groupMap[pageMap[((ch) & 0x1fffff) >> OFFSET_BITS] | ((ch) & ((1 << OFFSET_BITS)-1))]]) #else # define GetUniCharInfo(ch) (groups[groupMap[pageMap[((ch) & 0xffff) >> OFFSET_BITS] | ((ch) & ((1 << OFFSET_BITS)-1))]]) #endif |
Changes to generic/tclUtf.c.
| ︙ | ︙ | |||
63 64 65 66 67 68 69 |
1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
1,1,1,1,1,1,1,1,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,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,
| | < < | < < > > > > > > > > > > > > > | < > > | | | > > > > | | | | < < < | > > > > > > > > > | 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 |
1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
1,1,1,1,1,1,1,1,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,2,2,2,2,2,2,2,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,4,4,4,4,4,1,1,1,1,1,1,1,1,1,1,1
};
/*
*---------------------------------------------------------------------------
*
* TclUtfCount --
*
* Find the number of bytes in the Utf character "ch".
*
* Results:
* The return values is the number of bytes in the Utf character "ch".
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
size_t
TclUtfCount(
int ch) /* The Unicode character whose size is returned. */
{
if ((unsigned)(ch - 1) < (UNICODE_SELF - 1)) {
return 1;
}
if (ch <= 0x7FF) {
return 2;
}
if (((unsigned)(ch - 0x10000) <= 0xFFFFF)) {
return 4;
}
return 3;
}
/*
*---------------------------------------------------------------------------
*
* 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:
* None.
*
*---------------------------------------------------------------------------
*/
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). */
{
if ((unsigned)(ch - 1) < (UNICODE_SELF - 1)) {
buf[0] = (char) ch;
return 1;
}
if (ch >= 0) {
if (ch <= 0x7FF) {
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 (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;
}
}
ch = 0xFFFD;
three:
buf[2] = (char) ((ch | 0x80) & 0xBF);
buf[1] = (char) (((ch >> 6) | 0x80) & 0xBF);
buf[0] = (char) ((ch >> 12) | 0xE0);
|
| ︙ | ︙ | |||
200 201 202 203 204 205 206 |
*
*---------------------------------------------------------------------------
*/
char *
Tcl_UniCharToUtfDString(
const Tcl_UniChar *uniStr, /* Unicode string to convert to UTF-8. */
| | | > | > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > | > > > > > > > > > > | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | > > > > > > > > > > > > > > > > > | > | | < | | | < < < < < < < < < < < < < | | | < < < < < < < < < | < | < | | > | | 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 |
*
*---------------------------------------------------------------------------
*/
char *
Tcl_UniCharToUtfDString(
const Tcl_UniChar *uniStr, /* Unicode string to convert to UTF-8. */
size_t 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 Tcl_UniChar *w, *wEnd;
char *p, *string;
size_t oldLength;
int len = 1;
/*
* UTF-8 string length in bytes will be <= Unicode string length * 4.
*/
oldLength = Tcl_DStringLength(dsPtr);
Tcl_DStringSetLength(dsPtr, oldLength + (uniLength + 1) * 4);
string = Tcl_DStringValue(dsPtr) + oldLength;
p = string;
wEnd = uniStr + uniLength;
for (w = uniStr; w < wEnd; ) {
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;
}
#if (TCL_UTF_MAX > 4) && (defined(__CYGWIN__) || defined(_WIN32))
char *
TclWCharToUtfDString(
const WCHAR *uniStr, /* WCHAR string to convert to UTF-8. */
int uniLength, /* Length of WCHAR string in Tcl_UniChars
* (must be >= 0). */
Tcl_DString *dsPtr) /* UTF-8 representation of string is appended
* to this previously initialized DString. */
{
const WCHAR *w, *wEnd;
char *p, *string;
int oldLength, len = 1;
/*
* UTF-8 string length in bytes will be <= Unicode string length * 4.
*/
oldLength = Tcl_DStringLength(dsPtr);
Tcl_DStringSetLength(dsPtr, oldLength + (uniLength + 1) * 4);
string = Tcl_DStringValue(dsPtr) + oldLength;
p = string;
wEnd = uniStr + uniLength;
for (w = uniStr; w < wEnd; ) {
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;
}
#endif
/*
*---------------------------------------------------------------------------
*
* Tcl_UtfToUniChar --
*
* Extract the Tcl_UniChar represented by the UTF-8 string. Bad UTF-8
* sequences are converted to valid Tcl_UniChars and processing
* continues. Equivalent to Plan 9 chartorune().
*
* The caller must ensure that the source buffer is long enough that this
* routine does not run off the end and dereference non-existent memory
* looking for trail bytes. If the source buffer is known to be '\0'
* terminated, this cannot happen. Otherwise, the caller should call
* Tcl_UtfCharComplete() before calling this routine to ensure that
* enough bytes remain in the string.
*
* Special handling of Surrogate pairs is handled as follows:
* For any UTF-8 string containing a character outside of the BMP, the
* first call to this function will fill *chPtr with the high surrogate
* and generate a return value of 1. Calling Tcl_UtfToUniChar again
* will produce the low surrogate and a return value of 3. Because *chPtr
* is used to remember whether the high surrogate is already produced, it
* is recommended to initialize the variable it points to as 0 before
* the first call to Tcl_UtfToUniChar is done.
*
* Results:
* *chPtr is filled with the Tcl_UniChar, and the return value is the
* number of bytes from the UTF-8 string that were consumed.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
static const unsigned short cp1252[32] = {
0x20ac, 0x81, 0x201A, 0x0192, 0x201E, 0x2026, 0x2020, 0x2021,
0x02C6, 0x2030, 0x0160, 0x2039, 0x0152, 0x8D, 0x017D, 0x8F,
0x90, 0x2018, 0x2019, 0x201C, 0x201D, 0x2022, 0x2013, 0x2014,
0x2DC, 0x2122, 0x0161, 0x203A, 0x0153, 0x9D, 0x017E, 0x0178
};
int
Tcl_UtfToUniChar(
register const char *src, /* The UTF-8 string. */
register Tcl_UniChar *chPtr)/* Filled with the Tcl_UniChar represented by
* the UTF-8 string. */
{
Tcl_UniChar byte;
/*
* Unroll 1 to 4 byte UTF-8 sequences.
*/
byte = *((unsigned char *) src);
if (byte < 0xC0) {
/*
* Handles properly formed UTF-8 characters between 0x01 and 0x7F.
* Treats naked trail bytes 0x80 to 0x9F as valid characters from
* the cp1252 table. See: <https://en.wikipedia.org/wiki/UTF-8>
* Also treats \0 and other naked trail bytes 0xA0 to 0xBF as valid
* characters representing themselves.
*/
#if TCL_UTF_MAX <= 4
/* 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 >= 0x80)
&& (((((byte - 0x10) << 2) & 0xFC) | 0xD800) == (*chPtr & 0xFCFC))
&& ((src[1] & 0xF0) == (((*chPtr << 4) & 0x30) | 0x80))
&& ((src[2] & 0xC0) == 0x80)) {
*chPtr = ((src[1] & 0x0F) << 6) + (src[2] & 0x3F) + 0xDC00;
return 3;
}
#endif
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 < 0xF8) {
if (((src[1] & 0xC0) == 0x80) && ((src[2] & 0xC0) == 0x80) && ((src[3] & 0xC0) == 0x80)) {
/*
* Four-byte-character lead byte followed by three trail bytes.
*/
#if TCL_UTF_MAX <= 4
Tcl_UniChar high = (((byte & 0x07) << 8) | ((src[1] & 0x3F) << 2)
| ((src[2] & 0x3F) >> 4)) - 0x40;
if (high >= 0x400) {
/* out of range, < 0x10000 or > 0x10ffff */
} else {
/* produce high surrogate, advance source pointer */
*chPtr = 0xD800 + high;
return 1;
}
#else
*chPtr = (((byte & 0x07) << 18) | ((src[1] & 0x3F) << 12)
| ((src[2] & 0x3F) << 6) | (src[3] & 0x3F));
if ((unsigned)(*chPtr - 0x10000) <= 0xFFFFF) {
return 4;
}
#endif
}
/*
* A four-byte-character lead-byte not followed by three trail-bytes
* represents itself.
*/
}
*chPtr = byte;
return 1;
}
#if (TCL_UTF_MAX > 4) && (defined(__CYGWIN__) || defined(_WIN32))
int
TclUtfToWChar(
const char *src, /* The UTF-8 string. */
WCHAR *chPtr)/* Filled with the WCHAR represented by
* the UTF-8 string. */
{
WCHAR byte;
/*
* Unroll 1 to 4 byte UTF-8 sequences.
*/
byte = *((unsigned char *) src);
if (byte < 0xC0) {
/*
* Handles properly formed UTF-8 characters between 0x01 and 0x7F.
* Treats naked trail bytes 0x80 to 0x9F as valid characters from
* the cp1252 table. See: <https://en.wikipedia.org/wiki/UTF-8>
* Also treats \0 and other naked trail bytes 0xA0 to 0xBF as valid
* characters representing themselves.
*/
/* If *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 >= 0x80)
&& (((((byte - 0x10) << 2) & 0xFC) | 0xD800) == (*chPtr & 0xFCFC))
&& ((src[1] & 0xF0) == (((*chPtr << 4) & 0x30) | 0x80))
&& ((src[2] & 0xC0) == 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 < 0xF8) {
if (((src[1] & 0xC0) == 0x80) && ((src[2] & 0xC0) == 0x80) && ((src[3] & 0xC0) == 0x80)) {
/*
* Four-byte-character lead byte followed by three trail bytes.
*/
WCHAR high = (((byte & 0x07) << 8) | ((src[1] & 0x3F) << 2)
| ((src[2] & 0x3F) >> 4)) - 0x40;
if (high >= 0x400) {
/* out of range, < 0x10000 or > 0x10ffff */
} else {
/* produce high surrogate, advance source pointer */
*chPtr = 0xD800 + high;
return 1;
}
}
/*
* A four-byte-character lead-byte not followed by three trail-bytes
* represents itself.
*/
}
*chPtr = byte;
return 1;
}
#endif
/*
*---------------------------------------------------------------------------
*
* Tcl_UtfToUniCharDString --
*
* Convert the UTF-8 string to Unicode.
*
|
| ︙ | ︙ | |||
392 393 394 395 396 397 398 |
*
*---------------------------------------------------------------------------
*/
Tcl_UniChar *
Tcl_UtfToUniCharDString(
const char *src, /* UTF-8 string to convert to Unicode. */
| | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | > | | | > > > > > > > > > | | | 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 |
*
*---------------------------------------------------------------------------
*/
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
* strlen(). */
Tcl_DString *dsPtr) /* Unicode representation of string is
* appended to this previously initialized
* DString. */
{
Tcl_UniChar ch = 0, *w, *wString;
const char *p, *end;
size_t oldLength;
if (length == TCL_AUTO_LENGTH) {
length = strlen(src);
}
/*
* Unicode string length in Tcl_UniChars will be <= UTF-8 string length in
* bytes.
*/
oldLength = Tcl_DStringLength(dsPtr);
Tcl_DStringSetLength(dsPtr,
oldLength + (int) ((length + 1) * sizeof(Tcl_UniChar)));
wString = (Tcl_UniChar *) (Tcl_DStringValue(dsPtr) + oldLength);
w = wString;
p = src;
end = src + length - 4;
while (p < end) {
p += TclUtfToUniChar(p, &ch);
*w++ = ch;
}
end += 4;
while (p < end) {
if (Tcl_UtfCharComplete(p, end-p)) {
p += TclUtfToUniChar(p, &ch);
} else {
ch = UCHAR(*p++);
}
*w++ = ch;
}
*w = '\0';
Tcl_DStringSetLength(dsPtr,
oldLength + ((char *) w - (char *) wString));
return wString;
}
#if (TCL_UTF_MAX > 4) && (defined(__CYGWIN__) || defined(_WIN32))
WCHAR *
TclUtfToWCharDString(
const char *src, /* UTF-8 string to convert to Unicode. */
int length, /* Length of UTF-8 string in bytes, or -1 for
* strlen(). */
Tcl_DString *dsPtr) /* Unicode representation of string is
* appended to this previously initialized
* DString. */
{
WCHAR ch = 0, *w, *wString;
const char *p, *end;
int oldLength;
if (length < 0) {
length = strlen(src);
}
/*
* Unicode string length in Tcl_UniChars will be <= UTF-8 string length in
* bytes.
*/
oldLength = Tcl_DStringLength(dsPtr);
Tcl_DStringSetLength(dsPtr,
oldLength + (int) ((length + 1) * sizeof(WCHAR)));
wString = (WCHAR *) (Tcl_DStringValue(dsPtr) + oldLength);
w = wString;
p = src;
end = src + length - 4;
while (p < end) {
p += TclUtfToWChar(p, &ch);
*w++ = ch;
}
end += 4;
while (p < end) {
if (Tcl_UtfCharComplete(p, end-p)) {
p += TclUtfToWChar(p, &ch);
} else {
ch = UCHAR(*p++);
}
*w++ = ch;
}
*w = '\0';
Tcl_DStringSetLength(dsPtr,
oldLength + ((char *) w - (char *) wString));
return wString;
}
#endif
/*
*---------------------------------------------------------------------------
*
* Tcl_UtfCharComplete --
*
* Determine if the UTF-8 string of the given length is long enough to be
* decoded by Tcl_UtfToUniChar(). This does not ensure that the UTF-8
|
| ︙ | ︙ | |||
453 454 455 456 457 458 459 |
*---------------------------------------------------------------------------
*/
int
Tcl_UtfCharComplete(
const char *src, /* String to check if first few bytes contain
* a complete UTF-8 character. */
| | | | | | | < | 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 |
*---------------------------------------------------------------------------
*/
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. */
{
return length >= totalBytes[(unsigned char)*src];
}
/*
*---------------------------------------------------------------------------
*
* Tcl_NumUtfChars --
*
* Returns the number of characters (not bytes) in the UTF-8 string, not
* including the terminating NULL byte. This is equivalent to Plan 9
* utflen() and utfnlen().
*
* Results:
* As above.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
size_t
Tcl_NumUtfChars(
register const char *src, /* The UTF-8 string to measure. */
size_t length) /* The length of the string in bytes, or -1
* for strlen(string). */
{
Tcl_UniChar ch = 0;
register size_t i = 0;
/*
* The separate implementations are faster.
*
* Since this is a time-sensitive function, we also do the check for the
* single-byte char case specially.
*/
if (length == TCL_AUTO_LENGTH) {
while (*src != '\0') {
src += TclUtfToUniChar(src, &ch);
i++;
}
} else {
register const char *endPtr = src + length - 4;
while (src < endPtr) {
src += TclUtfToUniChar(src, &ch);
i++;
}
|
| ︙ | ︙ | |||
541 542 543 544 545 546 547 |
*/
const char *
Tcl_UtfFindFirst(
const char *src, /* The UTF-8 string to be searched. */
int ch) /* The Unicode character to search for. */
{
| > | | | | | 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 |
*/
const char *
Tcl_UtfFindFirst(
const char *src, /* The UTF-8 string to be searched. */
int ch) /* The Unicode character to search for. */
{
size_t len;
int fullchar;
Tcl_UniChar find = 0;
while (1) {
len = TclUtfToUniChar(src, &find);
fullchar = find;
#if TCL_UTF_MAX <= 4
if ((ch >= 0xD800) && (len < 3)) {
len += TclUtfToUniChar(src + len, &find);
fullchar = (((fullchar & 0x3ff) << 10) | (find & 0x3ff)) + 0x10000;
}
#endif
if (fullchar == ch) {
return src;
}
if (*src == '\0') {
|
| ︙ | ︙ | |||
587 588 589 590 591 592 593 |
*/
const char *
Tcl_UtfFindLast(
const char *src, /* The UTF-8 string to be searched. */
int ch) /* The Unicode character to search for. */
{
| > | | | | | 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 |
*/
const char *
Tcl_UtfFindLast(
const char *src, /* The UTF-8 string to be searched. */
int ch) /* The Unicode character to search for. */
{
size_t len;
int fullchar;
Tcl_UniChar find = 0;
const char *last;
last = NULL;
while (1) {
len = TclUtfToUniChar(src, &find);
fullchar = find;
#if TCL_UTF_MAX <= 4
if ((ch >= 0xD800) && (len < 3)) {
len += TclUtfToUniChar(src + len, &find);
fullchar = (((fullchar & 0x3ff) << 10) | (find & 0x3ff)) + 0x10000;
}
#endif
if (fullchar == ch) {
last = src;
}
if (*src == '\0') {
|
| ︙ | ︙ | |||
636 637 638 639 640 641 642 |
*/
const char *
Tcl_UtfNext(
const char *src) /* The current location in the string. */
{
Tcl_UniChar ch = 0;
| | | | | | 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 |
*/
const char *
Tcl_UtfNext(
const char *src) /* The current location in the string. */
{
Tcl_UniChar ch = 0;
size_t len = TclUtfToUniChar(src, &ch);
#if TCL_UTF_MAX <= 4
if ((ch >= 0xD800) && (len < 3)) {
len += TclUtfToUniChar(src + len, &ch);
}
#endif
return src + len;
}
/*
*---------------------------------------------------------------------------
|
| ︙ | ︙ | |||
713 714 715 716 717 718 719 | * * Side effects: * None. * *--------------------------------------------------------------------------- */ | | | > > > > > | > > > > > > > > > > > > | | > > | > > > > | > > > | > > > > > > > > | 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 |
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
int
Tcl_UniCharAtIndex(
register const char *src, /* The UTF-8 string to dereference. */
register size_t index) /* The position of the desired character. */
{
Tcl_UniChar ch = 0;
int fullchar = 0;
#if TCL_UTF_MAX <= 4
size_t len = 0;
#endif
src += TclUtfToUniChar(src, &ch);
while (index--) {
#if TCL_UTF_MAX <= 4
src += (len = TclUtfToUniChar(src, &ch));
#else
src += TclUtfToUniChar(src, &ch);
#endif
}
fullchar = ch;
#if TCL_UTF_MAX <= 4
if ((ch >= 0xD800) && (len < 3)) {
/* If last Tcl_UniChar was a high surrogate, combine with low surrogate */
(void)TclUtfToUniChar(src, &ch);
fullchar = (((fullchar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000;
}
#endif
return fullchar;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_UtfAtIndex --
*
* Returns a pointer to the specified character (not byte) position in
* the UTF-8 string. If TCL_UTF_MAX <= 4, characters > U+FFFF count as
* 2 positions, but then the pointer should never be placed between
* the two positions.
*
* Results:
* As above.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
const char *
Tcl_UtfAtIndex(
register const char *src, /* The UTF-8 string. */
register size_t index) /* The position of the desired character. */
{
Tcl_UniChar ch = 0;
#if TCL_UTF_MAX <= 4
size_t len = 0;
#endif
if (index != TCL_INDEX_NONE) {
while (index--) {
#if TCL_UTF_MAX <= 4
src += (len = TclUtfToUniChar(src, &ch));
#else
src += TclUtfToUniChar(src, &ch);
#endif
}
#if TCL_UTF_MAX <= 4
if ((ch >= 0xD800) && (len < 3)) {
/* Index points at character following high Surrogate */
src += TclUtfToUniChar(src, &ch);
}
#endif
}
return src;
}
/*
*---------------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
782 783 784 785 786 787 788 | * that represent the Unicode character is at least as large as the * source buffer from which the backslashed sequence was extracted, no * buffer overruns should occur. * *--------------------------------------------------------------------------- */ | | | < | | 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 |
* that represent the Unicode character is at least as large as the
* source buffer from which the backslashed sequence was extracted, no
* buffer overruns should occur.
*
*---------------------------------------------------------------------------
*/
size_t
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;
result = TclParseBackslash(src, LINE_LENGTH, &numRead, dst);
if (numRead == LINE_LENGTH) {
/*
* We ate a whole line. Pay the price of a strlen()
*/
result = TclParseBackslash(src, strlen(src), &numRead, dst);
}
if (readPtr != NULL) {
*readPtr = numRead;
}
return result;
}
|
| ︙ | ︙ | |||
831 832 833 834 835 836 837 |
*----------------------------------------------------------------------
*/
int
Tcl_UtfToUpper(
char *str) /* String to convert in place. */
{
| | > | | > > > > > > > > | | | | | | 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 |
*----------------------------------------------------------------------
*/
int
Tcl_UtfToUpper(
char *str) /* String to convert in place. */
{
Tcl_UniChar ch = 0;
int upChar;
char *src, *dst;
size_t len;
/*
* Iterate over the string until we hit the terminating null.
*/
src = dst = str;
while (*src) {
len = TclUtfToUniChar(src, &ch);
upChar = ch;
#if TCL_UTF_MAX <= 4
if ((ch >= 0xD800) && (len < 3)) {
len += TclUtfToUniChar(src + len, &ch);
/* Combine surrogates */
upChar = (((upChar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000;
}
#endif
upChar = Tcl_UniCharToUpper(upChar);
/*
* 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 & 0xF800) == 0xD800)) {
memmove(dst, src, len);
dst += len;
} else {
dst += Tcl_UniCharToUtf(upChar, dst);
}
src += len;
}
*dst = '\0';
return (dst - str);
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
884 885 886 887 888 889 890 |
*----------------------------------------------------------------------
*/
int
Tcl_UtfToLower(
char *str) /* String to convert in place. */
{
| | > | | > > > > > > > > | | | | | | 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 |
*----------------------------------------------------------------------
*/
int
Tcl_UtfToLower(
char *str) /* String to convert in place. */
{
Tcl_UniChar ch = 0;
int lowChar;
char *src, *dst;
size_t len;
/*
* Iterate over the string until we hit the terminating null.
*/
src = dst = str;
while (*src) {
len = TclUtfToUniChar(src, &ch);
lowChar = ch;
#if TCL_UTF_MAX <= 4
if ((ch >= 0xD800) && (len < 3)) {
len += TclUtfToUniChar(src + len, &ch);
/* Combine surrogates */
lowChar = (((lowChar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000;
}
#endif
lowChar = Tcl_UniCharToLower(lowChar);
/*
* 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 & 0xF800) == 0xD800)) {
memmove(dst, src, len);
dst += len;
} else {
dst += Tcl_UniCharToUtf(lowChar, dst);
}
src += len;
}
*dst = '\0';
return (dst - str);
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
938 939 940 941 942 943 944 |
*----------------------------------------------------------------------
*/
int
Tcl_UtfToTitle(
char *str) /* String to convert in place. */
{
| | > | | > > > > > > > > | | | | | | > > > > > > > > > > | | > | | | | | 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 |
*----------------------------------------------------------------------
*/
int
Tcl_UtfToTitle(
char *str) /* String to convert in place. */
{
Tcl_UniChar ch = 0;
int titleChar, lowChar;
char *src, *dst;
size_t 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 = TclUtfToUniChar(src, &ch);
titleChar = ch;
#if TCL_UTF_MAX <= 4
if ((ch >= 0xD800) && (len < 3)) {
len += TclUtfToUniChar(src + len, &ch);
/* Combine surrogates */
titleChar = (((titleChar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000;
}
#endif
titleChar = Tcl_UniCharToTitle(titleChar);
if ((len < TclUtfCount(titleChar)) || ((titleChar & 0xF800) == 0xD800)) {
memmove(dst, src, len);
dst += len;
} else {
dst += Tcl_UniCharToUtf(titleChar, dst);
}
src += len;
}
while (*src) {
len = TclUtfToUniChar(src, &ch);
lowChar = ch;
#if TCL_UTF_MAX <= 4
if ((ch >= 0xD800) && (len < 3)) {
len += TclUtfToUniChar(src + len, &ch);
/* Combine surrogates */
lowChar = (((lowChar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000;
}
#endif
/* Special exception for Georgian Asomtavruli chars, no titlecase. */
if ((unsigned)(lowChar - 0x1C90) >= 0x30) {
lowChar = Tcl_UniCharToLower(lowChar);
}
if ((len < TclUtfCount(lowChar)) || ((lowChar & 0xF800) == 0xD800)) {
memmove(dst, src, len);
dst += len;
} else {
dst += Tcl_UniCharToUtf(lowChar, dst);
}
src += len;
}
*dst = '\0';
return (dst - str);
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
998 999 1000 1001 1002 1003 1004 |
*----------------------------------------------------------------------
*/
int
TclpUtfNcmp2(
const char *cs, /* UTF string to compare to ct. */
const char *ct, /* UTF string cs is compared to. */
| | | 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 |
*----------------------------------------------------------------------
*/
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. */
{
/*
* 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.
*/
|
| ︙ | ︙ | |||
1045 1046 1047 1048 1049 1050 1051 |
*----------------------------------------------------------------------
*/
int
Tcl_UtfNcmp(
const char *cs, /* UTF string to compare to ct. */
const char *ct, /* UTF string cs is compared to. */
| | | | 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 |
*----------------------------------------------------------------------
*/
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. */
{
Tcl_UniChar ch1 = 0, ch2 = 0;
/*
* Cannot use 'memcmp(cs, ct, n);' as byte representation of \u0000 (the
* pair of bytes 0xC0,0x80) is larger than byte representation of \u0001
* (the byte 0x01.)
*/
while (numChars-- > 0) {
/*
* n must be interpreted as chars, not bytes. This should be called
* only when both strings are of at least n chars long (no need for \0
* check)
*/
cs += TclUtfToUniChar(cs, &ch1);
ct += TclUtfToUniChar(ct, &ch2);
if (ch1 != ch2) {
#if TCL_UTF_MAX <= 4
/* Surrogates always report higher than non-surrogates */
if (((ch1 & 0xFC00) == 0xD800)) {
if ((ch2 & 0xFC00) != 0xD800) {
return ch1;
}
} else if ((ch2 & 0xFC00) == 0xD800) {
return -ch2;
|
| ︙ | ︙ | |||
1103 1104 1105 1106 1107 1108 1109 |
*----------------------------------------------------------------------
*/
int
Tcl_UtfNcasecmp(
const char *cs, /* UTF string to compare to ct. */
const char *ct, /* UTF string cs is compared to. */
| | | | 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 |
*----------------------------------------------------------------------
*/
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. */
{
Tcl_UniChar ch1 = 0, ch2 = 0;
while (numChars-- > 0) {
/*
* n must be interpreted as chars, not bytes.
* This should be called only when both strings are of
* at least n chars long (no need for \0 check)
*/
cs += TclUtfToUniChar(cs, &ch1);
ct += TclUtfToUniChar(ct, &ch2);
if (ch1 != ch2) {
#if TCL_UTF_MAX <= 4
/* Surrogates always report higher than non-surrogates */
if (((ch1 & 0xFC00) == 0xD800)) {
if ((ch2 & 0xFC00) != 0xD800) {
return ch1;
}
} else if ((ch2 & 0xFC00) == 0xD800) {
return -ch2;
|
| ︙ | ︙ | |||
1165 1166 1167 1168 1169 1170 1171 |
{
Tcl_UniChar ch1 = 0, ch2 = 0;
while (*cs && *ct) {
cs += TclUtfToUniChar(cs, &ch1);
ct += TclUtfToUniChar(ct, &ch2);
if (ch1 != ch2) {
| | | 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 |
{
Tcl_UniChar ch1 = 0, ch2 = 0;
while (*cs && *ct) {
cs += TclUtfToUniChar(cs, &ch1);
ct += TclUtfToUniChar(ct, &ch2);
if (ch1 != ch2) {
#if TCL_UTF_MAX <= 4
/* Surrogates always report higher than non-surrogates */
if (((ch1 & 0xFC00) == 0xD800)) {
if ((ch2 & 0xFC00) != 0xD800) {
return ch1;
}
} else if ((ch2 & 0xFC00) == 0xD800) {
return -ch2;
|
| ︙ | ︙ | |||
1211 1212 1213 1214 1215 1216 1217 |
{
Tcl_UniChar ch1 = 0, ch2 = 0;
while (*cs && *ct) {
cs += TclUtfToUniChar(cs, &ch1);
ct += TclUtfToUniChar(ct, &ch2);
if (ch1 != ch2) {
| | | 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 |
{
Tcl_UniChar ch1 = 0, ch2 = 0;
while (*cs && *ct) {
cs += TclUtfToUniChar(cs, &ch1);
ct += TclUtfToUniChar(ct, &ch2);
if (ch1 != ch2) {
#if TCL_UTF_MAX <= 4
/* Surrogates always report higher than non-surrogates */
if (((ch1 & 0xFC00) == 0xD800)) {
if ((ch2 & 0xFC00) != 0xD800) {
return ch1;
}
} else if ((ch2 & 0xFC00) == 0xD800) {
return -ch2;
|
| ︙ | ︙ | |||
1248 1249 1250 1251 1252 1253 1254 | * * Side effects: * None. * *---------------------------------------------------------------------- */ | | > | | | | > | | > | > | | | > | | > | | | | | | > | > | | | > | | | | 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 |
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_UniCharToUpper(
int ch) /* Unicode character to convert. */
{
if (!UNICODE_OUT_OF_RANGE(ch)) {
int info = GetUniCharInfo(ch);
if (GetCaseType(info) & 0x04) {
ch -= GetDelta(info);
}
}
return ch & 0x1FFFFF;
}
/*
*----------------------------------------------------------------------
*
* Tcl_UniCharToLower --
*
* Compute the lowercase equivalent of the given Unicode character.
*
* Results:
* Returns the lowercase Unicode character.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_UniCharToLower(
int ch) /* Unicode character to convert. */
{
if (!UNICODE_OUT_OF_RANGE(ch)) {
int info = GetUniCharInfo(ch);
int mode = GetCaseType(info);
if ((mode & 0x02) && (mode != 0x7)) {
ch += GetDelta(info);
}
}
return ch & 0x1FFFFF;
}
/*
*----------------------------------------------------------------------
*
* Tcl_UniCharToTitle --
*
* Compute the titlecase equivalent of the given Unicode character.
*
* Results:
* Returns the titlecase Unicode character.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_UniCharToTitle(
int ch) /* Unicode character to convert. */
{
if (!UNICODE_OUT_OF_RANGE(ch)) {
int info = GetUniCharInfo(ch);
int mode = GetCaseType(info);
if (mode & 0x1) {
/*
* Subtract or add one depending on the original case.
*/
if (mode != 0x7) {
ch += ((mode & 0x4) ? -1 : 1);
}
} else if (mode == 0x4) {
ch -= GetDelta(info);
}
}
return ch & 0x1FFFFF;
}
/*
*----------------------------------------------------------------------
*
* Tcl_UniCharLen --
*
* Find the length of a UniChar string. The str input must be null
* terminated.
*
* Results:
* Returns the length of str in UniChars (not bytes).
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
size_t
Tcl_UniCharLen(
const Tcl_UniChar *uniStr) /* Unicode string to find length of. */
{
size_t len = 0;
while (*uniStr != '\0') {
len++;
uniStr++;
}
return len;
}
|
| ︙ | ︙ | |||
1374 1375 1376 1377 1378 1379 1380 |
*----------------------------------------------------------------------
*/
int
Tcl_UniCharNcmp(
const Tcl_UniChar *ucs, /* Unicode string to compare to uct. */
const Tcl_UniChar *uct, /* Unicode string ucs is compared to. */
| | | 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 |
*----------------------------------------------------------------------
*/
int
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. */
{
#ifdef WORDS_BIGENDIAN
/*
* We are definitely on a big-endian machine; memcmp() is safe
*/
return memcmp(ucs, uct, numChars*sizeof(Tcl_UniChar));
|
| ︙ | ︙ | |||
1419 1420 1421 1422 1423 1424 1425 |
*----------------------------------------------------------------------
*/
int
Tcl_UniCharNcasecmp(
const Tcl_UniChar *ucs, /* Unicode string to compare to uct. */
const Tcl_UniChar *uct, /* Unicode string ucs is compared to. */
| | | 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 |
*----------------------------------------------------------------------
*/
int
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. */
{
for ( ; numChars != 0; numChars--, ucs++, uct++) {
if (*ucs != *uct) {
Tcl_UniChar lcs = Tcl_UniCharToLower(*ucs);
Tcl_UniChar lct = Tcl_UniCharToLower(*uct);
if (lcs != lct) {
|
| ︙ | ︙ | |||
1454 1455 1456 1457 1458 1459 1460 |
*----------------------------------------------------------------------
*/
int
Tcl_UniCharIsAlnum(
int ch) /* Unicode character to test. */
{
| < < | 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 |
*----------------------------------------------------------------------
*/
int
Tcl_UniCharIsAlnum(
int ch) /* Unicode character to test. */
{
if (UNICODE_OUT_OF_RANGE(ch)) {
return 0;
}
return (((ALPHA_BITS | DIGIT_BITS) >> GetCategory(ch)) & 1);
}
/*
*----------------------------------------------------------------------
*
* Tcl_UniCharIsAlpha --
|
| ︙ | ︙ | |||
1482 1483 1484 1485 1486 1487 1488 |
*----------------------------------------------------------------------
*/
int
Tcl_UniCharIsAlpha(
int ch) /* Unicode character to test. */
{
| < < | 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 |
*----------------------------------------------------------------------
*/
int
Tcl_UniCharIsAlpha(
int ch) /* Unicode character to test. */
{
if (UNICODE_OUT_OF_RANGE(ch)) {
return 0;
}
return ((ALPHA_BITS >> GetCategory(ch)) & 1);
}
/*
*----------------------------------------------------------------------
*
* Tcl_UniCharIsControl --
|
| ︙ | ︙ | |||
1510 1511 1512 1513 1514 1515 1516 |
*----------------------------------------------------------------------
*/
int
Tcl_UniCharIsControl(
int ch) /* Unicode character to test. */
{
| < < | 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 |
*----------------------------------------------------------------------
*/
int
Tcl_UniCharIsControl(
int ch) /* Unicode character to test. */
{
if (UNICODE_OUT_OF_RANGE(ch)) {
ch &= 0x1FFFFF;
if ((ch == 0xE0001) || ((ch >= 0xE0020) && (ch <= 0xE007f))) {
return 1;
}
if ((ch >= 0xF0000) && ((ch & 0xFFFF) <= 0xFFFD)) {
return 1;
}
return 0;
}
return ((CONTROL_BITS >> GetCategory(ch)) & 1);
}
/*
*----------------------------------------------------------------------
*
* Tcl_UniCharIsDigit --
|
| ︙ | ︙ | |||
1545 1546 1547 1548 1549 1550 1551 |
*----------------------------------------------------------------------
*/
int
Tcl_UniCharIsDigit(
int ch) /* Unicode character to test. */
{
| < < | 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 |
*----------------------------------------------------------------------
*/
int
Tcl_UniCharIsDigit(
int ch) /* Unicode character to test. */
{
if (UNICODE_OUT_OF_RANGE(ch)) {
return 0;
}
return (GetCategory(ch) == DECIMAL_DIGIT_NUMBER);
}
/*
*----------------------------------------------------------------------
*
* Tcl_UniCharIsGraph --
|
| ︙ | ︙ | |||
1573 1574 1575 1576 1577 1578 1579 |
*----------------------------------------------------------------------
*/
int
Tcl_UniCharIsGraph(
int ch) /* Unicode character to test. */
{
| < < | 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 |
*----------------------------------------------------------------------
*/
int
Tcl_UniCharIsGraph(
int ch) /* Unicode character to test. */
{
if (UNICODE_OUT_OF_RANGE(ch)) {
ch &= 0x1FFFFF;
return (ch >= 0xE0100) && (ch <= 0xE01EF);
}
return ((GRAPH_BITS >> GetCategory(ch)) & 1);
}
/*
*----------------------------------------------------------------------
*
* Tcl_UniCharIsLower --
|
| ︙ | ︙ | |||
1602 1603 1604 1605 1606 1607 1608 |
*----------------------------------------------------------------------
*/
int
Tcl_UniCharIsLower(
int ch) /* Unicode character to test. */
{
| < < | 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 |
*----------------------------------------------------------------------
*/
int
Tcl_UniCharIsLower(
int ch) /* Unicode character to test. */
{
if (UNICODE_OUT_OF_RANGE(ch)) {
return 0;
}
return (GetCategory(ch) == LOWERCASE_LETTER);
}
/*
*----------------------------------------------------------------------
*
* Tcl_UniCharIsPrint --
|
| ︙ | ︙ | |||
1630 1631 1632 1633 1634 1635 1636 |
*----------------------------------------------------------------------
*/
int
Tcl_UniCharIsPrint(
int ch) /* Unicode character to test. */
{
| < < | 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 |
*----------------------------------------------------------------------
*/
int
Tcl_UniCharIsPrint(
int ch) /* Unicode character to test. */
{
if (UNICODE_OUT_OF_RANGE(ch)) {
ch &= 0x1FFFFF;
return (ch >= 0xE0100) && (ch <= 0xE01EF);
}
return (((GRAPH_BITS|SPACE_BITS) >> GetCategory(ch)) & 1);
}
/*
*----------------------------------------------------------------------
*
* Tcl_UniCharIsPunct --
|
| ︙ | ︙ | |||
1659 1660 1661 1662 1663 1664 1665 |
*----------------------------------------------------------------------
*/
int
Tcl_UniCharIsPunct(
int ch) /* Unicode character to test. */
{
| < < | 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 |
*----------------------------------------------------------------------
*/
int
Tcl_UniCharIsPunct(
int ch) /* Unicode character to test. */
{
if (UNICODE_OUT_OF_RANGE(ch)) {
return 0;
}
return ((PUNCT_BITS >> GetCategory(ch)) & 1);
}
/*
*----------------------------------------------------------------------
*
* Tcl_UniCharIsSpace --
|
| ︙ | ︙ | |||
1687 1688 1689 1690 1691 1692 1693 |
*----------------------------------------------------------------------
*/
int
Tcl_UniCharIsSpace(
int ch) /* Unicode character to test. */
{
| < < < < < < < | 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 |
*----------------------------------------------------------------------
*/
int
Tcl_UniCharIsSpace(
int ch) /* Unicode character to test. */
{
/* Ignore upper 11 bits. */
ch &= 0x1FFFFF;
/*
* If the character is within the first 127 characters, just use the
* standard C function, otherwise consult the Unicode table.
*/
if (ch < 0x80) {
return TclIsSpaceProc((char) ch);
} else if (UNICODE_OUT_OF_RANGE(ch)) {
return 0;
} else if (ch == 0x0085 || ch == 0x180E || ch == 0x200B
|| ch == 0x202F || ch == 0x2060 || ch == 0xFEFF) {
return 1;
} else {
return ((SPACE_BITS >> GetCategory(ch)) & 1);
}
}
|
| ︙ | ︙ | |||
1734 1735 1736 1737 1738 1739 1740 |
*----------------------------------------------------------------------
*/
int
Tcl_UniCharIsUpper(
int ch) /* Unicode character to test. */
{
| < < | 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 |
*----------------------------------------------------------------------
*/
int
Tcl_UniCharIsUpper(
int ch) /* Unicode character to test. */
{
if (UNICODE_OUT_OF_RANGE(ch)) {
return 0;
}
return (GetCategory(ch) == UPPERCASE_LETTER);
}
/*
*----------------------------------------------------------------------
*
* Tcl_UniCharIsWordChar --
|
| ︙ | ︙ | |||
1762 1763 1764 1765 1766 1767 1768 |
*----------------------------------------------------------------------
*/
int
Tcl_UniCharIsWordChar(
int ch) /* Unicode character to test. */
{
| < < | 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 |
*----------------------------------------------------------------------
*/
int
Tcl_UniCharIsWordChar(
int ch) /* Unicode character to test. */
{
if (UNICODE_OUT_OF_RANGE(ch)) {
return 0;
}
return ((WORD_BITS >> GetCategory(ch)) & 1);
}
/*
*----------------------------------------------------------------------
*
* Tcl_UniCharCaseMatch --
|
| ︙ | ︙ | |||
1852 1853 1854 1855 1856 1857 1858 |
* quickly if the next char in the pattern isn't a special
* character
*/
if ((p != '[') && (p != '?') && (p != '\\')) {
if (nocase) {
while (*uniStr && (p != *uniStr)
| | | 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 |
* quickly if the next char in the pattern isn't a special
* character
*/
if ((p != '[') && (p != '?') && (p != '\\')) {
if (nocase) {
while (*uniStr && (p != *uniStr)
&& (p != (Tcl_UniChar)Tcl_UniCharToLower(*uniStr))) {
uniStr++;
}
} else {
while (*uniStr && (p != *uniStr)) {
uniStr++;
}
}
|
| ︙ | ︙ | |||
1892 1893 1894 1895 1896 1897 1898 |
* characters separated by "-").
*/
if (p == '[') {
Tcl_UniChar startChar, endChar;
uniPattern++;
| | | | | 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 |
* characters separated by "-").
*/
if (p == '[') {
Tcl_UniChar startChar, endChar;
uniPattern++;
ch1 = (nocase ? (Tcl_UniChar)Tcl_UniCharToLower(*uniStr) : *uniStr);
uniStr++;
while (1) {
if ((*uniPattern == ']') || (*uniPattern == 0)) {
return 0;
}
startChar = (nocase ? (Tcl_UniChar)Tcl_UniCharToLower(*uniPattern)
: *uniPattern);
uniPattern++;
if (*uniPattern == '-') {
uniPattern++;
if (*uniPattern == 0) {
return 0;
}
endChar = (nocase ? (Tcl_UniChar)Tcl_UniCharToLower(*uniPattern)
: *uniPattern);
uniPattern++;
if (((startChar <= ch1) && (ch1 <= endChar))
|| ((endChar <= ch1) && (ch1 <= startChar))) {
/*
* Matches ranges of form [a-z] or [z-a].
*/
|
| ︙ | ︙ | |||
1984 1985 1986 1987 1988 1989 1990 |
*
*----------------------------------------------------------------------
*/
int
TclUniCharMatch(
const Tcl_UniChar *string, /* Unicode String. */
| | | | 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 |
*
*----------------------------------------------------------------------
*/
int
TclUniCharMatch(
const Tcl_UniChar *string, /* Unicode String. */
size_t strLen, /* Length of String */
const Tcl_UniChar *pattern, /* Pattern, which may contain special
* characters. */
size_t ptnLen, /* Length of Pattern */
int nocase) /* 0 for case sensitive, 1 for insensitive */
{
const Tcl_UniChar *stringEnd, *patternEnd;
Tcl_UniChar p;
stringEnd = string + strLen;
patternEnd = pattern + ptnLen;
|
| ︙ | ︙ | |||
2044 2045 2046 2047 2048 2049 2050 |
* quickly if the next char in the pattern isn't a special
* character.
*/
if ((p != '[') && (p != '?') && (p != '\\')) {
if (nocase) {
while ((string < stringEnd) && (p != *string)
| | | 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 |
* quickly if the next char in the pattern isn't a special
* character.
*/
if ((p != '[') && (p != '?') && (p != '\\')) {
if (nocase) {
while ((string < stringEnd) && (p != *string)
&& (p != (Tcl_UniChar)Tcl_UniCharToLower(*string))) {
string++;
}
} else {
while ((string < stringEnd) && (p != *string)) {
string++;
}
}
|
| ︙ | ︙ | |||
2085 2086 2087 2088 2089 2090 2091 |
* characters separated by "-").
*/
if (p == '[') {
Tcl_UniChar ch1, startChar, endChar;
pattern++;
| | | | | 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 |
* characters separated by "-").
*/
if (p == '[') {
Tcl_UniChar ch1, startChar, endChar;
pattern++;
ch1 = (nocase ? (Tcl_UniChar)Tcl_UniCharToLower(*string) : *string);
string++;
while (1) {
if ((*pattern == ']') || (pattern == patternEnd)) {
return 0;
}
startChar = (nocase ? (Tcl_UniChar)Tcl_UniCharToLower(*pattern) : *pattern);
pattern++;
if (*pattern == '-') {
pattern++;
if (pattern == patternEnd) {
return 0;
}
endChar = (nocase ? (Tcl_UniChar)Tcl_UniCharToLower(*pattern)
: *pattern);
pattern++;
if (((startChar <= ch1) && (ch1 <= endChar))
|| ((endChar <= ch1) && (ch1 <= startChar))) {
/*
* Matches ranges of form [a-z] or [z-a].
*/
|
| ︙ | ︙ |
Changes to generic/tclUtil.c.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 18 19 20 21 22 23 24 | * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #include "tclParse.h" #include "tclStringTrim.h" #include <math.h> /* * The absolute pathname of the executable in which this Tcl library is * running. */ | > | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 | * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #include "tclParse.h" #include "tclStringTrim.h" #include "tommath.h" #include <math.h> /* * The absolute pathname of the executable in which this Tcl library is * running. */ |
| ︙ | ︙ | |||
96 97 98 99 100 101 102 | /* * Prototypes for functions defined later in this file. */ static void ClearHash(Tcl_HashTable *tablePtr); static void FreeProcessGlobalValue(ClientData clientData); static void FreeThreadHash(ClientData clientData); | | | | | | | | > | | 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 |
/*
* 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_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);
/*
* 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.
*/
static const Tcl_ObjType endOffsetType = {
"end-offset", /* name */
NULL, /* freeIntRepProc */
NULL, /* dupIntRepProc */
NULL, /* updateStringProc */
NULL /* setFromAnyProc */
};
/*
* * 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
|
| ︙ | ︙ | |||
381 382 383 384 385 386 387 |
*
*----------------------------------------------------------------------
*/
int
TclMaxListLength(
const char *bytes,
| | | | | | | | | 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 |
*
*----------------------------------------------------------------------
*/
int
TclMaxListLength(
const char *bytes,
size_t numBytes,
const char **endPtr)
{
size_t count = 0;
if ((numBytes == 0) || ((numBytes == TCL_AUTO_LENGTH) && (*bytes == '\0'))) {
/* Empty string case - quick exit */
goto done;
}
/*
* No list element before leading white space.
*/
count += 1 - TclIsSpaceProc(*bytes);
/*
* Count white space runs as potential element separators.
*/
while (numBytes) {
if ((numBytes == TCL_AUTO_LENGTH) && (*bytes == '\0')) {
break;
}
if (TclIsSpaceProc(*bytes)) {
/*
* Space run started; bump count.
*/
count++;
do {
bytes++;
numBytes -= (numBytes != TCL_AUTO_LENGTH);
} while (numBytes && TclIsSpaceProc(*bytes));
if ((numBytes == 0) || ((numBytes == TCL_AUTO_LENGTH) && (*bytes == '\0'))) {
break;
}
/*
* (*bytes) is non-space; return to counting state.
*/
}
bytes++;
numBytes -= (numBytes != TCL_AUTO_LENGTH);
}
/*
* No list element following trailing white space.
*/
count -= TclIsSpaceProc(bytes[-1]);
|
| ︙ | ︙ | |||
493 494 495 496 497 498 499 |
* elements (possibly in braces). */
int listLength, /* Number of bytes in the list's string. */
const char **elementPtr, /* Where to put address of first significant
* character in first element of list. */
const char **nextPtr, /* Fill in with location of character just
* after all white space following end of
* argument (next arg or end of list). */
| | | 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 |
* elements (possibly in braces). */
int listLength, /* Number of bytes in the list's string. */
const char **elementPtr, /* Where to put address of first significant
* character in first element of list. */
const char **nextPtr, /* Fill in with location of character just
* after all white space following end of
* argument (next arg or end of list). */
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 element and therefore
* does not/does require a call to
* TclCopyAndCollapse() by the caller. */
|
| ︙ | ︙ | |||
522 523 524 525 526 527 528 |
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). */
| | | 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 |
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. */
|
| ︙ | ︙ | |||
554 555 556 557 558 559 560 |
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). */
| | | | 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 |
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. */
int openBraces = 0; /* Brace nesting level during parse. */
int inQuotes = 0;
int size = 0; /* lint. */
size_t numChars;
int literal = 1;
const char *p2;
/*
* Skim off leading white space and check for an opening brace or quote.
* We treat embedded NULLs in the list/dict as bytes belonging to a list
* element (or dictionary key or value).
|
| ︙ | ︙ | |||
780 781 782 783 784 785 786 | * * Side effects: * None. * *---------------------------------------------------------------------- */ | | | | | | | 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 |
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
size_t
TclCopyAndCollapse(
size_t count, /* Number of byte to copy from src. */
const char *src, /* Copy from here... */
char *dst) /* ... to here. */
{
size_t newCount = 0;
while (count > 0) {
char c = *src;
if (c == '\\') {
size_t numRead;
size_t backslashCount = TclParseBackslash(src, count, &numRead, dst);
dst += backslashCount;
newCount += backslashCount;
src += numRead;
count -= numRead;
} else {
*dst = c;
|
| ︙ | ︙ | |||
851 852 853 854 855 856 857 |
int *argcPtr, /* Pointer to location to fill in with the
* number of elements in the list. */
const char ***argvPtr) /* Pointer to place to store pointer to array
* of pointers to list elements. */
{
const char **argv, *end, *element;
char *p;
| | > | | | | | 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 |
int *argcPtr, /* Pointer to location to fill in with the
* number of elements in the list. */
const char ***argvPtr) /* Pointer to place to store pointer to array
* of pointers to list elements. */
{
const char **argv, *end, *element;
char *p;
int length, size, i, result;
size_t elSize;
/*
* Allocate enough space to work in. A (const char *) for each (possible)
* list element plus one more for terminating NULL, plus as many bytes as
* in the original string value, plus one more for a terminating '\0'.
* Space used to hold element separating white space in the original
* string gets re-purposed to hold '\0' characters in the argv array.
*/
size = TclMaxListLength(list, -1, &end) + 1;
length = end - list;
argv = Tcl_Alloc((size * sizeof(char *)) + length + 1);
for (i = 0, p = ((char *) argv) + size*sizeof(char *);
*list != 0; i++) {
const char *prevList = list;
int literal;
result = TclFindElement(interp, list, length, &element, &list,
&elSize, &literal);
length -= (list - prevList);
if (result != TCL_OK) {
Tcl_Free((void *)argv);
return result;
}
if (*element == 0) {
break;
}
if (i >= size) {
Tcl_Free((void *)argv);
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"internal error in Tcl_SplitList", -1));
Tcl_SetErrorCode(interp, "TCL", "INTERNAL", "Tcl_SplitList",
NULL);
}
return TCL_ERROR;
}
argv[i] = p;
if (literal) {
memcpy(p, element, elSize);
p += elSize;
*p = 0;
p++;
} else {
p += 1 + TclCopyAndCollapse(elSize, element, p);
}
}
|
| ︙ | ︙ | |||
928 929 930 931 932 933 934 | * * Side effects: * None. * *---------------------------------------------------------------------- */ | | | | | | 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 |
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
size_t
Tcl_ScanElement(
const char *src, /* String to convert to list element. */
int *flagPtr) /* Where to store information to guide
* Tcl_ConvertCountedElement. */
{
return Tcl_ScanCountedElement(src, -1, flagPtr);
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
960 961 962 963 964 965 966 | * * Side effects: * None. * *---------------------------------------------------------------------- */ | | | | 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 |
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
size_t
Tcl_ScanCountedElement(
const char *src, /* String to convert to Tcl list element. */
size_t length, /* Number of bytes in src, or -1. */
int *flagPtr) /* Where to store information to guide
* Tcl_ConvertElement. */
{
char flags = CONVERT_ANY;
int numBytes = TclScanElement(src, length, &flags);
*flagPtr = flags;
|
| ︙ | ︙ | |||
1004 1005 1006 1007 1008 1009 1010 | * * Side effects: * None. * *---------------------------------------------------------------------- */ | | | | | > > > > > > > > > > > > > > > > > | 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 |
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
size_t
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
* Tcl_ConvertElement. */
{
const char *p = src;
int nestingLevel = 0; /* Brace nesting count */
int forbidNone = 0; /* Do not permit CONVERT_NONE mode. Something
* needs protection or escape. */
int requireEscape = 0; /* Force use of CONVERT_ESCAPE mode. For some
* reason bare or brace-quoted form fails. */
int extra = 0; /* Count of number of extra bytes needed for
* formatted element, assuming we use escape
* sequences in formatting. */
size_t bytesNeeded; /* Buffer length computed to complete the
* element formatting in the selected mode. */
#if COMPAT
int preferEscape = 0; /* Use preferences to track whether to use */
int preferBrace = 0; /* CONVERT_MASK mode. */
int braceCount = 0; /* Count of all braces '{' '}' seen. */
#endif /* COMPAT */
if ((p == NULL) || (length == 0) || ((*p == '\0') && (length == TCL_AUTO_LENGTH))) {
/*
* Empty string element must be brace quoted.
*/
*flagPtr = CONVERT_BRACE;
return 2;
}
#if COMPAT
/*
* We have an established history in TclConvertElement() when quoting
* because of a leading hash character to force what would be the
* CONVERT_MASK mode into the CONVERT_BRACE mode. That is, we format
* the element #{a"b} like this:
* {#{a"b}}
* and not like this:
* \#{a\"b}
* This is inconsistent with [list x{a"b}], but we will not change that now.
* Set that preference here so that we compute a tight size requirement.
*/
if ((*src == '#') && !(*flagPtr & TCL_DONT_QUOTE_HASH)) {
preferBrace = 1;
}
#endif
if ((*p == '{') || (*p == '"')) {
/*
* Must escape or protect so leading character of value is not
* misinterpreted as list element delimiting syntax.
*/
|
| ︙ | ︙ | |||
1100 1101 1102 1103 1104 1105 1106 | extra++; /* Escape sequences all one byte longer. */ #if COMPAT preferBrace = 1; #endif /* COMPAT */ break; case '\\': /* TYPE_SUBS */ extra++; /* Escape '\' => '\\' */ | | | 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 |
extra++; /* Escape sequences all one byte longer. */
#if COMPAT
preferBrace = 1;
#endif /* COMPAT */
break;
case '\\': /* TYPE_SUBS */
extra++; /* Escape '\' => '\\' */
if ((length == 1) || ((length == TCL_AUTO_LENGTH) && (p[1] == '\0'))) {
/*
* Final backslash. Cannot format with brace quoting.
*/
requireEscape = 1;
break;
}
|
| ︙ | ︙ | |||
1131 1132 1133 1134 1135 1136 1137 | } forbidNone = 1; #if COMPAT preferBrace = 1; #endif /* COMPAT */ break; case '\0': /* TYPE_SUBS */ | | | | 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 |
}
forbidNone = 1;
#if COMPAT
preferBrace = 1;
#endif /* COMPAT */
break;
case '\0': /* TYPE_SUBS */
if (length == TCL_AUTO_LENGTH) {
goto endOfString;
}
/* TODO: Panic on improper encoding? */
break;
}
}
length -= (length+1 > 1);
p++;
}
endOfString:
if (nestingLevel != 0) {
/*
* Unbalanced braces! Cannot format with brace quoting.
|
| ︙ | ︙ | |||
1173 1174 1175 1176 1177 1178 1179 |
* Make room to escape leading #, if needed.
*/
if ((*src == '#') && !(*flagPtr & TCL_DONT_QUOTE_HASH)) {
bytesNeeded++;
}
*flagPtr = CONVERT_ESCAPE;
| | | 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 |
* Make room to escape leading #, if needed.
*/
if ((*src == '#') && !(*flagPtr & TCL_DONT_QUOTE_HASH)) {
bytesNeeded++;
}
*flagPtr = CONVERT_ESCAPE;
return bytesNeeded;
}
if (*flagPtr & CONVERT_ANY) {
/*
* The caller has not let us know what flags it will pass to
* TclConvertElement() so compute the max size we might need for any
* possible choice. Normally the formatting using escape sequences is
* the longer one, and a minimum "extra" value of 2 makes sure we
|
| ︙ | ︙ | |||
1221 1222 1223 1224 1225 1226 1227 |
* escape the braces.
*/
if (*flagPtr & TCL_DONT_USE_BRACES) {
bytesNeeded += braceCount;
}
*flagPtr = CONVERT_MASK;
| | | 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 |
* escape the braces.
*/
if (*flagPtr & TCL_DONT_USE_BRACES) {
bytesNeeded += braceCount;
}
*flagPtr = CONVERT_MASK;
return bytesNeeded;
}
#endif /* COMPAT */
if (*flagPtr & TCL_DONT_USE_BRACES) {
/*
* If the caller reports it will direct TclConvertElement() to
* use escapes, add the extra bytes needed to have room for them.
*/
|
| ︙ | ︙ | |||
1247 1248 1249 1250 1251 1252 1253 | /* * Add 2 bytes for room for the enclosing braces. */ bytesNeeded += 2; } *flagPtr = CONVERT_BRACE; | | < < < < < | 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 |
/*
* Add 2 bytes for room for the enclosing braces.
*/
bytesNeeded += 2;
}
*flagPtr = CONVERT_BRACE;
return bytesNeeded;
}
/*
* So far, no need to quote or escape anything.
*/
if ((*src == '#') && !(*flagPtr & TCL_DONT_QUOTE_HASH)) {
/*
* If we need to quote a leading #, make room to enclose in braces.
*/
bytesNeeded += 2;
}
*flagPtr = CONVERT_NONE;
return bytesNeeded;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ConvertElement --
|
| ︙ | ︙ | |||
1291 1292 1293 1294 1295 1296 1297 | * * Side effects: * None. * *---------------------------------------------------------------------- */ | | | | | | 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 |
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
size_t
Tcl_ConvertElement(
const char *src, /* Source information for list element. */
char *dst, /* Place to put list-ified element. */
int flags) /* Flags produced by Tcl_ScanElement. */
{
return Tcl_ConvertCountedElement(src, -1, dst, flags);
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1321 1322 1323 1324 1325 1326 1327 | * * Side effects: * None. * *---------------------------------------------------------------------- */ | | | | | 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 |
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
size_t
Tcl_ConvertCountedElement(
register const char *src, /* Source information for list element. */
size_t 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);
dst[numBytes] = '\0';
return numBytes;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1354 1355 1356 1357 1358 1359 1360 | * * Side effects: * None. * *---------------------------------------------------------------------- */ | | | | | | | | | | | | | 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 |
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
size_t
TclConvertElement(
register const char *src, /* Source information for list element. */
size_t length, /* Number of bytes in src, or -1. */
char *dst, /* Place to put list-ified element. */
int flags) /* Flags produced by Tcl_ScanElement. */
{
int conversion = flags & CONVERT_MASK;
char *p = dst;
/*
* Let the caller demand we use escape sequences rather than braces.
*/
if ((flags & TCL_DONT_USE_BRACES) && (conversion & CONVERT_BRACE)) {
conversion = CONVERT_ESCAPE;
}
/*
* No matter what the caller demands, empty string must be braced!
*/
if ((src == NULL) || (length == 0) || (*src == '\0' && length == TCL_AUTO_LENGTH)) {
p[0] = '{';
p[1] = '}';
return 2;
}
/*
* Escape leading hash as needed and requested.
*/
if ((*src == '#') && !(flags & TCL_DONT_QUOTE_HASH)) {
if (conversion == CONVERT_ESCAPE) {
p[0] = '\\';
p[1] = '#';
p += 2;
src++;
length -= (length+1 > 1);
} else {
conversion = CONVERT_BRACE;
}
}
/*
* No escape or quoting needed. Copy the literal string value.
*/
if (conversion == CONVERT_NONE) {
if (length == TCL_AUTO_LENGTH) {
/* TODO: INT_MAX overflow? */
while (*src) {
*p++ = *src++;
}
return p - dst;
} else {
memcpy(dst, src, length);
return length;
}
}
/*
* Formatted string is original string enclosed in braces.
*/
if (conversion == CONVERT_BRACE) {
*p = '{';
p++;
if (length == TCL_AUTO_LENGTH) {
/* TODO: INT_MAX overflow? */
while (*src) {
*p++ = *src++;
}
} else {
memcpy(p, src, length);
p += length;
}
*p = '}';
p++;
return (size_t)(p - dst);
}
/* conversion == CONVERT_ESCAPE or CONVERT_MASK */
/*
* Formatted string is original string converted to escape sequences.
*/
for ( ; length; src++, length -= (length+1 > 1)) {
switch (*src) {
case ']':
case '[':
case '$':
case ';':
case ' ':
case '\\':
|
| ︙ | ︙ | |||
1495 1496 1497 1498 1499 1500 1501 | case '\v': *p = '\\'; p++; *p = 'v'; p++; continue; case '\0': | | | | | 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 |
case '\v':
*p = '\\';
p++;
*p = 'v';
p++;
continue;
case '\0':
if (length == TCL_AUTO_LENGTH) {
return (size_t)(p - dst);
}
/*
* If we reach this point, there's an embedded NULL in the string
* range being processed, which should not happen when the
* encoding rules for Tcl strings are properly followed. If the
* day ever comes when we stop tolerating such things, this is
* where to put the Tcl_Panic().
*/
break;
}
*p = *src;
p++;
}
return (size_t)(p - dst);
}
/*
*----------------------------------------------------------------------
*
* Tcl_Merge --
*
|
| ︙ | ︙ | |||
1542 1543 1544 1545 1546 1547 1548 |
char *
Tcl_Merge(
int argc, /* How many strings to merge. */
const char *const *argv) /* Array of string values. */
{
#define LOCAL_SIZE 64
char localFlags[LOCAL_SIZE], *flagPtr = NULL;
| > | | | < < < < < < | | | 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 |
char *
Tcl_Merge(
int argc, /* How many strings to merge. */
const char *const *argv) /* Array of string values. */
{
#define LOCAL_SIZE 64
char localFlags[LOCAL_SIZE], *flagPtr = NULL;
int i;
size_t bytesNeeded = 0;
char *result, *dst;
/*
* Handle empty list case first, so logic of the general case can be
* simpler.
*/
if (argc == 0) {
result = Tcl_Alloc(1);
result[0] = '\0';
return result;
}
/*
* Pass 1: estimate space, gather flags.
*/
if (argc <= LOCAL_SIZE) {
flagPtr = localFlags;
} else {
flagPtr = Tcl_Alloc(argc);
}
for (i = 0; i < argc; i++) {
flagPtr[i] = ( i ? TCL_DONT_QUOTE_HASH : 0 );
bytesNeeded += TclScanElement(argv[i], -1, &flagPtr[i]);
}
bytesNeeded += argc;
/*
* Pass two: copy into the result area.
*/
result = Tcl_Alloc(bytesNeeded);
dst = result;
for (i = 0; i < argc; i++) {
flagPtr[i] |= ( i ? TCL_DONT_QUOTE_HASH : 0 );
dst += TclConvertElement(argv[i], -1, dst, flagPtr[i]);
*dst = ' ';
dst++;
}
dst[-1] = 0;
if (flagPtr != localFlags) {
Tcl_Free(flagPtr);
}
return result;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1626 1627 1628 1629 1630 1631 1632 |
{
const char *l = bytes + length;
const char *p = Tcl_UtfPrev(l, bytes);
if (Tcl_UtfCharComplete(p, l - p)) {
return bytes;
}
| | | 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 |
{
const char *l = bytes + length;
const char *p = Tcl_UtfPrev(l, bytes);
if (Tcl_UtfCharComplete(p, l - p)) {
return bytes;
}
/*
* Malformed utf-8 end, be sure we've NTS to safe compare of end-character,
* avoid segfault by access violation out of range.
*/
Tcl_DStringAppend(buffer, bytes, length);
return Tcl_DStringValue(buffer);
}
/*
|
| ︙ | ︙ | |||
1650 1651 1652 1653 1654 1655 1656 | * * Side effects: * None. * *---------------------------------------------------------------------- */ | | | | | | | | 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 |
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static inline size_t
TrimRight(
const char *bytes, /* String to be trimmed... */
size_t numBytes, /* ...and its length in bytes */
const char *trim, /* String of trim characters... */
size_t numTrim) /* ...and its length in bytes */
{
const char *p = bytes + numBytes;
size_t pInc;
Tcl_UniChar ch1 = 0, ch2 = 0;
/*
* Outer loop: iterate over string to be trimmed.
*/
do {
const char *q = trim;
size_t bytesLeft = numTrim;
p = Tcl_UtfPrev(p, bytes);
pInc = TclUtfToUniChar(p, &ch1);
/*
* Inner loop: scan trim string for match to current character.
*/
do {
size_t qInc = TclUtfToUniChar(q, &ch2);
if (ch1 == ch2) {
break;
}
q += qInc;
bytesLeft -= qInc;
|
| ︙ | ︙ | |||
1700 1701 1702 1703 1704 1705 1706 |
break;
}
} while (p > bytes);
return numBytes - (p - bytes);
}
| | | | | | 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 |
break;
}
} while (p > bytes);
return numBytes - (p - bytes);
}
size_t
TclTrimRight(
const char *bytes, /* String to be trimmed... */
size_t numBytes, /* ...and its length in bytes */
const char *trim, /* String of trim characters... */
size_t numTrim) /* ...and its length in bytes */
{
size_t res;
Tcl_DString bytesBuf, trimBuf;
/* Empty strings -> nothing to do */
if ((numBytes == 0) || (numTrim == 0)) {
return 0;
}
|
| ︙ | ︙ | |||
1749 1750 1751 1752 1753 1754 1755 | * * Side effects: * None. * *---------------------------------------------------------------------- */ | | | | | | | | 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 |
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static inline size_t
TrimLeft(
const char *bytes, /* String to be trimmed... */
size_t numBytes, /* ...and its length in bytes */
const char *trim, /* String of trim characters... */
size_t numTrim) /* ...and its length in bytes */
{
const char *p = bytes;
Tcl_UniChar ch1 = 0, ch2 = 0;
/*
* Outer loop: iterate over string to be trimmed.
*/
do {
size_t pInc = TclUtfToUniChar(p, &ch1);
const char *q = trim;
size_t bytesLeft = numTrim;
/*
* Inner loop: scan trim string for match to current character.
*/
do {
size_t qInc = TclUtfToUniChar(q, &ch2);
if (ch1 == ch2) {
break;
}
q += qInc;
bytesLeft -= qInc;
|
| ︙ | ︙ | |||
1798 1799 1800 1801 1802 1803 1804 |
p += pInc;
numBytes -= pInc;
} while (numBytes > 0);
return p - bytes;
}
| | | | | | 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 |
p += pInc;
numBytes -= pInc;
} while (numBytes > 0);
return p - bytes;
}
size_t
TclTrimLeft(
const char *bytes, /* String to be trimmed... */
size_t numBytes, /* ...and its length in bytes */
const char *trim, /* String of trim characters... */
size_t numTrim) /* ...and its length in bytes */
{
size_t res;
Tcl_DString bytesBuf, trimBuf;
/* Empty strings -> nothing to do */
if ((numBytes == 0) || (numTrim == 0)) {
return 0;
}
|
| ︙ | ︙ | |||
1845 1846 1847 1848 1849 1850 1851 | * * Side effects: * None. * *---------------------------------------------------------------------- */ | | | | | | | 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 |
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
size_t
TclTrim(
const char *bytes, /* String to be trimmed... */
size_t numBytes, /* ...and its length in bytes */
const char *trim, /* String of trim characters... */
size_t numTrim, /* ...and its length in bytes */
size_t *trimRight) /* Offset from the end of the string. */
{
size_t trimLeft;
Tcl_DString bytesBuf, trimBuf;
*trimRight = 0;
/* Empty strings -> nothing to do */
if ((numBytes == 0) || (numTrim == 0)) {
return 0;
}
|
| ︙ | ︙ | |||
1907 1908 1909 1910 1911 1912 1913 | * Memory is allocated for the result; the caller is responsible for * freeing the memory. * *---------------------------------------------------------------------- */ /* The whitespace characters trimmed during [concat] operations */ | | > | | < < < < < < < < < < < | | | 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 |
* Memory is allocated for the result; the caller is responsible for
* freeing the memory.
*
*----------------------------------------------------------------------
*/
/* The whitespace characters trimmed during [concat] operations */
#define CONCAT_WS_SIZE (sizeof(CONCAT_TRIM_SET "") - 1)
char *
Tcl_Concat(
int argc, /* Number of strings to concatenate. */
const char *const *argv) /* Array of strings to concatenate. */
{
int i;
size_t needSpace = 0, bytesNeeded = 0;
char *result, *p;
/*
* Dispose of the empty result corner case first to simplify later code.
*/
if (argc == 0) {
result = (char *) Tcl_Alloc(1);
result[0] = '\0';
return result;
}
/*
* First allocate the result buffer at the size required.
*/
for (i = 0; i < argc; i++) {
bytesNeeded += strlen(argv[i]);
}
/*
* All element bytes + (argc - 1) spaces + 1 terminating NULL.
*/
result = Tcl_Alloc(bytesNeeded + argc);
for (p = result, i = 0; i < argc; i++) {
size_t 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,
|
| ︙ | ︙ | |||
1983 1984 1985 1986 1987 1988 1989 |
/*
* Append to the result with space if needed.
*/
if (needSpace) {
*p++ = ' ';
}
| | | 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 |
/*
* Append to the result with space if needed.
*/
if (needSpace) {
*p++ = ' ';
}
memcpy(p, element, elemLength);
p += elemLength;
needSpace = 1;
}
*p = '\0';
return result;
}
|
| ︙ | ︙ | |||
2014 2015 2016 2017 2018 2019 2020 |
*/
Tcl_Obj *
Tcl_ConcatObj(
int objc, /* Number of objects to concatenate. */
Tcl_Obj *const objv[]) /* Array of objects to concatenate. */
{
| | > | | | | 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 |
*/
Tcl_Obj *
Tcl_ConcatObj(
int objc, /* Number of objects to concatenate. */
Tcl_Obj *const objv[]) /* Array of objects to concatenate. */
{
int i, needSpace = 0;
size_t bytesNeeded = 0, elemLength;
const char *element;
Tcl_Obj *objPtr, *resPtr;
/*
* Check first to see if all the items are of list type or empty. If so,
* we will concat them together as lists, and return a list object. This
* is only valid when the lists are in canonical form.
*/
for (i = 0; i < objc; i++) {
size_t length;
objPtr = objv[i];
if (TclListObjIsCanonical(objPtr)) {
continue;
}
(void)TclGetStringFromObj(objPtr, &length);
if (length > 0) {
break;
}
}
if (i == objc) {
resPtr = NULL;
for (i = 0; i < objc; i++) {
objPtr = objv[i];
if (!TclListObjIsCanonical(objPtr)) {
continue;
}
if (resPtr) {
if (TCL_OK != Tcl_ListObjAppendList(NULL, resPtr, objPtr)) {
/* Abandon ship! */
Tcl_DecrRefCount(resPtr);
goto slow;
|
| ︙ | ︙ | |||
2070 2071 2072 2073 2074 2075 2076 |
*
* First try to pre-allocate the size required.
*/
for (i = 0; i < objc; i++) {
element = TclGetStringFromObj(objv[i], &elemLength);
bytesNeeded += elemLength;
| < < < | | 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 |
*
* First try to pre-allocate the size required.
*/
for (i = 0; i < objc; i++) {
element = TclGetStringFromObj(objv[i], &elemLength);
bytesNeeded += elemLength;
}
/*
* Does not matter if this fails, will simply try later to build up the
* string with each Append reallocating as needed with the usual string
* append algorithm. When that fails it will report the error.
*/
TclNewObj(resPtr);
(void) Tcl_AttemptSetObjLength(resPtr, bytesNeeded + objc - 1);
Tcl_SetObjLength(resPtr, 0);
for (i = 0; i < objc; i++) {
size_t triml, trimr;
element = TclGetStringFromObj(objv[i], &elemLength);
/* Trim away the leading/trailing whitespace. */
triml = TclTrim(element, elemLength, CONCAT_TRIM_SET,
CONCAT_WS_SIZE, &trimr);
element += triml;
|
| ︙ | ︙ | |||
2119 2120 2121 2122 2123 2124 2125 |
Tcl_AppendToObj(resPtr, " ", 1);
}
Tcl_AppendToObj(resPtr, element, elemLength);
needSpace = 1;
}
return resPtr;
}
| < < < < < < < < < < < < < < < < < < < < < < < < < < < | 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 |
Tcl_AppendToObj(resPtr, " ", 1);
}
Tcl_AppendToObj(resPtr, element, elemLength);
needSpace = 1;
}
return resPtr;
}
/*
*----------------------------------------------------------------------
*
* Tcl_StringCaseMatch --
*
* See if a particular string matches a particular pattern. Allows case
|
| ︙ | ︙ | |||
2236 2237 2238 2239 2240 2241 2242 |
* character
*/
if ((p != '[') && (p != '?') && (p != '\\')) {
if (nocase) {
while (*str) {
charLen = TclUtfToUniChar(str, &ch1);
| | | 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 |
* character
*/
if ((p != '[') && (p != '?') && (p != '\\')) {
if (nocase) {
while (*str) {
charLen = TclUtfToUniChar(str, &ch1);
if (ch2==ch1 || ch2==(Tcl_UniChar)Tcl_UniCharToLower(ch1)) {
break;
}
str += charLen;
}
} else {
/*
* There's no point in trying to make this code
|
| ︙ | ︙ | |||
2402 2403 2404 2405 2406 2407 2408 |
*
*----------------------------------------------------------------------
*/
int
TclByteArrayMatch(
const unsigned char *string,/* String. */
| | | | 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 |
*
*----------------------------------------------------------------------
*/
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 */
int flags)
{
const unsigned char *stringEnd, *patternEnd;
unsigned char p;
stringEnd = string + strLen;
patternEnd = pattern + ptnLen;
|
| ︙ | ︙ | |||
2583 2584 2585 2586 2587 2588 2589 |
int
TclStringMatchObj(
Tcl_Obj *strObj, /* string object. */
Tcl_Obj *ptnObj, /* pattern object. */
int flags) /* Only TCL_MATCH_NOCASE should be passed, or
* 0. */
{
| | > | | | | | | 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 |
int
TclStringMatchObj(
Tcl_Obj *strObj, /* string object. */
Tcl_Obj *ptnObj, /* pattern object. */
int flags) /* Only TCL_MATCH_NOCASE should be passed, or
* 0. */
{
int match;
size_t length = 0, plen = 0;
/*
* Promote based on the type of incoming object.
* XXX: Currently doesn't take advantage of exact-ness that
* XXX: TclReToGlob tells us about
trivial = nocase ? 0 : TclMatchIsTrivial(TclGetString(ptnObj));
*/
if (TclHasIntRep(strObj, &tclStringType) || (strObj->typePtr == NULL)) {
Tcl_UniChar *udata, *uptn;
udata = TclGetUnicodeFromObj(strObj, &length);
uptn = TclGetUnicodeFromObj(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);
match = TclByteArrayMatch(data, length, ptn, plen, 0);
} else {
match = Tcl_StringCaseMatch(TclGetString(strObj),
TclGetString(ptnObj), flags);
}
return match;
}
|
| ︙ | ︙ | |||
2661 2662 2663 2664 2665 2666 2667 |
*
*----------------------------------------------------------------------
*/
char *
Tcl_DStringAppend(
Tcl_DString *dsPtr, /* Structure describing dynamic string. */
| | | | | | | | | | | | | | | 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 |
*
*----------------------------------------------------------------------
*/
char *
Tcl_DStringAppend(
Tcl_DString *dsPtr, /* Structure describing dynamic string. */
const char *bytes, /* String to append. If length is
* TCL_AUTO_LENGTH then this must be null-terminated. */
size_t length) /* Number of bytes from "bytes" to append. If
* TCL_AUTO_LENGTH, then append all of bytes, up to null
* at end. */
{
size_t newSize;
if (length == TCL_AUTO_LENGTH) {
length = strlen(bytes);
}
newSize = length + dsPtr->length;
/*
* Allocate a larger buffer for the string if the current one isn't large
* enough. Allocate extra space in the new buffer so that there will be
* room to grow before we have to allocate again.
*/
if (newSize >= dsPtr->spaceAvl) {
dsPtr->spaceAvl = newSize * 2;
if (dsPtr->string == dsPtr->staticSpace) {
char *newString = Tcl_Alloc(dsPtr->spaceAvl);
memcpy(newString, dsPtr->string, dsPtr->length);
dsPtr->string = newString;
} else {
size_t index = TCL_INDEX_NONE;
/* See [16896d49fd] */
if (bytes >= dsPtr->string
&& bytes <= dsPtr->string + dsPtr->length) {
index = bytes - dsPtr->string;
}
dsPtr->string = Tcl_Realloc(dsPtr->string, dsPtr->spaceAvl);
if (index != TCL_INDEX_NONE) {
bytes = dsPtr->string + index;
}
}
}
/*
* Copy the new string into the buffer at the end of the old one.
*/
|
| ︙ | ︙ | |||
2730 2731 2732 2733 2734 2735 2736 |
*/
char *
TclDStringAppendObj(
Tcl_DString *dsPtr,
Tcl_Obj *objPtr)
{
| | | | 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 |
*/
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,
|
| ︙ | ︙ | |||
2772 2773 2774 2775 2776 2777 2778 |
Tcl_DString *dsPtr, /* Structure describing dynamic string. */
const char *element) /* String to append. Must be
* null-terminated. */
{
char *dst = dsPtr->string + dsPtr->length;
int needSpace = TclNeedSpace(dsPtr->string, dst);
char flags = needSpace ? TCL_DONT_QUOTE_HASH : 0;
| | | | | | 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 |
Tcl_DString *dsPtr, /* Structure describing dynamic string. */
const char *element) /* String to append. Must be
* null-terminated. */
{
char *dst = dsPtr->string + dsPtr->length;
int needSpace = TclNeedSpace(dsPtr->string, dst);
char flags = needSpace ? TCL_DONT_QUOTE_HASH : 0;
size_t newSize = dsPtr->length + needSpace
+ TclScanElement(element, -1, &flags);
/*
* Allocate a larger buffer for the string if the current one isn't large
* enough. Allocate extra space in the new buffer so that there will be
* room to grow before we have to allocate again. SPECIAL NOTE: must use
* memcpy, not strcpy, to copy the string to a larger buffer, since there
* may be embedded NULLs in the string in some cases.
*/
if (newSize >= dsPtr->spaceAvl) {
dsPtr->spaceAvl = newSize * 2;
if (dsPtr->string == dsPtr->staticSpace) {
char *newString = Tcl_Alloc(dsPtr->spaceAvl);
memcpy(newString, dsPtr->string, dsPtr->length);
dsPtr->string = newString;
} else {
int offset = -1;
/* See [16896d49fd] */
if (element >= dsPtr->string
&& element <= dsPtr->string + dsPtr->length) {
offset = element - dsPtr->string;
}
dsPtr->string = Tcl_Realloc(dsPtr->string, dsPtr->spaceAvl);
if (offset >= 0) {
element = dsPtr->string + offset;
}
}
dst = dsPtr->string + dsPtr->length;
}
|
| ︙ | ︙ | |||
2844 2845 2846 2847 2848 2849 2850 | * either grow or shrink, depending on the value of length. * * Results: * None. * * Side effects: * The length of dsPtr is changed to length and a null byte is stored at | | < | | < < < | | | | 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 |
* either grow or shrink, depending on the value of length.
*
* Results:
* None.
*
* Side effects:
* The length of dsPtr is changed to length and a null byte is stored at
* that position in the string.
*
*----------------------------------------------------------------------
*/
void
Tcl_DStringSetLength(
Tcl_DString *dsPtr, /* Structure describing dynamic string. */
size_t length) /* New length for dynamic string. */
{
size_t newsize;
if (length >= dsPtr->spaceAvl) {
/*
* There are two interesting cases here. In the first case, the user
* may be trying to allocate a large buffer of a specific size. It
* would be wasteful to overallocate that buffer, so we just allocate
* enough for the requested size plus the trailing null byte. In the
* second case, we are growing the buffer incrementally, so we need
* behavior similar to Tcl_DStringAppend. The requested length will
* usually be a small delta above the current spaceAvl, so we'll end
* up doubling the old size. This won't grow the buffer quite as
* quickly, but it should be close enough.
*/
newsize = dsPtr->spaceAvl * 2;
if (length < newsize) {
dsPtr->spaceAvl = newsize;
} else {
dsPtr->spaceAvl = length + 1;
}
if (dsPtr->string == dsPtr->staticSpace) {
char *newString = Tcl_Alloc(dsPtr->spaceAvl);
memcpy(newString, dsPtr->string, dsPtr->length);
dsPtr->string = newString;
} else {
dsPtr->string = Tcl_Realloc(dsPtr->string, dsPtr->spaceAvl);
}
}
dsPtr->length = length;
dsPtr->string[length] = 0;
}
/*
|
| ︙ | ︙ | |||
2915 2916 2917 2918 2919 2920 2921 |
*/
void
Tcl_DStringFree(
Tcl_DString *dsPtr) /* Structure describing dynamic string. */
{
if (dsPtr->string != dsPtr->staticSpace) {
| | | 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 |
*/
void
Tcl_DStringFree(
Tcl_DString *dsPtr) /* Structure describing dynamic string. */
{
if (dsPtr->string != dsPtr->staticSpace) {
Tcl_Free(dsPtr->string);
}
dsPtr->string = dsPtr->staticSpace;
dsPtr->length = 0;
dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE;
dsPtr->staticSpace[0] = '\0';
}
|
| ︙ | ︙ | |||
2977 2978 2979 2980 2981 2982 2983 |
void
Tcl_DStringGetResult(
Tcl_Interp *interp, /* Interpreter whose result is to be reset. */
Tcl_DString *dsPtr) /* Dynamic string that is to become the result
* of interp. */
{
| | | | | 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 |
void
Tcl_DStringGetResult(
Tcl_Interp *interp, /* Interpreter whose result is to be reset. */
Tcl_DString *dsPtr) /* Dynamic string that is to become the result
* of interp. */
{
Tcl_Obj *obj = Tcl_GetObjResult(interp);
char *bytes = TclGetString(obj);
Tcl_DStringFree(dsPtr);
Tcl_DStringAppend(dsPtr, bytes, obj->length);
Tcl_ResetResult(interp);
}
/*
*----------------------------------------------------------------------
*
* TclDStringToObj --
|
| ︙ | ︙ | |||
3214 3215 3216 3217 3218 3219 3220 |
while (c != '\0') {
*dst++ = c;
c = *++p;
}
}
*dst++ = '\0';
}
| | | 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 |
while (c != '\0') {
*dst++ = c;
c = *++p;
}
}
*dst++ = '\0';
}
Tcl_Free(digits);
}
/*
*----------------------------------------------------------------------
*
* TclNeedSpace --
*
|
| ︙ | ︙ | |||
3329 3330 3331 3332 3333 3334 3335 | * Side effects: * The formatted characters are written into the storage pointer to by * the "buffer" argument. * *---------------------------------------------------------------------- */ | | | < | | 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 |
* Side effects:
* 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
* formatted characters are written. */
Tcl_WideInt n) /* The integer to format. */
{
Tcl_WideInt intVal;
size_t i, numFormatted, j;
const char *digits = "0123456789";
/*
* Check first whether "n" is zero.
*/
if (n == 0) {
|
| ︙ | ︙ | |||
3395 3396 3397 3398 3399 3400 3401 |
}
return numFormatted;
}
/*
*----------------------------------------------------------------------
*
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 3505 3506 3507 3508 3509 3510 3511 3512 3513 3514 3515 3516 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 3549 3550 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 |
}
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.
*
* 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.
*
* 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. */
{
ClientData cd;
const char *opPtr;
int numType, length, t1 = 0, t2 = 0;
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) {
/* Must be a double -> not a valid index */
goto parseError;
}
/* objPtr holds an integer outside the signed wide range */
/* Truncate to the signed wide range. */
*widePtr = (((mp_int *)cd)->sign != MP_ZPOS) ? WIDE_MIN : WIDE_MAX;
return TCL_OK;
}
/* objPtr does not hold a number, check the end+/- format... */
if (GetEndOffsetFromObj(objPtr, endValue, widePtr) == TCL_OK) {
return TCL_OK;
}
/* If we reach here, the string rep of objPtr exists. */
/*
* The valid index syntax does not include any value that is
* a list of more than one element. This is necessary so that
* lists of index values can be reliably distinguished from any
* single index value.
*/
/*
* Quick scan to see if multi-value list is even possible.
* This relies on TclGetString() returning a NUL-terminated string.
*/
if ((TclMaxListLength(TclGetString(objPtr), -1, NULL) > 1)
/* If it's possible, do the full list parse. */
&& (TCL_OK == Tcl_ListObjLength(NULL, objPtr, &length))
&& (length > 1)) {
goto parseError;
}
/* Passed the list screen, so parse for index arithmetic expression */
if (TCL_OK == TclParseNumber(NULL, objPtr, NULL, NULL, -1, &opPtr,
TCL_PARSE_INTEGER_ONLY)) {
Tcl_WideInt w1=0, w2=0;
/* value starts with valid integer... */
if ((*opPtr == '-') || (*opPtr == '+')) {
/* ... value continues with [-+] ... */
/* Save first integer as wide if possible */
TclGetNumberFromObj(NULL, objPtr, &cd, &t1);
if (t1 == TCL_NUMBER_INT) {
w1 = (*(Tcl_WideInt *)cd);
}
if (TCL_OK == TclParseNumber(NULL, objPtr, NULL, opPtr + 1,
-1, NULL, TCL_PARSE_INTEGER_ONLY)) {
/* ... value concludes with second valid integer */
/* Save second integer as wide if possible */
TclGetNumberFromObj(NULL, objPtr, &cd, &t2);
if (t2 == TCL_NUMBER_INT) {
w2 = (*(Tcl_WideInt *)cd);
}
}
}
/* Clear invalid intreps left by TclParseNumber */
TclFreeIntRep(objPtr);
if (t1 && t2) {
/* We have both integer values */
if ((t1 == TCL_NUMBER_INT) && (t2 == TCL_NUMBER_INT)) {
/* Both are wide, do wide-integer math */
if (*opPtr == '-') {
if ((w2 == WIDE_MIN) && (interp != NULL)) {
goto extreme;
}
w2 = -w2;
}
if ((w1 ^ w2) < 0) {
/* Different signs, sum cannot overflow */
*widePtr = w1 + w2;
} else if (w1 >= 0) {
if (w1 < WIDE_MAX - w2) {
*widePtr = w1 + w2;
} else {
*widePtr = WIDE_MAX;
}
} else {
if (w1 > WIDE_MIN - w2) {
*widePtr = w1 + w2;
} else {
*widePtr = WIDE_MIN;
}
}
} else if (interp == NULL) {
/*
* We use an interp to do bignum index calculations.
* If we don't get one, call all indices with bignums errors,
* and rely on callers to handle it.
*/
return TCL_ERROR;
} else {
/*
* At least one is big, do bignum math. Little reason to
* value performance here. Re-use code. Parse has verified
* objPtr is an expression. Compute it.
*/
Tcl_Obj *sum;
extreme:
Tcl_ExprObj(interp, objPtr, &sum);
TclGetNumberFromObj(NULL, sum, &cd, &numType);
if (numType == TCL_NUMBER_INT) {
/* sum holds an integer in the signed wide range */
*widePtr = *(Tcl_WideInt *)cd;
} else {
/* sum holds an integer outside the signed wide range */
/* Truncate to the signed wide range. */
if (((mp_int *)cd)->sign != MP_ZPOS) {
*widePtr = WIDE_MIN;
} else {
*widePtr = WIDE_MAX;
}
}
Tcl_DecrRefCount(sum);
}
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);
}
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* 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
|
| ︙ | ︙ | |||
3422 3423 3424 3425 3426 3427 3428 | * The object referenced by 'objPtr' is converted, as needed, to an * integer, wide integer, or end-based-index object. * *---------------------------------------------------------------------- */ int | | | | < < < | < < | | > | | | < < | < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < | | | | | | < < < < < < < < < < < < < < < < < < < < | | | | | | | | | > > > > < < > > | | | > > | < < | < < < > | < < < < < < | < < < < < < | | < < < | | < < > | | > | | | > > | < > | < < < < < < < | > | | | < < < | | | | < < < < | < < | < < < | < < < > | | > | < < | < < < < | < < < < < | > | > < < < < > > | | > > > > > | | | | | | 3585 3586 3587 3588 3589 3590 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 3629 3630 3631 3632 3633 3634 3635 3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 3652 3653 3654 3655 3656 3657 3658 3659 3660 3661 3662 3663 3664 3665 3666 3667 3668 3669 3670 3671 3672 3673 3674 3675 3676 3677 3678 3679 3680 3681 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 3695 3696 3697 3698 3699 3700 3701 3702 3703 3704 3705 3706 3707 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 3729 3730 3731 3732 3733 3734 3735 3736 3737 3738 3739 3740 3741 3742 3743 3744 3745 3746 3747 3748 3749 3750 3751 3752 |
* The object referenced by 'objPtr' is converted, as needed, to an
* integer, wide integer, or end-based-index object.
*
*----------------------------------------------------------------------
*/
int
Tcl_GetIntForIndex(
Tcl_Interp *interp, /* Interpreter to use for error reporting. If
* NULL, then no error message is left after
* errors. */
Tcl_Obj *objPtr, /* Points to an object containing either "end"
* or an integer. */
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 (wide < 0) {
*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" and convert it to an
* internal representation holding the offset.
*
* Results:
* Tcl return code.
*
* Side effects:
* May store a Tcl_ObjType.
*
*----------------------------------------------------------------------
*/
static int
GetEndOffsetFromObj(
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 = 0; /* Offset in the "end-offset" expression */
while ((irPtr = TclFetchIntRep(objPtr, &endOffsetType)) == NULL) {
Tcl_ObjIntRep ir;
size_t length;
const char *bytes = TclGetStringFromObj(objPtr, &length);
if ((length < 3) || (length == 4)) {
/* Too short to be "end" or to be "end-$integer" */
return TCL_ERROR;
}
if ((*bytes != 'e') || (strncmp(bytes, "end", 3) != 0)) {
/* Value doesn't start with "end" */
return TCL_ERROR;
}
if (length > 4) {
ClientData cd;
int t;
/* Parse for the "end-..." or "end+..." formats */
if ((bytes[3] != '-') && (bytes[3] != '+')) {
/* No operator where we need one */
return TCL_ERROR;
}
if (TclIsSpaceProc(bytes[4])) {
/* Space after + or - not permitted. */
return TCL_ERROR;
}
/* 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 */
return TCL_ERROR;
}
/* 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_int *)cd)->sign != MP_ZPOS) {
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;
}
}
}
/* Success. Store the new internal rep. */
ir.wideValue = offset;
Tcl_StoreIntRep(objPtr, &endOffsetType, &ir);
}
offset = irPtr->wideValue;
if (endValue == TCL_INDEX_NONE) {
*widePtr = offset - 1;
} else if (offset < 0) {
/* Different signs, sum cannot overflow */
*widePtr = endValue + offset;
} else if (endValue < (Tcl_WideUInt)WIDE_MAX - offset) {
*widePtr = endValue + offset;
} else {
*widePtr = WIDE_MAX;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* 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
|
| ︙ | ︙ | |||
3702 3703 3704 3705 3706 3707 3708 |
*----------------------------------------------------------------------
*/
int
TclIndexEncode(
Tcl_Interp *interp, /* For error reporting, may be NULL */
Tcl_Obj *objPtr, /* Index value to parse */
| | | > | > | | > | | > > | | | | | | | | | | | | | 3774 3775 3776 3777 3778 3779 3780 3781 3782 3783 3784 3785 3786 3787 3788 3789 3790 3791 3792 3793 3794 3795 3796 3797 3798 3799 3800 3801 3802 3803 3804 3805 3806 3807 3808 3809 3810 3811 3812 3813 3814 3815 3816 3817 3818 3819 3820 3821 3822 3823 3824 3825 3826 3827 3828 3829 3830 3831 3832 3833 |
*----------------------------------------------------------------------
*/
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 */
{
ClientData cd;
Tcl_WideInt wide;
int idx, numType, code = TclGetNumberFromObj(NULL, objPtr, &cd, &numType);
if ((code == TCL_OK) && (numType == TCL_NUMBER_INT)) {
/* We parsed a value in the range WIDE_MIN...WIDE_MAX */
wide = (*(Tcl_WideInt *)cd);
integerEncode:
if (wide < 0) {
/* All negative absolute indices are "before the beginning" */
idx = before;
} else if (wide >= INT_MAX) {
/* This index value is always "after the end" */
idx = after;
} else {
idx = (int) wide;
}
/* usual case, the absolute index value encodes itself */
} else if (TCL_OK == GetEndOffsetFromObj(objPtr, 0, &wide)) {
/*
* We parsed an end+offset index value.
* wide holds the offset value in the range WIDE_MIN...WIDE_MAX.
*/
if (wide > 0) {
/*
* All end+positive or end-negative expressions
* always indicate "after the end".
*/
idx = (int) after;
} else if (wide < INT_MIN - (int) TCL_INDEX_END) {
/* These indices always indicate "before the beginning */
idx = (int) before;
} else {
/* Encoded end-positive (or end+negative) are offset */
idx = (int) wide + (int) TCL_INDEX_END;
}
/* TODO: Consider flag to suppress repeated end-offset parse. */
} else if (TCL_OK == GetWideForIndex(interp, objPtr, 0, &wide)) {
/*
* Only reach this case when the index value is a
* constant index arithmetic expression, and wide
* holds the result. Treat it the same as if it were
* parsed as an absolute integer value.
*/
goto integerEncode;
} else {
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
3769 3770 3771 3772 3773 3774 3775 | * * Results: * The decoded index value. * *---------------------------------------------------------------------- */ | | | | > > > | | | 3846 3847 3848 3849 3850 3851 3852 3853 3854 3855 3856 3857 3858 3859 3860 3861 3862 3863 3864 3865 3866 3867 3868 3869 3870 3871 |
*
* Results:
* The decoded index value.
*
*----------------------------------------------------------------------
*/
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;
}
/*
*----------------------------------------------------------------------
*
* ClearHash --
*
|
| ︙ | ︙ | |||
3832 3833 3834 3835 3836 3837 3838 |
GetThreadHash(
Tcl_ThreadDataKey *keyPtr)
{
Tcl_HashTable **tablePtrPtr =
Tcl_GetThreadData(keyPtr, sizeof(Tcl_HashTable *));
if (NULL == *tablePtrPtr) {
| | | 3912 3913 3914 3915 3916 3917 3918 3919 3920 3921 3922 3923 3924 3925 3926 |
GetThreadHash(
Tcl_ThreadDataKey *keyPtr)
{
Tcl_HashTable **tablePtrPtr =
Tcl_GetThreadData(keyPtr, sizeof(Tcl_HashTable *));
if (NULL == *tablePtrPtr) {
*tablePtrPtr = Tcl_Alloc(sizeof(Tcl_HashTable));
Tcl_CreateThreadExitHandler(FreeThreadHash, *tablePtrPtr);
Tcl_InitHashTable(*tablePtrPtr, TCL_ONE_WORD_KEYS);
}
return *tablePtrPtr;
}
/*
|
| ︙ | ︙ | |||
3861 3862 3863 3864 3865 3866 3867 |
FreeThreadHash(
ClientData clientData)
{
Tcl_HashTable *tablePtr = clientData;
ClearHash(tablePtr);
Tcl_DeleteHashTable(tablePtr);
| | | 3941 3942 3943 3944 3945 3946 3947 3948 3949 3950 3951 3952 3953 3954 3955 |
FreeThreadHash(
ClientData clientData)
{
Tcl_HashTable *tablePtr = clientData;
ClearHash(tablePtr);
Tcl_DeleteHashTable(tablePtr);
Tcl_Free(tablePtr);
}
/*
*----------------------------------------------------------------------
*
* FreeProcessGlobalValue --
*
|
| ︙ | ︙ | |||
3883 3884 3885 3886 3887 3888 3889 |
FreeProcessGlobalValue(
ClientData clientData)
{
ProcessGlobalValue *pgvPtr = clientData;
pgvPtr->epoch++;
pgvPtr->numBytes = 0;
| | | 3963 3964 3965 3966 3967 3968 3969 3970 3971 3972 3973 3974 3975 3976 3977 |
FreeProcessGlobalValue(
ClientData clientData)
{
ProcessGlobalValue *pgvPtr = clientData;
pgvPtr->epoch++;
pgvPtr->numBytes = 0;
Tcl_Free(pgvPtr->value);
pgvPtr->value = NULL;
if (pgvPtr->encoding) {
Tcl_FreeEncoding(pgvPtr->encoding);
pgvPtr->encoding = NULL;
}
Tcl_MutexFinalize(&pgvPtr->mutex);
}
|
| ︙ | ︙ | |||
3922 3923 3924 3925 3926 3927 3928 |
/*
* Fill the global string value.
*/
pgvPtr->epoch++;
if (NULL != pgvPtr->value) {
| | | | 4002 4003 4004 4005 4006 4007 4008 4009 4010 4011 4012 4013 4014 4015 4016 4017 4018 4019 4020 4021 4022 |
/*
* Fill the global string value.
*/
pgvPtr->epoch++;
if (NULL != pgvPtr->value) {
Tcl_Free(pgvPtr->value);
} else {
Tcl_CreateExitHandler(FreeProcessGlobalValue, pgvPtr);
}
bytes = TclGetString(newValue);
pgvPtr->numBytes = newValue->length;
pgvPtr->value = Tcl_Alloc(pgvPtr->numBytes + 1);
memcpy(pgvPtr->value, bytes, pgvPtr->numBytes + 1);
if (pgvPtr->encoding) {
Tcl_FreeEncoding(pgvPtr->encoding);
}
pgvPtr->encoding = encoding;
/*
|
| ︙ | ︙ | |||
3991 3992 3993 3994 3995 3996 3997 | Tcl_MutexLock(&pgvPtr->mutex); epoch = ++pgvPtr->epoch; Tcl_UtfToExternalDString(pgvPtr->encoding, pgvPtr->value, pgvPtr->numBytes, &native); Tcl_ExternalToUtfDString(current, Tcl_DStringValue(&native), Tcl_DStringLength(&native), &newValue); Tcl_DStringFree(&native); | | | | | 4071 4072 4073 4074 4075 4076 4077 4078 4079 4080 4081 4082 4083 4084 4085 4086 4087 4088 |
Tcl_MutexLock(&pgvPtr->mutex);
epoch = ++pgvPtr->epoch;
Tcl_UtfToExternalDString(pgvPtr->encoding, pgvPtr->value,
pgvPtr->numBytes, &native);
Tcl_ExternalToUtfDString(current, Tcl_DStringValue(&native),
Tcl_DStringLength(&native), &newValue);
Tcl_DStringFree(&native);
Tcl_Free(pgvPtr->value);
pgvPtr->value = Tcl_Alloc(Tcl_DStringLength(&newValue) + 1);
memcpy(pgvPtr->value, Tcl_DStringValue(&newValue),
Tcl_DStringLength(&newValue) + 1);
Tcl_DStringFree(&newValue);
Tcl_FreeEncoding(pgvPtr->encoding);
pgvPtr->encoding = current;
Tcl_MutexUnlock(&pgvPtr->mutex);
} else {
Tcl_FreeEncoding(current);
}
|
| ︙ | ︙ | |||
4176 4177 4178 4179 4180 4181 4182 |
*----------------------------------------------------------------------
*/
int
TclReToGlob(
Tcl_Interp *interp,
const char *reStr,
| | | 4256 4257 4258 4259 4260 4261 4262 4263 4264 4265 4266 4267 4268 4269 4270 |
*----------------------------------------------------------------------
*/
int
TclReToGlob(
Tcl_Interp *interp,
const char *reStr,
size_t reStrLen,
Tcl_DString *dsPtr,
int *exactPtr,
int *quantifiersFoundPtr)
{
int anchorLeft, anchorRight, lastIsStar, numStars;
char *dsStr, *dsStrStart;
const char *msg, *p, *strEnd, *code;
|
| ︙ | ︙ |
Changes to generic/tclVar.c.
| ︙ | ︙ | |||
41 42 43 44 45 46 47 | Tcl_Obj *key, int *newPtr); static inline Var * VarHashFirstVar(TclVarHashTable *tablePtr, Tcl_HashSearch *searchPtr); static inline Var * VarHashNextVar(Tcl_HashSearch *searchPtr); static inline void CleanupVar(Var *varPtr, Var *arrayPtr); #define VarHashGetValue(hPtr) \ | | | < | < < > | 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 |
Tcl_Obj *key, int *newPtr);
static inline Var * VarHashFirstVar(TclVarHashTable *tablePtr,
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)))
/*
* 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
* can bubble up to callers of callers .... etc.
*/
static inline Var *
VarHashCreateVar(
TclVarHashTable *tablePtr,
Tcl_Obj *key,
int *newPtr)
{
Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(&tablePtr->table, key, newPtr);
if (!hPtr) {
return NULL;
}
return VarHashGetValue(hPtr);
}
#define VarHashFindVar(tablePtr, key) \
VarHashCreateVar((tablePtr), (key), NULL)
#define VarHashInvalidateEntry(varPtr) \
((varPtr)->flags |= VAR_DEAD_HASH)
|
| ︙ | ︙ | |||
88 89 90 91 92 93 94 |
static inline Var *
VarHashFirstVar(
TclVarHashTable *tablePtr,
Tcl_HashSearch *searchPtr)
{
Tcl_HashEntry *hPtr = VarHashFirstEntry(tablePtr, searchPtr);
| | < < > | < < > | 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 |
static inline Var *
VarHashFirstVar(
TclVarHashTable *tablePtr,
Tcl_HashSearch *searchPtr)
{
Tcl_HashEntry *hPtr = VarHashFirstEntry(tablePtr, searchPtr);
if (!hPtr) {
return NULL;
}
return VarHashGetValue(hPtr);
}
static inline Var *
VarHashNextVar(
Tcl_HashSearch *searchPtr)
{
Tcl_HashEntry *hPtr = VarHashNextEntry(searchPtr);
if (!hPtr) {
return NULL;
}
return VarHashGetValue(hPtr);
}
#define VarHashGetKey(varPtr) \
(((VarInHash *)(varPtr))->entry.key.objPtr)
#define VarHashDeleteTable(tablePtr) \
Tcl_DeleteHashTable(&(tablePtr)->table)
|
| ︙ | ︙ | |||
145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 |
/*
* 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 {
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. */
Tcl_HashSearch search; /* Info kept by the hash module about progress
* through the array. */
Tcl_HashEntry *nextEntry; /* Non-null means this is the next element to
* be enumerated (it's leftover from the
* Tcl_FirstHashEntry call or from an "array
* anymore" command). NULL means must call
* Tcl_NextHashEntry to get value to
* return. */
struct ArraySearch *nextPtr;/* Next in list of all active searches for
* this variable, or NULL if this is the last
* one. */
} ArraySearch;
/*
* 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 DeleteSearches(Interp *iPtr, Var *arrayVarPtr);
static void DeleteArray(Interp *iPtr, Tcl_Obj *arrayNamePtr,
Var *varPtr, int flags, int index);
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,
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);
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | > > | 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 |
/*
* 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. */
Tcl_HashSearch search; /* Info kept by the hash module about progress
* through the array. */
Tcl_HashEntry *nextEntry; /* Non-null means this is the next element to
* be enumerated (it's leftover from the
* Tcl_FirstHashEntry call or from an "array
* anymore" command). NULL means must call
* Tcl_NextHashEntry to get value to
* return. */
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 int ArrayForNRCmd(ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *const *objv);
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,
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,
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);
/*
* 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.
*/
MODULE_SCOPE Var * TclLookupSimpleVar(Tcl_Interp *interp,
|
| ︙ | ︙ | |||
210 211 212 213 214 215 216 | * 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 * | < < < < > > > > > > > > > > > > > > > > > > | < > > | < < > > > > | | > > | < < < < | > | > > | < > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 |
* 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
*
* 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 ? 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 ? irPtr->twoPtrValue.ptr1 : NULL; \
(elem) = irPtr ? irPtr->twoPtrValue.ptr2 : NULL; \
} while (0)
Var *
TclVarHashCreateVar(
TclVarHashTable *tablePtr,
const char *key,
int *newPtr)
{
Tcl_Obj *keyPtr;
Var *varPtr;
keyPtr = Tcl_NewStringObj(key, -1);
Tcl_IncrRefCount(keyPtr);
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 --
*
* This function is called when it looks like it may be OK to free up a
|
| ︙ | ︙ | |||
296 297 298 299 300 301 302 |
Var *varPtr, /* Pointer to variable that may be a candidate
* for being expunged. */
Var *arrayPtr) /* Array that contains the variable, or NULL
* if this variable isn't an array element. */
{
if (TclIsVarUndefined(varPtr) && TclIsVarInHash(varPtr)
&& !TclIsVarTraced(varPtr)
| | > | | > | | 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 |
Var *varPtr, /* Pointer to variable that may be a candidate
* for being expunged. */
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))) {
if (VarHashRefCount(varPtr) == 0) {
Tcl_Free(varPtr);
} else {
VarHashDeleteEntry(varPtr);
}
}
if (arrayPtr != NULL && TclIsVarUndefined(arrayPtr) &&
TclIsVarInHash(arrayPtr) && !TclIsVarTraced(arrayPtr) &&
(VarHashRefCount(arrayPtr) == (unsigned)
!TclIsVarDeadHash(arrayPtr))) {
if (VarHashRefCount(arrayPtr) == 0) {
Tcl_Free(arrayPtr);
} else {
VarHashDeleteEntry(arrayPtr);
}
}
}
void
|
| ︙ | ︙ | |||
433 434 435 436 437 438 439 | * entry or array to be created). For example, the variable might be a * global that has been unset but is still referenced by a procedure, or * 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 | | | < | 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 | * entry or array to be created). For example, the variable might be a * global that has been unset but is still referenced by a procedure, or * 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. * When createPart1 is 1, callers must IncrRefCount part1Ptr if they * plan to DecrRefCount it. * *---------------------------------------------------------------------- */ Var * |
| ︙ | ︙ | |||
522 523 524 525 526 527 528 |
{
Interp *iPtr = (Interp *) interp;
CallFrame *varFramePtr = iPtr->varFramePtr;
register Var *varPtr; /* Points to the variable's in-frame Var
* structure. */
const char *errMsg = NULL;
int index, parsed = 0;
| | > > | | | < < < | < | | | | < < | < < < < | | < | | < < | | | < | < < < < | | | 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 |
{
Interp *iPtr = (Interp *) interp;
CallFrame *varFramePtr = iPtr->varFramePtr;
register Var *varPtr; /* Points to the variable's in-frame Var
* structure. */
const char *errMsg = NULL;
int index, parsed = 0;
int localIndex;
Tcl_Obj *namePtr, *arrayPtr, *elem;
*arrayPtrPtr = NULL;
restart:
LocalGetIntRep(part1Ptr, localIndex, namePtr);
if (localIndex >= 0) {
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);
if ((!namePtr && (checkNamePtr == part1Ptr)) ||
(namePtr && (checkNamePtr == namePtr))) {
varPtr = (Var *) &(varFramePtr->compiledLocals[localIndex]);
goto donePart1;
}
}
goto doneParsing;
}
/*
* If part1Ptr is a parsedVarNameType, retrieve the pre-parsed parts.
*/
ParsedGetIntRep(part1Ptr, parsed, arrayPtr, elem);
if (parsed && arrayPtr) {
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);
}
return NULL;
}
part2Ptr = elem;
part1Ptr = arrayPtr;
goto restart;
}
if (!parsed) {
/*
* part1Ptr is possibly an unparsed array element.
*/
size_t len;
const char *part1 = TclGetStringFromObj(part1Ptr, &len);
if ((len > 1) && (part1[len - 1] == ')')) {
const char *part2 = strchr(part1, '(');
if (part2) {
if (part2Ptr != NULL) {
if (flags & TCL_LEAVE_ERR_MSG) {
TclObjVarErrMsg(interp, part1Ptr, part2Ptr, msg,
needArray, -1);
Tcl_SetErrorCode(interp, "TCL", "VALUE", "VARNAME",
NULL);
}
return NULL;
}
arrayPtr = Tcl_NewStringObj(part1, (part2 - part1));
part2Ptr = Tcl_NewStringObj(part2 + 1,
len - (part2 - part1) - 2);
ParsedSetIntRep(part1Ptr, arrayPtr, part2Ptr);
part1Ptr = arrayPtr;
}
}
}
doneParsing:
/*
* part1Ptr is not an array element; look it up, and convert it to one of
* the cached types if possible.
|
| ︙ | ︙ | |||
643 644 645 646 647 648 649 |
return NULL;
}
/*
* Cache the newly found variable if possible.
*/
| < > | > > > > > | > > > > | > > | > > > > | | > | | > > | < > > > < | < < | 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 |
return NULL;
}
/*
* Cache the newly found variable if possible.
*/
if (index >= 0) {
/*
* An indexed local variable.
*/
Tcl_Obj *cachedNamePtr = localName(varFramePtr, index);
if (part1Ptr == cachedNamePtr) {
LocalSetIntRep(part1Ptr, index, NULL);
} 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);
}
} else {
/*
* At least mark part1Ptr as already parsed.
*/
ParsedSetIntRep(part1Ptr, NULL, NULL);
}
donePart1:
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
|
| ︙ | ︙ | |||
759 760 761 762 763 764 765 |
TclVarHashTable *tablePtr; /* Points to the hashtable, if any, in which
* to look up the variable. */
Tcl_Var var; /* Used to search for global names. */
Var *varPtr; /* Points to the Var structure returned for
* the variable. */
Namespace *varNsPtr, *cxtNsPtr, *dummy1Ptr, *dummy2Ptr;
ResolverScheme *resPtr;
| | > | 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 |
TclVarHashTable *tablePtr; /* Points to the hashtable, if any, in which
* to look up the variable. */
Tcl_Var var; /* Used to search for global names. */
Var *varPtr; /* Points to the Var structure returned for
* the variable. */
Namespace *varNsPtr, *cxtNsPtr, *dummy1Ptr, *dummy2Ptr;
ResolverScheme *resPtr;
int isNew, i, result;
size_t varLen;
const char *varName = TclGetStringFromObj(varNamePtr, &varLen);
varPtr = NULL;
varNsPtr = NULL; /* Set non-NULL if a nonlocal variable. */
*indexPtr = -3;
if (flags & TCL_GLOBAL_ONLY) {
|
| ︙ | ︙ | |||
847 848 849 850 851 852 853 |
varPtr = (Var *) ObjFindNamespaceVar(interp, varNamePtr,
(Tcl_Namespace *) cxtNsPtr,
(flags | TCL_AVOID_RESOLVERS) & ~TCL_LEAVE_ERR_MSG);
if (varPtr == NULL) {
Tcl_Obj *tailPtr;
| > > > > > > | > > | | | | | | | | | | | | | | | < | | | | | | | | | | < < < < | > > | | > | | | | | | | > | | 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 |
varPtr = (Var *) ObjFindNamespaceVar(interp, varNamePtr,
(Tcl_Namespace *) cxtNsPtr,
(flags | TCL_AVOID_RESOLVERS) & ~TCL_LEAVE_ERR_MSG);
if (varPtr == NULL) {
Tcl_Obj *tailPtr;
if (!create) { /* Var wasn't found and not to create it. */
*errMsgPtr = noSuchVar;
return NULL;
}
/*
* Var wasn't found so create it.
*/
TclGetNamespaceForQualName(interp, varName, cxtNsPtr, flags,
&varNsPtr, &dummy1Ptr, &dummy2Ptr, &tail);
if (varNsPtr == NULL) {
*errMsgPtr = badNamespace;
return NULL;
} else if (tail == NULL) {
*errMsgPtr = missingName;
return NULL;
}
if (tail != varName) {
tailPtr = Tcl_NewStringObj(tail, -1);
} else {
tailPtr = varNamePtr;
}
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 { /* 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 ; i<localCt ; i++, objPtrPtr++) {
register Tcl_Obj *objPtr = *objPtrPtr;
if (objPtr) {
localNameStr = TclGetStringFromObj(objPtr, &localLen);
if ((varLen == localLen) && (varName[0] == localNameStr[0])
&& !memcmp(varName, localNameStr, varLen)) {
*indexPtr = i;
return (Var *) &varFramePtr->compiledLocals[i];
}
}
}
}
tablePtr = varFramePtr->varTablePtr;
if (create) {
if (tablePtr == NULL) {
tablePtr = Tcl_Alloc(sizeof(TclVarHashTable));
TclInitVarHashTable(tablePtr, NULL);
varFramePtr->varTablePtr = tablePtr;
}
varPtr = VarHashCreateVar(tablePtr, varNamePtr, &isNew);
} else {
varPtr = NULL;
if (tablePtr != NULL) {
|
| ︙ | ︙ | |||
980 981 982 983 984 985 986 |
* element, if it doesn't already exist. If 0,
* return error if it doesn't exist. */
Var *arrayPtr, /* Pointer to the array's Var structure. */
int index) /* If >=0, the index of the local array. */
{
int isNew;
Var *varPtr;
| < < | 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 |
* element, if it doesn't already exist. If 0,
* return error if it doesn't exist. */
Var *arrayPtr, /* Pointer to the array's Var structure. */
int index) /* If >=0, the index of the local array. */
{
int isNew;
Var *varPtr;
/*
* We're dealing with an array element. Make sure the variable is an array
* and look up the element (create the element if desired).
*/
if (TclIsVarUndefined(arrayPtr) && !TclIsVarArrayElement(arrayPtr)) {
|
| ︙ | ︙ | |||
1014 1015 1016 1017 1018 1019 1020 | danglingVar, index); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME", arrayNamePtr?TclGetString(arrayNamePtr):NULL, NULL); } return NULL; } | | < < < < < < < < < | 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 |
danglingVar, index);
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME",
arrayNamePtr?TclGetString(arrayNamePtr):NULL, NULL);
}
return NULL;
}
TclInitArrayVar(arrayPtr);
} else if (!TclIsVarArray(arrayPtr)) {
if (flags & TCL_LEAVE_ERR_MSG) {
TclObjVarErrMsg(interp, arrayNamePtr, elNamePtr, msg, needArray,
index);
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME",
arrayNamePtr?TclGetString(arrayNamePtr):NULL, NULL);
}
|
| ︙ | ︙ | |||
1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 |
/*
* Return the element if it's an existing scalar variable.
*/
if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr)) {
return varPtr->value.objPtr;
}
if (flags & TCL_LEAVE_ERR_MSG) {
if (TclIsVarUndefined(varPtr) && arrayPtr
&& !TclIsVarUndefined(arrayPtr)) {
msg = noSuchElement;
} else if (TclIsVarArray(varPtr)) {
msg = isArray;
| > > > > > > > > > > > > > > > > > > > > > > | 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 |
/*
* Return the element if it's an existing scalar variable.
*/
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;
} else if (TclIsVarArray(varPtr)) {
msg = isArray;
|
| ︙ | ︙ | |||
1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 |
return TclPtrSetVarIdx(interp, (Var *) varPtr, (Var *) arrayPtr,
part1Ptr, part2Ptr, newValuePtr, flags, -1);
}
/*
*----------------------------------------------------------------------
*
* 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:
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 |
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:
|
| ︙ | ︙ | |||
1753 1754 1755 1756 1757 1758 1759 |
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 (flags & TCL_LIST_ELEMENT) { /* Append list element. */
| < | < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < | 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 |
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 (flags & TCL_LIST_ELEMENT) { /* Append list element. */
result = ListAppendInVar(interp, varPtr, arrayPtr, oldValuePtr,
newValuePtr);
if (result != TCL_OK) {
goto earlyError;
}
} else { /* Append string. */
StringAppendInVar(varPtr, arrayPtr, oldValuePtr, 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.
*/
|
| ︙ | ︙ | |||
2029 2030 2031 2032 2033 2034 2035 |
}
varValuePtr = TclPtrGetVarIdx(interp, varPtr, arrayPtr, part1Ptr,
part2Ptr, flags, index);
if (TclIsVarInHash(varPtr)) {
VarHashRefCount(varPtr)--;
}
if (varValuePtr == NULL) {
| | < | 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 |
}
varValuePtr = TclPtrGetVarIdx(interp, varPtr, arrayPtr, part1Ptr,
part2Ptr, flags, index);
if (TclIsVarInHash(varPtr)) {
VarHashRefCount(varPtr)--;
}
if (varValuePtr == NULL) {
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);
} 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.
*/
|
| ︙ | ︙ | |||
2736 2737 2738 2739 2740 2741 2742 |
Tcl_SetObjResult(interp, newValuePtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
| | | | | > < | > | > > | < > > > > | | | | < < < | < | < < < < < < < | < < | < < | < < < | < < < | < | < < | < < < < < < < < | < < | < < < < < < < < < < < < < | | < < < | < < | < < < < < | < < < < | < < | | < < < | | < < | < < < < < | < < < < | | < < | > > > > > > | > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > | > > > > > > > > > > > > > > > > > > > | > > | > > > | > > > | > > > | > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | > | > | > > > | > | > > > > | > > > | > > > > | > > > | > > > > > > > > > > | > > > > > > > > | > > > > > > > | > < | < < | < < < < < | < < < < < < < < < < < < < < | | | | < < < < < | < < < < < < | | > > > | > > > > > > > > > > | > | | > > > | > > > > | | > > | < | | > > | > > > > | | | > > > | 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 |
Tcl_SetObjResult(interp, newValuePtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* 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 dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
return Tcl_NRCallObjProc(interp, ArrayForNRCmd, dummy, objc, objv);
}
static int
ArrayForNRCmd(
ClientData dummy,
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 = 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 = data[0];
Tcl_Obj *varListObj = data[1];
Tcl_Obj *arrayNameObj = data[2];
Tcl_Obj *scriptObj = 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 = 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.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
static int
ArrayStartSearchCmd(
ClientData 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 = 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=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"
|
| ︙ | ︙ | |||
3027 3028 3029 3030 3031 3032 3033 |
ArrayAnyMoreCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Interp *iPtr = (Interp *) interp;
| | | < < < | < < < < < < < < < < < < < | | | | < < < < < | < < < < < < < | 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 |
ArrayAnyMoreCmd(
ClientData 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);
|
| ︙ | ︙ | |||
3133 3134 3135 3136 3137 3138 3139 |
static int
ArrayNextElementCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
| < | > < < < | < < < < < < < < < < < < < | | | | < < < < < | < < < < < < < | 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 |
static int
ArrayNextElementCmd(
ClientData 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);
|
| ︙ | ︙ | |||
3243 3244 3245 3246 3247 3248 3249 |
ArrayDoneSearchCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Interp *iPtr = (Interp *) interp;
| | < | > < < < | < < < < < < < < < < < < < | | | | < < < < < | < < < < < < < < < < < | < < | < < < < < < < < < < < < < | | 3516 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 3549 3550 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 |
ArrayDoneSearchCmd(
ClientData 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 --
|
| ︙ | ︙ | |||
3350 3351 3352 3353 3354 3355 3356 |
static int
ArrayExistsCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
| | < < | < < < < | < < < < < < < < < < < < < | | | < < < < < < < | | 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 3590 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 |
static int
ArrayExistsCmd(
ClientData 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 --
|
| ︙ | ︙ | |||
3417 3418 3419 3420 3421 3422 3423 |
static int
ArrayGetCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
| < | | < < < | < < < < < < < < < < < < < | | | < < < < | < | < < | 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 3629 3630 3631 3632 3633 3634 3635 3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 3652 3653 3654 3655 3656 3657 |
static int
ArrayGetCmd(
ClientData 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.
|
| ︙ | ︙ | |||
3605 3606 3607 3608 3609 3610 3611 |
int objc,
Tcl_Obj *const objv[])
{
static const char *const options[] = {
"-exact", "-glob", "-regexp", NULL
};
enum options { OPT_EXACT, OPT_GLOB, OPT_REGEXP };
| < | | | < < < < | < < < < < < < < < < < < < | < | | < < < | < | < | 3781 3782 3783 3784 3785 3786 3787 3788 3789 3790 3791 3792 3793 3794 3795 3796 3797 3798 3799 3800 3801 3802 3803 3804 3805 3806 3807 3808 3809 3810 3811 3812 3813 3814 3815 3816 3817 3818 3819 3820 3821 3822 |
int objc,
Tcl_Obj *const objv[])
{
static const char *const options[] = {
"-exact", "-glob", "-regexp", NULL
};
enum options { OPT_EXACT, OPT_GLOB, OPT_REGEXP };
Var *varPtr, *varPtr2;
Tcl_Obj *nameObj, *resultObj, *patternObj;
Tcl_HashSearch search;
const char *pattern = NULL;
int isArray, mode = OPT_GLOB;
if ((objc < 2) || (objc > 4)) {
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.
*/
|
| ︙ | ︙ | |||
3793 3794 3795 3796 3797 3798 3799 |
static int
ArraySetCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
| | > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > | > > | > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > | > > > > | > > > > > > > > > > > > > > > > | | > > > | > > > > > > | > | > | | | 3945 3946 3947 3948 3949 3950 3951 3952 3953 3954 3955 3956 3957 3958 3959 3960 3961 3962 3963 3964 3965 3966 3967 3968 3969 3970 3971 3972 3973 3974 3975 3976 3977 3978 3979 3980 3981 3982 3983 3984 3985 3986 3987 3988 3989 3990 3991 3992 3993 3994 3995 3996 3997 3998 3999 4000 4001 4002 4003 4004 4005 4006 4007 4008 4009 4010 4011 4012 4013 4014 4015 4016 4017 4018 4019 4020 4021 4022 4023 4024 4025 4026 4027 4028 4029 4030 4031 4032 4033 4034 4035 4036 4037 4038 4039 4040 4041 4042 4043 4044 4045 4046 4047 4048 4049 4050 4051 4052 4053 4054 4055 4056 4057 4058 4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 4070 4071 4072 4073 4074 4075 4076 4077 4078 4079 4080 4081 4082 4083 4084 4085 4086 4087 4088 4089 4090 4091 4092 4093 4094 4095 4096 4097 4098 4099 4100 4101 4102 4103 4104 4105 4106 4107 |
static int
ArraySetCmd(
ClientData 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];
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);
return TCL_ERROR;
}
/*
* Install the contents of the dictionary or list into the array.
*/
arrayElemObj = objv[2];
if (TclHasIntRep(arrayElemObj, &tclDictType) && arrayElemObj->bytes == NULL) {
Tcl_Obj *keyPtr, *valuePtr;
Tcl_DictSearch search;
int done;
if (Tcl_DictObjSize(interp, arrayElemObj, &done) != TCL_OK) {
return TCL_ERROR;
}
if (done == 0) {
/*
* Empty, so we'll just force the array to be properly existing
* instead.
*/
goto ensureArray;
}
/*
* Don't need to look at result of Tcl_DictObjFirst as we've just
* successfully used a dictionary operation on the same object.
*/
for (Tcl_DictObjFirst(interp, arrayElemObj, &search,
&keyPtr, &valuePtr, &done) ; !done ;
Tcl_DictObjNext(&search, &keyPtr, &valuePtr, &done)) {
/*
* At this point, it would be nice if the key was directly usable
* by the array. This isn't the case though.
*/
Var *elemVarPtr = TclLookupArrayElement(interp, arrayNameObj,
keyPtr, TCL_LEAVE_ERR_MSG, "set", 1, 1, varPtr, -1);
if ((elemVarPtr == NULL) ||
(TclPtrSetVarIdx(interp, elemVarPtr, varPtr, arrayNameObj,
keyPtr, valuePtr, TCL_LEAVE_ERR_MSG, -1) == NULL)) {
Tcl_DictObjDone(&search);
return TCL_ERROR;
}
}
return TCL_OK;
} else {
/*
* Not a dictionary, so assume (and convert to, for backward-
* -compatibility reasons) a list.
*/
int elemLen;
Tcl_Obj **elemPtrs, *copyListObj;
result = TclListObjGetElements(interp, arrayElemObj,
&elemLen, &elemPtrs);
if (result != TCL_OK) {
return result;
}
if (elemLen & 1) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"list must have an even number of elements", -1));
Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "FORMAT", 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.
*/
copyListObj = TclListObjCopy(NULL, arrayElemObj);
for (i=0 ; i<elemLen ; i+=2) {
Var *elemVarPtr = TclLookupArrayElement(interp, arrayNameObj,
elemPtrs[i], TCL_LEAVE_ERR_MSG, "set", 1, 1, varPtr, -1);
if ((elemVarPtr == NULL) ||
(TclPtrSetVarIdx(interp, elemVarPtr, varPtr, arrayNameObj,
elemPtrs[i], elemPtrs[i+1], TCL_LEAVE_ERR_MSG,
-1) == NULL)) {
result = TCL_ERROR;
break;
}
}
Tcl_DecrRefCount(copyListObj);
return result;
}
/*
* The list is empty make sure we have an array, or create one if
* necessary.
*/
ensureArray:
if (varPtr != NULL) {
if (TclIsVarArray(varPtr)) {
/*
* Already an array, done.
*/
return TCL_OK;
}
if (TclIsVarArrayElement(varPtr) || !TclIsVarUndefined(varPtr)) {
/*
* Either an array element, or a scalar: lose!
*/
TclObjVarErrMsg(interp, arrayNameObj, NULL, "array set",
needArray, -1);
Tcl_SetErrorCode(interp, "TCL", "WRITE", "ARRAY", NULL);
return TCL_ERROR;
}
}
TclInitArrayVar(varPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ArraySizeCmd --
*
|
| ︙ | ︙ | |||
3850 3851 3852 3853 3854 3855 3856 |
static int
ArraySizeCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
| < | < | < < < < | < < < < < < < < < < < < < | | | < < < < | < | | | 4121 4122 4123 4124 4125 4126 4127 4128 4129 4130 4131 4132 4133 4134 4135 4136 4137 4138 4139 4140 4141 4142 4143 4144 4145 4146 4147 4148 4149 4150 4151 4152 4153 4154 4155 4156 4157 4158 4159 4160 4161 4162 4163 4164 4165 |
static int
ArraySizeCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Var *varPtr;
Tcl_HashSearch search;
Var *varPtr2;
int isArray, size = 0;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "arrayName");
return TCL_ERROR;
}
if (TCL_ERROR == LocateArray(interp, objv[1], &varPtr, &isArray)) {
return TCL_ERROR;
}
/* We can only iterate over the array if it exists... */
if (isArray) {
/*
* Must iterate in order to get chance to check for present but
* "undefined" entries.
*/
for (varPtr2=VarHashFirstVar(varPtr->value.tablePtr, &search);
varPtr2!=NULL ; varPtr2=VarHashNextVar(&search)) {
if (!TclIsVarUndefined(varPtr2)) {
size++;
}
}
}
Tcl_SetObjResult(interp, Tcl_NewIntObj(size));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ArrayStatsCmd --
|
| ︙ | ︙ | |||
3934 3935 3936 3937 3938 3939 3940 |
static int
ArrayStatsCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
| < | > < < < | < < < < < < < < < < < < < | | | | < < < < < | < < < < < < < | | 4181 4182 4183 4184 4185 4186 4187 4188 4189 4190 4191 4192 4193 4194 4195 4196 4197 4198 4199 4200 4201 4202 4203 4204 4205 4206 4207 4208 4209 4210 4211 4212 4213 4214 4215 4216 4217 4218 4219 4220 4221 |
static int
ArrayStatsCmd(
ClientData 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 --
|
| ︙ | ︙ | |||
4017 4018 4019 4020 4021 4022 4023 |
static int
ArrayUnsetCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
| < | > < < < | < < < < < < < < < < < < < | | | | < < < < < < < < | 4236 4237 4238 4239 4240 4241 4242 4243 4244 4245 4246 4247 4248 4249 4250 4251 4252 4253 4254 4255 4256 4257 4258 4259 4260 4261 4262 4263 4264 4265 4266 4267 4268 4269 4270 4271 4272 4273 4274 4275 |
static int
ArrayUnsetCmd(
ClientData 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.
*/
|
| ︙ | ︙ | |||
4177 4178 4179 4180 4181 4182 4183 4184 4185 4186 4187 4188 4189 4190 4191 4192 |
/* ARGSUSED */
Tcl_Command
TclInitArrayCmd(
Tcl_Interp *interp) /* Current interpreter. */
{
static const EnsembleImplMap arrayImplMap[] = {
{"anymore", ArrayAnyMoreCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
{"donesearch", ArrayDoneSearchCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
{"exists", ArrayExistsCmd, TclCompileArrayExistsCmd, NULL, 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},
| > > | 4372 4373 4374 4375 4376 4377 4378 4379 4380 4381 4382 4383 4384 4385 4386 4387 4388 4389 |
/* ARGSUSED */
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},
|
| ︙ | ︙ | |||
4203 4204 4205 4206 4207 4208 4209 | * ObjMakeUpvar -- * * 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 | | | 4400 4401 4402 4403 4404 4405 4406 4407 4408 4409 4410 4411 4412 4413 4414 | * ObjMakeUpvar -- * * 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. * * 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. * Callers must Incr myNamePtr if they plan to Decr it. * Callers must Incr otherP1Ptr if they plan to Decr it. |
| ︙ | ︙ | |||
4297 4298 4299 4300 4301 4302 4303 | * TclPtrMakeUpvar -- * * 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 | | | 4494 4495 4496 4497 4498 4499 4500 4501 4502 4503 4504 4505 4506 4507 4508 | * TclPtrMakeUpvar -- * * 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. * * 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. * *---------------------------------------------------------------------- |
| ︙ | ︙ | |||
4921 4922 4923 4924 4925 4926 4927 |
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | < < < > | | < | | < < < | < < < | < < < < | < < | < < | | < < < < < < < < | < < < < | > > > | > > > > > > > | < > | | 5118 5119 5120 5121 5122 5123 5124 5125 5126 5127 5128 5129 5130 5131 5132 5133 5134 5135 5136 5137 5138 5139 5140 5141 5142 5143 5144 5145 5146 5147 5148 5149 5150 5151 5152 5153 5154 5155 5156 5157 5158 5159 5160 5161 5162 5163 5164 5165 5166 5167 5168 5169 5170 5171 5172 5173 5174 5175 5176 5177 5178 5179 5180 5181 5182 5183 5184 5185 5186 5187 5188 5189 5190 5191 5192 5193 |
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* 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.
*
*----------------------------------------------------------------------
*/
static ArraySearch *
ParseSearchId(
Tcl_Interp *interp, /* Interpreter containing variable. */
const Var *varPtr, /* Array variable search is for. */
Tcl_Obj *varNamePtr, /* Name of array variable that search is
* supposed to be for. */
Tcl_Obj *handleObj) /* Object containing id of search. Must have
* 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 = Tcl_GetHashValue(hPtr); searchPtr != NULL;
searchPtr = searchPtr->nextPtr) {
if (searchPtr->name == handleObj) {
return searchPtr;
}
}
/* Fallback: do string compares. */
for (searchPtr = 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);
return NULL;
}
/*
*----------------------------------------------------------------------
*
* DeleteSearches --
|
| ︙ | ︙ | |||
5112 5113 5114 5115 5116 5117 5118 |
Tcl_HashEntry *sPtr;
if (arrayVarPtr->flags & VAR_SEARCH_ACTIVE) {
sPtr = Tcl_FindHashEntry(&iPtr->varSearches, arrayVarPtr);
for (searchPtr = Tcl_GetHashValue(sPtr); searchPtr != NULL;
searchPtr = nextPtr) {
nextPtr = searchPtr->nextPtr;
| > | | 5214 5215 5216 5217 5218 5219 5220 5221 5222 5223 5224 5225 5226 5227 5228 5229 |
Tcl_HashEntry *sPtr;
if (arrayVarPtr->flags & VAR_SEARCH_ACTIVE) {
sPtr = Tcl_FindHashEntry(&iPtr->varSearches, arrayVarPtr);
for (searchPtr = Tcl_GetHashValue(sPtr); searchPtr != NULL;
searchPtr = nextPtr) {
nextPtr = searchPtr->nextPtr;
Tcl_DecrRefCount(searchPtr->name);
Tcl_Free(searchPtr);
}
arrayVarPtr->flags &= ~VAR_SEARCH_ACTIVE;
Tcl_DeleteHashEntry(sPtr);
}
}
/*
|
| ︙ | ︙ | |||
5240 5241 5242 5243 5244 5245 5246 5247 5248 |
void
TclDeleteVars(
Interp *iPtr, /* Interpreter to which variables belong. */
TclVarHashTable *tablePtr) /* Hash table containing variables to
* delete. */
{
Tcl_HashSearch search;
register Var *varPtr;
| > | < < < | < < < < < < | < | | < < < | < | < | > | < > | | < | | | < < | < | 5343 5344 5345 5346 5347 5348 5349 5350 5351 5352 5353 5354 5355 5356 5357 5358 5359 5360 5361 5362 5363 5364 5365 5366 5367 5368 5369 5370 5371 5372 5373 5374 5375 5376 5377 |
void
TclDeleteVars(
Interp *iPtr, /* Interpreter to which variables belong. */
TclVarHashTable *tablePtr) /* Hash table containing variables to
* delete. */
{
Tcl_Interp *interp = (Tcl_Interp *) iPtr;
Tcl_HashSearch search;
register Var *varPtr;
int flags;
Namespace *currNsPtr = (Namespace *) TclGetCurrentNamespace(interp);
/*
* Determine what flags to pass to the trace callback functions.
*/
flags = TCL_TRACE_UNSETS;
if (tablePtr == &iPtr->globalNsPtr->varTable) {
flags |= TCL_GLOBAL_ONLY;
} else if (tablePtr == &currNsPtr->varTable) {
flags |= TCL_NAMESPACE_ONLY;
}
for (varPtr = VarHashFirstVar(tablePtr, &search); varPtr != NULL;
varPtr = VarHashFirstVar(tablePtr, &search)) {
UnsetVarStruct(varPtr, NULL, iPtr, VarHashGetKey(varPtr), NULL, flags,
-1);
VarHashDeleteEntry(varPtr);
}
VarHashDeleteTable(tablePtr);
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
5365 5366 5367 5368 5369 5370 5371 |
Tcl_HashSearch search;
Tcl_HashEntry *tPtr;
register Var *elPtr;
ActiveVarTrace *activePtr;
Tcl_Obj *objPtr;
VarTrace *tracePtr;
| < < < | 5451 5452 5453 5454 5455 5456 5457 5458 5459 5460 5461 5462 5463 5464 |
Tcl_HashSearch search;
Tcl_HashEntry *tPtr;
register Var *elPtr;
ActiveVarTrace *activePtr;
Tcl_Obj *objPtr;
VarTrace *tracePtr;
for (elPtr = VarHashFirstVar(varPtr->value.tablePtr, &search);
elPtr != NULL; elPtr = VarHashNextVar(&search)) {
if (TclIsVarScalar(elPtr) && (elPtr->value.objPtr != NULL)) {
objPtr = elPtr->value.objPtr;
TclDecrRefCount(objPtr);
elPtr->value.objPtr = NULL;
}
|
| ︙ | ︙ | |||
5423 5424 5425 5426 5427 5428 5429 |
* variables, some combinations of [upvar] and [variable] may create
* such beasts - see [Bug 604239]. This is necessary to avoid leaking
* the corresponding Var struct, and is otherwise harmless.
*/
TclClearVarNamespaceVar(elPtr);
}
| < | | 5506 5507 5508 5509 5510 5511 5512 5513 5514 5515 5516 5517 5518 5519 5520 |
* variables, some combinations of [upvar] and [variable] may create
* such beasts - see [Bug 604239]. This is necessary to avoid leaking
* the corresponding Var struct, and is otherwise harmless.
*/
TclClearVarNamespaceVar(elPtr);
}
DeleteArrayVar(varPtr);
}
/*
*----------------------------------------------------------------------
*
* TclObjVarErrMsg --
*
|
| ︙ | ︙ | |||
5514 5515 5516 5517 5518 5519 5520 |
* twoPtrValue.ptr2: index into locals table
*/
static void
FreeLocalVarName(
Tcl_Obj *objPtr)
{
| > | > > > < > | > < < | < < < | > | > > < | | | < < | | | < < | 5596 5597 5598 5599 5600 5601 5602 5603 5604 5605 5606 5607 5608 5609 5610 5611 5612 5613 5614 5615 5616 5617 5618 5619 5620 5621 5622 5623 5624 5625 5626 5627 5628 5629 5630 5631 5632 5633 5634 5635 5636 5637 5638 5639 5640 5641 5642 5643 5644 5645 5646 5647 5648 5649 5650 5651 5652 5653 5654 5655 5656 5657 5658 5659 5660 5661 5662 5663 5664 5665 5666 5667 5668 5669 5670 5671 5672 |
* twoPtrValue.ptr2: index into locals table
*/
static void
FreeLocalVarName(
Tcl_Obj *objPtr)
{
int index;
Tcl_Obj *namePtr;
LocalGetIntRep(objPtr, index, namePtr);
index++; /* Compiler warning bait. */
if (namePtr) {
Tcl_DecrRefCount(namePtr);
}
}
static void
DupLocalVarName(
Tcl_Obj *srcPtr,
Tcl_Obj *dupPtr)
{
int index;
Tcl_Obj *namePtr;
LocalGetIntRep(srcPtr, index, namePtr);
if (!namePtr) {
namePtr = srcPtr;
}
LocalSetIntRep(dupPtr, index, namePtr);
}
/*
* parsedVarName -
*
* INTERNALREP DEFINITION:
* twoPtrValue.ptr1 = pointer to the array name Tcl_Obj (NULL if scalar)
* twoPtrValue.ptr2 = pointer to the element name string (owned by this
* Tcl_Obj), or NULL if it is a scalar variable
*/
static void
FreeParsedVarName(
Tcl_Obj *objPtr)
{
register Tcl_Obj *arrayPtr, *elem;
int parsed;
ParsedGetIntRep(objPtr, parsed, arrayPtr, elem);
parsed++; /* Silence compiler. */
if (arrayPtr != NULL) {
TclDecrRefCount(arrayPtr);
TclDecrRefCount(elem);
}
}
static void
DupParsedVarName(
Tcl_Obj *srcPtr,
Tcl_Obj *dupPtr)
{
register Tcl_Obj *arrayPtr, *elem;
int parsed;
ParsedGetIntRep(srcPtr, parsed, arrayPtr, elem);
parsed++; /* Silence compiler. */
ParsedSetIntRep(dupPtr, arrayPtr, elem);
}
/*
*----------------------------------------------------------------------
*
* Tcl_FindNamespaceVar -- MOVED OVER from tclNamesp.c
*
|
| ︙ | ︙ | |||
5911 5912 5913 5914 5915 5916 5917 |
* pattern only specifies variable names), then add in all global
* :: variables that match the simple pattern. Of course, add in
* only those variables that aren't hidden by a variable in the
* effective namespace.
*/
if ((nsPtr != globalNsPtr) && !specificNsInPattern) {
| | | 5991 5992 5993 5994 5995 5996 5997 5998 5999 6000 6001 6002 6003 6004 6005 |
* pattern only specifies variable names), then add in all global
* :: variables that match the simple pattern. Of course, add in
* only those variables that aren't hidden by a variable in the
* effective namespace.
*/
if ((nsPtr != globalNsPtr) && !specificNsInPattern) {
varPtr = VarHashFirstVar(&globalNsPtr->varTable, &search);
while (varPtr) {
if (!TclIsVarUndefined(varPtr)
|| TclIsVarNamespaceVar(varPtr)) {
varNamePtr = VarHashGetKey(varPtr);
varName = TclGetString(varNamePtr);
if ((simplePattern == NULL)
|| Tcl_StringMatch(varName, simplePattern)) {
|
| ︙ | ︙ | |||
6117 6118 6119 6120 6121 6122 6123 |
Tcl_Obj *listPtr, /* List object to append names to. */
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;
| | < > > > | | | | | | | | | | | | | | > | 6197 6198 6199 6200 6201 6202 6203 6204 6205 6206 6207 6208 6209 6210 6211 6212 6213 6214 6215 6216 6217 6218 6219 6220 6221 6222 6223 6224 6225 6226 6227 6228 6229 6230 6231 6232 6233 6234 6235 6236 6237 6238 6239 6240 6241 6242 6243 6244 |
Tcl_Obj *listPtr, /* List object to append names to. */
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;
TclVarHashTable *localVarTablePtr;
Tcl_HashSearch search;
Tcl_HashTable addedTable;
const char *pattern = patternPtr? TclGetString(patternPtr) : NULL;
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)
&& (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++;
}
}
/*
* Do nothing if no local variables.
*/
if (localVarTablePtr == NULL) {
|
| ︙ | ︙ | |||
6204 6205 6206 6207 6208 6209 6210 |
objectVars:
if (!includeLinks) {
return;
}
if (iPtr->varFramePtr->isProcCallFrame & FRAME_IS_METHOD) {
| > | < > > > | > > > > > > > > > > > > > > > > > > > > < | | > | > | > | 6287 6288 6289 6290 6291 6292 6293 6294 6295 6296 6297 6298 6299 6300 6301 6302 6303 6304 6305 6306 6307 6308 6309 6310 6311 6312 6313 6314 6315 6316 6317 6318 6319 6320 6321 6322 6323 6324 6325 6326 6327 6328 6329 6330 6331 6332 6333 6334 6335 6336 6337 6338 6339 6340 6341 6342 |
objectVars:
if (!includeLinks) {
return;
}
if (iPtr->varFramePtr->isProcCallFrame & FRAME_IS_METHOD) {
Method *mPtr = (Method *)
Tcl_ObjectContextMethod(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);
}
|
| ︙ | ︙ | |||
6247 6248 6249 6250 6251 6252 6253 |
}
static Tcl_HashEntry *
AllocVarEntry(
Tcl_HashTable *tablePtr, /* Hash table. */
void *keyPtr) /* Key to store in the hash table entry. */
{
| | | | 6355 6356 6357 6358 6359 6360 6361 6362 6363 6364 6365 6366 6367 6368 6369 6370 6371 6372 6373 |
}
static Tcl_HashEntry *
AllocVarEntry(
Tcl_HashTable *tablePtr, /* Hash table. */
void *keyPtr) /* Key to store in the hash table entry. */
{
Tcl_Obj *objPtr = (Tcl_Obj *)keyPtr;
Tcl_HashEntry *hPtr;
Var *varPtr;
varPtr = Tcl_Alloc(sizeof(VarInHash));
varPtr->flags = VAR_IN_HASHTABLE;
varPtr->value.objPtr = NULL;
VarHashRefCount(varPtr) = 1;
hPtr = &(((VarInHash *) varPtr)->entry);
Tcl_SetHashValue(hPtr, varPtr);
hPtr->key.objPtr = objPtr;
|
| ︙ | ︙ | |||
6273 6274 6275 6276 6277 6278 6279 |
Tcl_HashEntry *hPtr)
{
Var *varPtr = VarHashGetValue(hPtr);
Tcl_Obj *objPtr = hPtr->key.objPtr;
if (TclIsVarUndefined(varPtr) && !TclIsVarTraced(varPtr)
&& (VarHashRefCount(varPtr) == 1)) {
| | | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 6381 6382 6383 6384 6385 6386 6387 6388 6389 6390 6391 6392 6393 6394 6395 6396 6397 6398 6399 6400 6401 6402 6403 6404 6405 6406 6407 6408 6409 6410 6411 6412 6413 6414 6415 6416 6417 6418 6419 6420 6421 6422 6423 6424 6425 6426 6427 6428 6429 6430 6431 6432 6433 6434 6435 6436 6437 6438 6439 6440 6441 6442 6443 6444 6445 6446 6447 6448 6449 6450 6451 6452 6453 6454 6455 6456 6457 6458 6459 6460 6461 6462 6463 6464 6465 6466 6467 6468 6469 6470 6471 6472 6473 6474 6475 6476 6477 6478 6479 6480 6481 6482 6483 6484 6485 6486 6487 6488 6489 6490 6491 6492 6493 6494 6495 6496 6497 6498 6499 6500 6501 6502 6503 6504 6505 6506 6507 6508 6509 6510 6511 6512 6513 6514 6515 6516 6517 6518 6519 6520 6521 6522 6523 6524 6525 6526 6527 6528 6529 6530 6531 6532 6533 6534 6535 6536 6537 6538 6539 6540 6541 6542 6543 6544 6545 6546 6547 6548 6549 6550 6551 6552 6553 6554 6555 6556 6557 6558 6559 6560 6561 6562 6563 6564 6565 6566 6567 6568 6569 6570 6571 6572 6573 6574 6575 6576 6577 6578 6579 6580 6581 6582 6583 6584 6585 6586 6587 6588 6589 6590 6591 6592 6593 6594 6595 6596 6597 6598 6599 6600 6601 6602 6603 6604 6605 6606 6607 6608 6609 6610 6611 6612 6613 6614 6615 6616 6617 6618 6619 6620 6621 6622 6623 6624 6625 6626 6627 6628 6629 6630 6631 6632 6633 6634 6635 6636 6637 6638 6639 6640 6641 6642 6643 6644 6645 6646 6647 6648 6649 6650 6651 6652 6653 6654 6655 6656 6657 6658 6659 6660 6661 6662 6663 6664 6665 6666 6667 6668 6669 6670 6671 6672 6673 6674 6675 6676 6677 6678 6679 6680 6681 6682 6683 6684 6685 6686 6687 6688 6689 6690 6691 6692 6693 6694 6695 |
Tcl_HashEntry *hPtr)
{
Var *varPtr = VarHashGetValue(hPtr);
Tcl_Obj *objPtr = hPtr->key.objPtr;
if (TclIsVarUndefined(varPtr) && !TclIsVarTraced(varPtr)
&& (VarHashRefCount(varPtr) == 1)) {
Tcl_Free(varPtr);
} else {
VarHashInvalidateEntry(varPtr);
TclSetVarUndefined(varPtr);
VarHashRefCount(varPtr)--;
}
Tcl_DecrRefCount(objPtr);
}
static int
CompareVarKeys(
void *keyPtr, /* New key to compare. */
Tcl_HashEntry *hPtr) /* Existing key to compare. */
{
Tcl_Obj *objPtr1 = (Tcl_Obj *)keyPtr;
Tcl_Obj *objPtr2 = hPtr->key.objPtr;
register const char *p1, *p2;
register size_t l1, l2;
/*
* If the object pointers are the same then they match.
* OPT: this comparison was moved to the caller
*
* if (objPtr1 == objPtr2) return 1;
*/
/*
* Don't use Tcl_GetStringFromObj as it would prevent l1 and l2 being in a
* register.
*/
p1 = TclGetString(objPtr1);
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.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
static int
ArrayDefaultCmd(
ClientData clientData, /* Not used. */
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 options { 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 (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 = 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);
}
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Added generic/tclZipfs.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 3505 3506 3507 3508 3509 3510 3511 3512 3513 3514 3515 3516 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 3549 3550 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 3590 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 3629 3630 3631 3632 3633 3634 3635 3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 3652 3653 3654 3655 3656 3657 3658 3659 3660 3661 3662 3663 3664 3665 3666 3667 3668 3669 3670 3671 3672 3673 3674 3675 3676 3677 3678 3679 3680 3681 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 3695 3696 3697 3698 3699 3700 3701 3702 3703 3704 3705 3706 3707 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 3729 3730 3731 3732 3733 3734 3735 3736 3737 3738 3739 3740 3741 3742 3743 3744 3745 3746 3747 3748 3749 3750 3751 3752 3753 3754 3755 3756 3757 3758 3759 3760 3761 3762 3763 3764 3765 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 3782 3783 3784 3785 3786 3787 3788 3789 3790 3791 3792 3793 3794 3795 3796 3797 3798 3799 3800 3801 3802 3803 3804 3805 3806 3807 3808 3809 3810 3811 3812 3813 3814 3815 3816 3817 3818 3819 3820 3821 3822 3823 3824 3825 3826 3827 3828 3829 3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 3846 3847 3848 3849 3850 3851 3852 3853 3854 3855 3856 3857 3858 3859 3860 3861 3862 3863 3864 3865 3866 3867 3868 3869 3870 3871 3872 3873 3874 3875 3876 3877 3878 3879 3880 3881 3882 3883 3884 3885 3886 3887 3888 3889 3890 3891 3892 3893 3894 3895 3896 3897 3898 3899 3900 3901 3902 3903 3904 3905 3906 3907 3908 3909 3910 3911 3912 3913 3914 3915 3916 3917 3918 3919 3920 3921 3922 3923 3924 3925 3926 3927 3928 3929 3930 3931 3932 3933 3934 3935 3936 3937 3938 3939 3940 3941 3942 3943 3944 3945 3946 3947 3948 3949 3950 3951 3952 3953 3954 3955 3956 3957 3958 3959 3960 3961 3962 3963 3964 3965 3966 3967 3968 3969 3970 3971 3972 3973 3974 3975 3976 3977 3978 3979 3980 3981 3982 3983 3984 3985 3986 3987 3988 3989 3990 3991 3992 3993 3994 3995 3996 3997 3998 3999 4000 4001 4002 4003 4004 4005 4006 4007 4008 4009 4010 4011 4012 4013 4014 4015 4016 4017 4018 4019 4020 4021 4022 4023 4024 4025 4026 4027 4028 4029 4030 4031 4032 4033 4034 4035 4036 4037 4038 4039 4040 4041 4042 4043 4044 4045 4046 4047 4048 4049 4050 4051 4052 4053 4054 4055 4056 4057 4058 4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 4070 4071 4072 4073 4074 4075 4076 4077 4078 4079 4080 4081 4082 4083 4084 4085 4086 4087 4088 4089 4090 4091 4092 4093 4094 4095 4096 4097 4098 4099 4100 4101 4102 4103 4104 4105 4106 4107 4108 4109 4110 4111 4112 4113 4114 4115 4116 4117 4118 4119 4120 4121 4122 4123 4124 4125 4126 4127 4128 4129 4130 4131 4132 4133 4134 4135 4136 4137 4138 4139 4140 4141 4142 4143 4144 4145 4146 4147 4148 4149 4150 4151 4152 4153 4154 4155 4156 4157 4158 4159 4160 4161 4162 4163 4164 4165 4166 4167 4168 4169 4170 4171 4172 4173 4174 4175 4176 4177 4178 4179 4180 4181 4182 4183 4184 4185 4186 4187 4188 4189 4190 4191 4192 4193 4194 4195 4196 4197 4198 4199 4200 4201 4202 4203 4204 4205 4206 4207 4208 4209 4210 4211 4212 4213 4214 4215 4216 4217 4218 4219 4220 4221 4222 4223 4224 4225 4226 4227 4228 4229 4230 4231 4232 4233 4234 4235 4236 4237 4238 4239 4240 4241 4242 4243 4244 4245 4246 4247 4248 4249 4250 4251 4252 4253 4254 4255 4256 4257 4258 4259 4260 4261 4262 4263 4264 4265 4266 4267 4268 4269 4270 4271 4272 4273 4274 4275 4276 4277 4278 4279 4280 4281 4282 4283 4284 4285 4286 4287 4288 4289 4290 4291 4292 4293 4294 4295 4296 4297 4298 4299 4300 4301 4302 4303 4304 4305 4306 4307 4308 4309 4310 4311 4312 4313 4314 4315 4316 4317 4318 4319 4320 4321 4322 4323 4324 4325 4326 4327 4328 4329 4330 4331 4332 4333 4334 4335 4336 4337 4338 4339 4340 4341 4342 4343 4344 4345 4346 4347 4348 4349 4350 4351 4352 4353 4354 4355 4356 4357 4358 4359 4360 4361 4362 4363 4364 4365 4366 4367 4368 4369 4370 4371 4372 4373 4374 4375 4376 4377 4378 4379 4380 4381 4382 4383 4384 4385 4386 4387 4388 4389 4390 4391 4392 4393 4394 4395 4396 4397 4398 4399 4400 4401 4402 4403 4404 4405 4406 4407 4408 4409 4410 4411 4412 4413 4414 4415 4416 4417 4418 4419 4420 4421 4422 4423 4424 4425 4426 4427 4428 4429 4430 4431 4432 4433 4434 4435 4436 4437 4438 4439 4440 4441 4442 4443 4444 4445 4446 4447 4448 4449 4450 4451 4452 4453 4454 4455 4456 4457 4458 4459 4460 4461 4462 4463 4464 4465 4466 4467 4468 4469 4470 4471 4472 4473 4474 4475 4476 4477 4478 4479 4480 4481 4482 4483 4484 4485 4486 4487 4488 4489 4490 4491 4492 4493 4494 4495 4496 4497 4498 4499 4500 4501 4502 4503 4504 4505 4506 4507 4508 4509 4510 4511 4512 4513 4514 4515 4516 4517 4518 4519 4520 4521 4522 4523 4524 4525 4526 4527 4528 4529 4530 4531 4532 4533 4534 4535 4536 4537 4538 4539 4540 4541 4542 4543 4544 4545 4546 4547 4548 4549 4550 4551 4552 4553 4554 4555 4556 4557 4558 4559 4560 4561 4562 4563 4564 4565 4566 4567 4568 4569 4570 4571 4572 4573 4574 4575 4576 4577 4578 4579 4580 4581 4582 4583 4584 4585 4586 4587 4588 4589 4590 4591 4592 4593 4594 4595 4596 4597 4598 4599 4600 4601 4602 4603 4604 4605 4606 4607 4608 4609 4610 4611 4612 4613 4614 4615 4616 4617 4618 4619 4620 4621 4622 4623 4624 4625 4626 4627 4628 4629 4630 4631 4632 4633 4634 4635 4636 4637 4638 4639 4640 4641 4642 4643 4644 4645 4646 4647 4648 4649 4650 4651 4652 4653 4654 4655 4656 4657 4658 4659 4660 4661 4662 4663 4664 4665 4666 4667 4668 4669 4670 4671 4672 4673 4674 4675 4676 4677 4678 4679 4680 4681 4682 4683 4684 4685 4686 4687 4688 4689 4690 4691 4692 4693 4694 4695 4696 4697 4698 4699 4700 4701 4702 4703 4704 4705 4706 4707 4708 4709 4710 4711 4712 4713 4714 4715 4716 4717 4718 4719 4720 4721 4722 4723 4724 4725 4726 4727 4728 4729 4730 4731 4732 4733 4734 4735 4736 4737 4738 4739 4740 4741 4742 4743 4744 4745 4746 4747 4748 4749 4750 4751 4752 4753 4754 4755 4756 4757 4758 4759 4760 4761 4762 4763 4764 4765 4766 4767 4768 4769 4770 4771 4772 4773 4774 4775 4776 4777 4778 4779 4780 4781 4782 4783 4784 4785 4786 4787 4788 4789 4790 4791 4792 4793 4794 4795 4796 4797 4798 4799 4800 4801 4802 4803 4804 4805 4806 4807 4808 4809 4810 4811 4812 4813 4814 4815 4816 4817 4818 4819 4820 4821 4822 4823 4824 4825 4826 4827 4828 4829 4830 4831 4832 4833 4834 4835 4836 4837 4838 4839 4840 4841 4842 4843 4844 4845 4846 4847 4848 4849 4850 4851 4852 4853 4854 4855 4856 4857 4858 4859 4860 4861 4862 4863 4864 4865 4866 4867 4868 4869 4870 4871 4872 4873 4874 4875 4876 4877 4878 4879 4880 4881 4882 4883 4884 4885 4886 4887 4888 4889 4890 4891 4892 4893 4894 4895 4896 4897 4898 4899 4900 4901 4902 4903 4904 4905 4906 4907 4908 4909 4910 4911 4912 4913 4914 4915 4916 4917 4918 4919 4920 4921 4922 4923 4924 4925 4926 4927 4928 4929 4930 4931 4932 4933 4934 4935 4936 4937 4938 4939 4940 4941 4942 4943 4944 4945 4946 4947 4948 4949 4950 4951 4952 4953 4954 4955 4956 4957 4958 4959 4960 4961 4962 4963 4964 4965 4966 4967 4968 4969 4970 4971 4972 4973 4974 4975 4976 4977 4978 4979 4980 4981 4982 4983 4984 4985 4986 4987 4988 4989 4990 4991 4992 4993 4994 4995 4996 4997 4998 4999 5000 5001 5002 5003 5004 5005 5006 5007 5008 5009 5010 5011 5012 5013 5014 5015 5016 5017 5018 5019 5020 5021 5022 5023 5024 5025 5026 5027 5028 5029 5030 5031 5032 5033 5034 |
/*
* tclZipfs.c --
*
* Implementation of the ZIP filesystem used in TIP 430
* Adapted from the implentation for AndroWish.
*
* Copyright (c) 2016-2017 Sean Woods <yoda@etoyoc.com>
* Copyright (c) 2013-2015 Christian Werner <chw@ch-werner.de>
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* This file is distributed in two ways:
* generic/tclZipfs.c file in the TIP430-enabled Tcl cores.
* compat/tclZipfs.c file in the tclconfig (TEA) file system, for pre-tip430
* projects.
*/
#include "tclInt.h"
#include "tclFileSystem.h"
#ifndef _WIN32
#include <sys/mman.h>
#endif /* _WIN32*/
#ifndef MAP_FILE
#define MAP_FILE 0
#endif /* !MAP_FILE */
#ifdef HAVE_ZLIB
#include "zlib.h"
#include "crypt.h"
#ifdef CFG_RUNTIME_DLLFILE
/*
** We are compiling as part of the core.
** TIP430 style zipfs prefix
*/
#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,
};
/*
* For password rotation.
*/
static const char pwrot[16] = {
0x00, 0x80, 0x40, 0xc0, 0x20, 0xa0, 0x60, 0xe0,
0x10, 0x90, 0x50, 0xd0, 0x30, 0xb0, 0x70, 0xf0
};
/*
* Table to compute CRC32.
*/
#ifdef Z_U4
typedef Z_U4 z_crc_t;
#else
typedef unsigned long z_crc_t;
#endif
static const z_crc_t crc32tab[256] = {
0x00000000, 0x77073096, 0xee0e612c, 0x990951ba, 0x076dc419,
0x706af48f, 0xe963a535, 0x9e6495a3, 0x0edb8832, 0x79dcb8a4,
0xe0d5e91e, 0x97d2d988, 0x09b64c2b, 0x7eb17cbd, 0xe7b82d07,
0x90bf1d91, 0x1db71064, 0x6ab020f2, 0xf3b97148, 0x84be41de,
0x1adad47d, 0x6ddde4eb, 0xf4d4b551, 0x83d385c7, 0x136c9856,
0x646ba8c0, 0xfd62f97a, 0x8a65c9ec, 0x14015c4f, 0x63066cd9,
0xfa0f3d63, 0x8d080df5, 0x3b6e20c8, 0x4c69105e, 0xd56041e4,
0xa2677172, 0x3c03e4d1, 0x4b04d447, 0xd20d85fd, 0xa50ab56b,
0x35b5a8fa, 0x42b2986c, 0xdbbbc9d6, 0xacbcf940, 0x32d86ce3,
0x45df5c75, 0xdcd60dcf, 0xabd13d59, 0x26d930ac, 0x51de003a,
0xc8d75180, 0xbfd06116, 0x21b4f4b5, 0x56b3c423, 0xcfba9599,
0xb8bda50f, 0x2802b89e, 0x5f058808, 0xc60cd9b2, 0xb10be924,
0x2f6f7c87, 0x58684c11, 0xc1611dab, 0xb6662d3d, 0x76dc4190,
0x01db7106, 0x98d220bc, 0xefd5102a, 0x71b18589, 0x06b6b51f,
0x9fbfe4a5, 0xe8b8d433, 0x7807c9a2, 0x0f00f934, 0x9609a88e,
0xe10e9818, 0x7f6a0dbb, 0x086d3d2d, 0x91646c97, 0xe6635c01,
0x6b6b51f4, 0x1c6c6162, 0x856530d8, 0xf262004e, 0x6c0695ed,
0x1b01a57b, 0x8208f4c1, 0xf50fc457, 0x65b0d9c6, 0x12b7e950,
0x8bbeb8ea, 0xfcb9887c, 0x62dd1ddf, 0x15da2d49, 0x8cd37cf3,
0xfbd44c65, 0x4db26158, 0x3ab551ce, 0xa3bc0074, 0xd4bb30e2,
0x4adfa541, 0x3dd895d7, 0xa4d1c46d, 0xd3d6f4fb, 0x4369e96a,
0x346ed9fc, 0xad678846, 0xda60b8d0, 0x44042d73, 0x33031de5,
0xaa0a4c5f, 0xdd0d7cc9, 0x5005713c, 0x270241aa, 0xbe0b1010,
0xc90c2086, 0x5768b525, 0x206f85b3, 0xb966d409, 0xce61e49f,
0x5edef90e, 0x29d9c998, 0xb0d09822, 0xc7d7a8b4, 0x59b33d17,
0x2eb40d81, 0xb7bd5c3b, 0xc0ba6cad, 0xedb88320, 0x9abfb3b6,
0x03b6e20c, 0x74b1d29a, 0xead54739, 0x9dd277af, 0x04db2615,
0x73dc1683, 0xe3630b12, 0x94643b84, 0x0d6d6a3e, 0x7a6a5aa8,
0xe40ecf0b, 0x9309ff9d, 0x0a00ae27, 0x7d079eb1, 0xf00f9344,
0x8708a3d2, 0x1e01f268, 0x6906c2fe, 0xf762575d, 0x806567cb,
0x196c3671, 0x6e6b06e7, 0xfed41b76, 0x89d32be0, 0x10da7a5a,
0x67dd4acc, 0xf9b9df6f, 0x8ebeeff9, 0x17b7be43, 0x60b08ed5,
0xd6d6a3e8, 0xa1d1937e, 0x38d8c2c4, 0x4fdff252, 0xd1bb67f1,
0xa6bc5767, 0x3fb506dd, 0x48b2364b, 0xd80d2bda, 0xaf0a1b4c,
0x36034af6, 0x41047a60, 0xdf60efc3, 0xa867df55, 0x316e8eef,
0x4669be79, 0xcb61b38c, 0xbc66831a, 0x256fd2a0, 0x5268e236,
0xcc0c7795, 0xbb0b4703, 0x220216b9, 0x5505262f, 0xc5ba3bbe,
0xb2bd0b28, 0x2bb45a92, 0x5cb36a04, 0xc2d7ffa7, 0xb5d0cf31,
0x2cd99e8b, 0x5bdeae1d, 0x9b64c2b0, 0xec63f226, 0x756aa39c,
0x026d930a, 0x9c0906a9, 0xeb0e363f, 0x72076785, 0x05005713,
0x95bf4a82, 0xe2b87a14, 0x7bb12bae, 0x0cb61b38, 0x92d28e9b,
0xe5d5be0d, 0x7cdcefb7, 0x0bdbdf21, 0x86d3d2d4, 0xf1d4e242,
0x68ddb3f8, 0x1fda836e, 0x81be16cd, 0xf6b9265b, 0x6fb077e1,
0x18b74777, 0x88085ae6, 0xff0f6a70, 0x66063bca, 0x11010b5c,
0x8f659eff, 0xf862ae69, 0x616bffd3, 0x166ccf45, 0xa00ae278,
0xd70dd2ee, 0x4e048354, 0x3903b3c2, 0xa7672661, 0xd06016f7,
0x4969474d, 0x3e6e77db, 0xaed16a4a, 0xd9d65adc, 0x40df0b66,
0x37d83bf0, 0xa9bcae53, 0xdebb9ec5, 0x47b2cf7f, 0x30b5ffe9,
0xbdbdf21c, 0xcabac28a, 0x53b39330, 0x24b4a3a6, 0xbad03605,
0xcdd70693, 0x54de5729, 0x23d967bf, 0xb3667a2e, 0xc4614ab8,
0x5d681b02, 0x2a6f2b94, 0xb40bbe37, 0xc30c8ea1, 0x5a05df1b,
0x2d02ef8d,
};
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);
static int ZipChannelGetFile(void *instanceData,
int direction, void **handlePtr);
static int ZipChannelRead(void *instanceData, char *buf,
int toRead, int *errloc);
static int ZipChannelSeek(void *instanceData, long 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.
*/
MODULE_SCOPE const Tcl_Filesystem zipfsFilesystem;
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 *) 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,
ZipChannelClose, /* Close channel, clean instance data */
ZipChannelRead, /* Handle read request */
ZipChannelWrite, /* Handle write request */
ZipChannelSeek, /* 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 */
NULL, /* 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 */
NULL, /* 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 = 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 = MAP_FAILED;
}
#endif /* _WIN32 */
if (zf->ptrToFree) {
Tcl_Free(zf->ptrToFree);
zf->ptrToFree = NULL;
}
if (zf->chan) {
Tcl_Close(interp, zf->chan);
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 = 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 = 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_Close(interp, zf->chan);
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 = CreateFileMapping((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 = 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 = 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 = 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 = Tcl_GetHashKey(&ZipFS.zipHash, hPtr);
Tcl_CreateExitHandler(ZipfsExitHandler, (ClientData)zf);
zf->mountPointLen = strlen(zf->mountPoint);
zf->nameLength = strlen(zipname);
zf->name = 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 = 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 = 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 = 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 = 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 = 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 = 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 = 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 = 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 = 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 = 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 = 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 = 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, (ClientData)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(
void *clientData, /* Not used. */
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(
void *clientData, /* Not used. */
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 = TclGetByteArrayFromObj(objv[2], &length);
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(
void *clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
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(
void *clientData, /* 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, "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(
void *clientData, /* Not used. */
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_Close(interp, in);
return TCL_OK;
}
#endif /* _WIN32 */
Tcl_Close(interp, in);
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_Close(interp, in);
return TCL_OK;
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf("read error on \"%s\": %s",
path, Tcl_PosixError(interp)));
Tcl_Close(interp, in);
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_Close(interp, in);
return TCL_ERROR;
}
pos[0] = Tcl_Tell(out);
memset(buf, '\0', ZIP_LOCAL_HEADER_LEN);
memcpy(buf + ZIP_LOCAL_HEADER_LEN, zpath, zpathlen);
len = zpathlen + ZIP_LOCAL_HEADER_LEN;
if (Tcl_Write(out, buf, len) != len) {
wrerr:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"write error on %s: %s", path, Tcl_PosixError(interp)));
Tcl_Close(interp, in);
return TCL_ERROR;
}
if ((len + pos[0]) & 3) {
unsigned char abuf[8];
/*
* Align payload to next 4-byte boundary using a dummy extra entry
* similar to the zipalign tool from Android's SDK.
*/
align = 4 + ((len + pos[0]) & 3);
ZipWriteShort(abuf, 0xffff);
ZipWriteShort(abuf + 2, align - 4);
ZipWriteInt(abuf + 4, 0x03020100);
if (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_Close(interp, in);
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_Close(interp, in);
return TCL_ERROR;
}
ch = (int) (r * 256);
kvbuf[i + 12] = (unsigned char) zencode(keys, crc32tab, ch, tmp);
}
Tcl_ResetResult(interp);
init_keys(passwd, keys, crc32tab);
for (i = 0; i < 12 - 2; i++) {
kvbuf[i] = (unsigned char)
zencode(keys, crc32tab, kvbuf[i + 12], tmp);
}
kvbuf[i++] = (unsigned char) zencode(keys, crc32tab, crc >> 16, tmp);
kvbuf[i++] = (unsigned char) zencode(keys, crc32tab, crc >> 24, tmp);
len = Tcl_Write(out, (char *) kvbuf, 12);
memset(kvbuf, 0, 24);
if (len != 12) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"write error on %s: %s", path, Tcl_PosixError(interp)));
Tcl_Close(interp, in);
return TCL_ERROR;
}
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_Close(interp, in);
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_Close(interp, in);
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_Close(interp, in);
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_Close(interp, in);
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_Close(interp, in);
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_Close(interp, in);
return TCL_ERROR;
} else if (len == 0) {
break;
}
if (passwd) {
size_t i;
int tmp;
for (i = 0; i < len; i++) {
buf[i] = (char) zencode(keys0, crc32tab, buf[i], tmp);
}
}
if (Tcl_Write(out, buf, len) != len) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"write error: %s", Tcl_PosixError(interp)));
Tcl_Close(interp, in);
return TCL_ERROR;
}
nbytecompr += len;
}
compMeth = ZIP_COMPMETH_STORED;
Tcl_Flush(out);
pos[1] = Tcl_Tell(out);
Tcl_TruncateChannel(out, pos[1]);
}
Tcl_Close(interp, in);
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 = 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 = 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 = 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_Close(interp, out);
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_Close(interp, out);
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_Close(interp, out);
Tcl_Close(interp, in);
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_Close(interp, in);
}
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_Close(interp, out);
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 = 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_Close(interp, out);
} else {
Tcl_Close(interp, out);
}
Tcl_DecrRefCount(list);
for (hPtr = Tcl_FirstHashEntry(&fileHash, &search); hPtr;
hPtr = Tcl_NextHashEntry(&search)) {
z = 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(
void *clientData, /* Not used. */
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(
void *clientData, /* Not used. */
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(
void *clientData, /* Not used. */
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(
void *clientData, /* Not used. */
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(
void *clientData, /* Not used. */
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(
void *clientData, /* Not used. */
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(
void *clientData, /* Not used. */
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(
void *clientData, /* Not used. */
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 = 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 = 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 = 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) * TCL_UTF_MAX];
#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 = 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(
void *clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
if (!Tcl_IsSafe(interp)) {
Tcl_Obj *pResult = TclZipfs_TclLibrary();
if (!pResult) {
pResult = Tcl_NewObj();
}
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_Interp *interp) /* Current interpreter. */
{
ZipChannel *info = instanceData;
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 = 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 --
*
* 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 int
ZipChannelSeek(
void *instanceData,
long offset,
int mode,
int *errloc)
{
ZipChannel *info = (ZipChannel *) instanceData;
unsigned long 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 ((unsigned long) offset > info->maxWrite) {
*errloc = EINVAL;
return -1;
}
if ((unsigned long) offset > info->numBytes) {
info->numBytes = offset;
}
} else if ((unsigned long) offset > end) {
*errloc = EINVAL;
return -1;
}
info->numRead = (unsigned long) offset;
return info->numRead;
}
/*
*-------------------------------------------------------------------------
*
* ZipChannelWatchChannel --
*
* This function is called for event notifications on channel. Does
* nothing.
*
* Results:
* None.
*
* Side effects:
* None.
*
*-------------------------------------------------------------------------
*/
static void
ZipChannelWatchChannel(
void *instanceData,
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(
void *instanceData,
int direction,
void **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,
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 = 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 = 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 = 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 = 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 = 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_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_Interp *interp, /* Current interpreter. */
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 = 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 = 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 = 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 = 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,
void **clientDataPtr)
{
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 = 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_Obj *pathPtr,
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:
*objPtrRef = Tcl_NewWideIntObj(z->numBytes);
break;
case 1:
*objPtrRef = Tcl_NewWideIntObj(z->numCompressedBytes);
break;
case 2:
*objPtrRef = Tcl_NewWideIntObj(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. */
int index,
Tcl_Obj *pathPtr,
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_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 *) 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.
*
*-------------------------------------------------------------------------
*/
MODULE_SCOPE 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(
int *argcPtr, /* Pointer to argc */
#ifdef _WIN32
WCHAR
#else /* !_WIN32 */
char
#endif /* _WIN32 */
***argvPtr) /* Pointer to argv */
{
char *archive;
Tcl_FindExecutable((*argvPtr)[0]);
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;
archive = Tcl_WinTCharToUtf((*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:
*/
|
Changes to generic/tclZlib.c.
| ︙ | ︙ | |||
60 61 62 63 64 65 66 |
typedef struct {
Tcl_Interp *interp;
z_stream stream; /* The interface to the zlib library. */
int streamEnd; /* If we've got to end-of-stream. */
Tcl_Obj *inData, *outData; /* Input / output buffers (lists) */
Tcl_Obj *currentInput; /* Pointer to what is currently being
* inflated. */
| | | 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 |
typedef struct {
Tcl_Interp *interp;
z_stream stream; /* The interface to the zlib library. */
int streamEnd; /* If we've got to end-of-stream. */
Tcl_Obj *inData, *outData; /* Input / output buffers (lists) */
Tcl_Obj *currentInput; /* Pointer to what is currently being
* inflated. */
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
|
| ︙ | ︙ | |||
113 114 115 116 117 118 119 |
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. */
| | | 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 |
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_DString decompressed; /* Buffer for decompression results. */
|
| ︙ | ︙ | |||
174 175 176 177 178 179 180 | 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, | | | | | 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 |
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 inline int ResultCopy(ZlibChannelData *cd, char *buf,
size_t toRead);
static int ResultGenerate(ZlibChannelData *cd, int n, int flush,
int *errorCodePtr);
static Tcl_Channel ZlibStackChannelTransform(Tcl_Interp *interp,
int mode, int format, int level, int limit,
Tcl_Channel channel, Tcl_Obj *gzipHeaderDictPtr,
Tcl_Obj *compDictObj);
static void ZlibStreamCleanup(ZlibStreamHandle *zshPtr);
static int ZlibStreamSubcmd(Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
static inline void ZlibTransformEventTimerKill(ZlibChannelData *cd);
static void ZlibTransformTimerRun(void *clientData);
/*
* Type of zlib-based compressing and decompressing channels.
*/
static const Tcl_ChannelType zlibChannelType = {
"zlib",
|
| ︙ | ︙ | |||
418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 |
* 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;
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) {
| > > | | | | | 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 |
* 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;
}
}
|
| ︙ | ︙ | |||
481 482 483 484 485 486 487 |
/*
* 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;
| | | > | 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 |
/*
* 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;
}
|
| ︙ | ︙ | |||
543 544 545 546 547 548 549 |
}
}
Tcl_ExternalToUtfDString(latin1enc, (char *) headerPtr->comment, -1,
&tmp);
SetValue(dictObj, "comment", TclDStringToObj(&tmp));
}
| | | | | 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 |
}
}
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) {
|
| ︙ | ︙ | |||
586 587 588 589 590 591 592 |
static int
SetInflateDictionary(
z_streamp strm,
Tcl_Obj *compDictObj)
{
if (compDictObj != NULL) {
| | | | | | | | | | | | 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 |
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);
}
}
|
| ︙ | ︙ | |||
693 694 695 696 697 698 699 |
switch (format) {
case TCL_ZLIB_FORMAT_RAW:
wbits = WBITS_RAW;
break;
case TCL_ZLIB_FORMAT_GZIP:
wbits = WBITS_GZIP;
if (dictObj) {
| | | | 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 |
switch (format) {
case TCL_ZLIB_FORMAT_RAW:
wbits = WBITS_RAW;
break;
case TCL_ZLIB_FORMAT_GZIP:
wbits = WBITS_GZIP;
if (dictObj) {
gzHeaderPtr = 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;
|
| ︙ | ︙ | |||
727 728 729 730 731 732 733 |
switch (format) {
case TCL_ZLIB_FORMAT_RAW:
wbits = WBITS_RAW;
break;
case TCL_ZLIB_FORMAT_GZIP:
wbits = WBITS_GZIP;
| | | 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 |
switch (format) {
case TCL_ZLIB_FORMAT_RAW:
wbits = WBITS_RAW;
break;
case TCL_ZLIB_FORMAT_GZIP:
wbits = WBITS_GZIP;
gzHeaderPtr = 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;
|
| ︙ | ︙ | |||
753 754 755 756 757 758 759 |
}
break;
default:
Tcl_Panic("bad mode, must be TCL_ZLIB_STREAM_DEFLATE or"
" TCL_ZLIB_STREAM_INFLATE");
}
| | | 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 |
}
break;
default:
Tcl_Panic("bad mode, must be TCL_ZLIB_STREAM_DEFLATE or"
" TCL_ZLIB_STREAM_INFLATE");
}
zshPtr = 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;
|
| ︙ | ︙ | |||
853 854 855 856 857 858 859 |
return TCL_OK;
error:
if (zshPtr->compDictObj) {
Tcl_DecrRefCount(zshPtr->compDictObj);
}
if (zshPtr->gzHeaderPtr) {
| | | | 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 |
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 --
|
| ︙ | ︙ | |||
878 879 880 881 882 883 884 | * Invalidates the zlib stream handle as obtained from Tcl_ZlibStreamInit * *---------------------------------------------------------------------- */ static void ZlibStreamCmdDelete( | | | 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 |
* Invalidates the zlib stream handle as obtained from Tcl_ZlibStreamInit
*
*----------------------------------------------------------------------
*/
static void
ZlibStreamCmdDelete(
void *cd)
{
ZlibStreamHandle *zshPtr = cd;
zshPtr->cmd = NULL;
ZlibStreamCleanup(zshPtr);
}
|
| ︙ | ︙ | |||
966 967 968 969 970 971 972 |
if (zshPtr->currentInput) {
Tcl_DecrRefCount(zshPtr->currentInput);
}
if (zshPtr->compDictObj) {
Tcl_DecrRefCount(zshPtr->compDictObj);
}
if (zshPtr->gzHeaderPtr) {
| | | | 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 |
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 --
*
|
| ︙ | ︙ | |||
1184 1185 1186 1187 1188 1189 1190 |
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;
| > | | | 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 |
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;
if (zshPtr->streamEnd) {
if (zshPtr->interp) {
Tcl_SetObjResult(zshPtr->interp, Tcl_NewStringObj(
"already past compressed stream end", -1));
Tcl_SetErrorCode(zshPtr->interp, "TCL", "ZIP", "CLOSED", NULL);
}
return TCL_ERROR;
}
if (zshPtr->mode == TCL_ZLIB_STREAM_DEFLATE) {
zshPtr->stream.next_in = TclGetByteArrayFromObj(data, &size);
zshPtr->stream.avail_in = size;
/*
* Must not do a zero-length compress unless finalizing. [Bug 25842c161]
*/
if (size == 0 && flush != Z_FINISH) {
|
| ︙ | ︙ | |||
1227 1228 1229 1230 1231 1232 1233 |
* size.
*/
outSize = deflateBound(&zshPtr->stream, size) + 100;
if (outSize > BUFFER_SIZE_LIMIT) {
outSize = BUFFER_SIZE_LIMIT;
}
| | | 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 |
* size.
*/
outSize = deflateBound(&zshPtr->stream, size) + 100;
if (outSize > BUFFER_SIZE_LIMIT) {
outSize = BUFFER_SIZE_LIMIT;
}
dataTmp = 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
|
| ︙ | ︙ | |||
1261 1262 1263 1264 1265 1266 1267 |
*/
AppendByteArray(zshPtr->outData, dataTmp, outSize);
if (outSize < BUFFER_SIZE_LIMIT) {
outSize = BUFFER_SIZE_LIMIT;
/* There may be *lots* of data left to output... */
| | | | 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 |
*/
AppendByteArray(zshPtr->outData, dataTmp, outSize);
if (outSize < BUFFER_SIZE_LIMIT) {
outSize = BUFFER_SIZE_LIMIT;
/* There may be *lots* of data left to output... */
dataTmp = 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);
|
| ︙ | ︙ | |||
1303 1304 1305 1306 1307 1308 1309 |
*----------------------------------------------------------------------
*/
int
Tcl_ZlibStreamGet(
Tcl_ZlibStream zshandle, /* As obtained from Tcl_ZlibStreamInit */
Tcl_Obj *data, /* A place to append the data. */
| | | > | | | | 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 |
*----------------------------------------------------------------------
*/
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;
}
(void) TclGetByteArrayFromObj(data, &existing);
if (zshPtr->mode == TCL_ZLIB_STREAM_INFLATE) {
if (count == TCL_AUTO_LENGTH) {
/*
* 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;
}
|
| ︙ | ︙ | |||
1363 1364 1365 1366 1367 1368 1369 |
* under our feet. [Bug 3081008]
*/
Tcl_ListObjIndex(NULL, zshPtr->inData, 0, &itemObj);
if (Tcl_IsShared(itemObj)) {
itemObj = Tcl_DuplicateObj(itemObj);
}
| | | 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 |
* 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
|
| ︙ | ︙ | |||
1435 1436 1437 1438 1439 1440 1441 |
* 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);
}
| | | 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 |
* 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.
|
| ︙ | ︙ | |||
1480 1481 1482 1483 1484 1485 1486 |
Tcl_DecrRefCount(zshPtr->currentInput);
zshPtr->currentInput = 0;
}
inflateEnd(&zshPtr->stream);
}
} else {
Tcl_ListObjLength(NULL, zshPtr->outData, &listLen);
| | | | 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 |
Tcl_DecrRefCount(zshPtr->currentInput);
zshPtr->currentInput = 0;
}
inflateEnd(&zshPtr->stream);
}
} else {
Tcl_ListObjLength(NULL, zshPtr->outData, &listLen);
if (count == TCL_AUTO_LENGTH) {
count = 0;
for (i=0; i<listLen; i++) {
Tcl_ListObjIndex(NULL, zshPtr->outData, i, &itemObj);
(void) TclGetByteArrayFromObj(itemObj, &itemLen);
if (i == 0) {
count += itemLen - zshPtr->outPos;
} else {
count += itemLen;
}
}
}
|
| ︙ | ︙ | |||
1509 1510 1511 1512 1513 1514 1515 |
&& (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);
| | | | | | 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 |
&& (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);
|
| ︙ | ︙ | |||
1556 1557 1558 1559 1560 1561 1562 |
Tcl_ZlibDeflate(
Tcl_Interp *interp,
int format,
Tcl_Obj *data,
int level,
Tcl_Obj *gzipHeaderDictObj)
{
| | > | 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 |
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) {
|
| ︙ | ︙ | |||
1616 1617 1618 1619 1620 1621 1622 |
TclNewObj(obj);
/*
* Obtain the pointer to the byte array, we'll pass this pointer straight
* to the deflate command.
*/
| | | | 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 |
TclNewObj(obj);
/*
* Obtain the pointer to the byte array, we'll pass this pointer straight
* to the deflate command.
*/
inData = TclGetByteArrayFromObj(data, &inLen);
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,
|
| ︙ | ︙ | |||
1703 1704 1705 1706 1707 1708 1709 |
*/
int
Tcl_ZlibInflate(
Tcl_Interp *interp,
int format,
Tcl_Obj *data,
| | | > | 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 |
*/
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) {
|
| ︙ | ︙ | |||
1746 1747 1748 1749 1750 1751 1752 |
"TCL_ZLIB_FORMAT_GZIP, TCL_ZLIB_FORMAT_RAW or "
"TCL_ZLIB_FORMAT_AUTO");
}
if (gzipHeaderDictObj) {
headerPtr = &header;
memset(headerPtr, 0, sizeof(gz_header));
| | | | | | 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 |
"TCL_ZLIB_FORMAT_GZIP, TCL_ZLIB_FORMAT_RAW or "
"TCL_ZLIB_FORMAT_AUTO");
}
if (gzipHeaderDictObj) {
headerPtr = &header;
memset(headerPtr, 0, sizeof(gz_header));
nameBuf = Tcl_Alloc(MAXPATHLEN);
header.name = (Bytef *) nameBuf;
header.name_max = MAXPATHLEN - 1;
commentBuf = Tcl_Alloc(MAX_COMMENT_LEN);
header.comment = (Bytef *) commentBuf;
header.comm_max = MAX_COMMENT_LEN - 1;
}
inData = TclGetByteArrayFromObj(data, &inLen);
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.
|
| ︙ | ︙ | |||
1854 1855 1856 1857 1858 1859 1860 |
* 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",
| | | | | | | | | | | | | > | 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 |
* 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(
void *notUsed,
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
|
| ︙ | ︙ | |||
1957 1958 1959 1960 1961 1962 1963 |
if (objc>3 && Tcl_GetIntFromObj(interp, objv[3],
(int *) &start) != TCL_OK) {
return TCL_ERROR;
}
if (objc < 4) {
start = Tcl_ZlibAdler32(0, NULL, 0);
}
| | | | 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 |
if (objc>3 && Tcl_GetIntFromObj(interp, objv[3],
(int *) &start) != TCL_OK) {
return TCL_ERROR;
}
if (objc < 4) {
start = Tcl_ZlibAdler32(0, NULL, 0);
}
data = TclGetByteArrayFromObj(objv[2], &dlen);
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;
}
if (objc>3 && Tcl_GetIntFromObj(interp, objv[3],
(int *) &start) != TCL_OK) {
return TCL_ERROR;
}
if (objc < 4) {
start = Tcl_ZlibCRC32(0, NULL, 0);
}
data = TclGetByteArrayFromObj(objv[2], &dlen);
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?");
|
| ︙ | ︙ | |||
2067 2068 2069 2070 2071 2072 2073 |
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) {
| | | | | > | | | | > | 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 |
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;
|
| ︙ | ︙ | |||
2117 2118 2119 2120 2121 2122 2123 |
if (Tcl_GetIndexFromObj(interp, objv[i], gunzipopts, "option", 0,
&option) != TCL_OK) {
return TCL_ERROR;
}
switch (option) {
case 0:
| | | | | > | 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 |
if (Tcl_GetIndexFromObj(interp, objv[i], gunzipopts, "option", 0,
&option) != TCL_OK) {
return TCL_ERROR;
}
switch (option) {
case 0:
if (Tcl_GetWideIntFromObj(interp, objv[i+1],
&wideLen) != TCL_OK) {
return TCL_ERROR;
}
if (wideLen < MIN_NONSTREAM_BUFFER_SIZE
|| wideLen > MAX_BUFFER_SIZE) {
goto badBuffer;
}
buffersize = wideLen;
break;
case 1:
headerVarObj = objv[i+1];
headerDictObj = Tcl_NewObj();
break;
}
}
|
| ︙ | ︙ | |||
2510 2511 2512 2513 2514 2515 2516 | * Implementation of the commands returned by [zlib stream]. * *---------------------------------------------------------------------- */ static int ZlibStreamCmd( | | | 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 |
* 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 = cd;
int command, count, code;
Tcl_Obj *obj;
|
| ︙ | ︙ | |||
2613 2614 2615 2616 2617 2618 2619 |
}
return Tcl_ZlibStreamClose(zstream);
case zs_eof: /* $strm eof */
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
| | | 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 |
}
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)
|
| ︙ | ︙ | |||
2636 2637 2638 2639 2640 2641 2642 |
}
return TCL_OK;
}
static int
ZlibStreamAddCmd(
| | | 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 |
}
return TCL_OK;
}
static int
ZlibStreamAddCmd(
void *cd,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_ZlibStream zstream = cd;
int index, code, buffersize = -1, flush = -1, i;
Tcl_Obj *obj, *compDictObj = NULL;
|
| ︙ | ︙ | |||
2727 2728 2729 2730 2731 2732 2733 |
}
/*
* Set the compression dictionary if requested.
*/
if (compDictObj != NULL) {
| | | | 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 |
}
/*
* Set the compression dictionary if requested.
*/
if (compDictObj != NULL) {
size_t len = 0;
(void) TclGetByteArrayFromObj(compDictObj, &len);
if (len == 0) {
compDictObj = NULL;
}
Tcl_ZlibStreamSetCompressionDictionary(zstream, compDictObj);
}
/*
|
| ︙ | ︙ | |||
2760 2761 2762 2763 2764 2765 2766 |
TclDecrRefCount(obj);
}
return code;
}
static int
ZlibStreamPutCmd(
| | | 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 |
TclDecrRefCount(obj);
}
return code;
}
static int
ZlibStreamPutCmd(
void *cd,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_ZlibStream zstream = cd;
int index, flush = -1, i;
Tcl_Obj *compDictObj = NULL;
|
| ︙ | ︙ | |||
2831 2832 2833 2834 2835 2836 2837 |
}
/*
* Set the compression dictionary if requested.
*/
if (compDictObj != NULL) {
| | | | | 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 |
}
/*
* Set the compression dictionary if requested.
*/
if (compDictObj != NULL) {
size_t len = 0;
(void) TclGetByteArrayFromObj(compDictObj, &len);
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 = cd;
Tcl_Obj *resultObj;
|
| ︙ | ︙ | |||
2888 2889 2890 2891 2892 2893 2894 | * How to shut down a stacked compressing/decompressing transform. * *---------------------------------------------------------------------- */ static int ZlibTransformClose( | | | > | 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 |
* How to shut down a stacked compressing/decompressing transform.
*
*----------------------------------------------------------------------
*/
static int
ZlibTransformClose(
void *instanceData,
Tcl_Interp *interp)
{
ZlibChannelData *cd = instanceData;
int e, result = TCL_OK;
size_t written;
/*
* Delete the support timer.
*/
ZlibTransformEventTimerKill(cd);
|
| ︙ | ︙ | |||
2927 2928 2929 2930 2931 2932 2933 |
/* TODO: is this the right way to do errors on close? */
if (!TclInThreadExit()) {
ConvertError(interp, e, cd->outStream.adler);
}
result = TCL_ERROR;
break;
}
| | | 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 |
/* 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)));
|
| ︙ | ︙ | |||
2956 2957 2958 2959 2960 2961 2962 |
if (cd->compDictObj) {
Tcl_DecrRefCount(cd->compDictObj);
cd->compDictObj = NULL;
}
Tcl_DStringFree(&cd->decompressed);
if (cd->inBuffer) {
| | | | | | 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 |
if (cd->compDictObj) {
Tcl_DecrRefCount(cd->compDictObj);
cd->compDictObj = NULL;
}
Tcl_DStringFree(&cd->decompressed);
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 = instanceData;
Tcl_DriverInputProc *inProc =
Tcl_ChannelInputProc(Tcl_GetChannelType(cd->parent));
|
| ︙ | ︙ | |||
3029 3030 3031 3032 3033 3034 3035 | readBytes = Tcl_ReadRaw(cd->parent, cd->inBuffer, cd->readAheadLimit); /* * Three cases here: * 1. Got some data from the underlying channel (readBytes > 0) so * it should be fed through the decompression engine. | | | | 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 |
readBytes = Tcl_ReadRaw(cd->parent, cd->inBuffer, cd->readAheadLimit);
/*
* Three cases here:
* 1. Got some data from the underlying channel (readBytes > 0) so
* it should be fed through the decompression engine.
* 2. Got an error (readBytes == -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)) {
return gotBytes;
}
*errorCodePtr = Tcl_GetErrno();
|
| ︙ | ︙ | |||
3093 3094 3095 3096 3097 3098 3099 | * Writer filter that does compression. * *---------------------------------------------------------------------- */ static int ZlibTransformOutput( | | > | | 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 |
* Writer filter that does compression.
*
*----------------------------------------------------------------------
*/
static int
ZlibTransformOutput(
void *instanceData,
const char *buf,
int toWrite,
int *errorCodePtr)
{
ZlibChannelData *cd = 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);
}
|
| ︙ | ︙ | |||
3126 3127 3128 3129 3130 3131 3132 |
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;
}
| | | 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 |
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;
|
| ︙ | ︙ | |||
3163 3164 3165 3166 3167 3168 3169 |
static int
ZlibTransformFlush(
Tcl_Interp *interp,
ZlibChannelData *cd,
int flushType)
{
| | > | | 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 |
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;
}
/*
|
| ︙ | ︙ | |||
3214 3215 3216 3217 3218 3219 3220 | * Writing side of [fconfigure] on our channel. * *---------------------------------------------------------------------- */ static int ZlibTransformSetOption( /* not used */ | | | | 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 |
* 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 = 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);
Tcl_GetByteArrayFromObj(compDictObj, NULL);
if (cd->compDictObj) {
TclDecrRefCount(cd->compDictObj);
}
cd->compDictObj = compDictObj;
code = Z_OK;
if (cd->mode == TCL_ZLIB_STREAM_DEFLATE) {
code = SetDeflateDictionary(&cd->outStream, compDictObj);
|
| ︙ | ︙ | |||
3327 3328 3329 3330 3331 3332 3333 | * Reading side of [fconfigure] on our channel. * *---------------------------------------------------------------------- */ static int ZlibTransformGetOption( | | | 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 |
* Reading side of [fconfigure] on our channel.
*
*----------------------------------------------------------------------
*/
static int
ZlibTransformGetOption(
void *instanceData,
Tcl_Interp *interp,
const char *optionName,
Tcl_DString *dsPtr)
{
ZlibChannelData *cd = instanceData;
Tcl_DriverGetOptionProc *getOptionProc =
Tcl_ChannelGetOptionProc(Tcl_GetChannelType(cd->parent));
|
| ︙ | ︙ | |||
3376 3377 3378 3379 3380 3381 3382 |
* Embedded NUL bytes are ok; they'll be C080-encoded.
*/
if (optionName == NULL) {
Tcl_DStringAppendElement(dsPtr, "-dictionary");
if (cd->compDictObj) {
Tcl_DStringAppendElement(dsPtr,
| | | | | | | 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 |
* 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 = Tcl_NewObj();
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;
}
}
|
| ︙ | ︙ | |||
3447 3448 3449 3450 3451 3452 3453 | * (in order to allow a real event to catch up). * *---------------------------------------------------------------------- */ static void ZlibTransformWatch( | | | 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 |
* (in order to allow a real event to catch up).
*
*----------------------------------------------------------------------
*/
static void
ZlibTransformWatch(
void *instanceData,
int mask)
{
ZlibChannelData *cd = instanceData;
Tcl_DriverWatchProc *watchProc;
/*
* This code is based on the code in tclIORTrans.c
|
| ︙ | ︙ | |||
3470 3471 3472 3473 3474 3475 3476 |
cd->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME,
ZlibTransformTimerRun, cd);
}
}
static int
ZlibTransformEventHandler(
| | | | | | | 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 3505 3506 3507 3508 3509 3510 3511 3512 3513 3514 3515 3516 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 3549 3550 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 |
cd->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME,
ZlibTransformTimerRun, cd);
}
}
static int
ZlibTransformEventHandler(
void *instanceData,
int interestMask)
{
ZlibChannelData *cd = 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 = 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 = 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 = instanceData;
if (mode == TCL_MODE_NONBLOCKING) {
cd->flags |= ASYNC;
} else {
|
| ︙ | ︙ | |||
3586 3587 3588 3589 3590 3591 3592 |
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. */
{
| | | 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 |
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 = 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);
}
|
| ︙ | ︙ | |||
3646 3647 3648 3649 3650 3651 3652 |
*/
if (mode == TCL_ZLIB_STREAM_INFLATE) {
if (inflateInit2(&cd->inStream, wbits) != Z_OK) {
goto error;
}
cd->inAllocated = DEFAULT_BUFFER_SIZE;
| | | | 3660 3661 3662 3663 3664 3665 3666 3667 3668 3669 3670 3671 3672 3673 3674 3675 3676 3677 3678 3679 3680 3681 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 |
*/
if (mode == TCL_ZLIB_STREAM_INFLATE) {
if (inflateInit2(&cd->inStream, wbits) != Z_OK) {
goto error;
}
cd->inAllocated = DEFAULT_BUFFER_SIZE;
cd->inBuffer = 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 = 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) {
|
| ︙ | ︙ | |||
3690 3691 3692 3693 3694 3695 3696 |
cd->chan = chan;
cd->parent = Tcl_GetStackedChannel(chan);
Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_GetChannelName(chan), -1));
return chan;
error:
if (cd->inBuffer) {
| | | | | 3704 3705 3706 3707 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 |
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;
}
/*
*----------------------------------------------------------------------
*
* ResultCopy --
|
| ︙ | ︙ | |||
3726 3727 3728 3729 3730 3731 3732 |
*----------------------------------------------------------------------
*/
static inline int
ResultCopy(
ZlibChannelData *cd, /* The location of the buffer to read from. */
char *buf, /* The buffer to copy into */
| | | | 3740 3741 3742 3743 3744 3745 3746 3747 3748 3749 3750 3751 3752 3753 3754 3755 3756 |
*----------------------------------------------------------------------
*/
static inline int
ResultCopy(
ZlibChannelData *cd, /* The location of the buffer to read from. */
char *buf, /* The buffer to copy into */
size_t toRead) /* Number of requested bytes */
{
size_t have = Tcl_DStringLength(&cd->decompressed);
if (have == 0) {
/*
* Nothing to copy in the case of an empty buffer.
*/
return 0;
|
| ︙ | ︙ | |||
3904 3905 3906 3907 3908 3909 3910 3911 3912 3913 3914 3915 3916 3917 |
*/
cfg[0].key = "zlibVersion";
cfg[0].value = zlibVersion();
cfg[1].key = NULL;
Tcl_RegisterConfig(interp, "zlib", cfg, "iso8859-1");
/*
* Formally provide the package as a Tcl built-in.
*/
return Tcl_PkgProvideEx(interp, "zlib", TCL_ZLIB_VERSION, NULL);
}
| > > > > > > | 3918 3919 3920 3921 3922 3923 3924 3925 3926 3927 3928 3929 3930 3931 3932 3933 3934 3935 3936 3937 |
*/
cfg[0].key = "zlibVersion";
cfg[0].value = zlibVersion();
cfg[1].key = NULL;
Tcl_RegisterConfig(interp, "zlib", cfg, "iso8859-1");
/*
* 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);
}
|
| ︙ | ︙ | |||
3983 3984 3985 3986 3987 3988 3989 |
return TCL_OK;
}
int
Tcl_ZlibStreamGet(
Tcl_ZlibStream zshandle,
Tcl_Obj *data,
| | | 4003 4004 4005 4006 4007 4008 4009 4010 4011 4012 4013 4014 4015 4016 4017 |
return TCL_OK;
}
int
Tcl_ZlibStreamGet(
Tcl_ZlibStream zshandle,
Tcl_Obj *data,
size_t count)
{
return TCL_OK;
}
int
Tcl_ZlibDeflate(
Tcl_Interp *interp,
|
| ︙ | ︙ | |||
4008 4009 4010 4011 4012 4013 4014 |
}
int
Tcl_ZlibInflate(
Tcl_Interp *interp,
int format,
Tcl_Obj *data,
| | | | | | | 4028 4029 4030 4031 4032 4033 4034 4035 4036 4037 4038 4039 4040 4041 4042 4043 4044 4045 4046 4047 4048 4049 4050 4051 4052 4053 4054 4055 4056 4057 4058 4059 4060 4061 4062 4063 4064 4065 |
}
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,
|
| ︙ | ︙ |
Changes to library/auto.tcl.
| ︙ | ︙ | |||
69 70 71 72 73 74 75 76 77 78 79 80 81 82 |
# 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)
}
# 2. In the package script directory registered within the
# configuration of the package itself.
catch {
lappend dirs [::${basename}::pkgconfig get scriptdir,runtime]
}
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 |
# 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}
}
}
}
}
}
# 2. In the package script directory registered within the
# configuration of the package itself.
catch {
lappend dirs [::${basename}::pkgconfig get scriptdir,runtime]
}
|
| ︙ | ︙ |
Changes to library/dde/pkgIndex.tcl.
1 2 3 |
if {([info commands ::tcl::pkgconfig] eq "")
|| ([info sharedlibextension] ne ".dll")} return
if {[::tcl::pkgconfig get debug]} {
| | | | 1 2 3 4 5 6 7 |
if {([info commands ::tcl::pkgconfig] eq "")
|| ([info sharedlibextension] ne ".dll")} return
if {[::tcl::pkgconfig get debug]} {
package ifneeded dde 1.4.1 [list load [file join $dir tcldde14g.dll] dde]
} else {
package ifneeded dde 1.4.1 [list load [file join $dir tcldde14.dll] dde]
}
|
Added library/http/cookiejar.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 |
# 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.1
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 "/"] "/"]
for {set j -1} {$j < [llength $pieces]} {incr j} {
lappend result /[join [lrange $pieces 0 $j] "/"]
}
return $result
}
proc isoNow {} {
set ms [clock milliseconds]
set ts [expr {$ms / 1000}]
set ms [format %03d [expr {$ms % 1000}]]
clock format $ts -format "%Y%m%dT%H%M%S.${ms}Z" -gmt 1
}
proc log {level msg args} {
namespace upvar [info object namespace ::http::cookiejar] \
loglevel loglevel
set who [uplevel 1 self class]
set mth [uplevel 1 self method]
set map {debug 0 info 1 warn 2 error 3}
if {[string map $map $level] >= [string map $map $loglevel]} {
set msg [format $msg {*}$args]
set LVL [string toupper $level]
::http::Log "[isoNow] $LVL $who $mth - $msg"
}
}
}
}
# Now we have enough information to provide the package.
package provide cookiejar \
[set [info object namespace ::http::cookiejar]::version]
# The implementation of the cookiejar package
::oo::define ::http::cookiejar {
self {
method configure {{optionName "\u0000\u0000"} {optionValue "\u0000\u0000"}} {
set tbl {
-domainfile {domainfile set}
-domainlist {domainlist set}
-domainrefresh {refreshinterval setInterval}
-loglevel {loglevel setLog}
-offline {offline setBool}
-purgeold {purgeinterval setInterval}
-retain {retainlimit setInt}
-vacuumtrigger {vacuumtrigger setInt}
}
dict lappend tbl -domainrefresh [namespace code {
my IntervalTrigger PostponeRefresh
}]
dict lappend tbl -purgeold [namespace code {
my IntervalTrigger PostponePurge
}]
if {$optionName eq "\u0000\u0000"} {
return [dict keys $tbl]
}
set opt [::tcl::prefix match -message "option" \
[dict keys $tbl] $optionName]
set setter [lassign [dict get $tbl $opt] varname]
namespace upvar [namespace current] $varname var
if {$optionValue ne "\u0000\u0000"} {
{*}$setter var $optionValue
}
return $var
}
method IntervalTrigger {method} {
# TODO: handle subclassing
foreach obj [info class instances [self]] {
[info object namespace $obj]::my $method
}
}
}
variable purgeTimer deletions refreshTimer
constructor {{path ""}} {
namespace import [info object namespace [self class]]::support::*
if {$path eq ""} {
sqlite3 [namespace current]::db :memory:
set storeorigin "constructed cookie store in memory"
} else {
sqlite3 [namespace current]::db $path
db timeout 500
set storeorigin "loaded cookie store from $path"
}
set deletions 0
db transaction {
db eval {
--;# Store the persistent cookies in this table.
--;# Deletion policy: once they expire, or if explicitly
--;# killed.
CREATE TABLE IF NOT EXISTS persistentCookies (
id INTEGER PRIMARY KEY,
secure INTEGER NOT NULL,
domain TEXT NOT NULL COLLATE NOCASE,
path TEXT NOT NULL,
key TEXT NOT NULL,
value TEXT NOT NULL,
originonly INTEGER NOT NULL,
expiry INTEGER NOT NULL,
lastuse INTEGER NOT NULL,
creation INTEGER NOT NULL);
CREATE UNIQUE INDEX IF NOT EXISTS persistentUnique
ON persistentCookies (domain, path, key);
CREATE INDEX IF NOT EXISTS persistentLookup
ON persistentCookies (domain, path);
--;# Store the session cookies in this table.
--;# Deletion policy: at cookiejar instance deletion, if
--;# explicitly killed, or if the number of session cookies is
--;# too large and the cookie has not been used recently.
CREATE TEMP TABLE sessionCookies (
id INTEGER PRIMARY KEY,
secure INTEGER NOT NULL,
domain TEXT NOT NULL COLLATE NOCASE,
path TEXT NOT NULL,
key TEXT NOT NULL,
originonly INTEGER NOT NULL,
value TEXT NOT NULL,
lastuse INTEGER NOT NULL,
creation INTEGER NOT NULL);
CREATE UNIQUE INDEX sessionUnique
ON sessionCookies (domain, path, key);
CREATE INDEX sessionLookup ON sessionCookies (domain, path);
--;# View to allow for simple looking up of a cookie.
--;# Deletion policy: NOT SUPPORTED via this view.
CREATE TEMP VIEW cookies AS
SELECT id, domain, (
CASE originonly WHEN 1 THEN path ELSE '.' || path END
) AS path, key, value, secure, 1 AS persistent
FROM persistentCookies
UNION
SELECT id, domain, (
CASE originonly WHEN 1 THEN path ELSE '.' || path END
) AS path, key, value, secure, 0 AS persistent
FROM sessionCookies;
--;# Encoded domain permission policy; if forbidden is 1, no
--;# cookie may be ever set for the domain, and if forbidden
--;# is 0, cookies *may* be created for the domain (overriding
--;# the forbiddenSuper table).
--;# Deletion policy: normally not modified.
CREATE TABLE IF NOT EXISTS domains (
domain TEXT PRIMARY KEY NOT NULL,
forbidden INTEGER NOT NULL);
--;# Domains that may not have a cookie defined for direct
--;# child domains of them.
--;# Deletion policy: normally not modified.
CREATE TABLE IF NOT EXISTS forbiddenSuper (
domain TEXT PRIMARY KEY);
--;# When we last retrieved the domain list.
CREATE TABLE IF NOT EXISTS domainCacheMetadata (
id INTEGER PRIMARY KEY,
retrievalDate INTEGER,
installDate INTEGER);
}
set cookieCount "no"
db eval {
SELECT COUNT(*) AS cookieCount FROM persistentCookies
}
log info "%s with %s entries" $storeorigin $cookieCount
my PostponePurge
if {$path ne ""} {
if {[db exists {SELECT 1 FROM domains}]} {
my RefreshDomains
} else {
my InitDomainList
my PostponeRefresh
}
} else {
set data [my GetDomainListOffline metadata]
my InstallDomainData $data $metadata
my PostponeRefresh
}
}
}
method PostponePurge {} {
namespace upvar [info object namespace [self class]] \
purgeinterval interval
catch {after cancel $purgeTimer}
set purgeTimer [after $interval [namespace code {my PurgeCookies}]]
}
method PostponeRefresh {} {
namespace upvar [info object namespace [self class]] \
refreshinterval interval
catch {after cancel $refreshTimer}
set refreshTimer [after $interval [namespace code {my RefreshDomains}]]
}
method RefreshDomains {} {
# TODO: domain list refresh policy
my PostponeRefresh
}
method HttpGet {url {timeout 0} {maxRedirects 5}} {
for {set r 0} {$r < $maxRedirects} {incr r} {
set tok [::http::geturl $url -timeout $timeout]
try {
if {[::http::status $tok] eq "timeout"} {
return -code error "connection timed out"
} elseif {[::http::ncode $tok] == 200} {
return [::http::data $tok]
} elseif {[::http::ncode $tok] >= 400} {
return -code error [::http::error $tok]
} elseif {[dict exists [::http::meta $tok] Location]} {
set url [dict get [::http::meta $tok] Location]
continue
}
return -code error \
"unexpected state: [::http::code $tok]"
} finally {
::http::cleanup $tok
}
}
return -code error "too many redirects"
}
method GetDomainListOnline {metaVar} {
upvar 1 $metaVar meta
namespace upvar [info object namespace [self class]] \
domainlist url domaincache cache
lassign $cache when data
if {$when > [clock seconds] - 3600} {
log debug "using cached value created at %s" \
[clock format $when -format {%Y%m%dT%H%M%SZ} -gmt 1]
dict set meta retrievalDate $when
return $data
}
log debug "loading domain list from %s" $url
try {
set when [clock seconds]
set data [my HttpGet $url]
set cache [list $when $data]
# TODO: Should we use the Last-Modified header instead?
dict set meta retrievalDate $when
return $data
} on error msg {
log error "failed to fetch list of forbidden cookie domains from %s: %s" \
$url $msg
return {}
}
}
method GetDomainListOffline {metaVar} {
upvar 1 $metaVar meta
namespace upvar [info object namespace [self class]] \
domainfile filename
log debug "loading domain list from %s" $filename
try {
set f [open $filename]
try {
if {[string match *.gz $filename]} {
zlib push gunzip $f
}
fconfigure $f -encoding utf-8
dict set meta retrievalDate [file mtime $filename]
return [read $f]
} finally {
close $f
}
} on error {msg opt} {
log error "failed to read list of forbidden cookie domains from %s: %s" \
$filename $msg
return -options $opt $msg
}
}
method InitDomainList {} {
namespace upvar [info object namespace [self class]] \
offline offline
if {!$offline} {
try {
set data [my GetDomainListOnline metadata]
if {[string length $data]} {
my InstallDomainData $data $metadata
return
}
} on error {} {
log warn "attempting to fall back to built in version"
}
}
set data [my GetDomainListOffline metadata]
my InstallDomainData $data $metadata
}
method InstallDomainData {data meta} {
set n [db total_changes]
db transaction {
foreach line [split $data "\n"] {
if {[string trim $line] eq ""} {
continue
} elseif {[string match //* $line]} {
continue
} elseif {[string match !* $line]} {
set line [string range $line 1 end]
set idna [string tolower [::tcl::idna encode $line]]
set utf [::tcl::idna decode [string tolower $line]]
db eval {
INSERT OR REPLACE INTO domains (domain, forbidden)
VALUES ($utf, 0);
}
if {$idna ne $utf} {
db eval {
INSERT OR REPLACE INTO domains (domain, forbidden)
VALUES ($idna, 0);
}
}
} else {
if {[string match {\*.*} $line]} {
set line [string range $line 2 end]
set idna [string tolower [::tcl::idna encode $line]]
set utf [::tcl::idna decode [string tolower $line]]
db eval {
INSERT OR REPLACE INTO forbiddenSuper (domain)
VALUES ($utf);
}
if {$idna ne $utf} {
db eval {
INSERT OR REPLACE INTO forbiddenSuper (domain)
VALUES ($idna);
}
}
} else {
set idna [string tolower [::tcl::idna encode $line]]
set utf [::tcl::idna decode [string tolower $line]]
}
db eval {
INSERT OR REPLACE INTO domains (domain, forbidden)
VALUES ($utf, 1);
}
if {$idna ne $utf} {
db eval {
INSERT OR REPLACE INTO domains (domain, forbidden)
VALUES ($idna, 1);
}
}
}
if {$utf ne [::tcl::idna decode [string tolower $idna]]} {
log warn "mismatch in IDNA handling for %s (%d, %s, %s)" \
$idna $line $utf [::tcl::idna decode $idna]
}
}
dict with meta {
set installDate [clock seconds]
db eval {
INSERT OR REPLACE INTO domainCacheMetadata
(id, retrievalDate, installDate)
VALUES (1, $retrievalDate, $installDate);
}
}
}
set n [expr {[db total_changes] - $n}]
log info "constructed domain info with %d entries" $n
}
# This forces the rebuild of the domain data, loading it from
method forceLoadDomainData {} {
db transaction {
db eval {
DELETE FROM domains;
DELETE FROM forbiddenSuper;
INSERT OR REPLACE INTO domainCacheMetadata
(id, retrievalDate, installDate)
VALUES (1, -1, -1);
}
my InitDomainList
}
}
destructor {
catch {
after cancel $purgeTimer
}
catch {
after cancel $refreshTimer
}
catch {
db close
}
return
}
method GetCookiesForHostAndPath {listVar secure host path fullhost} {
upvar 1 $listVar result
log debug "check for cookies for %s" [locn $secure $host $path]
set exact [expr {$host eq $fullhost}]
db eval {
SELECT key, value FROM persistentCookies
WHERE domain = $host AND path = $path AND secure <= $secure
AND (NOT originonly OR domain = $fullhost)
AND originonly = $exact
} {
lappend result $key $value
db eval {
UPDATE persistentCookies SET lastuse = $now WHERE id = $id
}
}
set now [clock seconds]
db eval {
SELECT id, key, value FROM sessionCookies
WHERE domain = $host AND path = $path AND secure <= $secure
AND (NOT originonly OR domain = $fullhost)
AND originonly = $exact
} {
lappend result $key $value
db eval {
UPDATE sessionCookies SET lastuse = $now WHERE id = $id
}
}
}
method getCookies {proto host path} {
set result {}
set paths [splitPath $path]
if {[regexp {[^0-9.]} $host]} {
set domains [splitDomain [string tolower [::tcl::idna encode $host]]]
} else {
# Ugh, it's a numeric domain! Restrict it to just itself...
set domains [list $host]
}
set secure [string equal -nocase $proto "https"]
# Open question: how to move these manipulations into the database
# engine (if that's where they *should* be).
#
# Suggestion from kbk:
#LENGTH(theColumn) <= LENGTH($queryStr) AND
#SUBSTR(theColumn, LENGTH($queryStr) LENGTH(theColumn)+1) = $queryStr
#
# However, we instead do most of the work in Tcl because that lets us
# do the splitting exactly right, and it's far easier to work with
# strings in Tcl than in SQL.
db transaction {
foreach domain $domains {
foreach p $paths {
my GetCookiesForHostAndPath result $secure $domain $p $host
}
}
return $result
}
}
method BadDomain options {
if {![dict exists $options domain]} {
log error "no domain present in options"
return 0
}
dict with options {}
if {$domain ne $origin} {
log debug "cookie domain varies from origin (%s, %s)" \
$domain $origin
if {[string match .* $domain]} {
set dotd $domain
} else {
set dotd .$domain
}
if {![string equal -length [string length $dotd] \
[string reverse $dotd] [string reverse $origin]]} {
log warn "bad cookie: domain not suffix of origin"
return 1
}
}
if {![regexp {[^0-9.]} $domain]} {
if {$domain eq $origin} {
# May set for itself
return 0
}
log warn "bad cookie: for a numeric address"
return 1
}
db eval {
SELECT forbidden FROM domains WHERE domain = $domain
} {
if {$forbidden} {
log warn "bad cookie: for a forbidden address"
}
return $forbidden
}
if {[regexp {^[^.]+\.(.+)$} $domain -> super] && [db exists {
SELECT 1 FROM forbiddenSuper WHERE domain = $super
}]} then {
log warn "bad cookie: for a forbidden address"
return 1
}
return 0
}
# A defined extension point to allow users to easily impose extra policies
# on whether to accept cookies from a particular domain and path.
method policyAllow {operation domain path} {
return true
}
method storeCookie {options} {
db transaction {
if {[my BadDomain $options]} {
return
}
set now [clock seconds]
set persistent [dict exists $options expires]
dict with options {}
if {!$persistent} {
if {![my policyAllow session $domain $path]} {
log warn "bad cookie: $domain prohibited by user policy"
return
}
db eval {
INSERT OR REPLACE INTO sessionCookies (
secure, domain, path, key, value, originonly, creation,
lastuse)
VALUES ($secure, $domain, $path, $key, $value, $hostonly,
$now, $now);
DELETE FROM persistentCookies
WHERE domain = $domain AND path = $path AND key = $key
AND secure <= $secure AND originonly = $hostonly
}
incr deletions [db changes]
log debug "defined session cookie for %s" \
[locn $secure $domain $path $key]
} elseif {$expires < $now} {
if {![my policyAllow delete $domain $path]} {
log warn "bad cookie: $domain prohibited by user policy"
return
}
db eval {
DELETE FROM persistentCookies
WHERE domain = $domain AND path = $path AND key = $key
AND secure <= $secure AND originonly = $hostonly
}
set del [db changes]
db eval {
DELETE FROM sessionCookies
WHERE domain = $domain AND path = $path AND key = $key
AND secure <= $secure AND originonly = $hostonly
}
incr deletions [incr del [db changes]]
log debug "deleted %d cookies for %s" \
$del [locn $secure $domain $path $key]
} else {
if {![my policyAllow set $domain $path]} {
log warn "bad cookie: $domain prohibited by user policy"
return
}
db eval {
INSERT OR REPLACE INTO persistentCookies (
secure, domain, path, key, value, originonly, expiry,
creation, lastuse)
VALUES ($secure, $domain, $path, $key, $value, $hostonly,
$expires, $now, $now);
DELETE FROM sessionCookies
WHERE domain = $domain AND path = $path AND key = $key
AND secure <= $secure AND originonly = $hostonly
}
incr deletions [db changes]
log debug "defined persistent cookie for %s, expires at %s" \
[locn $secure $domain $path $key] \
[clock format $expires]
}
}
}
method PurgeCookies {} {
namespace upvar [info object namespace [self class]] \
vacuumtrigger trigger retainlimit retain
my PostponePurge
set now [clock seconds]
log debug "purging cookies that expired before %s" [clock format $now]
db transaction {
db eval {
DELETE FROM persistentCookies WHERE expiry < $now
}
incr deletions [db changes]
db eval {
DELETE FROM persistentCookies WHERE id IN (
SELECT id FROM persistentCookies ORDER BY lastuse ASC
LIMIT -1 OFFSET $retain)
}
incr deletions [db changes]
db eval {
DELETE FROM sessionCookies WHERE id IN (
SELECT id FROM sessionCookies ORDER BY lastuse
LIMIT -1 OFFSET $retain)
}
incr deletions [db changes]
}
# Once we've deleted a fair bit, vacuum the database. Must be done
# outside a transaction.
if {$deletions > $trigger} {
set deletions 0
log debug "vacuuming cookie database"
catch {
db eval {
VACUUM
}
}
}
}
forward Database db
method lookup {{host ""} {key ""}} {
set host [string tolower [::tcl::idna encode $host]]
db transaction {
if {$host eq ""} {
set result {}
db eval {
SELECT DISTINCT domain FROM cookies
ORDER BY domain
} {
lappend result [::tcl::idna decode [string tolower $domain]]
}
return $result
} elseif {$key eq ""} {
set result {}
db eval {
SELECT DISTINCT key FROM cookies
WHERE domain = $host
ORDER BY key
} {
lappend result $key
}
return $result
} else {
db eval {
SELECT value FROM cookies
WHERE domain = $host AND key = $key
LIMIT 1
} {
return $value
}
return -code error "no such key for that host"
}
}
}
}
# Local variables:
# mode: tcl
# fill-column: 78
# End:
|
Added library/http/effective_tld_names.txt.gz.
cannot compute difference between binary files
Changes to library/http/http.tcl.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # http.tcl -- # # Client-side HTTP for GET, POST, and HEAD commands. These routines can # be used in untrusted code that uses the Safesock security policy. # These procedures use a callback interface to avoid using vwait, which # is not defined in the safe base. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. package require Tcl 8.6- # Keep this in sync with pkgIndex.tcl and with the install directories in # Makefiles | | > > > > > | | | | | | | | | | > > > > > > | | | > > | > > > > > > > > > > > > > > | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 |
# http.tcl --
#
# Client-side HTTP for GET, POST, and HEAD commands. These routines can
# be used in untrusted code that uses the Safesock security policy.
# These procedures use a callback interface to avoid using vwait, which
# is not defined in the safe base.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
package require Tcl 8.6-
# Keep this in sync with pkgIndex.tcl and with the install directories in
# Makefiles
package provide http 2.9.0
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]"
}
}
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
# ALPHA (%41-%5A and %61-%7A), DIGIT (%30-%39), hyphen (%2D), period
# (%2E), underscore (%5F), or tilde (%7E) should not be created by URI
# producers ..."
for {set i 0} {$i <= 256} {incr i} {
set c [format %c $i]
if {![string match {[-._~a-zA-Z0-9]} $c]} {
set map($c) %[format %.2X $i]
}
}
# 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 {}
}
init
variable urlTypes
if {![info exists urlTypes]} {
set urlTypes(http) [list 80 ::socket]
}
|
| ︙ | ︙ | |||
91 92 93 94 95 96 97 |
# Let user control default keepalive for compatibility
variable defaultKeepalive
if {![info exists defaultKeepalive]} {
set defaultKeepalive 0
}
| > > > > > > > > > > > > | > | > > > > | 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 |
# Let user control default keepalive for compatibility
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.
}
# http::Log --
#
# Debugging output -- define this to observe HTTP/1.1 socket usage.
# Should echo any args received.
#
|
| ︙ | ︙ | |||
186 187 188 189 190 191 192 | # http::Finish -- # # Clean up the socket and eval close time callbacks # # Arguments: # token Connection token. # errormsg (optional) If set, forces status to error. | | | > > > > > > > > > > > > | > > > > | > > > > > > | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | > > > > > > > > > | | | | | | | | | | | > | > > > > > > > > > > > > | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | > > | > | > | | < > > > > > | > > > > > > > > | > > > > > > > | | | > > > | > | 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 |
# http::Finish --
#
# Clean up the socket and eval close time callbacks
#
# Arguments:
# token Connection token.
# errormsg (optional) If set, forces status to error.
# skipCB (optional) If set, don't call the -command callback. This
# is useful when geturl wants to throw an exception instead
# of calling the callback. That way, the same error isn't
# reported to two places.
#
# Side Effects:
# May close the socket.
proc http::Finish {token {errormsg ""} {skipCB 0}} {
variable socketMapping
variable socketRdState
variable socketWrState
variable socketRdQueue
variable socketWrQueue
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 {[info exists state(after)]} {
after cancel $state(after)
unset state(after)
}
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]
catch {fileevent $s readable {}}
set connId {}
if {$token ne ""} {
variable $token
upvar 0 $token state
if {[info exists state(socketinfo)]} {
set connId $state(socketinfo)
}
} else {
set map [array get socketMapping]
set ndx [lsearch -exact $map $s]
if {$ndx != -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)
}
# http::reset --
#
# See documentation for details.
#
# Arguments:
# token Connection token.
# why Status info.
#
# Side Effects:
# See Finish
proc http::reset {token {why reset}} {
variable $token
upvar 0 $token state
set state(status) $why
catch {fileevent $state(sock) readable {}}
catch {fileevent $state(sock) writable {}}
Finish $token
if {[info exists state(error)]} {
set errorlist $state(error)
unset state
eval ::error $errorlist
}
}
# 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:
# -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.
proc http::geturl {url args} {
variable http
variable urlTypes
variable defaultCharset
variable defaultKeepalive
variable strict
# Initialize the state variable, an array. We'll return the name of this
# array as the token for the transaction.
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
-blocksize 8192
-queryblocksize 8192
-validate 0
-headers {}
-timeout 0
-type application/x-www-form-urlencoded
-queryprogress {}
-protocol 1.1
binary 0
state created
meta {}
method {}
coding {}
currentsize 0
totalsize 0
querylength 0
queryoffset 0
type text/html
body {}
|
| ︙ | ︙ | |||
515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 |
# Provide a better error message in this error case
if {[regexp {(?i)%(?![0-9a-f][0-9a-f])..} $srvurl bad]} {
return -code error \
"Illegal encoding character usage \"$bad\" in URL path"
}
return -code error "Illegal characters in URL path"
}
} else {
set srvurl /
}
if {$proto eq ""} {
set proto http
}
set lower [string tolower $proto]
if {![info exists urlTypes($lower)]} {
unset $token
| > > > > | 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 |
# Provide a better error message in this error case
if {[regexp {(?i)%(?![0-9a-f][0-9a-f])..} $srvurl bad]} {
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]
if {![info exists urlTypes($lower)]} {
unset $token
|
| ︙ | ︙ | |||
551 552 553 554 555 556 557 |
if {$port != $defport} {
append url : $port
}
append url $srvurl
# Don't append the fragment!
set state(url) $url
| < < < < < < < > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > | > > > | > > > > > > | > > > > > > | | < < | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | > | > > > > > > > | > > > | > > > > > > > | | > | > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > | 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 |
if {$port != $defport} {
append url : $port
}
append url $srvurl
# Don't append the fragment!
set state(url) $url
set sockopts [list -async]
# If we are using the proxy, we must pass in the full URL that includes
# the server name.
if {[info exists phost] && ($phost ne "")} {
set srvurl $url
set targetAddr [list $phost $pport]
} else {
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)
}
# 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)
} 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) {}
}
}
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]]
}
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.
# 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
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).
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 {} {}}
}
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]
}
# 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.
http::wait $token
|
| ︙ | ︙ | |||
643 644 645 646 647 648 649 |
# callback (if available) because we're going to throw an
# exception from here instead.
set err [lindex $state(error) 0]
cleanup $token
return -code error $err
}
}
| | | | > > > > > > > > > > > > > | | | > > | > | 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 |
# callback (if available) because we're going to throw an
# exception from here instead.
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} {
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 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)
# The following is disallowed in safe interpreters, but the socket is
# already in non-blocking mode in that case.
catch {fconfigure $sock -blocking off}
set how GET
if {$isQuery} {
|
| ︙ | ︙ | |||
702 703 704 705 706 707 708 |
}
} elseif {$state(-validate)} {
set how HEAD
} elseif {$isQueryChannel} {
set how POST
# The query channel must be blocking for the async Write to
# work properly.
| > | > | > > > > > > | > > | > > | | | | | | | 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 |
}
} elseif {$state(-validate)} {
set how HEAD
} elseif {$isQueryChannel} {
set how POST
# The query channel must be blocking for the async Write to
# work properly.
lassign [fconfigure $sock -translation] trRead trWrite
fconfigure $state(-querychannel) -blocking 1 \
-translation [list $trRead binary]
set contDone 0
}
if {[info exists state(-method)] && ($state(-method) ne "")} {
set how $state(-method)
}
# We cannot handle chunked encodings with -handler, so force HTTP/1.0
# until we can manage this.
if {[info exists state(-handler)]} {
set state(-protocol) 1.0
}
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]} {
# Allow Host spoofing. [Bug 928154]
set hostHdr [dict get $state(-headers) Host]
regexp {^[^:]+} $hostHdr state(host)
puts $sock "Host: $hostHdr"
} 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"
}
puts $sock "User-Agent: $http(-useragent)"
if {($state(-protocol) >= 1.0) && $state(-keepalive)} {
# Send this header, because a 1.1 server is not compelled to treat
# this as the default.
puts $sock "Connection: keep-alive"
}
if {($state(-protocol) > 1.0) && !$state(-keepalive)} {
puts $sock "Connection: close" ;# RFC2616 sec 8.1.2.1
}
if {[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]]
if {[string equal -nocase $key "host"]} {
continue
}
|
| ︙ | ︙ | |||
766 767 768 769 770 771 772 |
}
}
# 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)"
}
| > | > > | | > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > | > | | > > > > > > > > > > | | > > > > > > > > > > | > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 |
}
}
# 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)} {
# 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
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:
#
# It is possible to have both the read and write fileevents active at
# 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
# 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]
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"} {
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
fileevent $sock readable ${token}EventCoroutine
}
# 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
# Code - the HTTP transaction code, e.g., 200
# Size - the size of the URL data
proc http::data {token} {
variable $token
upvar 0 $token state
return $state(body)
|
| ︙ | ︙ | |||
890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 |
#
# Side Effects
# unsets the state array
proc http::cleanup {token} {
variable $token
upvar 0 $token state
if {[info exists state]} {
unset state
}
}
# http::Connect
#
# This callback is made when an asyncronous connection completes.
#
# Arguments
# token The token returned from http::geturl
#
# Side Effects
# Sets the status of the connection, which unblocks
# the waiting geturl call
proc http::Connect {token proto phost srvurl} {
variable $token
upvar 0 $token state
set err "due to unexpected EOF"
if {
[eof $state(sock)] ||
[set err [fconfigure $state(sock) -error]] ne ""
} {
Finish $token "connect failed $err"
} else {
fileevent $state(sock) writable {}
::http::Connected $token $proto $phost $srvurl
}
| > > > > > > > > > > > > > > > > > > > > > > > > < > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > | > | > > > > > > > > > > > > > > > | | | | | > | | > | | | | > > > > > > > > > > | > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | > > | | > > > > > > > > > > > > > > | > > > > > > | > > > > > > > > > > > > > > > > > | > > > | > > > > | > > > > > > > > > > > | > | > > | > > | | | | > > | | | | | | | > > > > > > > > > | | | > > | | | | > > > > | | | | > | | | | | | | | | | | | | | > | | | | | | > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > > > > | | | | | | > | | | > > > > | > > | > | | < > | > > > > > > | > | > > | < > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > | | | > | | | | | | < | | < | | | > > > | | | | > > > > > > > > | > > | | > > > > > > > > > > > > > > > > > | > > > > > > > > > | > > > | | | > > | | | | > > | | > > | | | > > > > | | | | | | > > > | | | | > | > | | | | | | | | > | > | | > > > > > > > | | > > > > > | > | | > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 |
#
# Side Effects
# 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
}
}
# http::Connect
#
# This callback is made when an asyncronous connection completes.
#
# Arguments
# token The token returned from http::geturl
#
# Side Effects
# Sets the status of the connection, which unblocks
# the waiting geturl call
proc http::Connect {token proto phost srvurl} {
variable $token
upvar 0 $token state
set tk [namespace tail $token]
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.
}
Finish $token "connect failed $err"
} else {
set state(state) connecting
fileevent $state(sock) writable {}
::http::Connected $token $proto $phost $srvurl
}
}
# http::Write
#
# Write POST query data to the socket
#
# Arguments
# token The token for the connection
#
# 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 {
# 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)} {
set state(queryoffset) $state(querylength)
set done 1
}
} 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]} {
# 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
}
# Callback to the client after we've completely handled everything.
if {[string length $state(-queryprogress)]} {
eval $state(-queryprogress) \
[list $token $state(querylength) $state(queryoffset)]
}
}
# 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.
#
# 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 state(connection) \
[string trim [string tolower $value]]
}
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
}
}
# http::IsBinaryContentType --
#
# Determine if the content-type means that we should definitely transfer
# the data as binary. [Bug 838e99a76d]
|
| ︙ | ︙ | |||
1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 |
# Not just application/foobar+xml but also image/svg+xml, so let us not
# restrict things for now...
if {[string match "*+xml" $minor]} {
return false
}
return true
}
# http::getTextLine --
#
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 |
# Not just application/foobar+xml but also image/svg+xml, so let us not
# restrict things for now...
if {[string match "*+xml" $minor]} {
return false
}
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:
# <URL:http://curl.haxx.se/rfc/cookie_spec.html>
#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.
#
# 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
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 > -1 || $eof} {
return $line
} else {
yield
}
}
}
# http::CopyStart
#
# Error handling wrapper around fcopy
#
# Arguments
# sock The socket to copy from
|
| ︙ | ︙ | |||
1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 |
} else {
if {$initial} {
foreach coding [ContentEncoding $token] {
zlib push $coding $sock
}
}
if {[catch {
fcopy $sock $state(-channel) -size $state(-blocksize) -command \
[list http::CopyDone $token]
} err]} {
Finish $token $err
}
}
}
| > > > > | 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 |
} 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
}
}
}
|
| ︙ | ︙ | |||
1289 1290 1291 1292 1293 1294 1295 |
}
puts -nonewline $state(-channel) $chunk
if {[info exists state(-progress)]} {
eval [linsert $state(-progress) end \
$token $state(totalsize) $state(currentsize)]
}
} else {
| | | | 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 |
}
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.
}
}
# http::CopyDone
#
# fcopy completion callback
#
|
| ︙ | ︙ | |||
1323 1324 1325 1326 1327 1328 1329 |
upvar 0 $token state
set sock $state(sock)
incr state(currentsize) $count
if {[info exists state(-progress)]} {
eval $state(-progress) \
[list $token $state(totalsize) $state(currentsize)]
}
| | | | > | > > > > > > > > > > > > > > | | | > > > > > | | > | | | | | 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 |
upvar 0 $token state
set sock $state(sock)
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.
if {[string length $error]} {
Finish $token $error
} elseif {[catch {eof $sock} iseof] || $iseof} {
Eot $token
} else {
CopyStart $sock $token 0
}
}
# 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
#
# 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 {}}} {
variable $token
upvar 0 $token state
if {$reason eq "eof"} {
# 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
}
# http::wait --
#
# See documentation for details.
#
# Arguments:
# token Connection token.
#
# Results:
# The status after the wait.
proc http::wait {token} {
variable $token
upvar 0 $token state
if {![info exists state(status)] || $state(status) eq ""} {
# We must wait on the original variable name, not the upvar alias
|
| ︙ | ︙ | |||
1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 |
# Arguments:
# args A list of name-value pairs.
#
# Results:
# TODO
proc http::formatQuery {args} {
set result ""
set sep ""
foreach i $args {
append result $sep [mapReply $i]
if {$sep eq "="} {
set sep &
} else {
| > > > > > > | 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 |
# Arguments:
# args A list of name-value pairs.
#
# Results:
# TODO
proc http::formatQuery {args} {
if {[llength $args] % 2} {
return \
-code error \
-errorcode [list HTTP BADARGCNT $args] \
{Incorrect number of arguments, must be an even number.}
}
set result ""
set sep ""
foreach i $args {
append result $sep [mapReply $i]
if {$sep eq "="} {
set sep &
} else {
|
| ︙ | ︙ | |||
1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 |
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
}
# http::ProxyRequired --
# Default proxy filter.
#
# Arguments:
# host The destination host
#
| > | 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 |
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:
# host The destination host
#
|
| ︙ | ︙ | |||
1541 1542 1543 1544 1545 1546 1547 1548 |
return -code error "unsupported content-encoding \"$coding\""
}
}
}
}
return $r
}
| | < | | | | | | | | > > | | | | | | | | | | | | | | | | | > | > | | < | 3501 3502 3503 3504 3505 3506 3507 3508 3509 3510 3511 3512 3513 3514 3515 3516 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 |
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
}
# Local variables:
# indent-tabs-mode: t
# End:
|
Added library/http/idna.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 |
# cookiejar.tcl --
#
# Implementation of IDNA (Internationalized Domain Names for
# Applications) encoding/decoding system, built on a punycode engine
# developed directly from the code in RFC 3492, Appendix C (with
# substantial modifications).
#
# This implementation includes code from that RFC, translated to Tcl; the
# other parts are:
# Copyright (c) 2014 Donal K. Fellows
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
namespace eval ::tcl::idna {
namespace ensemble create -command puny -map {
encode punyencode
decode punydecode
}
namespace ensemble create -command ::tcl::idna -map {
encode IDNAencode
decode IDNAdecode
puny puny
version {::apply {{} {package present tcl::idna} ::}}
}
proc IDNAencode hostname {
set parts {}
# Split term from RFC 3490, Sec 3.1
foreach part [split $hostname "\u002E\u3002\uFF0E\uFF61"] {
if {[regexp {[^-A-Za-z0-9]} $part]} {
if {[regexp {[^-A-Za-z0-9\u00a1-\uffff]} $part ch]} {
scan $ch %c c
if {$ch < "!" || $ch > "~"} {
set ch [format "\\u%04x" $c]
}
throw [list IDNA INVALID_NAME_CHARACTER $ch] \
"bad character \"$ch\" in DNS name"
}
set part xn--[punyencode $part]
# Length restriction from RFC 5890, Sec 2.3.1
if {[string length $part] > 63} {
throw [list IDNA OVERLONG_PART $part] \
"hostname part too long"
}
}
lappend parts $part
}
return [join $parts .]
}
proc IDNAdecode hostname {
set parts {}
# Split term from RFC 3490, Sec 3.1
foreach part [split $hostname "\u002E\u3002\uFF0E\uFF61"] {
if {[string match -nocase "xn--*" $part]} {
set part [punydecode [string range $part 4 end]]
}
lappend parts $part
}
return [join $parts .]
}
variable digits [split "abcdefghijklmnopqrstuvwxyz0123456789" ""]
# Bootstring parameters for Punycode
variable base 36
variable tmin 1
variable tmax 26
variable skew 38
variable damp 700
variable initial_bias 72
variable initial_n 0x80
variable max_codepoint 0x10FFFF
proc adapt {delta first numchars} {
variable base
variable tmin
variable tmax
variable damp
variable skew
set delta [expr {$delta / ($first ? $damp : 2)}]
incr delta [expr {$delta / $numchars}]
set k 0
while {$delta > ($base - $tmin) * $tmax / 2} {
set delta [expr {$delta / ($base-$tmin)}]
incr k $base
}
return [expr {$k + ($base-$tmin+1) * $delta / ($delta+$skew)}]
}
# Main punycode encoding function
proc punyencode {string {case ""}} {
variable digits
variable tmin
variable tmax
variable base
variable initial_n
variable initial_bias
if {![string is boolean $case]} {
return -code error "\"$case\" must be boolean"
}
set in {}
foreach char [set string [split $string ""]] {
scan $char "%c" ch
lappend in $ch
}
set output {}
# Initialize the state:
set n $initial_n
set delta 0
set bias $initial_bias
# Handle the basic code points:
foreach ch $string {
if {$ch < "\u0080"} {
if {$case eq ""} {
append output $ch
} elseif {[string is true $case]} {
append output [string toupper $ch]
} elseif {[string is false $case]} {
append output [string tolower $ch]
}
}
}
set b [string length $output]
# h is the number of code points that have been handled, b is the
# number of basic code points.
if {$b > 0} {
append output "-"
}
# Main encoding loop:
for {set h $b} {$h < [llength $in]} {incr delta; incr n} {
# All non-basic code points < n have been handled already. Find
# the next larger one:
set m inf
foreach ch $in {
if {$ch >= $n && $ch < $m} {
set m $ch
}
}
# Increase delta enough to advance the decoder's <n,i> state to
# <m,0>, but guard against overflow:
if {$m-$n > (0xffffffff-$delta)/($h+1)} {
throw {PUNYCODE OVERFLOW} "overflow in delta computation"
}
incr delta [expr {($m-$n) * ($h+1)}]
set n $m
foreach ch $in {
if {$ch < $n && ([incr delta] & 0xffffffff) == 0} {
throw {PUNYCODE OVERFLOW} "overflow in delta computation"
}
if {$ch != $n} {
continue
}
# Represent delta as a generalized variable-length integer:
for {set q $delta; set k $base} true {incr k $base} {
set t [expr {min(max($k-$bias, $tmin), $tmax)}]
if {$q < $t} {
break
}
append output \
[lindex $digits [expr {$t + ($q-$t)%($base-$t)}]]
set q [expr {($q-$t) / ($base-$t)}]
}
append output [lindex $digits $q]
set bias [adapt $delta [expr {$h==$b}] [expr {$h+1}]]
set delta 0
incr h
}
}
return $output
}
# Main punycode decode function
proc punydecode {string {case ""}} {
variable tmin
variable tmax
variable base
variable initial_n
variable initial_bias
variable max_codepoint
if {![string is boolean $case]} {
return -code error "\"$case\" must be boolean"
}
# Initialize the state:
set n $initial_n
set i 0
set first 1
set bias $initial_bias
# Split the string into the "real" ASCII characters and the ones to
# feed into the main decoder. Note that we don't need to check the
# result of [regexp] because that RE will technically match any string
# at all.
regexp {^(?:(.*)-)?([^-]*)$} $string -> pre post
if {[string is true -strict $case]} {
set pre [string toupper $pre]
} elseif {[string is false -strict $case]} {
set pre [string tolower $pre]
}
set output [split $pre ""]
set out [llength $output]
# Main decoding loop:
for {set in 0} {$in < [string length $post]} {incr in} {
# Decode a generalized variable-length integer into delta, which
# gets added to i. The overflow checking is easier if we increase
# i as we go, then subtract off its starting value at the end to
# obtain delta.
for {set oldi $i; set w 1; set k $base} 1 {incr in} {
if {[set ch [string index $post $in]] eq ""} {
throw {PUNYCODE BAD_INPUT LENGTH} "exceeded input data"
}
if {[string match -nocase {[a-z]} $ch]} {
scan [string toupper $ch] %c digit
incr digit -65
} elseif {[string match {[0-9]} $ch]} {
set digit [expr {$ch + 26}]
} else {
throw {PUNYCODE BAD_INPUT CHAR} \
"bad decode character \"$ch\""
}
incr i [expr {$digit * $w}]
set t [expr {min(max($tmin, $k-$bias), $tmax)}]
if {$digit < $t} {
set bias [adapt [expr {$i-$oldi}] $first [incr out]]
set first 0
break
}
if {[set w [expr {$w * ($base - $t)}]] > 0x7fffffff} {
throw {PUNYCODE OVERFLOW} \
"excessively large integer computed in digit decode"
}
incr k $base
}
# i was supposed to wrap around from out+1 to 0, incrementing n
# each time, so we'll fix that now:
if {[incr n [expr {$i / $out}]] > 0x7fffffff} {
throw {PUNYCODE OVERFLOW} \
"excessively large integer computed in character choice"
} elseif {$n > $max_codepoint} {
if {$n >= 0x00d800 && $n < 0x00e000} {
# Bare surrogate?!
throw {PUNYCODE NON_BMP} \
[format "unsupported character U+%06x" $n]
}
throw {PUNYCODE NON_UNICODE} "bad codepoint $n"
}
set i [expr {$i % $out}]
# Insert n at position i of the output:
set output [linsert $output $i [format "%c" $n]]
incr i
}
return [join $output ""]
}
}
package provide tcl::idna 1.0
# Local variables:
# mode: tcl
# fill-column: 78
# End:
|
Changes to library/http/pkgIndex.tcl.
1 |
if {![package vsatisfies [package provide Tcl] 8.6-]} {return}
| | > > | 1 2 3 4 |
if {![package vsatisfies [package provide Tcl] 8.6-]} {return}
package ifneeded http 2.9.0 [list tclPkgSetup $dir http 2.9.0 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}]
package ifneeded cookiejar 0.1 [list source [file join $dir cookiejar.tcl]]
package ifneeded tcl::idna 1.0 [list source [file join $dir idna.tcl]]
|
Changes to library/init.tcl.
1 2 3 4 5 6 7 8 | # init.tcl -- # # Default system startup file for Tcl-based applications. Defines # "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. | | > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
# init.tcl --
#
# Default system startup file for Tcl-based applications. Defines
# "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.
#
# 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] == ""} {
|
| ︙ | ︙ | |||
73 74 75 76 77 78 79 |
encoding dirs $Path
}
}
}
namespace eval tcl::Pkg {}
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 76 77 78 79 80 81 82 83 84 85 86 87 88 89 |
encoding dirs $Path
}
}
}
namespace eval tcl::Pkg {}
# Setup the unknown package handler
if {[interp issafe]} {
package unknown {::tcl::tm::UnknownHandler ::tclPkgUnknown}
} else {
|
| ︙ | ︙ |
Added library/install.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 |
###
# 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]
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]
set dat [read $fin]
close $fin
if {![regexp "package provide" $dat]} continue
set fname [file rootname [file tail $file]]
# Look for a package provide statement
foreach line [split $dat \n] {
set line [string trim $line]
if { [string range $line 0 14] != "package provide" } continue
set package [lindex $line 2]
set version [lindex $line 3]
if {[string index $package 0] in "\$ \[ @"} continue
if {[string index $version 0] in "\$ \[ @"} continue
append buffer "package ifneeded $package $version \[list source \[file join \$dir [file tail $file]\]\]" \n
break
}
}
return $buffer
}
set fin [open $pkgidxfile r]
set dat [read $fin]
close $fin
set trace 0
#if {[file tail $path] eq "tool"} {
# set trace 1
#}
set thisline {}
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 master
# 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
|
Added library/manifest.txt.
> > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 |
###
# Package manifest for all Tcl packages included in the /library file system
###
apply {{dir} {
set ::test [info script]
set isafe [interp issafe]
foreach {safe package version file} {
0 http 2.9.0 {http http.tcl}
1 msgcat 1.7.0 {msgcat msgcat.tcl}
1 opt 0.4.7 {opt optparse.tcl}
0 platform 1.0.14 {platform platform.tcl}
0 platform::shell 1.1.4 {platform shell.tcl}
1 tcltest 2.5.0 {tcltest tcltest.tcl}
} {
if {$isafe && !$safe} continue
package ifneeded $package $version [list source [file join $dir {*}$file]]
}
}} $dir
|
Changes to library/msgcat/msgcat.tcl.
| ︙ | ︙ | |||
45 46 47 48 49 50 51 |
variable Msgs [dict create]
}
# create ensemble namespace for mcutil command
namespace eval msgcat::mcutil {
namespace export getsystemlocale getpreferences
namespace ensemble create -prefix 0
| | | 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 |
variable Msgs [dict create]
}
# create ensemble namespace for mcutil command
namespace eval msgcat::mcutil {
namespace export getsystemlocale getpreferences
namespace ensemble create -prefix 0
# Map of language codes used in Windows registry to those of ISO-639
if {[info sharedlibextension] eq ".dll"} {
variable WinRegToISO639 [dict create {*}{
01 ar 0401 ar_SA 0801 ar_IQ 0c01 ar_EG 1001 ar_LY 1401 ar_DZ
1801 ar_MA 1c01 ar_TN 2001 ar_OM 2401 ar_YE 2801 ar_SY
2c01 ar_JO 3001 ar_LB 3401 ar_KW 3801 ar_AE 3c01 ar_BH
4001 ar_QA
|
| ︙ | ︙ | |||
183 184 185 186 187 188 189 | } # msgcat::mc -- # # Find the translation for the given string based on the current # locale setting. Check the local namespace first, then look in each # parent namespace until the source is found. If additional args are | | | 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 | } # msgcat::mc -- # # Find the translation for the given string based on the current # locale setting. Check the local namespace first, then look in each # parent namespace until the source is found. If additional args are # specified, use the format command to work them into the translated # string. # If no catalog item is found, mcunknown is called in the caller frame # and its result is returned. # # Arguments: # src The string to translate. # args Args to pass to the format command |
| ︙ | ︙ | |||
205 206 207 208 209 210 211 | } # msgcat::mcn -- # # Find the translation for the given string based on the current # locale setting. Check the passed namespace first, then look in each # parent namespace until the source is found. If additional args are | | | 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 | } # msgcat::mcn -- # # Find the translation for the given string based on the current # locale setting. Check the passed namespace first, then look in each # parent namespace until the source is found. If additional args are # specified, use the format command to work them into the translated # string. # If no catalog item is found, mcunknown is called in the caller frame # and its result is returned. # # Arguments: # ns Package namespace of the translation # src The string to translate. |
| ︙ | ︙ | |||
288 289 290 291 292 293 294 |
return -code error "wrong # args: should be\
\"[lindex [info level 0] 0] ?-exactnamespace?\
?-exactlocale? ?-namespace ns? src\""
}
}
}
set src [lindex $args 0]
| | | 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 |
return -code error "wrong # args: should be\
\"[lindex [info level 0] 0] ?-exactnamespace?\
?-exactlocale? ?-namespace ns? src\""
}
}
}
set src [lindex $args 0]
if {![info exists ns]} { set ns [PackageNamespaceGet] }
set loclist [PackagePreferences $ns]
if {[info exists -exactlocale]} { set loclist [lrange $loclist 0 0] }
while {$ns ne ""} {
foreach loc $loclist {
|
| ︙ | ︙ | |||
533 534 535 536 537 538 539 |
return [expr {[string tolower [lindex $args 0]]
in [PackageLocales $ns]} ]
}
isset { return [dict exists $PackageConfig loclist $ns] }
set - preferences {
# set a package locale or add a package locale
set fSet [expr {$subcommand eq "set"}]
| | | 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 |
return [expr {[string tolower [lindex $args 0]]
in [PackageLocales $ns]} ]
}
isset { return [dict exists $PackageConfig loclist $ns] }
set - preferences {
# set a package locale or add a package locale
set fSet [expr {$subcommand eq "set"}]
# Check parameter
if {$fSet && 1 < [llength $args] } {
return -code error "wrong # args: should be\
\"[lrange [info level 0] 0 1] ?locale?\""
}
# > Return preferences if no parameter
|
| ︙ | ︙ | |||
1101 1102 1103 1104 1105 1106 1107 |
variable FileLocale
variable Msgs
if {![info exists FileLocale]} {
return -code error "must only be used inside a message catalog loaded\
with ::msgcat::mcload"
}
| | | | | | 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 |
variable FileLocale
variable Msgs
if {![info exists FileLocale]} {
return -code error "must only be used inside a message catalog loaded\
with ::msgcat::mcload"
}
tailcall mcmset $FileLocale $pairs
}
# msgcat::mcunknown --
#
# This routine is called by msgcat::mc if a translation cannot
# be found for a string and no unknowncmd is set for the current
# package. This routine is intended to be replaced
# by an application specific routine for error reporting
# purposes. The default behavior is to return the source string.
# If additional args are specified, the format command will be used
# to work them into the translated string.
#
# Arguments:
# locale The current locale.
# src The string to be translated.
# args Args to pass to the format command
#
# Results:
# Returns the translated value.
proc msgcat::mcunknown {args} {
tailcall DefaultUnknown {*}$args
}
# msgcat::DefaultUnknown --
#
# This routine is called by msgcat::mc if a translation cannot
# be found for a string in the following circumstances:
# - Default global handler, if mcunknown is not redefined.
# - Per package handler, if the package sets unknowncmd to the empty
# string.
# It returns the source string if the argument list is empty.
# If additional args are specified, the format command will be used
# to work them into the translated string.
#
# Arguments:
# locale (unused) The current locale.
# src The string to be translated.
# args Args to pass to the format command
#
# Results:
|
| ︙ | ︙ | |||
1237 1238 1239 1240 1241 1242 1243 |
default {
# Not in object environment
return [namespace current]
}
}
}
}
| | | 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 |
default {
# Not in object environment
return [namespace current]
}
}
}
}
# Initialize the default locale
proc msgcat::mcutil::getsystemlocale {} {
global env
#
# set default locale, try to get from environment
#
|
| ︙ | ︙ | |||
1275 1276 1277 1278 1279 1280 1281 |
#
# On Windows or Cygwin, try to set locale depending on registry
# settings, or fall back on locale of "C".
#
# On Vista and later:
# HCU/Control Panel/Desktop : PreferredUILanguages is for language packs,
| | | 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 |
#
# On Windows or Cygwin, try to set locale depending on registry
# settings, or fall back on locale of "C".
#
# On Vista and later:
# HCU/Control Panel/Desktop : PreferredUILanguages is for language packs,
# HCU/Control Panel/International : localName is the default locale.
#
# They contain the local string as RFC5646, composed of:
# [a-z]{2,3} : language
# -[a-z]{4} : script (optional, translated by table Latn->latin)
# -[a-z]{2}|[0-9]{3} : territory (optional, numerical region codes not used)
# (-.*)* : variant, extension, private use (optional, not used)
# Those are translated to local strings.
|
| ︙ | ︙ | |||
1311 1312 1313 1314 1315 1316 1317 |
if {[catch {
set locale [registry get $key "locale"]
}]} {
return C
}
#
# Keep trying to match against smaller and smaller suffixes
| | | | 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 |
if {[catch {
set locale [registry get $key "locale"]
}]} {
return C
}
#
# Keep trying to match against smaller and smaller suffixes
# of the registry value, since the latter hexdigits appear
# to determine general language and earlier hexdigits determine
# more precise information, such as territory. For example,
# 0409 - English - United States
# 0809 - English - United Kingdom
# Add more translations to the WinRegToISO639 array above.
#
variable WinRegToISO639
set locale [string tolower $locale]
|
| ︙ | ︙ |
Changes to library/msgs/ja.msg.
| ︙ | ︙ | |||
36 37 38 39 40 41 42 |
::msgcat::mcset ja DATE_FORMAT "%Y/%m/%d"
::msgcat::mcset ja TIME_FORMAT "%k:%M:%S"
::msgcat::mcset ja TIME_FORMAT_12 "%P %I:%M:%S"
::msgcat::mcset ja DATE_TIME_FORMAT "%Y/%m/%d %k:%M:%S %z"
::msgcat::mcset ja LOCALE_DATE_FORMAT "%EY年%m月%d日"
::msgcat::mcset ja LOCALE_TIME_FORMAT "%H時%M分%S秒"
::msgcat::mcset ja LOCALE_DATE_TIME_FORMAT "%EY年%m月%d日 (%a) %H時%M分%S秒 %z"
| | | 36 37 38 39 40 41 42 43 44 |
::msgcat::mcset ja DATE_FORMAT "%Y/%m/%d"
::msgcat::mcset ja TIME_FORMAT "%k:%M:%S"
::msgcat::mcset ja TIME_FORMAT_12 "%P %I:%M:%S"
::msgcat::mcset ja DATE_TIME_FORMAT "%Y/%m/%d %k:%M:%S %z"
::msgcat::mcset ja LOCALE_DATE_FORMAT "%EY年%m月%d日"
::msgcat::mcset ja LOCALE_TIME_FORMAT "%H時%M分%S秒"
::msgcat::mcset ja LOCALE_DATE_TIME_FORMAT "%EY年%m月%d日 (%a) %H時%M分%S秒 %z"
::msgcat::mcset ja LOCALE_ERAS "{-9223372036854775808 西暦 0} {-3061011600 明治 1867} {-1812186000 大正 1911} {-1357635600 昭和 1925} {600220800 平成 1988} {1556668800 令和 2018}"
}
|
Changes to library/package.tcl.
| ︙ | ︙ | |||
492 493 494 495 496 497 498 |
if {![info exists procdDirs($dir)]} {
try {
::tcl::Pkg::source $file
} trap {POSIX EACCES} {} {
# $file was not readable; silently ignore
continue
} on error msg {
| > > > > | > > > > | 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 |
if {![info exists procdDirs($dir)]} {
try {
::tcl::Pkg::source $file
} trap {POSIX EACCES} {} {
# $file was not readable; silently ignore
continue
} on error msg {
if {[regexp {version conflict for package} $msg]} {
# In case of version conflict, silently ignore
continue
}
tclLog "error reading package index file $file: $msg"
} on ok {} {
set procdDirs($dir) 1
}
}
}
}
set dir [lindex $use_path end]
if {![info exists procdDirs($dir)]} {
set file [file join $dir pkgIndex.tcl]
# safe interps usually don't have "file exists",
if {([interp issafe] || [file exists $file])} {
try {
::tcl::Pkg::source $file
} trap {POSIX EACCES} {} {
# $file was not readable; silently ignore
continue
} on error msg {
if {[regexp {version conflict for package} $msg]} {
# In case of version conflict, silently ignore
continue
}
tclLog "error reading package index file $file: $msg"
} on ok {} {
set procdDirs($dir) 1
}
}
}
|
| ︙ | ︙ | |||
594 595 596 597 598 599 600 601 602 603 604 605 606 607 |
if {![info exists procdDirs($dir)]} {
try {
::tcl::Pkg::source $file
} trap {POSIX EACCES} {} {
# $file was not readable; silently ignore
continue
} on error msg {
tclLog "error reading package index file $file: $msg"
} on ok {} {
set procdDirs($dir) 1
}
}
}
set use_path [lrange $use_path 0 end-1]
| > > > > | 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 |
if {![info exists procdDirs($dir)]} {
try {
::tcl::Pkg::source $file
} trap {POSIX EACCES} {} {
# $file was not readable; silently ignore
continue
} on error msg {
if {[regexp {version conflict for package} $msg]} {
# In case of version conflict, silently ignore
continue
}
tclLog "error reading package index file $file: $msg"
} on ok {} {
set procdDirs($dir) 1
}
}
}
set use_path [lrange $use_path 0 end-1]
|
| ︙ | ︙ |
Changes to library/reg/pkgIndex.tcl.
1 2 3 |
if {([info commands ::tcl::pkgconfig] eq "")
|| ([info sharedlibextension] ne ".dll")} return
if {[::tcl::pkgconfig get debug]} {
| | | | 1 2 3 4 5 6 7 8 9 |
if {([info commands ::tcl::pkgconfig] eq "")
|| ([info sharedlibextension] ne ".dll")} return
if {[::tcl::pkgconfig get debug]} {
package ifneeded registry 1.3.3 \
[list load [file join $dir tclreg13g.dll] registry]
} else {
package ifneeded registry 1.3.3 \
[list load [file join $dir tclreg13.dll] registry]
}
|
Changes to library/safe.tcl.
| ︙ | ︙ | |||
451 452 453 454 455 456 457 |
# Handling Tcl Modules, we need a restricted form of Glob.
# This alias interposes on the 'exit' command and cleanly terminates
# the slave.
foreach {command alias} {
source AliasSource
load AliasLoad
| < > > > > > > > < | | | < < | | | < < < < | | < | 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 |
# Handling Tcl Modules, we need a restricted form of Glob.
# This alias interposes on the 'exit' command and cleanly terminates
# the slave.
foreach {command alias} {
source AliasSource
load AliasLoad
exit interpDelete
glob AliasGlob
} {
::interp alias $slave $command {} [namespace current]::$alias $slave
}
# UGLY POINT! These commands are safe (they're ensembles with unsafe
# subcommands), but is assumed to not be by existing policies so it is
# hidden by default. Hack it...
foreach command {encoding file} {
::interp alias $slave $command {} interp invokehidden $slave $command
}
# This alias lets the slave have access to a subset of the 'file'
# command functionality.
foreach subcommand {dirname extension rootname tail} {
::interp alias $slave ::tcl::file::$subcommand {} \
::safe::AliasFileSubcommand $slave $subcommand
}
# Subcommand of 'encoding' that has special handling; [encoding system] is
# OK provided it has no other arguments passed to it.
::interp alias $slave ::tcl::encoding::system {} \
::safe::AliasEncodingSystem $slave
# Subcommands of info
::interp alias $slave ::tcl::info::nameofexecutable {} \
::safe::AliasExeName $slave
# The allowed slave variables already have been set by Tcl_MakeSafe(3)
# Source init.tcl and tm.tcl into the slave, to get auto_load and
# other procedures defined:
if {[catch {::interp eval $slave {
|
| ︙ | ︙ | |||
1023 1024 1025 1026 1027 1028 1029 |
proc ::safe::BadSubcommand {slave command subcommand args} {
set msg "not allowed to invoke subcommand $subcommand of $command"
Log $slave $msg
return -code error -errorcode {TCL SAFE SUBCOMMAND} $msg
}
| | | | < < < < > | | | | 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 |
proc ::safe::BadSubcommand {slave command subcommand args} {
set msg "not allowed to invoke subcommand $subcommand of $command"
Log $slave $msg
return -code error -errorcode {TCL SAFE SUBCOMMAND} $msg
}
# AliasEncodingSystem is the target of the "encoding system" alias in safe
# interpreters.
proc ::safe::AliasEncodingSystem {slave args} {
try {
# Must not pass extra arguments; safe slaves may not set the system
# encoding but they may read it.
if {[llength $args]} {
return -code error -errorcode {TCL WRONGARGS} \
"wrong # args: should be \"encoding system\""
}
} on error {msg options} {
Log $slave $msg
return -options $options $msg
}
tailcall ::interp invokehidden $slave tcl:encoding:system
}
# Various minor hiding of platform features. [Bug 2913625]
proc ::safe::AliasExeName {slave} {
return ""
}
|
| ︙ | ︙ |
Changes to library/tcltest/pkgIndex.tcl.
1 2 3 4 5 6 7 8 9 10 11 |
# Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex -direct" command
# and sourced either when an application starts up or
# by a "package unknown" script. It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands. When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.
if {![package vsatisfies [package provide Tcl] 8.5-]} {return}
| | | 1 2 3 4 5 6 7 8 9 10 11 12 |
# Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex -direct" command
# and sourced either when an application starts up or
# by a "package unknown" script. It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands. When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.
if {![package vsatisfies [package provide Tcl] 8.5-]} {return}
package ifneeded tcltest 2.5.0 [list source [file join $dir tcltest.tcl]]
|
Changes to library/tcltest/tcltest.tcl.
| ︙ | ︙ | |||
18 19 20 21 22 23 24 |
package require Tcl 8.5- ;# -verbose line uses [info frame]
namespace eval tcltest {
# When the version number changes, be sure to update the pkgIndex.tcl file,
# and the install directory in the Makefiles. When the minor version
# changes (new feature) be sure to update the man page as well.
| | | 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 |
package require Tcl 8.5- ;# -verbose line uses [info frame]
namespace eval tcltest {
# When the version number changes, be sure to update the pkgIndex.tcl file,
# and the install directory in the Makefiles. When the minor version
# changes (new feature) be sure to update the man page as well.
variable Version 2.5.0
# Compatibility support for dumb variables defined in tcltest 1
# Do not use these. Call [package provide Tcl] and [info patchlevel]
# yourself. You don't need tcltest to wrap it for you.
variable version [package provide Tcl]
variable patchLevel [info patchlevel]
|
| ︙ | ︙ | |||
1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 |
# optional; default is {}.
# output - Expected output sent to stdout. This attribute
# is optional; default is {}.
# errorOutput - Expected output sent to stderr. This attribute
# is optional; default is {}.
# returnCodes - Expected return codes. This attribute is
# optional; default is {0 2}.
# setup - Code to run before $script (above). This
# attribute is optional; default is {}.
# cleanup - Code to run after $script (above). This
# attribute is optional; default is {}.
# match - specifies type of matching to do on result,
# output, errorOutput; this must be a string
# previously registered by a call to [customMatch].
| > > > | 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 |
# optional; default is {}.
# output - Expected output sent to stdout. This attribute
# is optional; default is {}.
# errorOutput - Expected output sent to stderr. This attribute
# is optional; default is {}.
# returnCodes - Expected return codes. This attribute is
# optional; default is {0 2}.
# errorCode - Expected error code. This attribute is
# optional; default is {*}. It is a glob pattern.
# If given, returnCodes defaults to {1}.
# setup - Code to run before $script (above). This
# attribute is optional; default is {}.
# cleanup - Code to run after $script (above). This
# attribute is optional; default is {}.
# match - specifies type of matching to do on result,
# output, errorOutput; this must be a string
# previously registered by a call to [customMatch].
|
| ︙ | ︙ | |||
1878 1879 1880 1881 1882 1883 1884 |
FillFilesExisted
incr testLevel
# Pre-define everything to null except output and errorOutput. We
# determine whether or not to trap output based on whether or not
# these variables (output & errorOutput) are defined.
| | > > > | | | 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 |
FillFilesExisted
incr testLevel
# Pre-define everything to null except output and errorOutput. We
# determine whether or not to trap output based on whether or not
# these variables (output & errorOutput) are defined.
lassign {} constraints setup cleanup body result returnCodes errorCode match
# Set the default match mode
set match exact
# Set the default match values for return codes (0 is the standard
# expected return value if everything went well; 2 represents
# 'return' being used in the test script).
set returnCodes [list 0 2]
# Set the default error code pattern
set errorCode "*"
# The old test format can't have a 3rd argument (constraints or
# script) that starts with '-'.
if {[string match -* [lindex $args 0]] || ([llength $args] <= 1)} {
if {[llength $args] == 1} {
set list [SubstArguments [lindex $args 0]]
foreach {element value} $list {
set testAttributes($element) $value
}
foreach item {constraints match setup body cleanup \
result returnCodes errorCode output errorOutput} {
if {[info exists testAttributes(-$item)]} {
set testAttributes(-$item) [uplevel 1 \
::concat $testAttributes(-$item)]
}
}
} else {
array set testAttributes $args
}
set validFlags {-setup -cleanup -body -result -returnCodes \
-errorCode -match -output -errorOutput -constraints}
foreach flag [array names testAttributes] {
if {$flag ni $validFlags} {
incr testLevel -1
set sorted [lsort $validFlags]
set options [join [lrange $sorted 0 end-1] ", "]
append options ", or [lindex $sorted end]"
|
| ︙ | ︙ | |||
1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 |
must be $values"
}
# Replace symbolic valies supplied for -returnCodes
foreach {strcode numcode} {ok 0 normal 0 error 1 return 2 break 3 continue 4} {
set returnCodes [string map -nocase [list $strcode $numcode] $returnCodes]
}
} else {
# This is parsing for the old test command format; it is here
# for backward compatibility.
set result [lindex $args end]
if {[llength $args] == 2} {
set body [lindex $args 0]
} elseif {[llength $args] == 3} {
| > > > > | 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 |
must be $values"
}
# Replace symbolic valies supplied for -returnCodes
foreach {strcode numcode} {ok 0 normal 0 error 1 return 2 break 3 continue 4} {
set returnCodes [string map -nocase [list $strcode $numcode] $returnCodes]
}
# errorCode without returnCode 1 is meaningless
if {$errorCode ne "*" && 1 ni $returnCodes} {
set returnCodes 1
}
} else {
# This is parsing for the old test command format; it is here
# for backward compatibility.
set result [lindex $args end]
if {[llength $args] == 2} {
set body [lindex $args 0]
} elseif {[llength $args] == 3} {
|
| ︙ | ︙ | |||
1972 1973 1974 1975 1976 1977 1978 |
}
}
# First, run the setup script
set code [catch {uplevel 1 $setup} setupMsg]
if {$code == 1} {
set errorInfo(setup) $::errorInfo
| | | 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 |
}
}
# First, run the setup script
set code [catch {uplevel 1 $setup} setupMsg]
if {$code == 1} {
set errorInfo(setup) $::errorInfo
set errorCodeRes(setup) $::errorCode
}
set setupFailure [expr {$code != 0}]
# Only run the test body if the setup was successful
if {!$setupFailure} {
# Register startup time
|
| ︙ | ︙ | |||
1999 2000 2001 2002 2003 2004 2005 |
set testResult [uplevel 1 [list [namespace origin Eval] $command 0]]
} else {
set testResult [uplevel 1 [list [namespace origin Eval] $command 1]]
}
lassign $testResult actualAnswer returnCode
if {$returnCode == 1} {
set errorInfo(body) $::errorInfo
| | > > > > > | 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 |
set testResult [uplevel 1 [list [namespace origin Eval] $command 0]]
} else {
set testResult [uplevel 1 [list [namespace origin Eval] $command 1]]
}
lassign $testResult actualAnswer returnCode
if {$returnCode == 1} {
set errorInfo(body) $::errorInfo
set errorCodeRes(body) $::errorCode
}
}
# check if the return code matched the expected return code
set codeFailure 0
if {!$setupFailure && ($returnCode ni $returnCodes)} {
set codeFailure 1
}
set errorCodeFailure 0
if {!$setupFailure && !$codeFailure && $returnCode == 1 && \
![string match $errorCode $errorCodeRes(body)]} {
set errorCodeFailure 1
}
# If expected output/error strings exist, we have to compare
# them. If the comparison fails, then so did the test.
set outputFailure 0
variable outData
if {[info exists output] && !$codeFailure} {
|
| ︙ | ︙ | |||
2051 2052 2053 2054 2055 2056 2057 |
set scriptFailure 1
}
# Always run the cleanup script
set code [catch {uplevel 1 $cleanup} cleanupMsg]
if {$code == 1} {
set errorInfo(cleanup) $::errorInfo
| | | 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 |
set scriptFailure 1
}
# Always run the cleanup script
set code [catch {uplevel 1 $cleanup} cleanupMsg]
if {$code == 1} {
set errorInfo(cleanup) $::errorInfo
set errorCodeRes(cleanup) $::errorCode
}
set cleanupFailure [expr {$code != 0}]
set coreFailure 0
set coreMsg ""
# check for a core file first - if one was created by the test,
# then the test failed
|
| ︙ | ︙ | |||
2102 2103 2104 2105 2106 2107 2108 |
}
}
# if we didn't experience any failures, then we passed
variable numTests
if {!($setupFailure || $cleanupFailure || $coreFailure
|| $outputFailure || $errorFailure || $codeFailure
| | | 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 |
}
}
# if we didn't experience any failures, then we passed
variable numTests
if {!($setupFailure || $cleanupFailure || $coreFailure
|| $outputFailure || $errorFailure || $codeFailure
|| $errorCodeFailure || $scriptFailure)} {
if {$testLevel == 1} {
incr numTests(Passed)
if {[IsVerbose pass]} {
puts [outputChannel] "++++ $name PASSED"
}
}
incr testLevel -1
|
| ︙ | ︙ | |||
2155 2156 2157 2158 2159 2160 2161 |
puts [outputChannel] $body
}
if {$setupFailure} {
puts [outputChannel] "---- Test setup\
failed:\n$setupMsg"
if {[info exists errorInfo(setup)]} {
puts [outputChannel] "---- errorInfo(setup): $errorInfo(setup)"
| | > > > > | | 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 |
puts [outputChannel] $body
}
if {$setupFailure} {
puts [outputChannel] "---- Test setup\
failed:\n$setupMsg"
if {[info exists errorInfo(setup)]} {
puts [outputChannel] "---- errorInfo(setup): $errorInfo(setup)"
puts [outputChannel] "---- errorCode(setup): $errorCodeRes(setup)"
}
}
if {$scriptFailure} {
if {$scriptCompare} {
puts [outputChannel] "---- Error testing result: $scriptMatch"
} else {
puts [outputChannel] "---- Result was:\n$actualAnswer"
puts [outputChannel] "---- Result should have been\
($match matching):\n$result"
}
}
if {$errorCodeFailure} {
puts [outputChannel] "---- Error code was: '$errorCodeRes(body)'"
puts [outputChannel] "---- Error code should have been: '$errorCode'"
}
if {$codeFailure} {
switch -- $returnCode {
0 { set msg "Test completed normally" }
1 { set msg "Test generated error" }
2 { set msg "Test generated return exception" }
3 { set msg "Test generated break exception" }
4 { set msg "Test generated continue exception" }
default { set msg "Test generated exception" }
}
puts [outputChannel] "---- $msg; Return code was: $returnCode"
puts [outputChannel] "---- Return code should have been\
one of: $returnCodes"
if {[IsVerbose error]} {
if {[info exists errorInfo(body)] && (1 ni $returnCodes)} {
puts [outputChannel] "---- errorInfo: $errorInfo(body)"
puts [outputChannel] "---- errorCode: $errorCodeRes(body)"
}
}
}
if {$outputFailure} {
if {$outputCompare} {
puts [outputChannel] "---- Error testing output: $outputMatch"
} else {
|
| ︙ | ︙ | |||
2208 2209 2210 2211 2212 2213 2214 |
been ($match matching):\n$errorOutput"
}
}
if {$cleanupFailure} {
puts [outputChannel] "---- Test cleanup failed:\n$cleanupMsg"
if {[info exists errorInfo(cleanup)]} {
puts [outputChannel] "---- errorInfo(cleanup): $errorInfo(cleanup)"
| | | 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 |
been ($match matching):\n$errorOutput"
}
}
if {$cleanupFailure} {
puts [outputChannel] "---- Test cleanup failed:\n$cleanupMsg"
if {[info exists errorInfo(cleanup)]} {
puts [outputChannel] "---- errorInfo(cleanup): $errorInfo(cleanup)"
puts [outputChannel] "---- errorCode(cleanup): $errorCodeRes(cleanup)"
}
}
if {$coreFailure} {
puts [outputChannel] "---- Core file produced while running\
test! $coreMsg"
}
puts [outputChannel] "==== $name FAILED\n"
|
| ︙ | ︙ | |||
2718 2719 2720 2721 2722 2723 2724 | # skip patterns provided. after sourcing test files, it goes on # to source all.tcl files in matching test subdirectories. # # Arguments: # shell being tested # # Results: | | > | 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 |
# skip patterns provided. after sourcing test files, it goes on
# to source all.tcl files in matching test subdirectories.
#
# Arguments:
# shell being tested
#
# Results:
# Whether there were any failures.
#
# Side effects:
# None.
proc tcltest::runAllTests { {shell ""} } {
variable testSingleFile
variable numTestFiles
variable numTests
variable failFiles
variable DefaultValue
set failFilesAccum {}
FillFilesExisted
if {[llength [info level 0]] == 1} {
set shell [interpreter]
}
set testSingleFile false
|
| ︙ | ︙ | |||
2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 |
} ""] $line null testFile \
Total Passed Skipped Failed]} {
foreach index {Total Passed Skipped Failed} {
incr numTests($index) [set $index]
}
if {$Failed > 0} {
lappend failFiles $testFile
}
} elseif {[regexp [join {
{^Number of tests skipped }
{for each constraint:}
{|^\t(\d+)\t(.+)$}
} ""] $line match skipped constraint]} {
if {[string match \t* $match]} {
| > | 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 |
} ""] $line null testFile \
Total Passed Skipped Failed]} {
foreach index {Total Passed Skipped Failed} {
incr numTests($index) [set $index]
}
if {$Failed > 0} {
lappend failFiles $testFile
lappend failFilesAccum $testFile
}
} elseif {[regexp [join {
{^Number of tests skipped }
{for each constraint:}
{|^\t(\d+)\t(.+)$}
} ""] $line match skipped constraint]} {
if {[string match \t* $match]} {
|
| ︙ | ︙ | |||
2864 2865 2866 2867 2868 2869 2870 |
uplevel 1 [list ::source [file join $directory all.tcl]]
set endTime [eval $timeCmd]
puts [outputChannel] "\n$dir test ended at $endTime"
puts [outputChannel] ""
puts [outputChannel] [string repeat ~ 44]
}
| | | 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 |
uplevel 1 [list ::source [file join $directory all.tcl]]
set endTime [eval $timeCmd]
puts [outputChannel] "\n$dir test ended at $endTime"
puts [outputChannel] ""
puts [outputChannel] [string repeat ~ 44]
}
return [expr {[info exists testFileFailures] || [llength $failFilesAccum]}]
}
#####################################################################
# Test utility procs - not used in tcltest, but may be useful for
# testing.
|
| ︙ | ︙ |
Changes to library/tzdata/Africa/Accra.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Africa/Accra) {
{-9223372036854775808 -52 0 LMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Africa/Accra) {
{-9223372036854775808 -52 0 LMT}
{-1640995148 0 0 GMT}
{-1556841600 1200 1 GMT}
{-1546388400 0 0 GMT}
{-1525305600 1200 1 GMT}
{-1514852400 0 0 GMT}
{-1493769600 1200 1 GMT}
{-1483316400 0 0 GMT}
{-1462233600 1200 1 GMT}
{-1451780400 0 0 GMT}
{-1430611200 1200 1 GMT}
{-1420158000 0 0 GMT}
{-1399075200 1200 1 GMT}
{-1388622000 0 0 GMT}
{-1367539200 1200 1 GMT}
{-1357086000 0 0 GMT}
{-1336003200 1200 1 GMT}
{-1325550000 0 0 GMT}
{-1304380800 1200 1 GMT}
{-1293927600 0 0 GMT}
{-1272844800 1200 1 GMT}
{-1262391600 0 0 GMT}
{-1241308800 1200 1 GMT}
{-1230855600 0 0 GMT}
{-1209772800 1200 1 GMT}
{-1199319600 0 0 GMT}
{-1178150400 1200 1 GMT}
{-1167697200 0 0 GMT}
{-1146614400 1200 1 GMT}
{-1136161200 0 0 GMT}
{-1115078400 1200 1 GMT}
{-1104625200 0 0 GMT}
{-1083542400 1200 1 GMT}
{-1073089200 0 0 GMT}
{-1051920000 1200 1 GMT}
{-1041466800 0 0 GMT}
{-1020384000 1200 1 GMT}
{-1009930800 0 0 GMT}
{-988848000 1200 1 GMT}
{-978394800 0 0 GMT}
{-957312000 1200 1 GMT}
{-946858800 0 0 GMT}
{-925689600 1200 1 GMT}
{-915236400 0 0 GMT}
{-894153600 1200 1 GMT}
{-883700400 0 0 GMT}
{-862617600 1200 1 GMT}
{-852164400 0 0 GMT}
}
|
Changes to library/tzdata/Africa/Bissau.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Africa/Bissau) {
{-9223372036854775808 -3740 0 LMT}
| | | 1 2 3 4 5 6 7 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Africa/Bissau) {
{-9223372036854775808 -3740 0 LMT}
{-1830380400 -3600 0 -01}
{157770000 0 0 GMT}
}
|
Changes to library/tzdata/Africa/Casablanca.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Africa/Casablanca) {
{-9223372036854775808 -1820 0 LMT}
| | | | | | | | | | | | | | | | | | | | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | < < < < < < | | | < < | < < | < < | | | | < < < < < < | | | < < < < | < < < | | | < | | | | < < | | < < | < < < < < < | < < < < | < < | < < < < | < < < < | | < < | < < < < | | < | | | | | | | | | | | < | < | | | < < < < | | | < < | | | | | | | | < < | | | | < < < < < < < < | | | < < | < < < < | | < < | | | < < < < < < < < | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Africa/Casablanca) {
{-9223372036854775808 -1820 0 LMT}
{-1773012580 0 0 +00}
{-956361600 3600 1 +00}
{-950490000 0 0 +00}
{-942019200 3600 1 +00}
{-761187600 0 0 +00}
{-617241600 3600 1 +00}
{-605149200 0 0 +00}
{-81432000 3600 1 +00}
{-71110800 0 0 +00}
{141264000 3600 1 +00}
{147222000 0 0 +00}
{199756800 3600 1 +00}
{207702000 0 0 +00}
{231292800 3600 1 +00}
{244249200 0 0 +00}
{265507200 3600 1 +00}
{271033200 0 0 +00}
{448243200 3600 0 +01}
{504918000 0 0 +00}
{1212278400 3600 1 +00}
{1220223600 0 0 +00}
{1243814400 3600 1 +00}
{1250809200 0 0 +00}
{1272758400 3600 1 +00}
{1281222000 0 0 +00}
{1301788800 3600 1 +00}
{1312066800 0 0 +00}
{1335664800 3600 1 +00}
{1342749600 0 0 +00}
{1345428000 3600 1 +00}
{1348970400 0 0 +00}
{1367114400 3600 1 +00}
{1373162400 0 0 +00}
{1376100000 3600 1 +00}
{1382839200 0 0 +00}
{1396144800 3600 1 +00}
{1403920800 0 0 +00}
{1406944800 3600 1 +00}
{1414288800 0 0 +00}
{1427594400 3600 1 +00}
{1434247200 0 0 +00}
{1437271200 3600 1 +00}
{1445738400 0 0 +00}
{1459044000 3600 1 +00}
{1465092000 0 0 +00}
{1468116000 3600 1 +00}
{1477792800 0 0 +00}
{1490493600 3600 1 +00}
{1495332000 0 0 +00}
{1498960800 3600 1 +00}
{1509242400 0 0 +00}
{1521943200 3600 1 +00}
{1526176800 0 0 +00}
{1529200800 3600 1 +00}
{1540695600 3600 0 +01}
{1557021600 0 1 +01}
{1560045600 3600 0 +01}
{1587261600 0 1 +01}
{1590285600 3600 0 +01}
{1618106400 0 1 +01}
{1621130400 3600 0 +01}
{1648346400 0 1 +01}
{1651975200 3600 0 +01}
{1679191200 0 1 +01}
{1682215200 3600 0 +01}
{1710036000 0 1 +01}
{1713060000 3600 0 +01}
{1740276000 0 1 +01}
{1743904800 3600 0 +01}
{1771120800 0 1 +01}
{1774144800 3600 0 +01}
{1801965600 0 1 +01}
{1804989600 3600 0 +01}
{1832205600 0 1 +01}
{1835229600 3600 0 +01}
{1863050400 0 1 +01}
{1866074400 3600 0 +01}
{1893290400 0 1 +01}
{1896919200 3600 0 +01}
{1924135200 0 1 +01}
{1927159200 3600 0 +01}
{1954980000 0 1 +01}
{1958004000 3600 0 +01}
{1985220000 0 1 +01}
{1988848800 3600 0 +01}
{2016064800 0 1 +01}
{2019088800 3600 0 +01}
{2046304800 0 1 +01}
{2049933600 3600 0 +01}
{2077149600 0 1 +01}
{2080173600 3600 0 +01}
{2107994400 0 1 +01}
{2111018400 3600 0 +01}
{2138234400 0 1 +01}
{2141863200 3600 0 +01}
}
|
Changes to library/tzdata/Africa/Ceuta.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
{-1379293200 3600 1 WEST}
{-1364774400 0 0 WET}
{-1348448400 3600 1 WEST}
{-1333324800 0 0 WET}
{-1316390400 3600 1 WEST}
{-1301270400 0 0 WET}
{-1293840000 0 0 WET}
{-81432000 3600 1 WEST}
{-71110800 0 0 WET}
{141264000 3600 1 WEST}
{147222000 0 0 WET}
{199756800 3600 1 WEST}
{207702000 0 0 WET}
{231292800 3600 1 WEST}
| > | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
{-1379293200 3600 1 WEST}
{-1364774400 0 0 WET}
{-1348448400 3600 1 WEST}
{-1333324800 0 0 WET}
{-1316390400 3600 1 WEST}
{-1301270400 0 0 WET}
{-1293840000 0 0 WET}
{-94694400 0 0 WET}
{-81432000 3600 1 WEST}
{-71110800 0 0 WET}
{141264000 3600 1 WEST}
{147222000 0 0 WET}
{199756800 3600 1 WEST}
{207702000 0 0 WET}
{231292800 3600 1 WEST}
|
| ︙ | ︙ |
Changes to library/tzdata/Africa/El_Aaiun.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Africa/El_Aaiun) {
{-9223372036854775808 -3168 0 LMT}
{-1136070432 -3600 0 -01}
| | | | | | | | | | | | | | | | | | | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | | | | < < | | | < < < < < < | | | < < < < < < | < < < < | < < < < < < | | | < < | < < | | | < < < < | < < < < < < < < | < | < < | | | < < | | | | < < | | | | < < | < < < < | | | < < | | | < | < | | | < < | | < < < < | | < < | | < < < < | | < < < | | < < < | < < < < | < < < < | | < < | | | < < < < < < < < | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Africa/El_Aaiun) {
{-9223372036854775808 -3168 0 LMT}
{-1136070432 -3600 0 -01}
{198291600 0 0 +00}
{199756800 3600 1 +00}
{207702000 0 0 +00}
{231292800 3600 1 +00}
{244249200 0 0 +00}
{265507200 3600 1 +00}
{271033200 0 0 +00}
{1212278400 3600 1 +00}
{1220223600 0 0 +00}
{1243814400 3600 1 +00}
{1250809200 0 0 +00}
{1272758400 3600 1 +00}
{1281222000 0 0 +00}
{1301788800 3600 1 +00}
{1312066800 0 0 +00}
{1335664800 3600 1 +00}
{1342749600 0 0 +00}
{1345428000 3600 1 +00}
{1348970400 0 0 +00}
{1367114400 3600 1 +00}
{1373162400 0 0 +00}
{1376100000 3600 1 +00}
{1382839200 0 0 +00}
{1396144800 3600 1 +00}
{1403920800 0 0 +00}
{1406944800 3600 1 +00}
{1414288800 0 0 +00}
{1427594400 3600 1 +00}
{1434247200 0 0 +00}
{1437271200 3600 1 +00}
{1445738400 0 0 +00}
{1459044000 3600 1 +00}
{1465092000 0 0 +00}
{1468116000 3600 1 +00}
{1477792800 0 0 +00}
{1490493600 3600 1 +00}
{1495332000 0 0 +00}
{1498960800 3600 1 +00}
{1509242400 0 0 +00}
{1521943200 3600 1 +00}
{1526176800 0 0 +00}
{1529200800 3600 1 +00}
{1540695600 3600 0 +01}
{1557021600 0 1 +01}
{1560045600 3600 0 +01}
{1587261600 0 1 +01}
{1590285600 3600 0 +01}
{1618106400 0 1 +01}
{1621130400 3600 0 +01}
{1648346400 0 1 +01}
{1651975200 3600 0 +01}
{1679191200 0 1 +01}
{1682215200 3600 0 +01}
{1710036000 0 1 +01}
{1713060000 3600 0 +01}
{1740276000 0 1 +01}
{1743904800 3600 0 +01}
{1771120800 0 1 +01}
{1774144800 3600 0 +01}
{1801965600 0 1 +01}
{1804989600 3600 0 +01}
{1832205600 0 1 +01}
{1835229600 3600 0 +01}
{1863050400 0 1 +01}
{1866074400 3600 0 +01}
{1893290400 0 1 +01}
{1896919200 3600 0 +01}
{1924135200 0 1 +01}
{1927159200 3600 0 +01}
{1954980000 0 1 +01}
{1958004000 3600 0 +01}
{1985220000 0 1 +01}
{1988848800 3600 0 +01}
{2016064800 0 1 +01}
{2019088800 3600 0 +01}
{2046304800 0 1 +01}
{2049933600 3600 0 +01}
{2077149600 0 1 +01}
{2080173600 3600 0 +01}
{2107994400 0 1 +01}
{2111018400 3600 0 +01}
{2138234400 0 1 +01}
{2141863200 3600 0 +01}
}
|
Changes to library/tzdata/Africa/Sao_Tome.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Africa/Sao_Tome) {
{-9223372036854775808 1616 0 LMT}
{-2713912016 -2205 0 LMT}
| | > | 1 2 3 4 5 6 7 8 9 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Africa/Sao_Tome) {
{-9223372036854775808 1616 0 LMT}
{-2713912016 -2205 0 LMT}
{-1830384000 0 0 GMT}
{1514768400 3600 0 WAT}
{1546304400 0 0 GMT}
}
|
Changes to library/tzdata/Africa/Windhoek.
1 2 3 4 5 6 7 8 9 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Africa/Windhoek) {
{-9223372036854775808 4104 0 LMT}
{-2458170504 5400 0 +0130}
{-2109288600 7200 0 SAST}
{-860976000 10800 1 SAST}
{-845254800 7200 0 SAST}
{637970400 7200 0 CAT}
| | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Africa/Windhoek) {
{-9223372036854775808 4104 0 LMT}
{-2458170504 5400 0 +0130}
{-2109288600 7200 0 SAST}
{-860976000 10800 1 SAST}
{-845254800 7200 0 SAST}
{637970400 7200 0 CAT}
{764200800 3600 1 WAT}
{778640400 7200 0 CAT}
{796780800 3600 1 WAT}
{810090000 7200 0 CAT}
{828835200 3600 1 WAT}
{841539600 7200 0 CAT}
{860284800 3600 1 WAT}
{873594000 7200 0 CAT}
{891734400 3600 1 WAT}
{905043600 7200 0 CAT}
{923184000 3600 1 WAT}
{936493200 7200 0 CAT}
{954633600 3600 1 WAT}
{967942800 7200 0 CAT}
{986083200 3600 1 WAT}
{999392400 7200 0 CAT}
{1018137600 3600 1 WAT}
{1030842000 7200 0 CAT}
{1049587200 3600 1 WAT}
{1062896400 7200 0 CAT}
{1081036800 3600 1 WAT}
{1094346000 7200 0 CAT}
{1112486400 3600 1 WAT}
{1125795600 7200 0 CAT}
{1143936000 3600 1 WAT}
{1157245200 7200 0 CAT}
{1175385600 3600 1 WAT}
{1188694800 7200 0 CAT}
{1207440000 3600 1 WAT}
{1220749200 7200 0 CAT}
{1238889600 3600 1 WAT}
{1252198800 7200 0 CAT}
{1270339200 3600 1 WAT}
{1283648400 7200 0 CAT}
{1301788800 3600 1 WAT}
{1315098000 7200 0 CAT}
{1333238400 3600 1 WAT}
{1346547600 7200 0 CAT}
{1365292800 3600 1 WAT}
{1377997200 7200 0 CAT}
{1396742400 3600 1 WAT}
{1410051600 7200 0 CAT}
{1428192000 3600 1 WAT}
{1441501200 7200 0 CAT}
{1459641600 3600 1 WAT}
{1472950800 7200 0 CAT}
{1491091200 3600 1 WAT}
{1504400400 7200 0 CAT}
}
|
Changes to library/tzdata/America/Araguaina.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Araguaina) {
{-9223372036854775808 -11568 0 LMT}
{-1767214032 -10800 0 -03}
| | | | | | | | | | | | | | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Araguaina) {
{-9223372036854775808 -11568 0 LMT}
{-1767214032 -10800 0 -03}
{-1206957600 -7200 1 -03}
{-1191362400 -10800 0 -03}
{-1175374800 -7200 1 -03}
{-1159826400 -10800 0 -03}
{-633819600 -7200 1 -03}
{-622069200 -10800 0 -03}
{-602283600 -7200 1 -03}
{-591832800 -10800 0 -03}
{-570747600 -7200 1 -03}
{-560210400 -10800 0 -03}
{-539125200 -7200 1 -03}
{-531352800 -10800 0 -03}
{-191365200 -7200 1 -03}
{-184197600 -10800 0 -03}
{-155163600 -7200 1 -03}
{-150069600 -10800 0 -03}
{-128898000 -7200 1 -03}
{-121125600 -10800 0 -03}
{-99954000 -7200 1 -03}
{-89589600 -10800 0 -03}
{-68418000 -7200 1 -03}
{-57967200 -10800 0 -03}
{499748400 -7200 1 -03}
{511236000 -10800 0 -03}
{530593200 -7200 1 -03}
{540266400 -10800 0 -03}
{562129200 -7200 1 -03}
{571197600 -10800 0 -03}
{592974000 -7200 1 -03}
{602042400 -10800 0 -03}
{624423600 -7200 1 -03}
{634701600 -10800 0 -03}
{653536800 -10800 0 -03}
{811047600 -10800 0 -03}
{813726000 -7200 1 -03}
{824004000 -10800 0 -03}
{844570800 -7200 1 -03}
{856058400 -10800 0 -03}
{876106800 -7200 1 -03}
{888717600 -10800 0 -03}
{908074800 -7200 1 -03}
{919562400 -10800 0 -03}
{938919600 -7200 1 -03}
{951616800 -10800 0 -03}
{970974000 -7200 1 -03}
{982461600 -10800 0 -03}
{1003028400 -7200 1 -03}
{1013911200 -10800 0 -03}
{1036292400 -7200 1 -03}
{1045360800 -10800 0 -03}
{1064368800 -10800 0 -03}
{1350788400 -7200 0 -03}
{1361066400 -10800 0 -03}
{1378000800 -10800 0 -03}
}
|
Changes to library/tzdata/America/Argentina/Buenos_Aires.
1 2 3 4 5 6 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Argentina/Buenos_Aires) {
{-9223372036854775808 -14028 0 LMT}
{-2372097972 -15408 0 CMT}
{-1567453392 -14400 0 -04}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Argentina/Buenos_Aires) {
{-9223372036854775808 -14028 0 LMT}
{-2372097972 -15408 0 CMT}
{-1567453392 -14400 0 -04}
{-1233432000 -10800 0 -04}
{-1222981200 -14400 0 -04}
{-1205956800 -10800 1 -04}
{-1194037200 -14400 0 -04}
{-1172865600 -10800 1 -04}
{-1162501200 -14400 0 -04}
{-1141329600 -10800 1 -04}
{-1130965200 -14400 0 -04}
{-1109793600 -10800 1 -04}
{-1099429200 -14400 0 -04}
{-1078257600 -10800 1 -04}
{-1067806800 -14400 0 -04}
{-1046635200 -10800 1 -04}
{-1036270800 -14400 0 -04}
{-1015099200 -10800 1 -04}
{-1004734800 -14400 0 -04}
{-983563200 -10800 1 -04}
{-973198800 -14400 0 -04}
{-952027200 -10800 1 -04}
{-941576400 -14400 0 -04}
{-931032000 -10800 1 -04}
{-900882000 -14400 0 -04}
{-890337600 -10800 1 -04}
{-833749200 -14400 0 -04}
{-827265600 -10800 1 -04}
{-752274000 -14400 0 -04}
{-733780800 -10800 1 -04}
{-197326800 -14400 0 -04}
{-190843200 -10800 1 -04}
{-184194000 -14400 0 -04}
{-164491200 -10800 1 -04}
{-152658000 -14400 0 -04}
{-132955200 -10800 1 -04}
{-121122000 -14400 0 -04}
{-101419200 -10800 1 -04}
{-86821200 -14400 0 -04}
{-71092800 -10800 1 -04}
{-54766800 -14400 0 -04}
{-39038400 -10800 1 -04}
{-23317200 -14400 0 -04}
{-7588800 -10800 0 -03}
{128142000 -7200 1 -03}
{136605600 -10800 0 -03}
{596948400 -7200 1 -03}
{605066400 -10800 0 -03}
{624423600 -7200 1 -03}
{636516000 -10800 0 -03}
{656478000 -7200 1 -03}
{667965600 -10800 0 -03}
{687927600 -7200 1 -03}
{699415200 -10800 0 -03}
{719377200 -7200 1 -03}
{731469600 -10800 0 -03}
{938916000 -10800 0 -04}
{938919600 -10800 1 -04}
{952056000 -10800 0 -03}
{1198983600 -7200 1 -03}
{1205632800 -10800 0 -03}
{1224385200 -7200 1 -03}
{1237082400 -10800 0 -03}
}
|
Changes to library/tzdata/America/Argentina/Catamarca.
1 2 3 4 5 6 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Argentina/Catamarca) {
{-9223372036854775808 -15788 0 LMT}
{-2372096212 -15408 0 CMT}
{-1567453392 -14400 0 -04}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Argentina/Catamarca) {
{-9223372036854775808 -15788 0 LMT}
{-2372096212 -15408 0 CMT}
{-1567453392 -14400 0 -04}
{-1233432000 -10800 0 -04}
{-1222981200 -14400 0 -04}
{-1205956800 -10800 1 -04}
{-1194037200 -14400 0 -04}
{-1172865600 -10800 1 -04}
{-1162501200 -14400 0 -04}
{-1141329600 -10800 1 -04}
{-1130965200 -14400 0 -04}
{-1109793600 -10800 1 -04}
{-1099429200 -14400 0 -04}
{-1078257600 -10800 1 -04}
{-1067806800 -14400 0 -04}
{-1046635200 -10800 1 -04}
{-1036270800 -14400 0 -04}
{-1015099200 -10800 1 -04}
{-1004734800 -14400 0 -04}
{-983563200 -10800 1 -04}
{-973198800 -14400 0 -04}
{-952027200 -10800 1 -04}
{-941576400 -14400 0 -04}
{-931032000 -10800 1 -04}
{-900882000 -14400 0 -04}
{-890337600 -10800 1 -04}
{-833749200 -14400 0 -04}
{-827265600 -10800 1 -04}
{-752274000 -14400 0 -04}
{-733780800 -10800 1 -04}
{-197326800 -14400 0 -04}
{-190843200 -10800 1 -04}
{-184194000 -14400 0 -04}
{-164491200 -10800 1 -04}
{-152658000 -14400 0 -04}
{-132955200 -10800 1 -04}
{-121122000 -14400 0 -04}
{-101419200 -10800 1 -04}
{-86821200 -14400 0 -04}
{-71092800 -10800 1 -04}
{-54766800 -14400 0 -04}
{-39038400 -10800 1 -04}
{-23317200 -14400 0 -04}
{-7588800 -10800 0 -03}
{128142000 -7200 1 -03}
{136605600 -10800 0 -03}
{596948400 -7200 1 -03}
{605066400 -10800 0 -03}
{624423600 -7200 1 -03}
{636516000 -10800 0 -03}
{656478000 -7200 1 -03}
{667965600 -14400 0 -04}
{687931200 -7200 0 -03}
{699415200 -10800 0 -03}
{719377200 -7200 1 -03}
{731469600 -10800 0 -03}
{938916000 -10800 0 -04}
{938919600 -10800 1 -04}
{952056000 -10800 0 -03}
{1086058800 -14400 0 -04}
{1087704000 -10800 0 -03}
{1198983600 -7200 1 -03}
{1205632800 -10800 0 -03}
{1224295200 -10800 0 -03}
}
|
Changes to library/tzdata/America/Argentina/Cordoba.
1 2 3 4 5 6 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Argentina/Cordoba) {
{-9223372036854775808 -15408 0 LMT}
{-2372096592 -15408 0 CMT}
{-1567453392 -14400 0 -04}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Argentina/Cordoba) {
{-9223372036854775808 -15408 0 LMT}
{-2372096592 -15408 0 CMT}
{-1567453392 -14400 0 -04}
{-1233432000 -10800 0 -04}
{-1222981200 -14400 0 -04}
{-1205956800 -10800 1 -04}
{-1194037200 -14400 0 -04}
{-1172865600 -10800 1 -04}
{-1162501200 -14400 0 -04}
{-1141329600 -10800 1 -04}
{-1130965200 -14400 0 -04}
{-1109793600 -10800 1 -04}
{-1099429200 -14400 0 -04}
{-1078257600 -10800 1 -04}
{-1067806800 -14400 0 -04}
{-1046635200 -10800 1 -04}
{-1036270800 -14400 0 -04}
{-1015099200 -10800 1 -04}
{-1004734800 -14400 0 -04}
{-983563200 -10800 1 -04}
{-973198800 -14400 0 -04}
{-952027200 -10800 1 -04}
{-941576400 -14400 0 -04}
{-931032000 -10800 1 -04}
{-900882000 -14400 0 -04}
{-890337600 -10800 1 -04}
{-833749200 -14400 0 -04}
{-827265600 -10800 1 -04}
{-752274000 -14400 0 -04}
{-733780800 -10800 1 -04}
{-197326800 -14400 0 -04}
{-190843200 -10800 1 -04}
{-184194000 -14400 0 -04}
{-164491200 -10800 1 -04}
{-152658000 -14400 0 -04}
{-132955200 -10800 1 -04}
{-121122000 -14400 0 -04}
{-101419200 -10800 1 -04}
{-86821200 -14400 0 -04}
{-71092800 -10800 1 -04}
{-54766800 -14400 0 -04}
{-39038400 -10800 1 -04}
{-23317200 -14400 0 -04}
{-7588800 -10800 0 -03}
{128142000 -7200 1 -03}
{136605600 -10800 0 -03}
{596948400 -7200 1 -03}
{605066400 -10800 0 -03}
{624423600 -7200 1 -03}
{636516000 -10800 0 -03}
{656478000 -7200 1 -03}
{667965600 -14400 0 -04}
{687931200 -7200 0 -03}
{699415200 -10800 0 -03}
{719377200 -7200 1 -03}
{731469600 -10800 0 -03}
{938916000 -10800 0 -04}
{938919600 -10800 1 -04}
{952056000 -10800 0 -03}
{1198983600 -7200 1 -03}
{1205632800 -10800 0 -03}
{1224385200 -7200 1 -03}
{1237082400 -10800 0 -03}
}
|
Changes to library/tzdata/America/Argentina/Jujuy.
1 2 3 4 5 6 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Argentina/Jujuy) {
{-9223372036854775808 -15672 0 LMT}
{-2372096328 -15408 0 CMT}
{-1567453392 -14400 0 -04}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Argentina/Jujuy) {
{-9223372036854775808 -15672 0 LMT}
{-2372096328 -15408 0 CMT}
{-1567453392 -14400 0 -04}
{-1233432000 -10800 0 -04}
{-1222981200 -14400 0 -04}
{-1205956800 -10800 1 -04}
{-1194037200 -14400 0 -04}
{-1172865600 -10800 1 -04}
{-1162501200 -14400 0 -04}
{-1141329600 -10800 1 -04}
{-1130965200 -14400 0 -04}
{-1109793600 -10800 1 -04}
{-1099429200 -14400 0 -04}
{-1078257600 -10800 1 -04}
{-1067806800 -14400 0 -04}
{-1046635200 -10800 1 -04}
{-1036270800 -14400 0 -04}
{-1015099200 -10800 1 -04}
{-1004734800 -14400 0 -04}
{-983563200 -10800 1 -04}
{-973198800 -14400 0 -04}
{-952027200 -10800 1 -04}
{-941576400 -14400 0 -04}
{-931032000 -10800 1 -04}
{-900882000 -14400 0 -04}
{-890337600 -10800 1 -04}
{-833749200 -14400 0 -04}
{-827265600 -10800 1 -04}
{-752274000 -14400 0 -04}
{-733780800 -10800 1 -04}
{-197326800 -14400 0 -04}
{-190843200 -10800 1 -04}
{-184194000 -14400 0 -04}
{-164491200 -10800 1 -04}
{-152658000 -14400 0 -04}
{-132955200 -10800 1 -04}
{-121122000 -14400 0 -04}
{-101419200 -10800 1 -04}
{-86821200 -14400 0 -04}
{-71092800 -10800 1 -04}
{-54766800 -14400 0 -04}
{-39038400 -10800 1 -04}
{-23317200 -14400 0 -04}
{-7588800 -10800 0 -03}
{128142000 -7200 1 -03}
{136605600 -10800 0 -03}
{596948400 -7200 1 -03}
{605066400 -10800 0 -03}
{624423600 -7200 1 -03}
{636516000 -14400 0 -04}
{657086400 -10800 1 -03}
{669178800 -14400 0 -04}
{686721600 -7200 1 -02}
{694231200 -7200 0 -03}
{699415200 -10800 0 -03}
{719377200 -7200 1 -03}
{731469600 -10800 0 -03}
{938916000 -10800 0 -04}
{938919600 -10800 1 -04}
{952056000 -10800 0 -03}
{1198983600 -7200 1 -03}
{1205632800 -10800 0 -03}
{1224295200 -10800 0 -03}
}
|
Changes to library/tzdata/America/Argentina/La_Rioja.
1 2 3 4 5 6 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Argentina/La_Rioja) {
{-9223372036854775808 -16044 0 LMT}
{-2372095956 -15408 0 CMT}
{-1567453392 -14400 0 -04}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Argentina/La_Rioja) {
{-9223372036854775808 -16044 0 LMT}
{-2372095956 -15408 0 CMT}
{-1567453392 -14400 0 -04}
{-1233432000 -10800 0 -04}
{-1222981200 -14400 0 -04}
{-1205956800 -10800 1 -04}
{-1194037200 -14400 0 -04}
{-1172865600 -10800 1 -04}
{-1162501200 -14400 0 -04}
{-1141329600 -10800 1 -04}
{-1130965200 -14400 0 -04}
{-1109793600 -10800 1 -04}
{-1099429200 -14400 0 -04}
{-1078257600 -10800 1 -04}
{-1067806800 -14400 0 -04}
{-1046635200 -10800 1 -04}
{-1036270800 -14400 0 -04}
{-1015099200 -10800 1 -04}
{-1004734800 -14400 0 -04}
{-983563200 -10800 1 -04}
{-973198800 -14400 0 -04}
{-952027200 -10800 1 -04}
{-941576400 -14400 0 -04}
{-931032000 -10800 1 -04}
{-900882000 -14400 0 -04}
{-890337600 -10800 1 -04}
{-833749200 -14400 0 -04}
{-827265600 -10800 1 -04}
{-752274000 -14400 0 -04}
{-733780800 -10800 1 -04}
{-197326800 -14400 0 -04}
{-190843200 -10800 1 -04}
{-184194000 -14400 0 -04}
{-164491200 -10800 1 -04}
{-152658000 -14400 0 -04}
{-132955200 -10800 1 -04}
{-121122000 -14400 0 -04}
{-101419200 -10800 1 -04}
{-86821200 -14400 0 -04}
{-71092800 -10800 1 -04}
{-54766800 -14400 0 -04}
{-39038400 -10800 1 -04}
{-23317200 -14400 0 -04}
{-7588800 -10800 0 -03}
{128142000 -7200 1 -03}
{136605600 -10800 0 -03}
{596948400 -7200 1 -03}
{605066400 -10800 0 -03}
{624423600 -7200 1 -03}
{636516000 -10800 0 -03}
{656478000 -7200 1 -03}
{667792800 -14400 0 -04}
{673588800 -10800 0 -03}
{687927600 -7200 1 -03}
{699415200 -10800 0 -03}
{719377200 -7200 1 -03}
{731469600 -10800 0 -03}
{938916000 -10800 0 -04}
{938919600 -10800 1 -04}
{952056000 -10800 0 -03}
{1086058800 -14400 0 -04}
{1087704000 -10800 0 -03}
{1198983600 -7200 1 -03}
{1205632800 -10800 0 -03}
{1224295200 -10800 0 -03}
}
|
Changes to library/tzdata/America/Argentina/Mendoza.
1 2 3 4 5 6 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Argentina/Mendoza) {
{-9223372036854775808 -16516 0 LMT}
{-2372095484 -15408 0 CMT}
{-1567453392 -14400 0 -04}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Argentina/Mendoza) {
{-9223372036854775808 -16516 0 LMT}
{-2372095484 -15408 0 CMT}
{-1567453392 -14400 0 -04}
{-1233432000 -10800 0 -04}
{-1222981200 -14400 0 -04}
{-1205956800 -10800 1 -04}
{-1194037200 -14400 0 -04}
{-1172865600 -10800 1 -04}
{-1162501200 -14400 0 -04}
{-1141329600 -10800 1 -04}
{-1130965200 -14400 0 -04}
{-1109793600 -10800 1 -04}
{-1099429200 -14400 0 -04}
{-1078257600 -10800 1 -04}
{-1067806800 -14400 0 -04}
{-1046635200 -10800 1 -04}
{-1036270800 -14400 0 -04}
{-1015099200 -10800 1 -04}
{-1004734800 -14400 0 -04}
{-983563200 -10800 1 -04}
{-973198800 -14400 0 -04}
{-952027200 -10800 1 -04}
{-941576400 -14400 0 -04}
{-931032000 -10800 1 -04}
{-900882000 -14400 0 -04}
{-890337600 -10800 1 -04}
{-833749200 -14400 0 -04}
{-827265600 -10800 1 -04}
{-752274000 -14400 0 -04}
{-733780800 -10800 1 -04}
{-197326800 -14400 0 -04}
{-190843200 -10800 1 -04}
{-184194000 -14400 0 -04}
{-164491200 -10800 1 -04}
{-152658000 -14400 0 -04}
{-132955200 -10800 1 -04}
{-121122000 -14400 0 -04}
{-101419200 -10800 1 -04}
{-86821200 -14400 0 -04}
{-71092800 -10800 1 -04}
{-54766800 -14400 0 -04}
{-39038400 -10800 1 -04}
{-23317200 -14400 0 -04}
{-7588800 -10800 0 -03}
{128142000 -7200 1 -03}
{136605600 -10800 0 -03}
{596948400 -7200 1 -03}
{605066400 -10800 0 -03}
{624423600 -7200 1 -03}
{636516000 -14400 0 -04}
{655963200 -10800 1 -03}
{667796400 -14400 0 -04}
{687499200 -10800 1 -03}
{699418800 -14400 0 -04}
{719380800 -7200 0 -03}
{731469600 -10800 0 -03}
{938916000 -10800 0 -04}
{938919600 -10800 1 -04}
{952056000 -10800 0 -03}
{1085281200 -14400 0 -04}
{1096171200 -10800 0 -03}
{1198983600 -7200 1 -03}
{1205632800 -10800 0 -03}
{1224295200 -10800 0 -03}
}
|
Changes to library/tzdata/America/Argentina/Rio_Gallegos.
1 2 3 4 5 6 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Argentina/Rio_Gallegos) {
{-9223372036854775808 -16612 0 LMT}
{-2372095388 -15408 0 CMT}
{-1567453392 -14400 0 -04}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Argentina/Rio_Gallegos) {
{-9223372036854775808 -16612 0 LMT}
{-2372095388 -15408 0 CMT}
{-1567453392 -14400 0 -04}
{-1233432000 -10800 0 -04}
{-1222981200 -14400 0 -04}
{-1205956800 -10800 1 -04}
{-1194037200 -14400 0 -04}
{-1172865600 -10800 1 -04}
{-1162501200 -14400 0 -04}
{-1141329600 -10800 1 -04}
{-1130965200 -14400 0 -04}
{-1109793600 -10800 1 -04}
{-1099429200 -14400 0 -04}
{-1078257600 -10800 1 -04}
{-1067806800 -14400 0 -04}
{-1046635200 -10800 1 -04}
{-1036270800 -14400 0 -04}
{-1015099200 -10800 1 -04}
{-1004734800 -14400 0 -04}
{-983563200 -10800 1 -04}
{-973198800 -14400 0 -04}
{-952027200 -10800 1 -04}
{-941576400 -14400 0 -04}
{-931032000 -10800 1 -04}
{-900882000 -14400 0 -04}
{-890337600 -10800 1 -04}
{-833749200 -14400 0 -04}
{-827265600 -10800 1 -04}
{-752274000 -14400 0 -04}
{-733780800 -10800 1 -04}
{-197326800 -14400 0 -04}
{-190843200 -10800 1 -04}
{-184194000 -14400 0 -04}
{-164491200 -10800 1 -04}
{-152658000 -14400 0 -04}
{-132955200 -10800 1 -04}
{-121122000 -14400 0 -04}
{-101419200 -10800 1 -04}
{-86821200 -14400 0 -04}
{-71092800 -10800 1 -04}
{-54766800 -14400 0 -04}
{-39038400 -10800 1 -04}
{-23317200 -14400 0 -04}
{-7588800 -10800 0 -03}
{128142000 -7200 1 -03}
{136605600 -10800 0 -03}
{596948400 -7200 1 -03}
{605066400 -10800 0 -03}
{624423600 -7200 1 -03}
{636516000 -10800 0 -03}
{656478000 -7200 1 -03}
{667965600 -10800 0 -03}
{687927600 -7200 1 -03}
{699415200 -10800 0 -03}
{719377200 -7200 1 -03}
{731469600 -10800 0 -03}
{938916000 -10800 0 -04}
{938919600 -10800 1 -04}
{952056000 -10800 0 -03}
{1086058800 -14400 0 -04}
{1087704000 -10800 0 -03}
{1198983600 -7200 1 -03}
{1205632800 -10800 0 -03}
{1224295200 -10800 0 -03}
}
|
Changes to library/tzdata/America/Argentina/Salta.
1 2 3 4 5 6 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Argentina/Salta) {
{-9223372036854775808 -15700 0 LMT}
{-2372096300 -15408 0 CMT}
{-1567453392 -14400 0 -04}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Argentina/Salta) {
{-9223372036854775808 -15700 0 LMT}
{-2372096300 -15408 0 CMT}
{-1567453392 -14400 0 -04}
{-1233432000 -10800 0 -04}
{-1222981200 -14400 0 -04}
{-1205956800 -10800 1 -04}
{-1194037200 -14400 0 -04}
{-1172865600 -10800 1 -04}
{-1162501200 -14400 0 -04}
{-1141329600 -10800 1 -04}
{-1130965200 -14400 0 -04}
{-1109793600 -10800 1 -04}
{-1099429200 -14400 0 -04}
{-1078257600 -10800 1 -04}
{-1067806800 -14400 0 -04}
{-1046635200 -10800 1 -04}
{-1036270800 -14400 0 -04}
{-1015099200 -10800 1 -04}
{-1004734800 -14400 0 -04}
{-983563200 -10800 1 -04}
{-973198800 -14400 0 -04}
{-952027200 -10800 1 -04}
{-941576400 -14400 0 -04}
{-931032000 -10800 1 -04}
{-900882000 -14400 0 -04}
{-890337600 -10800 1 -04}
{-833749200 -14400 0 -04}
{-827265600 -10800 1 -04}
{-752274000 -14400 0 -04}
{-733780800 -10800 1 -04}
{-197326800 -14400 0 -04}
{-190843200 -10800 1 -04}
{-184194000 -14400 0 -04}
{-164491200 -10800 1 -04}
{-152658000 -14400 0 -04}
{-132955200 -10800 1 -04}
{-121122000 -14400 0 -04}
{-101419200 -10800 1 -04}
{-86821200 -14400 0 -04}
{-71092800 -10800 1 -04}
{-54766800 -14400 0 -04}
{-39038400 -10800 1 -04}
{-23317200 -14400 0 -04}
{-7588800 -10800 0 -03}
{128142000 -7200 1 -03}
{136605600 -10800 0 -03}
{596948400 -7200 1 -03}
{605066400 -10800 0 -03}
{624423600 -7200 1 -03}
{636516000 -10800 0 -03}
{656478000 -7200 1 -03}
{667965600 -14400 0 -04}
{687931200 -7200 0 -03}
{699415200 -10800 0 -03}
{719377200 -7200 1 -03}
{731469600 -10800 0 -03}
{938916000 -10800 0 -04}
{938919600 -10800 1 -04}
{952056000 -10800 0 -03}
{1198983600 -7200 1 -03}
{1205632800 -10800 0 -03}
{1224295200 -10800 0 -03}
}
|
Changes to library/tzdata/America/Argentina/San_Juan.
1 2 3 4 5 6 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Argentina/San_Juan) {
{-9223372036854775808 -16444 0 LMT}
{-2372095556 -15408 0 CMT}
{-1567453392 -14400 0 -04}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Argentina/San_Juan) {
{-9223372036854775808 -16444 0 LMT}
{-2372095556 -15408 0 CMT}
{-1567453392 -14400 0 -04}
{-1233432000 -10800 0 -04}
{-1222981200 -14400 0 -04}
{-1205956800 -10800 1 -04}
{-1194037200 -14400 0 -04}
{-1172865600 -10800 1 -04}
{-1162501200 -14400 0 -04}
{-1141329600 -10800 1 -04}
{-1130965200 -14400 0 -04}
{-1109793600 -10800 1 -04}
{-1099429200 -14400 0 -04}
{-1078257600 -10800 1 -04}
{-1067806800 -14400 0 -04}
{-1046635200 -10800 1 -04}
{-1036270800 -14400 0 -04}
{-1015099200 -10800 1 -04}
{-1004734800 -14400 0 -04}
{-983563200 -10800 1 -04}
{-973198800 -14400 0 -04}
{-952027200 -10800 1 -04}
{-941576400 -14400 0 -04}
{-931032000 -10800 1 -04}
{-900882000 -14400 0 -04}
{-890337600 -10800 1 -04}
{-833749200 -14400 0 -04}
{-827265600 -10800 1 -04}
{-752274000 -14400 0 -04}
{-733780800 -10800 1 -04}
{-197326800 -14400 0 -04}
{-190843200 -10800 1 -04}
{-184194000 -14400 0 -04}
{-164491200 -10800 1 -04}
{-152658000 -14400 0 -04}
{-132955200 -10800 1 -04}
{-121122000 -14400 0 -04}
{-101419200 -10800 1 -04}
{-86821200 -14400 0 -04}
{-71092800 -10800 1 -04}
{-54766800 -14400 0 -04}
{-39038400 -10800 1 -04}
{-23317200 -14400 0 -04}
{-7588800 -10800 0 -03}
{128142000 -7200 1 -03}
{136605600 -10800 0 -03}
{596948400 -7200 1 -03}
{605066400 -10800 0 -03}
{624423600 -7200 1 -03}
{636516000 -10800 0 -03}
{656478000 -7200 1 -03}
{667792800 -14400 0 -04}
{673588800 -10800 0 -03}
{687927600 -7200 1 -03}
{699415200 -10800 0 -03}
{719377200 -7200 1 -03}
{731469600 -10800 0 -03}
{938916000 -10800 0 -04}
{938919600 -10800 1 -04}
{952056000 -10800 0 -03}
{1085972400 -14400 0 -04}
{1090728000 -10800 0 -03}
{1198983600 -7200 1 -03}
{1205632800 -10800 0 -03}
{1224295200 -10800 0 -03}
}
|
Changes to library/tzdata/America/Argentina/San_Luis.
1 2 3 4 5 6 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Argentina/San_Luis) {
{-9223372036854775808 -15924 0 LMT}
{-2372096076 -15408 0 CMT}
{-1567453392 -14400 0 -04}
| | | | | | | | | | | | | | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Argentina/San_Luis) {
{-9223372036854775808 -15924 0 LMT}
{-2372096076 -15408 0 CMT}
{-1567453392 -14400 0 -04}
{-1233432000 -10800 0 -04}
{-1222981200 -14400 0 -04}
{-1205956800 -10800 1 -04}
{-1194037200 -14400 0 -04}
{-1172865600 -10800 1 -04}
{-1162501200 -14400 0 -04}
{-1141329600 -10800 1 -04}
{-1130965200 -14400 0 -04}
{-1109793600 -10800 1 -04}
{-1099429200 -14400 0 -04}
{-1078257600 -10800 1 -04}
{-1067806800 -14400 0 -04}
{-1046635200 -10800 1 -04}
{-1036270800 -14400 0 -04}
{-1015099200 -10800 1 -04}
{-1004734800 -14400 0 -04}
{-983563200 -10800 1 -04}
{-973198800 -14400 0 -04}
{-952027200 -10800 1 -04}
{-941576400 -14400 0 -04}
{-931032000 -10800 1 -04}
{-900882000 -14400 0 -04}
{-890337600 -10800 1 -04}
{-833749200 -14400 0 -04}
{-827265600 -10800 1 -04}
{-752274000 -14400 0 -04}
{-733780800 -10800 1 -04}
{-197326800 -14400 0 -04}
{-190843200 -10800 1 -04}
{-184194000 -14400 0 -04}
{-164491200 -10800 1 -04}
{-152658000 -14400 0 -04}
{-132955200 -10800 1 -04}
{-121122000 -14400 0 -04}
{-101419200 -10800 1 -04}
{-86821200 -14400 0 -04}
{-71092800 -10800 1 -04}
{-54766800 -14400 0 -04}
{-39038400 -10800 1 -04}
{-23317200 -14400 0 -04}
{-7588800 -10800 0 -03}
{128142000 -7200 1 -03}
{136605600 -10800 0 -03}
{596948400 -7200 1 -03}
{605066400 -10800 0 -03}
{624423600 -7200 1 -03}
{631159200 -7200 1 -02}
{637380000 -14400 0 -04}
{655963200 -10800 1 -03}
{667796400 -14400 0 -04}
{675748800 -10800 0 -03}
{938919600 -10800 1 -03}
{952052400 -10800 0 -03}
{1085972400 -14400 0 -04}
{1090728000 -10800 0 -03}
{1198983600 -7200 1 -03}
{1200880800 -10800 0 -04}
{1205031600 -14400 0 -04}
{1223784000 -10800 1 -04}
{1236481200 -14400 0 -04}
{1255233600 -10800 0 -03}
}
|
Changes to library/tzdata/America/Argentina/Tucuman.
1 2 3 4 5 6 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Argentina/Tucuman) {
{-9223372036854775808 -15652 0 LMT}
{-2372096348 -15408 0 CMT}
{-1567453392 -14400 0 -04}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Argentina/Tucuman) {
{-9223372036854775808 -15652 0 LMT}
{-2372096348 -15408 0 CMT}
{-1567453392 -14400 0 -04}
{-1233432000 -10800 0 -04}
{-1222981200 -14400 0 -04}
{-1205956800 -10800 1 -04}
{-1194037200 -14400 0 -04}
{-1172865600 -10800 1 -04}
{-1162501200 -14400 0 -04}
{-1141329600 -10800 1 -04}
{-1130965200 -14400 0 -04}
{-1109793600 -10800 1 -04}
{-1099429200 -14400 0 -04}
{-1078257600 -10800 1 -04}
{-1067806800 -14400 0 -04}
{-1046635200 -10800 1 -04}
{-1036270800 -14400 0 -04}
{-1015099200 -10800 1 -04}
{-1004734800 -14400 0 -04}
{-983563200 -10800 1 -04}
{-973198800 -14400 0 -04}
{-952027200 -10800 1 -04}
{-941576400 -14400 0 -04}
{-931032000 -10800 1 -04}
{-900882000 -14400 0 -04}
{-890337600 -10800 1 -04}
{-833749200 -14400 0 -04}
{-827265600 -10800 1 -04}
{-752274000 -14400 0 -04}
{-733780800 -10800 1 -04}
{-197326800 -14400 0 -04}
{-190843200 -10800 1 -04}
{-184194000 -14400 0 -04}
{-164491200 -10800 1 -04}
{-152658000 -14400 0 -04}
{-132955200 -10800 1 -04}
{-121122000 -14400 0 -04}
{-101419200 -10800 1 -04}
{-86821200 -14400 0 -04}
{-71092800 -10800 1 -04}
{-54766800 -14400 0 -04}
{-39038400 -10800 1 -04}
{-23317200 -14400 0 -04}
{-7588800 -10800 0 -03}
{128142000 -7200 1 -03}
{136605600 -10800 0 -03}
{596948400 -7200 1 -03}
{605066400 -10800 0 -03}
{624423600 -7200 1 -03}
{636516000 -10800 0 -03}
{656478000 -7200 1 -03}
{667965600 -14400 0 -04}
{687931200 -7200 0 -03}
{699415200 -10800 0 -03}
{719377200 -7200 1 -03}
{731469600 -10800 0 -03}
{938916000 -10800 0 -04}
{938919600 -10800 1 -04}
{952056000 -10800 0 -03}
{1086058800 -14400 0 -04}
{1087099200 -10800 0 -03}
{1198983600 -7200 1 -03}
{1205632800 -10800 0 -03}
{1224385200 -7200 1 -03}
{1237082400 -10800 0 -03}
}
|
Changes to library/tzdata/America/Argentina/Ushuaia.
1 2 3 4 5 6 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Argentina/Ushuaia) {
{-9223372036854775808 -16392 0 LMT}
{-2372095608 -15408 0 CMT}
{-1567453392 -14400 0 -04}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Argentina/Ushuaia) {
{-9223372036854775808 -16392 0 LMT}
{-2372095608 -15408 0 CMT}
{-1567453392 -14400 0 -04}
{-1233432000 -10800 0 -04}
{-1222981200 -14400 0 -04}
{-1205956800 -10800 1 -04}
{-1194037200 -14400 0 -04}
{-1172865600 -10800 1 -04}
{-1162501200 -14400 0 -04}
{-1141329600 -10800 1 -04}
{-1130965200 -14400 0 -04}
{-1109793600 -10800 1 -04}
{-1099429200 -14400 0 -04}
{-1078257600 -10800 1 -04}
{-1067806800 -14400 0 -04}
{-1046635200 -10800 1 -04}
{-1036270800 -14400 0 -04}
{-1015099200 -10800 1 -04}
{-1004734800 -14400 0 -04}
{-983563200 -10800 1 -04}
{-973198800 -14400 0 -04}
{-952027200 -10800 1 -04}
{-941576400 -14400 0 -04}
{-931032000 -10800 1 -04}
{-900882000 -14400 0 -04}
{-890337600 -10800 1 -04}
{-833749200 -14400 0 -04}
{-827265600 -10800 1 -04}
{-752274000 -14400 0 -04}
{-733780800 -10800 1 -04}
{-197326800 -14400 0 -04}
{-190843200 -10800 1 -04}
{-184194000 -14400 0 -04}
{-164491200 -10800 1 -04}
{-152658000 -14400 0 -04}
{-132955200 -10800 1 -04}
{-121122000 -14400 0 -04}
{-101419200 -10800 1 -04}
{-86821200 -14400 0 -04}
{-71092800 -10800 1 -04}
{-54766800 -14400 0 -04}
{-39038400 -10800 1 -04}
{-23317200 -14400 0 -04}
{-7588800 -10800 0 -03}
{128142000 -7200 1 -03}
{136605600 -10800 0 -03}
{596948400 -7200 1 -03}
{605066400 -10800 0 -03}
{624423600 -7200 1 -03}
{636516000 -10800 0 -03}
{656478000 -7200 1 -03}
{667965600 -10800 0 -03}
{687927600 -7200 1 -03}
{699415200 -10800 0 -03}
{719377200 -7200 1 -03}
{731469600 -10800 0 -03}
{938916000 -10800 0 -04}
{938919600 -10800 1 -04}
{952056000 -10800 0 -03}
{1085886000 -14400 0 -04}
{1087704000 -10800 0 -03}
{1198983600 -7200 1 -03}
{1205632800 -10800 0 -03}
{1224295200 -10800 0 -03}
}
|
Changes to library/tzdata/America/Asuncion.
1 2 3 4 5 6 7 8 9 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Asuncion) {
{-9223372036854775808 -13840 0 LMT}
{-2524507760 -13840 0 AMT}
{-1206389360 -14400 0 -04}
{86760000 -10800 0 -03}
{134017200 -14400 0 -04}
{162878400 -14400 0 -04}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Asuncion) {
{-9223372036854775808 -13840 0 LMT}
{-2524507760 -13840 0 AMT}
{-1206389360 -14400 0 -04}
{86760000 -10800 0 -03}
{134017200 -14400 0 -04}
{162878400 -14400 0 -04}
{181368000 -10800 1 -04}
{194497200 -14400 0 -04}
{212990400 -10800 1 -04}
{226033200 -14400 0 -04}
{244526400 -10800 1 -04}
{257569200 -14400 0 -04}
{276062400 -10800 1 -04}
{291783600 -14400 0 -04}
{307598400 -10800 1 -04}
{323406000 -14400 0 -04}
{339220800 -10800 1 -04}
{354942000 -14400 0 -04}
{370756800 -10800 1 -04}
{386478000 -14400 0 -04}
{402292800 -10800 1 -04}
{418014000 -14400 0 -04}
{433828800 -10800 1 -04}
{449636400 -14400 0 -04}
{465451200 -10800 1 -04}
{481172400 -14400 0 -04}
{496987200 -10800 1 -04}
{512708400 -14400 0 -04}
{528523200 -10800 1 -04}
{544244400 -14400 0 -04}
{560059200 -10800 1 -04}
{575866800 -14400 0 -04}
{591681600 -10800 1 -04}
{607402800 -14400 0 -04}
{625032000 -10800 1 -04}
{638938800 -14400 0 -04}
{654753600 -10800 1 -04}
{670474800 -14400 0 -04}
{686721600 -10800 1 -04}
{699418800 -14400 0 -04}
{718257600 -10800 1 -04}
{733546800 -14400 0 -04}
{749448000 -10800 1 -04}
{762318000 -14400 0 -04}
{780984000 -10800 1 -04}
{793767600 -14400 0 -04}
{812520000 -10800 1 -04}
{825649200 -14400 0 -04}
{844574400 -10800 1 -04}
{856666800 -14400 0 -04}
{876024000 -10800 1 -04}
{888721200 -14400 0 -04}
{907473600 -10800 1 -04}
{920775600 -14400 0 -04}
{938923200 -10800 1 -04}
{952225200 -14400 0 -04}
{970372800 -10800 1 -04}
{983674800 -14400 0 -04}
{1002427200 -10800 1 -04}
{1018148400 -14400 0 -04}
{1030852800 -10800 1 -04}
{1049598000 -14400 0 -04}
{1062907200 -10800 1 -04}
{1081047600 -14400 0 -04}
{1097985600 -10800 1 -04}
{1110682800 -14400 0 -04}
{1129435200 -10800 1 -04}
{1142132400 -14400 0 -04}
{1160884800 -10800 1 -04}
{1173582000 -14400 0 -04}
{1192939200 -10800 1 -04}
{1205031600 -14400 0 -04}
{1224388800 -10800 1 -04}
{1236481200 -14400 0 -04}
{1255838400 -10800 1 -04}
{1270954800 -14400 0 -04}
{1286078400 -10800 1 -04}
{1302404400 -14400 0 -04}
{1317528000 -10800 1 -04}
{1333854000 -14400 0 -04}
{1349582400 -10800 1 -04}
{1364094000 -14400 0 -04}
{1381032000 -10800 1 -04}
{1395543600 -14400 0 -04}
{1412481600 -10800 1 -04}
{1426993200 -14400 0 -04}
{1443931200 -10800 1 -04}
{1459047600 -14400 0 -04}
{1475380800 -10800 1 -04}
{1490497200 -14400 0 -04}
{1506830400 -10800 1 -04}
{1521946800 -14400 0 -04}
{1538884800 -10800 1 -04}
{1553396400 -14400 0 -04}
{1570334400 -10800 1 -04}
{1584846000 -14400 0 -04}
{1601784000 -10800 1 -04}
{1616900400 -14400 0 -04}
{1633233600 -10800 1 -04}
{1648350000 -14400 0 -04}
{1664683200 -10800 1 -04}
{1679799600 -14400 0 -04}
{1696132800 -10800 1 -04}
{1711249200 -14400 0 -04}
{1728187200 -10800 1 -04}
{1742698800 -14400 0 -04}
{1759636800 -10800 1 -04}
{1774148400 -14400 0 -04}
{1791086400 -10800 1 -04}
{1806202800 -14400 0 -04}
{1822536000 -10800 1 -04}
{1837652400 -14400 0 -04}
{1853985600 -10800 1 -04}
{1869102000 -14400 0 -04}
{1886040000 -10800 1 -04}
{1900551600 -14400 0 -04}
{1917489600 -10800 1 -04}
{1932001200 -14400 0 -04}
{1948939200 -10800 1 -04}
{1964055600 -14400 0 -04}
{1980388800 -10800 1 -04}
{1995505200 -14400 0 -04}
{2011838400 -10800 1 -04}
{2026954800 -14400 0 -04}
{2043288000 -10800 1 -04}
{2058404400 -14400 0 -04}
{2075342400 -10800 1 -04}
{2089854000 -14400 0 -04}
{2106792000 -10800 1 -04}
{2121303600 -14400 0 -04}
{2138241600 -10800 1 -04}
{2153358000 -14400 0 -04}
{2169691200 -10800 1 -04}
{2184807600 -14400 0 -04}
{2201140800 -10800 1 -04}
{2216257200 -14400 0 -04}
{2233195200 -10800 1 -04}
{2247706800 -14400 0 -04}
{2264644800 -10800 1 -04}
{2279156400 -14400 0 -04}
{2296094400 -10800 1 -04}
{2310606000 -14400 0 -04}
{2327544000 -10800 1 -04}
{2342660400 -14400 0 -04}
{2358993600 -10800 1 -04}
{2374110000 -14400 0 -04}
{2390443200 -10800 1 -04}
{2405559600 -14400 0 -04}
{2422497600 -10800 1 -04}
{2437009200 -14400 0 -04}
{2453947200 -10800 1 -04}
{2468458800 -14400 0 -04}
{2485396800 -10800 1 -04}
{2500513200 -14400 0 -04}
{2516846400 -10800 1 -04}
{2531962800 -14400 0 -04}
{2548296000 -10800 1 -04}
{2563412400 -14400 0 -04}
{2579745600 -10800 1 -04}
{2594862000 -14400 0 -04}
{2611800000 -10800 1 -04}
{2626311600 -14400 0 -04}
{2643249600 -10800 1 -04}
{2657761200 -14400 0 -04}
{2674699200 -10800 1 -04}
{2689815600 -14400 0 -04}
{2706148800 -10800 1 -04}
{2721265200 -14400 0 -04}
{2737598400 -10800 1 -04}
{2752714800 -14400 0 -04}
{2769652800 -10800 1 -04}
{2784164400 -14400 0 -04}
{2801102400 -10800 1 -04}
{2815614000 -14400 0 -04}
{2832552000 -10800 1 -04}
{2847668400 -14400 0 -04}
{2864001600 -10800 1 -04}
{2879118000 -14400 0 -04}
{2895451200 -10800 1 -04}
{2910567600 -14400 0 -04}
{2926900800 -10800 1 -04}
{2942017200 -14400 0 -04}
{2958955200 -10800 1 -04}
{2973466800 -14400 0 -04}
{2990404800 -10800 1 -04}
{3004916400 -14400 0 -04}
{3021854400 -10800 1 -04}
{3036970800 -14400 0 -04}
{3053304000 -10800 1 -04}
{3068420400 -14400 0 -04}
{3084753600 -10800 1 -04}
{3099870000 -14400 0 -04}
{3116808000 -10800 1 -04}
{3131319600 -14400 0 -04}
{3148257600 -10800 1 -04}
{3162769200 -14400 0 -04}
{3179707200 -10800 1 -04}
{3194218800 -14400 0 -04}
{3211156800 -10800 1 -04}
{3226273200 -14400 0 -04}
{3242606400 -10800 1 -04}
{3257722800 -14400 0 -04}
{3274056000 -10800 1 -04}
{3289172400 -14400 0 -04}
{3306110400 -10800 1 -04}
{3320622000 -14400 0 -04}
{3337560000 -10800 1 -04}
{3352071600 -14400 0 -04}
{3369009600 -10800 1 -04}
{3384126000 -14400 0 -04}
{3400459200 -10800 1 -04}
{3415575600 -14400 0 -04}
{3431908800 -10800 1 -04}
{3447025200 -14400 0 -04}
{3463358400 -10800 1 -04}
{3478474800 -14400 0 -04}
{3495412800 -10800 1 -04}
{3509924400 -14400 0 -04}
{3526862400 -10800 1 -04}
{3541374000 -14400 0 -04}
{3558312000 -10800 1 -04}
{3573428400 -14400 0 -04}
{3589761600 -10800 1 -04}
{3604878000 -14400 0 -04}
{3621211200 -10800 1 -04}
{3636327600 -14400 0 -04}
{3653265600 -10800 1 -04}
{3667777200 -14400 0 -04}
{3684715200 -10800 1 -04}
{3699226800 -14400 0 -04}
{3716164800 -10800 1 -04}
{3731281200 -14400 0 -04}
{3747614400 -10800 1 -04}
{3762730800 -14400 0 -04}
{3779064000 -10800 1 -04}
{3794180400 -14400 0 -04}
{3810513600 -10800 1 -04}
{3825630000 -14400 0 -04}
{3842568000 -10800 1 -04}
{3857079600 -14400 0 -04}
{3874017600 -10800 1 -04}
{3888529200 -14400 0 -04}
{3905467200 -10800 1 -04}
{3920583600 -14400 0 -04}
{3936916800 -10800 1 -04}
{3952033200 -14400 0 -04}
{3968366400 -10800 1 -04}
{3983482800 -14400 0 -04}
{4000420800 -10800 1 -04}
{4014932400 -14400 0 -04}
{4031870400 -10800 1 -04}
{4046382000 -14400 0 -04}
{4063320000 -10800 1 -04}
{4077831600 -14400 0 -04}
{4094769600 -10800 1 -04}
}
|
Changes to library/tzdata/America/Bahia.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Bahia) {
{-9223372036854775808 -9244 0 LMT}
{-1767216356 -10800 0 -03}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Bahia) {
{-9223372036854775808 -9244 0 LMT}
{-1767216356 -10800 0 -03}
{-1206957600 -7200 1 -03}
{-1191362400 -10800 0 -03}
{-1175374800 -7200 1 -03}
{-1159826400 -10800 0 -03}
{-633819600 -7200 1 -03}
{-622069200 -10800 0 -03}
{-602283600 -7200 1 -03}
{-591832800 -10800 0 -03}
{-570747600 -7200 1 -03}
{-560210400 -10800 0 -03}
{-539125200 -7200 1 -03}
{-531352800 -10800 0 -03}
{-191365200 -7200 1 -03}
{-184197600 -10800 0 -03}
{-155163600 -7200 1 -03}
{-150069600 -10800 0 -03}
{-128898000 -7200 1 -03}
{-121125600 -10800 0 -03}
{-99954000 -7200 1 -03}
{-89589600 -10800 0 -03}
{-68418000 -7200 1 -03}
{-57967200 -10800 0 -03}
{499748400 -7200 1 -03}
{511236000 -10800 0 -03}
{530593200 -7200 1 -03}
{540266400 -10800 0 -03}
{562129200 -7200 1 -03}
{571197600 -10800 0 -03}
{592974000 -7200 1 -03}
{602042400 -10800 0 -03}
{624423600 -7200 1 -03}
{634701600 -10800 0 -03}
{656478000 -7200 1 -03}
{666756000 -10800 0 -03}
{687927600 -7200 1 -03}
{697600800 -10800 0 -03}
{719982000 -7200 1 -03}
{728445600 -10800 0 -03}
{750826800 -7200 1 -03}
{761709600 -10800 0 -03}
{782276400 -7200 1 -03}
{793159200 -10800 0 -03}
{813726000 -7200 1 -03}
{824004000 -10800 0 -03}
{844570800 -7200 1 -03}
{856058400 -10800 0 -03}
{876106800 -7200 1 -03}
{888717600 -10800 0 -03}
{908074800 -7200 1 -03}
{919562400 -10800 0 -03}
{938919600 -7200 1 -03}
{951616800 -10800 0 -03}
{970974000 -7200 1 -03}
{982461600 -10800 0 -03}
{1003028400 -7200 1 -03}
{1013911200 -10800 0 -03}
{1036292400 -7200 1 -03}
{1045360800 -10800 0 -03}
{1064368800 -10800 0 -03}
{1318734000 -7200 0 -03}
{1330221600 -10800 0 -03}
{1350784800 -10800 0 -03}
}
|
Changes to library/tzdata/America/Belem.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Belem) {
{-9223372036854775808 -11636 0 LMT}
{-1767213964 -10800 0 -03}
| | | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Belem) {
{-9223372036854775808 -11636 0 LMT}
{-1767213964 -10800 0 -03}
{-1206957600 -7200 1 -03}
{-1191362400 -10800 0 -03}
{-1175374800 -7200 1 -03}
{-1159826400 -10800 0 -03}
{-633819600 -7200 1 -03}
{-622069200 -10800 0 -03}
{-602283600 -7200 1 -03}
{-591832800 -10800 0 -03}
{-570747600 -7200 1 -03}
{-560210400 -10800 0 -03}
{-539125200 -7200 1 -03}
{-531352800 -10800 0 -03}
{-191365200 -7200 1 -03}
{-184197600 -10800 0 -03}
{-155163600 -7200 1 -03}
{-150069600 -10800 0 -03}
{-128898000 -7200 1 -03}
{-121125600 -10800 0 -03}
{-99954000 -7200 1 -03}
{-89589600 -10800 0 -03}
{-68418000 -7200 1 -03}
{-57967200 -10800 0 -03}
{499748400 -7200 1 -03}
{511236000 -10800 0 -03}
{530593200 -7200 1 -03}
{540266400 -10800 0 -03}
{562129200 -7200 1 -03}
{571197600 -10800 0 -03}
{590032800 -10800 0 -03}
}
|
Changes to library/tzdata/America/Boa_Vista.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Boa_Vista) {
{-9223372036854775808 -14560 0 LMT}
{-1767211040 -14400 0 -04}
| | | | | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Boa_Vista) {
{-9223372036854775808 -14560 0 LMT}
{-1767211040 -14400 0 -04}
{-1206954000 -10800 1 -04}
{-1191358800 -14400 0 -04}
{-1175371200 -10800 1 -04}
{-1159822800 -14400 0 -04}
{-633816000 -10800 1 -04}
{-622065600 -14400 0 -04}
{-602280000 -10800 1 -04}
{-591829200 -14400 0 -04}
{-570744000 -10800 1 -04}
{-560206800 -14400 0 -04}
{-539121600 -10800 1 -04}
{-531349200 -14400 0 -04}
{-191361600 -10800 1 -04}
{-184194000 -14400 0 -04}
{-155160000 -10800 1 -04}
{-150066000 -14400 0 -04}
{-128894400 -10800 1 -04}
{-121122000 -14400 0 -04}
{-99950400 -10800 1 -04}
{-89586000 -14400 0 -04}
{-68414400 -10800 1 -04}
{-57963600 -14400 0 -04}
{499752000 -10800 1 -04}
{511239600 -14400 0 -04}
{530596800 -10800 1 -04}
{540270000 -14400 0 -04}
{562132800 -10800 1 -04}
{571201200 -14400 0 -04}
{590036400 -14400 0 -04}
{938664000 -14400 0 -04}
{938923200 -10800 1 -04}
{951620400 -14400 0 -04}
{970977600 -10800 1 -04}
{971578800 -14400 0 -04}
}
|
Changes to library/tzdata/America/Bogota.
1 2 3 4 5 6 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Bogota) {
{-9223372036854775808 -17776 0 LMT}
{-2707671824 -17776 0 BMT}
{-1739041424 -18000 0 -05}
| | | 1 2 3 4 5 6 7 8 9 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Bogota) {
{-9223372036854775808 -17776 0 LMT}
{-2707671824 -17776 0 BMT}
{-1739041424 -18000 0 -05}
{704869200 -14400 1 -05}
{733896000 -18000 0 -05}
}
|
Changes to library/tzdata/America/Campo_Grande.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Campo_Grande) {
{-9223372036854775808 -13108 0 LMT}
{-1767212492 -14400 0 -04}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Campo_Grande) {
{-9223372036854775808 -13108 0 LMT}
{-1767212492 -14400 0 -04}
{-1206954000 -10800 1 -04}
{-1191358800 -14400 0 -04}
{-1175371200 -10800 1 -04}
{-1159822800 -14400 0 -04}
{-633816000 -10800 1 -04}
{-622065600 -14400 0 -04}
{-602280000 -10800 1 -04}
{-591829200 -14400 0 -04}
{-570744000 -10800 1 -04}
{-560206800 -14400 0 -04}
{-539121600 -10800 1 -04}
{-531349200 -14400 0 -04}
{-191361600 -10800 1 -04}
{-184194000 -14400 0 -04}
{-155160000 -10800 1 -04}
{-150066000 -14400 0 -04}
{-128894400 -10800 1 -04}
{-121122000 -14400 0 -04}
{-99950400 -10800 1 -04}
{-89586000 -14400 0 -04}
{-68414400 -10800 1 -04}
{-57963600 -14400 0 -04}
{499752000 -10800 1 -04}
{511239600 -14400 0 -04}
{530596800 -10800 1 -04}
{540270000 -14400 0 -04}
{562132800 -10800 1 -04}
{571201200 -14400 0 -04}
{592977600 -10800 1 -04}
{602046000 -14400 0 -04}
{624427200 -10800 1 -04}
{634705200 -14400 0 -04}
{656481600 -10800 1 -04}
{666759600 -14400 0 -04}
{687931200 -10800 1 -04}
{697604400 -14400 0 -04}
{719985600 -10800 1 -04}
{728449200 -14400 0 -04}
{750830400 -10800 1 -04}
{761713200 -14400 0 -04}
{782280000 -10800 1 -04}
{793162800 -14400 0 -04}
{813729600 -10800 1 -04}
{824007600 -14400 0 -04}
{844574400 -10800 1 -04}
{856062000 -14400 0 -04}
{876110400 -10800 1 -04}
{888721200 -14400 0 -04}
{908078400 -10800 1 -04}
{919566000 -14400 0 -04}
{938923200 -10800 1 -04}
{951620400 -14400 0 -04}
{970977600 -10800 1 -04}
{982465200 -14400 0 -04}
{1003032000 -10800 1 -04}
{1013914800 -14400 0 -04}
{1036296000 -10800 1 -04}
{1045364400 -14400 0 -04}
{1066536000 -10800 1 -04}
{1076814000 -14400 0 -04}
{1099368000 -10800 1 -04}
{1108868400 -14400 0 -04}
{1129435200 -10800 1 -04}
{1140318000 -14400 0 -04}
{1162699200 -10800 1 -04}
{1172372400 -14400 0 -04}
{1192334400 -10800 1 -04}
{1203217200 -14400 0 -04}
{1224388800 -10800 1 -04}
{1234666800 -14400 0 -04}
{1255838400 -10800 1 -04}
{1266721200 -14400 0 -04}
{1287288000 -10800 1 -04}
{1298170800 -14400 0 -04}
{1318737600 -10800 1 -04}
{1330225200 -14400 0 -04}
{1350792000 -10800 1 -04}
{1361070000 -14400 0 -04}
{1382241600 -10800 1 -04}
{1392519600 -14400 0 -04}
{1413691200 -10800 1 -04}
{1424574000 -14400 0 -04}
{1445140800 -10800 1 -04}
{1456023600 -14400 0 -04}
{1476590400 -10800 1 -04}
{1487473200 -14400 0 -04}
{1508040000 -10800 1 -04}
{1518922800 -14400 0 -04}
{1541304000 -10800 1 -04}
{1550372400 -14400 0 -04}
{1572753600 -10800 1 -04}
{1581822000 -14400 0 -04}
{1604203200 -10800 1 -04}
{1613876400 -14400 0 -04}
{1636257600 -10800 1 -04}
{1645326000 -14400 0 -04}
{1667707200 -10800 1 -04}
{1677380400 -14400 0 -04}
{1699156800 -10800 1 -04}
{1708225200 -14400 0 -04}
{1730606400 -10800 1 -04}
{1739674800 -14400 0 -04}
{1762056000 -10800 1 -04}
{1771729200 -14400 0 -04}
{1793505600 -10800 1 -04}
{1803178800 -14400 0 -04}
{1825560000 -10800 1 -04}
{1834628400 -14400 0 -04}
{1857009600 -10800 1 -04}
{1866078000 -14400 0 -04}
{1888459200 -10800 1 -04}
{1897527600 -14400 0 -04}
{1919908800 -10800 1 -04}
{1928977200 -14400 0 -04}
{1951358400 -10800 1 -04}
{1960426800 -14400 0 -04}
{1983412800 -10800 1 -04}
{1992481200 -14400 0 -04}
{2014862400 -10800 1 -04}
{2024535600 -14400 0 -04}
{2046312000 -10800 1 -04}
{2055380400 -14400 0 -04}
{2077761600 -10800 1 -04}
{2086830000 -14400 0 -04}
{2109211200 -10800 1 -04}
{2118884400 -14400 0 -04}
{2140660800 -10800 1 -04}
{2150334000 -14400 0 -04}
{2172715200 -10800 1 -04}
{2181783600 -14400 0 -04}
{2204164800 -10800 1 -04}
{2213233200 -14400 0 -04}
{2235614400 -10800 1 -04}
{2244682800 -14400 0 -04}
{2267064000 -10800 1 -04}
{2276132400 -14400 0 -04}
{2298513600 -10800 1 -04}
{2307582000 -14400 0 -04}
{2329963200 -10800 1 -04}
{2339636400 -14400 0 -04}
{2362017600 -10800 1 -04}
{2371086000 -14400 0 -04}
{2393467200 -10800 1 -04}
{2402535600 -14400 0 -04}
{2424916800 -10800 1 -04}
{2433985200 -14400 0 -04}
{2456366400 -10800 1 -04}
{2465434800 -14400 0 -04}
{2487816000 -10800 1 -04}
{2497489200 -14400 0 -04}
{2519870400 -10800 1 -04}
{2528938800 -14400 0 -04}
{2551320000 -10800 1 -04}
{2560388400 -14400 0 -04}
{2582769600 -10800 1 -04}
{2591838000 -14400 0 -04}
{2614219200 -10800 1 -04}
{2623287600 -14400 0 -04}
{2645668800 -10800 1 -04}
{2654737200 -14400 0 -04}
{2677118400 -10800 1 -04}
{2686791600 -14400 0 -04}
{2709172800 -10800 1 -04}
{2718241200 -14400 0 -04}
{2740622400 -10800 1 -04}
{2749690800 -14400 0 -04}
{2772072000 -10800 1 -04}
{2781140400 -14400 0 -04}
{2803521600 -10800 1 -04}
{2812590000 -14400 0 -04}
{2834971200 -10800 1 -04}
{2844039600 -14400 0 -04}
{2867025600 -10800 1 -04}
{2876094000 -14400 0 -04}
{2898475200 -10800 1 -04}
{2907543600 -14400 0 -04}
{2929924800 -10800 1 -04}
{2938993200 -14400 0 -04}
{2961374400 -10800 1 -04}
{2970442800 -14400 0 -04}
{2992824000 -10800 1 -04}
{3001892400 -14400 0 -04}
{3024273600 -10800 1 -04}
{3033946800 -14400 0 -04}
{3056328000 -10800 1 -04}
{3065396400 -14400 0 -04}
{3087777600 -10800 1 -04}
{3096846000 -14400 0 -04}
{3119227200 -10800 1 -04}
{3128295600 -14400 0 -04}
{3150676800 -10800 1 -04}
{3159745200 -14400 0 -04}
{3182126400 -10800 1 -04}
{3191194800 -14400 0 -04}
{3213576000 -10800 1 -04}
{3223249200 -14400 0 -04}
{3245630400 -10800 1 -04}
{3254698800 -14400 0 -04}
{3277080000 -10800 1 -04}
{3286148400 -14400 0 -04}
{3308529600 -10800 1 -04}
{3317598000 -14400 0 -04}
{3339979200 -10800 1 -04}
{3349047600 -14400 0 -04}
{3371428800 -10800 1 -04}
{3381102000 -14400 0 -04}
{3403483200 -10800 1 -04}
{3412551600 -14400 0 -04}
{3434932800 -10800 1 -04}
{3444001200 -14400 0 -04}
{3466382400 -10800 1 -04}
{3475450800 -14400 0 -04}
{3497832000 -10800 1 -04}
{3506900400 -14400 0 -04}
{3529281600 -10800 1 -04}
{3538350000 -14400 0 -04}
{3560731200 -10800 1 -04}
{3570404400 -14400 0 -04}
{3592785600 -10800 1 -04}
{3601854000 -14400 0 -04}
{3624235200 -10800 1 -04}
{3633303600 -14400 0 -04}
{3655684800 -10800 1 -04}
{3664753200 -14400 0 -04}
{3687134400 -10800 1 -04}
{3696202800 -14400 0 -04}
{3718584000 -10800 1 -04}
{3727652400 -14400 0 -04}
{3750638400 -10800 1 -04}
{3759706800 -14400 0 -04}
{3782088000 -10800 1 -04}
{3791156400 -14400 0 -04}
{3813537600 -10800 1 -04}
{3822606000 -14400 0 -04}
{3844987200 -10800 1 -04}
{3854055600 -14400 0 -04}
{3876436800 -10800 1 -04}
{3885505200 -14400 0 -04}
{3907886400 -10800 1 -04}
{3917559600 -14400 0 -04}
{3939940800 -10800 1 -04}
{3949009200 -14400 0 -04}
{3971390400 -10800 1 -04}
{3980458800 -14400 0 -04}
{4002840000 -10800 1 -04}
{4011908400 -14400 0 -04}
{4034289600 -10800 1 -04}
{4043358000 -14400 0 -04}
{4065739200 -10800 1 -04}
{4074807600 -14400 0 -04}
{4097188800 -10800 1 -04}
}
|
Changes to library/tzdata/America/Cuiaba.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Cuiaba) {
{-9223372036854775808 -13460 0 LMT}
{-1767212140 -14400 0 -04}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Cuiaba) {
{-9223372036854775808 -13460 0 LMT}
{-1767212140 -14400 0 -04}
{-1206954000 -10800 1 -04}
{-1191358800 -14400 0 -04}
{-1175371200 -10800 1 -04}
{-1159822800 -14400 0 -04}
{-633816000 -10800 1 -04}
{-622065600 -14400 0 -04}
{-602280000 -10800 1 -04}
{-591829200 -14400 0 -04}
{-570744000 -10800 1 -04}
{-560206800 -14400 0 -04}
{-539121600 -10800 1 -04}
{-531349200 -14400 0 -04}
{-191361600 -10800 1 -04}
{-184194000 -14400 0 -04}
{-155160000 -10800 1 -04}
{-150066000 -14400 0 -04}
{-128894400 -10800 1 -04}
{-121122000 -14400 0 -04}
{-99950400 -10800 1 -04}
{-89586000 -14400 0 -04}
{-68414400 -10800 1 -04}
{-57963600 -14400 0 -04}
{499752000 -10800 1 -04}
{511239600 -14400 0 -04}
{530596800 -10800 1 -04}
{540270000 -14400 0 -04}
{562132800 -10800 1 -04}
{571201200 -14400 0 -04}
{592977600 -10800 1 -04}
{602046000 -14400 0 -04}
{624427200 -10800 1 -04}
{634705200 -14400 0 -04}
{656481600 -10800 1 -04}
{666759600 -14400 0 -04}
{687931200 -10800 1 -04}
{697604400 -14400 0 -04}
{719985600 -10800 1 -04}
{728449200 -14400 0 -04}
{750830400 -10800 1 -04}
{761713200 -14400 0 -04}
{782280000 -10800 1 -04}
{793162800 -14400 0 -04}
{813729600 -10800 1 -04}
{824007600 -14400 0 -04}
{844574400 -10800 1 -04}
{856062000 -14400 0 -04}
{876110400 -10800 1 -04}
{888721200 -14400 0 -04}
{908078400 -10800 1 -04}
{919566000 -14400 0 -04}
{938923200 -10800 1 -04}
{951620400 -14400 0 -04}
{970977600 -10800 1 -04}
{982465200 -14400 0 -04}
{1003032000 -10800 1 -04}
{1013914800 -14400 0 -04}
{1036296000 -10800 1 -04}
{1045364400 -14400 0 -04}
{1064372400 -14400 0 -04}
{1096603200 -14400 0 -04}
{1099368000 -10800 1 -04}
{1108868400 -14400 0 -04}
{1129435200 -10800 1 -04}
{1140318000 -14400 0 -04}
{1162699200 -10800 1 -04}
{1172372400 -14400 0 -04}
{1192334400 -10800 1 -04}
{1203217200 -14400 0 -04}
{1224388800 -10800 1 -04}
{1234666800 -14400 0 -04}
{1255838400 -10800 1 -04}
{1266721200 -14400 0 -04}
{1287288000 -10800 1 -04}
{1298170800 -14400 0 -04}
{1318737600 -10800 1 -04}
{1330225200 -14400 0 -04}
{1350792000 -10800 1 -04}
{1361070000 -14400 0 -04}
{1382241600 -10800 1 -04}
{1392519600 -14400 0 -04}
{1413691200 -10800 1 -04}
{1424574000 -14400 0 -04}
{1445140800 -10800 1 -04}
{1456023600 -14400 0 -04}
{1476590400 -10800 1 -04}
{1487473200 -14400 0 -04}
{1508040000 -10800 1 -04}
{1518922800 -14400 0 -04}
{1541304000 -10800 1 -04}
{1550372400 -14400 0 -04}
{1572753600 -10800 1 -04}
{1581822000 -14400 0 -04}
{1604203200 -10800 1 -04}
{1613876400 -14400 0 -04}
{1636257600 -10800 1 -04}
{1645326000 -14400 0 -04}
{1667707200 -10800 1 -04}
{1677380400 -14400 0 -04}
{1699156800 -10800 1 -04}
{1708225200 -14400 0 -04}
{1730606400 -10800 1 -04}
{1739674800 -14400 0 -04}
{1762056000 -10800 1 -04}
{1771729200 -14400 0 -04}
{1793505600 -10800 1 -04}
{1803178800 -14400 0 -04}
{1825560000 -10800 1 -04}
{1834628400 -14400 0 -04}
{1857009600 -10800 1 -04}
{1866078000 -14400 0 -04}
{1888459200 -10800 1 -04}
{1897527600 -14400 0 -04}
{1919908800 -10800 1 -04}
{1928977200 -14400 0 -04}
{1951358400 -10800 1 -04}
{1960426800 -14400 0 -04}
{1983412800 -10800 1 -04}
{1992481200 -14400 0 -04}
{2014862400 -10800 1 -04}
{2024535600 -14400 0 -04}
{2046312000 -10800 1 -04}
{2055380400 -14400 0 -04}
{2077761600 -10800 1 -04}
{2086830000 -14400 0 -04}
{2109211200 -10800 1 -04}
{2118884400 -14400 0 -04}
{2140660800 -10800 1 -04}
{2150334000 -14400 0 -04}
{2172715200 -10800 1 -04}
{2181783600 -14400 0 -04}
{2204164800 -10800 1 -04}
{2213233200 -14400 0 -04}
{2235614400 -10800 1 -04}
{2244682800 -14400 0 -04}
{2267064000 -10800 1 -04}
{2276132400 -14400 0 -04}
{2298513600 -10800 1 -04}
{2307582000 -14400 0 -04}
{2329963200 -10800 1 -04}
{2339636400 -14400 0 -04}
{2362017600 -10800 1 -04}
{2371086000 -14400 0 -04}
{2393467200 -10800 1 -04}
{2402535600 -14400 0 -04}
{2424916800 -10800 1 -04}
{2433985200 -14400 0 -04}
{2456366400 -10800 1 -04}
{2465434800 -14400 0 -04}
{2487816000 -10800 1 -04}
{2497489200 -14400 0 -04}
{2519870400 -10800 1 -04}
{2528938800 -14400 0 -04}
{2551320000 -10800 1 -04}
{2560388400 -14400 0 -04}
{2582769600 -10800 1 -04}
{2591838000 -14400 0 -04}
{2614219200 -10800 1 -04}
{2623287600 -14400 0 -04}
{2645668800 -10800 1 -04}
{2654737200 -14400 0 -04}
{2677118400 -10800 1 -04}
{2686791600 -14400 0 -04}
{2709172800 -10800 1 -04}
{2718241200 -14400 0 -04}
{2740622400 -10800 1 -04}
{2749690800 -14400 0 -04}
{2772072000 -10800 1 -04}
{2781140400 -14400 0 -04}
{2803521600 -10800 1 -04}
{2812590000 -14400 0 -04}
{2834971200 -10800 1 -04}
{2844039600 -14400 0 -04}
{2867025600 -10800 1 -04}
{2876094000 -14400 0 -04}
{2898475200 -10800 1 -04}
{2907543600 -14400 0 -04}
{2929924800 -10800 1 -04}
{2938993200 -14400 0 -04}
{2961374400 -10800 1 -04}
{2970442800 -14400 0 -04}
{2992824000 -10800 1 -04}
{3001892400 -14400 0 -04}
{3024273600 -10800 1 -04}
{3033946800 -14400 0 -04}
{3056328000 -10800 1 -04}
{3065396400 -14400 0 -04}
{3087777600 -10800 1 -04}
{3096846000 -14400 0 -04}
{3119227200 -10800 1 -04}
{3128295600 -14400 0 -04}
{3150676800 -10800 1 -04}
{3159745200 -14400 0 -04}
{3182126400 -10800 1 -04}
{3191194800 -14400 0 -04}
{3213576000 -10800 1 -04}
{3223249200 -14400 0 -04}
{3245630400 -10800 1 -04}
{3254698800 -14400 0 -04}
{3277080000 -10800 1 -04}
{3286148400 -14400 0 -04}
{3308529600 -10800 1 -04}
{3317598000 -14400 0 -04}
{3339979200 -10800 1 -04}
{3349047600 -14400 0 -04}
{3371428800 -10800 1 -04}
{3381102000 -14400 0 -04}
{3403483200 -10800 1 -04}
{3412551600 -14400 0 -04}
{3434932800 -10800 1 -04}
{3444001200 -14400 0 -04}
{3466382400 -10800 1 -04}
{3475450800 -14400 0 -04}
{3497832000 -10800 1 -04}
{3506900400 -14400 0 -04}
{3529281600 -10800 1 -04}
{3538350000 -14400 0 -04}
{3560731200 -10800 1 -04}
{3570404400 -14400 0 -04}
{3592785600 -10800 1 -04}
{3601854000 -14400 0 -04}
{3624235200 -10800 1 -04}
{3633303600 -14400 0 -04}
{3655684800 -10800 1 -04}
{3664753200 -14400 0 -04}
{3687134400 -10800 1 -04}
{3696202800 -14400 0 -04}
{3718584000 -10800 1 -04}
{3727652400 -14400 0 -04}
{3750638400 -10800 1 -04}
{3759706800 -14400 0 -04}
{3782088000 -10800 1 -04}
{3791156400 -14400 0 -04}
{3813537600 -10800 1 -04}
{3822606000 -14400 0 -04}
{3844987200 -10800 1 -04}
{3854055600 -14400 0 -04}
{3876436800 -10800 1 -04}
{3885505200 -14400 0 -04}
{3907886400 -10800 1 -04}
{3917559600 -14400 0 -04}
{3939940800 -10800 1 -04}
{3949009200 -14400 0 -04}
{3971390400 -10800 1 -04}
{3980458800 -14400 0 -04}
{4002840000 -10800 1 -04}
{4011908400 -14400 0 -04}
{4034289600 -10800 1 -04}
{4043358000 -14400 0 -04}
{4065739200 -10800 1 -04}
{4074807600 -14400 0 -04}
{4097188800 -10800 1 -04}
}
|
Changes to library/tzdata/America/Eirunepe.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Eirunepe) {
{-9223372036854775808 -16768 0 LMT}
{-1767208832 -18000 0 -05}
| | | | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Eirunepe) {
{-9223372036854775808 -16768 0 LMT}
{-1767208832 -18000 0 -05}
{-1206950400 -14400 1 -05}
{-1191355200 -18000 0 -05}
{-1175367600 -14400 1 -05}
{-1159819200 -18000 0 -05}
{-633812400 -14400 1 -05}
{-622062000 -18000 0 -05}
{-602276400 -14400 1 -05}
{-591825600 -18000 0 -05}
{-570740400 -14400 1 -05}
{-560203200 -18000 0 -05}
{-539118000 -14400 1 -05}
{-531345600 -18000 0 -05}
{-191358000 -14400 1 -05}
{-184190400 -18000 0 -05}
{-155156400 -14400 1 -05}
{-150062400 -18000 0 -05}
{-128890800 -14400 1 -05}
{-121118400 -18000 0 -05}
{-99946800 -14400 1 -05}
{-89582400 -18000 0 -05}
{-68410800 -14400 1 -05}
{-57960000 -18000 0 -05}
{499755600 -14400 1 -05}
{511243200 -18000 0 -05}
{530600400 -14400 1 -05}
{540273600 -18000 0 -05}
{562136400 -14400 1 -05}
{571204800 -18000 0 -05}
{590040000 -18000 0 -05}
{749192400 -18000 0 -05}
{750834000 -14400 1 -05}
{761716800 -18000 0 -05}
{780206400 -18000 0 -05}
{1214283600 -14400 0 -04}
{1384056000 -18000 0 -05}
}
|
Changes to library/tzdata/America/Fortaleza.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Fortaleza) {
{-9223372036854775808 -9240 0 LMT}
{-1767216360 -10800 0 -03}
| | | | | | | | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Fortaleza) {
{-9223372036854775808 -9240 0 LMT}
{-1767216360 -10800 0 -03}
{-1206957600 -7200 1 -03}
{-1191362400 -10800 0 -03}
{-1175374800 -7200 1 -03}
{-1159826400 -10800 0 -03}
{-633819600 -7200 1 -03}
{-622069200 -10800 0 -03}
{-602283600 -7200 1 -03}
{-591832800 -10800 0 -03}
{-570747600 -7200 1 -03}
{-560210400 -10800 0 -03}
{-539125200 -7200 1 -03}
{-531352800 -10800 0 -03}
{-191365200 -7200 1 -03}
{-184197600 -10800 0 -03}
{-155163600 -7200 1 -03}
{-150069600 -10800 0 -03}
{-128898000 -7200 1 -03}
{-121125600 -10800 0 -03}
{-99954000 -7200 1 -03}
{-89589600 -10800 0 -03}
{-68418000 -7200 1 -03}
{-57967200 -10800 0 -03}
{499748400 -7200 1 -03}
{511236000 -10800 0 -03}
{530593200 -7200 1 -03}
{540266400 -10800 0 -03}
{562129200 -7200 1 -03}
{571197600 -10800 0 -03}
{592974000 -7200 1 -03}
{602042400 -10800 0 -03}
{624423600 -7200 1 -03}
{634701600 -10800 0 -03}
{653536800 -10800 0 -03}
{938660400 -10800 0 -03}
{938919600 -7200 1 -03}
{951616800 -10800 0 -03}
{970974000 -7200 1 -03}
{972180000 -10800 0 -03}
{1000350000 -10800 0 -03}
{1003028400 -7200 1 -03}
{1013911200 -10800 0 -03}
{1033437600 -10800 0 -03}
}
|
Changes to library/tzdata/America/Grand_Turk.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Grand_Turk) {
{-9223372036854775808 -17072 0 LMT}
| | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Grand_Turk) {
{-9223372036854775808 -17072 0 LMT}
{-2524504528 -18430 0 KMT}
{-1827687170 -18000 0 EST}
{284014800 -18000 0 EST}
{294217200 -14400 1 EDT}
{309938400 -18000 0 EST}
{325666800 -14400 1 EDT}
{341388000 -18000 0 EST}
{357116400 -14400 1 EDT}
{372837600 -18000 0 EST}
|
| ︙ | ︙ |
Changes to library/tzdata/America/Guayaquil.
1 2 3 4 5 6 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Guayaquil) {
{-9223372036854775808 -19160 0 LMT}
{-2524502440 -18840 0 QMT}
{-1230749160 -18000 0 -05}
| | | 1 2 3 4 5 6 7 8 9 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Guayaquil) {
{-9223372036854775808 -19160 0 LMT}
{-2524502440 -18840 0 QMT}
{-1230749160 -18000 0 -05}
{722926800 -14400 1 -05}
{728884800 -18000 0 -05}
}
|
Changes to library/tzdata/America/Jamaica.
1 2 3 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Jamaica) {
| | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Jamaica) {
{-9223372036854775808 -18430 0 LMT}
{-2524503170 -18430 0 KMT}
{-1827687170 -18000 0 EST}
{126248400 -18000 0 EST}
{126687600 -14400 1 EDT}
{152085600 -18000 0 EST}
{162370800 -14400 1 EDT}
{183535200 -18000 0 EST}
{199263600 -14400 1 EDT}
{215589600 -18000 0 EST}
|
| ︙ | ︙ |
Changes to library/tzdata/America/Lima.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Lima) {
{-9223372036854775808 -18492 0 LMT}
{-2524503108 -18516 0 LMT}
| | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Lima) {
{-9223372036854775808 -18492 0 LMT}
{-2524503108 -18516 0 LMT}
{-1938538284 -14400 0 -05}
{-1002052800 -18000 0 -05}
{-986756400 -14400 1 -05}
{-971035200 -18000 0 -05}
{-955306800 -14400 1 -05}
{-939585600 -18000 0 -05}
{512712000 -18000 0 -05}
{544248000 -18000 0 -05}
{638942400 -18000 0 -05}
{765172800 -18000 0 -05}
}
|
Changes to library/tzdata/America/Maceio.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Maceio) {
{-9223372036854775808 -8572 0 LMT}
{-1767217028 -10800 0 -03}
| | | | | | | | | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Maceio) {
{-9223372036854775808 -8572 0 LMT}
{-1767217028 -10800 0 -03}
{-1206957600 -7200 1 -03}
{-1191362400 -10800 0 -03}
{-1175374800 -7200 1 -03}
{-1159826400 -10800 0 -03}
{-633819600 -7200 1 -03}
{-622069200 -10800 0 -03}
{-602283600 -7200 1 -03}
{-591832800 -10800 0 -03}
{-570747600 -7200 1 -03}
{-560210400 -10800 0 -03}
{-539125200 -7200 1 -03}
{-531352800 -10800 0 -03}
{-191365200 -7200 1 -03}
{-184197600 -10800 0 -03}
{-155163600 -7200 1 -03}
{-150069600 -10800 0 -03}
{-128898000 -7200 1 -03}
{-121125600 -10800 0 -03}
{-99954000 -7200 1 -03}
{-89589600 -10800 0 -03}
{-68418000 -7200 1 -03}
{-57967200 -10800 0 -03}
{499748400 -7200 1 -03}
{511236000 -10800 0 -03}
{530593200 -7200 1 -03}
{540266400 -10800 0 -03}
{562129200 -7200 1 -03}
{571197600 -10800 0 -03}
{592974000 -7200 1 -03}
{602042400 -10800 0 -03}
{624423600 -7200 1 -03}
{634701600 -10800 0 -03}
{653536800 -10800 0 -03}
{813553200 -10800 0 -03}
{813726000 -7200 1 -03}
{824004000 -10800 0 -03}
{841802400 -10800 0 -03}
{938660400 -10800 0 -03}
{938919600 -7200 1 -03}
{951616800 -10800 0 -03}
{970974000 -7200 1 -03}
{972180000 -10800 0 -03}
{1000350000 -10800 0 -03}
{1003028400 -7200 1 -03}
{1013911200 -10800 0 -03}
{1033437600 -10800 0 -03}
}
|
Changes to library/tzdata/America/Manaus.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Manaus) {
{-9223372036854775808 -14404 0 LMT}
{-1767211196 -14400 0 -04}
| | | | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Manaus) {
{-9223372036854775808 -14404 0 LMT}
{-1767211196 -14400 0 -04}
{-1206954000 -10800 1 -04}
{-1191358800 -14400 0 -04}
{-1175371200 -10800 1 -04}
{-1159822800 -14400 0 -04}
{-633816000 -10800 1 -04}
{-622065600 -14400 0 -04}
{-602280000 -10800 1 -04}
{-591829200 -14400 0 -04}
{-570744000 -10800 1 -04}
{-560206800 -14400 0 -04}
{-539121600 -10800 1 -04}
{-531349200 -14400 0 -04}
{-191361600 -10800 1 -04}
{-184194000 -14400 0 -04}
{-155160000 -10800 1 -04}
{-150066000 -14400 0 -04}
{-128894400 -10800 1 -04}
{-121122000 -14400 0 -04}
{-99950400 -10800 1 -04}
{-89586000 -14400 0 -04}
{-68414400 -10800 1 -04}
{-57963600 -14400 0 -04}
{499752000 -10800 1 -04}
{511239600 -14400 0 -04}
{530596800 -10800 1 -04}
{540270000 -14400 0 -04}
{562132800 -10800 1 -04}
{571201200 -14400 0 -04}
{590036400 -14400 0 -04}
{749188800 -14400 0 -04}
{750830400 -10800 1 -04}
{761713200 -14400 0 -04}
{780202800 -14400 0 -04}
}
|
Changes to library/tzdata/America/Metlakatla.
| ︙ | ︙ | |||
42 43 44 45 46 47 48 |
{436356000 -28800 0 PST}
{1446372000 -32400 0 AKST}
{1457866800 -28800 1 AKDT}
{1478426400 -32400 0 AKST}
{1489316400 -28800 1 AKDT}
{1509876000 -32400 0 AKST}
{1520766000 -28800 1 AKDT}
| > | | 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 |
{436356000 -28800 0 PST}
{1446372000 -32400 0 AKST}
{1457866800 -28800 1 AKDT}
{1478426400 -32400 0 AKST}
{1489316400 -28800 1 AKDT}
{1509876000 -32400 0 AKST}
{1520766000 -28800 1 AKDT}
{1541329200 -28800 0 PST}
{1547978400 -32400 0 AKST}
{1552215600 -28800 1 AKDT}
{1572775200 -32400 0 AKST}
{1583665200 -28800 1 AKDT}
{1604224800 -32400 0 AKST}
{1615719600 -28800 1 AKDT}
{1636279200 -32400 0 AKST}
{1647169200 -28800 1 AKDT}
|
| ︙ | ︙ |
Changes to library/tzdata/America/Montevideo.
1 2 3 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Montevideo) {
| | | | | | | | | | | | | | | | < | | | | > | | < < < < | | < | | < | | | > | > | > > | | | | | | > > | | | | | | | | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Montevideo) {
{-9223372036854775808 -13491 0 LMT}
{-1942690509 -13491 0 MMT}
{-1567455309 -14400 0 -04}
{-1459627200 -10800 0 -0330}
{-1443819600 -12600 0 -0330}
{-1428006600 -10800 1 -0330}
{-1412283600 -12600 0 -0330}
{-1396470600 -10800 1 -0330}
{-1380747600 -12600 0 -0330}
{-1141590600 -10800 1 -0330}
{-1128286800 -12600 0 -0330}
{-1110141000 -10800 1 -0330}
{-1096837200 -12600 0 -0330}
{-1078691400 -10800 1 -0330}
{-1065387600 -12600 0 -0330}
{-1047241800 -10800 1 -0330}
{-1033938000 -12600 0 -0330}
{-1015187400 -10800 1 -0330}
{-1002488400 -12600 0 -0330}
{-983737800 -10800 1 -0330}
{-971038800 -12600 0 -0330}
{-954707400 -10800 1 -0330}
{-938984400 -12600 0 -0330}
{-920838600 -10800 1 -0330}
{-907534800 -12600 0 -0330}
{-896819400 -10800 1 -0330}
{-853621200 -9000 0 -03}
{-845847000 -10800 0 -03}
{-334789200 -9000 1 -03}
{-319671000 -10800 0 -03}
{-315608400 -10800 0 -03}
{-314226000 -7200 1 -03}
{-309996000 -10800 0 -03}
{-149720400 -7200 1 -03}
{-134604000 -10800 0 -03}
{-63147600 -10800 0 -03}
{-50446800 -9000 1 -03}
{-34205400 -10800 0 -03}
{10800 -10800 0 -03}
{9860400 -7200 1 -03}
{14176800 -10800 0 -03}
{72846000 -7200 1 -03}
{80100000 -10800 0 -03}
{126241200 -10800 0 -03}
{127278000 -5400 1 -03}
{132112800 -9000 0 -03}
{147234600 -10800 0 -03}
{156909600 -10800 0 -03}
{156913200 -7200 1 -03}
{165376800 -10800 0 -03}
{219812400 -7200 1 -03}
{226461600 -10800 0 -03}
{250052400 -7200 1 -03}
{257911200 -10800 0 -03}
{282711600 -7200 1 -03}
{289360800 -10800 0 -03}
{294202800 -7200 1 -03}
{322020000 -10800 0 -03}
{566449200 -7200 1 -03}
{573012000 -10800 0 -03}
{597812400 -7200 1 -03}
{605066400 -10800 0 -03}
{625633200 -7200 1 -03}
{635911200 -10800 0 -03}
{656478000 -7200 1 -03}
{667965600 -10800 0 -03}
{688532400 -7200 1 -03}
{699415200 -10800 0 -03}
{719377200 -7200 1 -03}
{730864800 -10800 0 -03}
{1095562800 -7200 1 -03}
{1111896000 -10800 0 -03}
{1128834000 -7200 1 -03}
{1142136000 -10800 0 -03}
{1159678800 -7200 1 -03}
{1173585600 -10800 0 -03}
{1191733200 -7200 1 -03}
{1205035200 -10800 0 -03}
{1223182800 -7200 1 -03}
{1236484800 -10800 0 -03}
{1254632400 -7200 1 -03}
{1268539200 -10800 0 -03}
{1286082000 -7200 1 -03}
{1299988800 -10800 0 -03}
{1317531600 -7200 1 -03}
{1331438400 -10800 0 -03}
{1349586000 -7200 1 -03}
{1362888000 -10800 0 -03}
{1381035600 -7200 1 -03}
{1394337600 -10800 0 -03}
{1412485200 -7200 1 -03}
{1425787200 -10800 0 -03}
}
|
Changes to library/tzdata/America/Noronha.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Noronha) {
{-9223372036854775808 -7780 0 LMT}
{-1767217820 -7200 0 -02}
| | | | | | | | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Noronha) {
{-9223372036854775808 -7780 0 LMT}
{-1767217820 -7200 0 -02}
{-1206961200 -3600 1 -02}
{-1191366000 -7200 0 -02}
{-1175378400 -3600 1 -02}
{-1159830000 -7200 0 -02}
{-633823200 -3600 1 -02}
{-622072800 -7200 0 -02}
{-602287200 -3600 1 -02}
{-591836400 -7200 0 -02}
{-570751200 -3600 1 -02}
{-560214000 -7200 0 -02}
{-539128800 -3600 1 -02}
{-531356400 -7200 0 -02}
{-191368800 -3600 1 -02}
{-184201200 -7200 0 -02}
{-155167200 -3600 1 -02}
{-150073200 -7200 0 -02}
{-128901600 -3600 1 -02}
{-121129200 -7200 0 -02}
{-99957600 -3600 1 -02}
{-89593200 -7200 0 -02}
{-68421600 -3600 1 -02}
{-57970800 -7200 0 -02}
{499744800 -3600 1 -02}
{511232400 -7200 0 -02}
{530589600 -3600 1 -02}
{540262800 -7200 0 -02}
{562125600 -3600 1 -02}
{571194000 -7200 0 -02}
{592970400 -3600 1 -02}
{602038800 -7200 0 -02}
{624420000 -3600 1 -02}
{634698000 -7200 0 -02}
{653533200 -7200 0 -02}
{938656800 -7200 0 -02}
{938916000 -3600 1 -02}
{951613200 -7200 0 -02}
{970970400 -3600 1 -02}
{971571600 -7200 0 -02}
{1000346400 -7200 0 -02}
{1003024800 -3600 1 -02}
{1013907600 -7200 0 -02}
{1033434000 -7200 0 -02}
}
|
Changes to library/tzdata/America/Porto_Velho.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Porto_Velho) {
{-9223372036854775808 -15336 0 LMT}
{-1767210264 -14400 0 -04}
| | | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Porto_Velho) {
{-9223372036854775808 -15336 0 LMT}
{-1767210264 -14400 0 -04}
{-1206954000 -10800 1 -04}
{-1191358800 -14400 0 -04}
{-1175371200 -10800 1 -04}
{-1159822800 -14400 0 -04}
{-633816000 -10800 1 -04}
{-622065600 -14400 0 -04}
{-602280000 -10800 1 -04}
{-591829200 -14400 0 -04}
{-570744000 -10800 1 -04}
{-560206800 -14400 0 -04}
{-539121600 -10800 1 -04}
{-531349200 -14400 0 -04}
{-191361600 -10800 1 -04}
{-184194000 -14400 0 -04}
{-155160000 -10800 1 -04}
{-150066000 -14400 0 -04}
{-128894400 -10800 1 -04}
{-121122000 -14400 0 -04}
{-99950400 -10800 1 -04}
{-89586000 -14400 0 -04}
{-68414400 -10800 1 -04}
{-57963600 -14400 0 -04}
{499752000 -10800 1 -04}
{511239600 -14400 0 -04}
{530596800 -10800 1 -04}
{540270000 -14400 0 -04}
{562132800 -10800 1 -04}
{571201200 -14400 0 -04}
{590036400 -14400 0 -04}
}
|
Changes to library/tzdata/America/Punta_Arenas.
1 2 3 4 5 6 7 8 9 10 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Punta_Arenas) {
{-9223372036854775808 -17020 0 LMT}
{-2524504580 -16966 0 SMT}
{-1892661434 -18000 0 -05}
{-1688410800 -16966 0 SMT}
{-1619205434 -14400 0 -04}
{-1593806400 -16966 0 SMT}
{-1335986234 -18000 0 -05}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Punta_Arenas) {
{-9223372036854775808 -17020 0 LMT}
{-2524504580 -16966 0 SMT}
{-1892661434 -18000 0 -05}
{-1688410800 -16966 0 SMT}
{-1619205434 -14400 0 -04}
{-1593806400 -16966 0 SMT}
{-1335986234 -18000 0 -05}
{-1335985200 -14400 1 -05}
{-1317585600 -18000 0 -05}
{-1304362800 -14400 1 -05}
{-1286049600 -18000 0 -05}
{-1272826800 -14400 1 -05}
{-1254513600 -18000 0 -05}
{-1241290800 -14400 1 -05}
{-1222977600 -18000 0 -05}
{-1209754800 -14400 1 -05}
{-1191355200 -18000 0 -05}
{-1178132400 -14400 0 -04}
{-870552000 -18000 0 -05}
{-865278000 -14400 0 -04}
{-718056000 -18000 0 -05}
{-713649600 -14400 0 -04}
{-36619200 -10800 1 -04}
{-23922000 -14400 0 -04}
{-3355200 -10800 1 -04}
{7527600 -14400 0 -04}
{24465600 -10800 1 -04}
{37767600 -14400 0 -04}
{55915200 -10800 1 -04}
{69217200 -14400 0 -04}
{87969600 -10800 1 -04}
{100666800 -14400 0 -04}
{118209600 -10800 1 -04}
{132116400 -14400 0 -04}
{150868800 -10800 1 -04}
{163566000 -14400 0 -04}
{182318400 -10800 1 -04}
{195620400 -14400 0 -04}
{213768000 -10800 1 -04}
{227070000 -14400 0 -04}
{245217600 -10800 1 -04}
{258519600 -14400 0 -04}
{277272000 -10800 1 -04}
{289969200 -14400 0 -04}
{308721600 -10800 1 -04}
{321418800 -14400 0 -04}
{340171200 -10800 1 -04}
{353473200 -14400 0 -04}
{371620800 -10800 1 -04}
{384922800 -14400 0 -04}
{403070400 -10800 1 -04}
{416372400 -14400 0 -04}
{434520000 -10800 1 -04}
{447822000 -14400 0 -04}
{466574400 -10800 1 -04}
{479271600 -14400 0 -04}
{498024000 -10800 1 -04}
{510721200 -14400 0 -04}
{529473600 -10800 1 -04}
{545194800 -14400 0 -04}
{560923200 -10800 1 -04}
{574225200 -14400 0 -04}
{592372800 -10800 1 -04}
{605674800 -14400 0 -04}
{624427200 -10800 1 -04}
{637124400 -14400 0 -04}
{653457600 -10800 1 -04}
{668574000 -14400 0 -04}
{687326400 -10800 1 -04}
{700628400 -14400 0 -04}
{718776000 -10800 1 -04}
{732078000 -14400 0 -04}
{750225600 -10800 1 -04}
{763527600 -14400 0 -04}
{781675200 -10800 1 -04}
{794977200 -14400 0 -04}
{813729600 -10800 1 -04}
{826426800 -14400 0 -04}
{845179200 -10800 1 -04}
{859690800 -14400 0 -04}
{876628800 -10800 1 -04}
{889930800 -14400 0 -04}
{906868800 -10800 1 -04}
{923194800 -14400 0 -04}
{939528000 -10800 1 -04}
{952830000 -14400 0 -04}
{971582400 -10800 1 -04}
{984279600 -14400 0 -04}
{1003032000 -10800 1 -04}
{1015729200 -14400 0 -04}
{1034481600 -10800 1 -04}
{1047178800 -14400 0 -04}
{1065931200 -10800 1 -04}
{1079233200 -14400 0 -04}
{1097380800 -10800 1 -04}
{1110682800 -14400 0 -04}
{1128830400 -10800 1 -04}
{1142132400 -14400 0 -04}
{1160884800 -10800 1 -04}
{1173582000 -14400 0 -04}
{1192334400 -10800 1 -04}
{1206846000 -14400 0 -04}
{1223784000 -10800 1 -04}
{1237086000 -14400 0 -04}
{1255233600 -10800 1 -04}
{1270350000 -14400 0 -04}
{1286683200 -10800 1 -04}
{1304823600 -14400 0 -04}
{1313899200 -10800 1 -04}
{1335668400 -14400 0 -04}
{1346558400 -10800 1 -04}
{1367118000 -14400 0 -04}
{1378612800 -10800 1 -04}
{1398567600 -14400 0 -04}
{1410062400 -10800 1 -04}
{1463281200 -14400 0 -04}
{1471147200 -10800 1 -04}
{1480820400 -10800 0 -03}
}
|
Changes to library/tzdata/America/Recife.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Recife) {
{-9223372036854775808 -8376 0 LMT}
{-1767217224 -10800 0 -03}
| | | | | | | | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Recife) {
{-9223372036854775808 -8376 0 LMT}
{-1767217224 -10800 0 -03}
{-1206957600 -7200 1 -03}
{-1191362400 -10800 0 -03}
{-1175374800 -7200 1 -03}
{-1159826400 -10800 0 -03}
{-633819600 -7200 1 -03}
{-622069200 -10800 0 -03}
{-602283600 -7200 1 -03}
{-591832800 -10800 0 -03}
{-570747600 -7200 1 -03}
{-560210400 -10800 0 -03}
{-539125200 -7200 1 -03}
{-531352800 -10800 0 -03}
{-191365200 -7200 1 -03}
{-184197600 -10800 0 -03}
{-155163600 -7200 1 -03}
{-150069600 -10800 0 -03}
{-128898000 -7200 1 -03}
{-121125600 -10800 0 -03}
{-99954000 -7200 1 -03}
{-89589600 -10800 0 -03}
{-68418000 -7200 1 -03}
{-57967200 -10800 0 -03}
{499748400 -7200 1 -03}
{511236000 -10800 0 -03}
{530593200 -7200 1 -03}
{540266400 -10800 0 -03}
{562129200 -7200 1 -03}
{571197600 -10800 0 -03}
{592974000 -7200 1 -03}
{602042400 -10800 0 -03}
{624423600 -7200 1 -03}
{634701600 -10800 0 -03}
{653536800 -10800 0 -03}
{938660400 -10800 0 -03}
{938919600 -7200 1 -03}
{951616800 -10800 0 -03}
{970974000 -7200 1 -03}
{971575200 -10800 0 -03}
{1000350000 -10800 0 -03}
{1003028400 -7200 1 -03}
{1013911200 -10800 0 -03}
{1033437600 -10800 0 -03}
}
|
Changes to library/tzdata/America/Rio_Branco.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Rio_Branco) {
{-9223372036854775808 -16272 0 LMT}
{-1767209328 -18000 0 -05}
| | | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Rio_Branco) {
{-9223372036854775808 -16272 0 LMT}
{-1767209328 -18000 0 -05}
{-1206950400 -14400 1 -05}
{-1191355200 -18000 0 -05}
{-1175367600 -14400 1 -05}
{-1159819200 -18000 0 -05}
{-633812400 -14400 1 -05}
{-622062000 -18000 0 -05}
{-602276400 -14400 1 -05}
{-591825600 -18000 0 -05}
{-570740400 -14400 1 -05}
{-560203200 -18000 0 -05}
{-539118000 -14400 1 -05}
{-531345600 -18000 0 -05}
{-191358000 -14400 1 -05}
{-184190400 -18000 0 -05}
{-155156400 -14400 1 -05}
{-150062400 -18000 0 -05}
{-128890800 -14400 1 -05}
{-121118400 -18000 0 -05}
{-99946800 -14400 1 -05}
{-89582400 -18000 0 -05}
{-68410800 -14400 1 -05}
{-57960000 -18000 0 -05}
{499755600 -14400 1 -05}
{511243200 -18000 0 -05}
{530600400 -14400 1 -05}
{540273600 -18000 0 -05}
{562136400 -14400 1 -05}
{571204800 -18000 0 -05}
{590040000 -18000 0 -05}
{1214283600 -14400 0 -04}
{1384056000 -18000 0 -05}
}
|
Changes to library/tzdata/America/Santarem.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Santarem) {
{-9223372036854775808 -13128 0 LMT}
{-1767212472 -14400 0 -04}
| | | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Santarem) {
{-9223372036854775808 -13128 0 LMT}
{-1767212472 -14400 0 -04}
{-1206954000 -10800 1 -04}
{-1191358800 -14400 0 -04}
{-1175371200 -10800 1 -04}
{-1159822800 -14400 0 -04}
{-633816000 -10800 1 -04}
{-622065600 -14400 0 -04}
{-602280000 -10800 1 -04}
{-591829200 -14400 0 -04}
{-570744000 -10800 1 -04}
{-560206800 -14400 0 -04}
{-539121600 -10800 1 -04}
{-531349200 -14400 0 -04}
{-191361600 -10800 1 -04}
{-184194000 -14400 0 -04}
{-155160000 -10800 1 -04}
{-150066000 -14400 0 -04}
{-128894400 -10800 1 -04}
{-121122000 -14400 0 -04}
{-99950400 -10800 1 -04}
{-89586000 -14400 0 -04}
{-68414400 -10800 1 -04}
{-57963600 -14400 0 -04}
{499752000 -10800 1 -04}
{511239600 -14400 0 -04}
{530596800 -10800 1 -04}
{540270000 -14400 0 -04}
{562132800 -10800 1 -04}
{571201200 -14400 0 -04}
{590036400 -14400 0 -04}
{1214280000 -10800 0 -03}
}
|
Changes to library/tzdata/America/Santiago.
1 2 3 4 5 6 7 8 9 10 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Santiago) {
{-9223372036854775808 -16966 0 LMT}
{-2524504634 -16966 0 SMT}
{-1892661434 -18000 0 -05}
{-1688410800 -16966 0 SMT}
{-1619205434 -14400 0 -04}
{-1593806400 -16966 0 SMT}
{-1335986234 -18000 0 -05}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > | | | | | | | | | | | | | < < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < < | | | | | | | | | | | | | | > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > | | | | > > | | | | | | | | | | | | | | | | | | | | | < < < < | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Santiago) {
{-9223372036854775808 -16966 0 LMT}
{-2524504634 -16966 0 SMT}
{-1892661434 -18000 0 -05}
{-1688410800 -16966 0 SMT}
{-1619205434 -14400 0 -04}
{-1593806400 -16966 0 SMT}
{-1335986234 -18000 0 -05}
{-1335985200 -14400 1 -05}
{-1317585600 -18000 0 -05}
{-1304362800 -14400 1 -05}
{-1286049600 -18000 0 -05}
{-1272826800 -14400 1 -05}
{-1254513600 -18000 0 -05}
{-1241290800 -14400 1 -05}
{-1222977600 -18000 0 -05}
{-1209754800 -14400 1 -05}
{-1191355200 -18000 0 -05}
{-1178132400 -14400 0 -04}
{-870552000 -18000 0 -05}
{-865278000 -14400 0 -04}
{-740520000 -10800 1 -03}
{-736376400 -14400 0 -04}
{-718056000 -18000 0 -05}
{-713649600 -14400 0 -04}
{-36619200 -10800 1 -04}
{-23922000 -14400 0 -04}
{-3355200 -10800 1 -04}
{7527600 -14400 0 -04}
{24465600 -10800 1 -04}
{37767600 -14400 0 -04}
{55915200 -10800 1 -04}
{69217200 -14400 0 -04}
{87969600 -10800 1 -04}
{100666800 -14400 0 -04}
{118209600 -10800 1 -04}
{132116400 -14400 0 -04}
{150868800 -10800 1 -04}
{163566000 -14400 0 -04}
{182318400 -10800 1 -04}
{195620400 -14400 0 -04}
{213768000 -10800 1 -04}
{227070000 -14400 0 -04}
{245217600 -10800 1 -04}
{258519600 -14400 0 -04}
{277272000 -10800 1 -04}
{289969200 -14400 0 -04}
{308721600 -10800 1 -04}
{321418800 -14400 0 -04}
{340171200 -10800 1 -04}
{353473200 -14400 0 -04}
{371620800 -10800 1 -04}
{384922800 -14400 0 -04}
{403070400 -10800 1 -04}
{416372400 -14400 0 -04}
{434520000 -10800 1 -04}
{447822000 -14400 0 -04}
{466574400 -10800 1 -04}
{479271600 -14400 0 -04}
{498024000 -10800 1 -04}
{510721200 -14400 0 -04}
{529473600 -10800 1 -04}
{545194800 -14400 0 -04}
{560923200 -10800 1 -04}
{574225200 -14400 0 -04}
{592372800 -10800 1 -04}
{605674800 -14400 0 -04}
{624427200 -10800 1 -04}
{637124400 -14400 0 -04}
{653457600 -10800 1 -04}
{668574000 -14400 0 -04}
{687326400 -10800 1 -04}
{700628400 -14400 0 -04}
{718776000 -10800 1 -04}
{732078000 -14400 0 -04}
{750225600 -10800 1 -04}
{763527600 -14400 0 -04}
{781675200 -10800 1 -04}
{794977200 -14400 0 -04}
{813729600 -10800 1 -04}
{826426800 -14400 0 -04}
{845179200 -10800 1 -04}
{859690800 -14400 0 -04}
{876628800 -10800 1 -04}
{889930800 -14400 0 -04}
{906868800 -10800 1 -04}
{923194800 -14400 0 -04}
{939528000 -10800 1 -04}
{952830000 -14400 0 -04}
{971582400 -10800 1 -04}
{984279600 -14400 0 -04}
{1003032000 -10800 1 -04}
{1015729200 -14400 0 -04}
{1034481600 -10800 1 -04}
{1047178800 -14400 0 -04}
{1065931200 -10800 1 -04}
{1079233200 -14400 0 -04}
{1097380800 -10800 1 -04}
{1110682800 -14400 0 -04}
{1128830400 -10800 1 -04}
{1142132400 -14400 0 -04}
{1160884800 -10800 1 -04}
{1173582000 -14400 0 -04}
{1192334400 -10800 1 -04}
{1206846000 -14400 0 -04}
{1223784000 -10800 1 -04}
{1237086000 -14400 0 -04}
{1255233600 -10800 1 -04}
{1270350000 -14400 0 -04}
{1286683200 -10800 1 -04}
{1304823600 -14400 0 -04}
{1313899200 -10800 1 -04}
{1335668400 -14400 0 -04}
{1346558400 -10800 1 -04}
{1367118000 -14400 0 -04}
{1378612800 -10800 1 -04}
{1398567600 -14400 0 -04}
{1410062400 -10800 1 -04}
{1463281200 -14400 0 -04}
{1471147200 -10800 1 -04}
{1494730800 -14400 0 -04}
{1502596800 -10800 1 -04}
{1526180400 -14400 0 -04}
{1534046400 -10800 1 -04}
{1554606000 -14400 0 -04}
{1567915200 -10800 1 -04}
{1586055600 -14400 0 -04}
{1599364800 -10800 1 -04}
{1617505200 -14400 0 -04}
{1630814400 -10800 1 -04}
{1648954800 -14400 0 -04}
{1662264000 -10800 1 -04}
{1680404400 -14400 0 -04}
{1693713600 -10800 1 -04}
{1712458800 -14400 0 -04}
{1725768000 -10800 1 -04}
{1743908400 -14400 0 -04}
{1757217600 -10800 1 -04}
{1775358000 -14400 0 -04}
{1788667200 -10800 1 -04}
{1806807600 -14400 0 -04}
{1820116800 -10800 1 -04}
{1838257200 -14400 0 -04}
{1851566400 -10800 1 -04}
{1870311600 -14400 0 -04}
{1883016000 -10800 1 -04}
{1901761200 -14400 0 -04}
{1915070400 -10800 1 -04}
{1933210800 -14400 0 -04}
{1946520000 -10800 1 -04}
{1964660400 -14400 0 -04}
{1977969600 -10800 1 -04}
{1996110000 -14400 0 -04}
{2009419200 -10800 1 -04}
{2027559600 -14400 0 -04}
{2040868800 -10800 1 -04}
{2059614000 -14400 0 -04}
{2072318400 -10800 1 -04}
{2091063600 -14400 0 -04}
{2104372800 -10800 1 -04}
{2122513200 -14400 0 -04}
{2135822400 -10800 1 -04}
{2153962800 -14400 0 -04}
{2167272000 -10800 1 -04}
{2185412400 -14400 0 -04}
{2198721600 -10800 1 -04}
{2217466800 -14400 0 -04}
{2230171200 -10800 1 -04}
{2248916400 -14400 0 -04}
{2262225600 -10800 1 -04}
{2280366000 -14400 0 -04}
{2293675200 -10800 1 -04}
{2311815600 -14400 0 -04}
{2325124800 -10800 1 -04}
{2343265200 -14400 0 -04}
{2356574400 -10800 1 -04}
{2374714800 -14400 0 -04}
{2388024000 -10800 1 -04}
{2406769200 -14400 0 -04}
{2419473600 -10800 1 -04}
{2438218800 -14400 0 -04}
{2451528000 -10800 1 -04}
{2469668400 -14400 0 -04}
{2482977600 -10800 1 -04}
{2501118000 -14400 0 -04}
{2514427200 -10800 1 -04}
{2532567600 -14400 0 -04}
{2545876800 -10800 1 -04}
{2564017200 -14400 0 -04}
{2577326400 -10800 1 -04}
{2596071600 -14400 0 -04}
{2609380800 -10800 1 -04}
{2627521200 -14400 0 -04}
{2640830400 -10800 1 -04}
{2658970800 -14400 0 -04}
{2672280000 -10800 1 -04}
{2690420400 -14400 0 -04}
{2703729600 -10800 1 -04}
{2721870000 -14400 0 -04}
{2735179200 -10800 1 -04}
{2753924400 -14400 0 -04}
{2766628800 -10800 1 -04}
{2785374000 -14400 0 -04}
{2798683200 -10800 1 -04}
{2816823600 -14400 0 -04}
{2830132800 -10800 1 -04}
{2848273200 -14400 0 -04}
{2861582400 -10800 1 -04}
{2879722800 -14400 0 -04}
{2893032000 -10800 1 -04}
{2911172400 -14400 0 -04}
{2924481600 -10800 1 -04}
{2943226800 -14400 0 -04}
{2955931200 -10800 1 -04}
{2974676400 -14400 0 -04}
{2987985600 -10800 1 -04}
{3006126000 -14400 0 -04}
{3019435200 -10800 1 -04}
{3037575600 -14400 0 -04}
{3050884800 -10800 1 -04}
{3069025200 -14400 0 -04}
{3082334400 -10800 1 -04}
{3101079600 -14400 0 -04}
{3113784000 -10800 1 -04}
{3132529200 -14400 0 -04}
{3145838400 -10800 1 -04}
{3163978800 -14400 0 -04}
{3177288000 -10800 1 -04}
{3195428400 -14400 0 -04}
{3208737600 -10800 1 -04}
{3226878000 -14400 0 -04}
{3240187200 -10800 1 -04}
{3258327600 -14400 0 -04}
{3271636800 -10800 1 -04}
{3290382000 -14400 0 -04}
{3303086400 -10800 1 -04}
{3321831600 -14400 0 -04}
{3335140800 -10800 1 -04}
{3353281200 -14400 0 -04}
{3366590400 -10800 1 -04}
{3384730800 -14400 0 -04}
{3398040000 -10800 1 -04}
{3416180400 -14400 0 -04}
{3429489600 -10800 1 -04}
{3447630000 -14400 0 -04}
{3460939200 -10800 1 -04}
{3479684400 -14400 0 -04}
{3492993600 -10800 1 -04}
{3511134000 -14400 0 -04}
{3524443200 -10800 1 -04}
{3542583600 -14400 0 -04}
{3555892800 -10800 1 -04}
{3574033200 -14400 0 -04}
{3587342400 -10800 1 -04}
{3605482800 -14400 0 -04}
{3618792000 -10800 1 -04}
{3637537200 -14400 0 -04}
{3650241600 -10800 1 -04}
{3668986800 -14400 0 -04}
{3682296000 -10800 1 -04}
{3700436400 -14400 0 -04}
{3713745600 -10800 1 -04}
{3731886000 -14400 0 -04}
{3745195200 -10800 1 -04}
{3763335600 -14400 0 -04}
{3776644800 -10800 1 -04}
{3794785200 -14400 0 -04}
{3808094400 -10800 1 -04}
{3826839600 -14400 0 -04}
{3839544000 -10800 1 -04}
{3858289200 -14400 0 -04}
{3871598400 -10800 1 -04}
{3889738800 -14400 0 -04}
{3903048000 -10800 1 -04}
{3921188400 -14400 0 -04}
{3934497600 -10800 1 -04}
{3952638000 -14400 0 -04}
{3965947200 -10800 1 -04}
{3984692400 -14400 0 -04}
{3997396800 -10800 1 -04}
{4016142000 -14400 0 -04}
{4029451200 -10800 1 -04}
{4047591600 -14400 0 -04}
{4060900800 -10800 1 -04}
{4079041200 -14400 0 -04}
{4092350400 -10800 1 -04}
}
|
Changes to library/tzdata/America/Sao_Paulo.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Sao_Paulo) {
{-9223372036854775808 -11188 0 LMT}
{-1767214412 -10800 0 -03}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Sao_Paulo) {
{-9223372036854775808 -11188 0 LMT}
{-1767214412 -10800 0 -03}
{-1206957600 -7200 1 -03}
{-1191362400 -10800 0 -03}
{-1175374800 -7200 1 -03}
{-1159826400 -10800 0 -03}
{-633819600 -7200 1 -03}
{-622069200 -10800 0 -03}
{-602283600 -7200 1 -03}
{-591832800 -10800 0 -03}
{-570747600 -7200 1 -03}
{-560210400 -10800 0 -03}
{-539125200 -7200 1 -03}
{-531352800 -10800 0 -03}
{-195429600 -7200 1 -02}
{-189381600 -7200 0 -03}
{-184197600 -10800 0 -03}
{-155163600 -7200 1 -03}
{-150069600 -10800 0 -03}
{-128898000 -7200 1 -03}
{-121125600 -10800 0 -03}
{-99954000 -7200 1 -03}
{-89589600 -10800 0 -03}
{-68418000 -7200 1 -03}
{-57967200 -10800 0 -03}
{499748400 -7200 1 -03}
{511236000 -10800 0 -03}
{530593200 -7200 1 -03}
{540266400 -10800 0 -03}
{562129200 -7200 1 -03}
{571197600 -10800 0 -03}
{592974000 -7200 1 -03}
{602042400 -10800 0 -03}
{624423600 -7200 1 -03}
{634701600 -10800 0 -03}
{656478000 -7200 1 -03}
{666756000 -10800 0 -03}
{687927600 -7200 1 -03}
{697600800 -10800 0 -03}
{719982000 -7200 1 -03}
{728445600 -10800 0 -03}
{750826800 -7200 1 -03}
{761709600 -10800 0 -03}
{782276400 -7200 1 -03}
{793159200 -10800 0 -03}
{813726000 -7200 1 -03}
{824004000 -10800 0 -03}
{844570800 -7200 1 -03}
{856058400 -10800 0 -03}
{876106800 -7200 1 -03}
{888717600 -10800 0 -03}
{908074800 -7200 1 -03}
{919562400 -10800 0 -03}
{938919600 -7200 1 -03}
{951616800 -10800 0 -03}
{970974000 -7200 1 -03}
{982461600 -10800 0 -03}
{1003028400 -7200 1 -03}
{1013911200 -10800 0 -03}
{1036292400 -7200 1 -03}
{1045360800 -10800 0 -03}
{1066532400 -7200 1 -03}
{1076810400 -10800 0 -03}
{1099364400 -7200 1 -03}
{1108864800 -10800 0 -03}
{1129431600 -7200 1 -03}
{1140314400 -10800 0 -03}
{1162695600 -7200 1 -03}
{1172368800 -10800 0 -03}
{1192330800 -7200 1 -03}
{1203213600 -10800 0 -03}
{1224385200 -7200 1 -03}
{1234663200 -10800 0 -03}
{1255834800 -7200 1 -03}
{1266717600 -10800 0 -03}
{1287284400 -7200 1 -03}
{1298167200 -10800 0 -03}
{1318734000 -7200 1 -03}
{1330221600 -10800 0 -03}
{1350788400 -7200 1 -03}
{1361066400 -10800 0 -03}
{1382238000 -7200 1 -03}
{1392516000 -10800 0 -03}
{1413687600 -7200 1 -03}
{1424570400 -10800 0 -03}
{1445137200 -7200 1 -03}
{1456020000 -10800 0 -03}
{1476586800 -7200 1 -03}
{1487469600 -10800 0 -03}
{1508036400 -7200 1 -03}
{1518919200 -10800 0 -03}
{1541300400 -7200 1 -03}
{1550368800 -10800 0 -03}
{1572750000 -7200 1 -03}
{1581818400 -10800 0 -03}
{1604199600 -7200 1 -03}
{1613872800 -10800 0 -03}
{1636254000 -7200 1 -03}
{1645322400 -10800 0 -03}
{1667703600 -7200 1 -03}
{1677376800 -10800 0 -03}
{1699153200 -7200 1 -03}
{1708221600 -10800 0 -03}
{1730602800 -7200 1 -03}
{1739671200 -10800 0 -03}
{1762052400 -7200 1 -03}
{1771725600 -10800 0 -03}
{1793502000 -7200 1 -03}
{1803175200 -10800 0 -03}
{1825556400 -7200 1 -03}
{1834624800 -10800 0 -03}
{1857006000 -7200 1 -03}
{1866074400 -10800 0 -03}
{1888455600 -7200 1 -03}
{1897524000 -10800 0 -03}
{1919905200 -7200 1 -03}
{1928973600 -10800 0 -03}
{1951354800 -7200 1 -03}
{1960423200 -10800 0 -03}
{1983409200 -7200 1 -03}
{1992477600 -10800 0 -03}
{2014858800 -7200 1 -03}
{2024532000 -10800 0 -03}
{2046308400 -7200 1 -03}
{2055376800 -10800 0 -03}
{2077758000 -7200 1 -03}
{2086826400 -10800 0 -03}
{2109207600 -7200 1 -03}
{2118880800 -10800 0 -03}
{2140657200 -7200 1 -03}
{2150330400 -10800 0 -03}
{2172711600 -7200 1 -03}
{2181780000 -10800 0 -03}
{2204161200 -7200 1 -03}
{2213229600 -10800 0 -03}
{2235610800 -7200 1 -03}
{2244679200 -10800 0 -03}
{2267060400 -7200 1 -03}
{2276128800 -10800 0 -03}
{2298510000 -7200 1 -03}
{2307578400 -10800 0 -03}
{2329959600 -7200 1 -03}
{2339632800 -10800 0 -03}
{2362014000 -7200 1 -03}
{2371082400 -10800 0 -03}
{2393463600 -7200 1 -03}
{2402532000 -10800 0 -03}
{2424913200 -7200 1 -03}
{2433981600 -10800 0 -03}
{2456362800 -7200 1 -03}
{2465431200 -10800 0 -03}
{2487812400 -7200 1 -03}
{2497485600 -10800 0 -03}
{2519866800 -7200 1 -03}
{2528935200 -10800 0 -03}
{2551316400 -7200 1 -03}
{2560384800 -10800 0 -03}
{2582766000 -7200 1 -03}
{2591834400 -10800 0 -03}
{2614215600 -7200 1 -03}
{2623284000 -10800 0 -03}
{2645665200 -7200 1 -03}
{2654733600 -10800 0 -03}
{2677114800 -7200 1 -03}
{2686788000 -10800 0 -03}
{2709169200 -7200 1 -03}
{2718237600 -10800 0 -03}
{2740618800 -7200 1 -03}
{2749687200 -10800 0 -03}
{2772068400 -7200 1 -03}
{2781136800 -10800 0 -03}
{2803518000 -7200 1 -03}
{2812586400 -10800 0 -03}
{2834967600 -7200 1 -03}
{2844036000 -10800 0 -03}
{2867022000 -7200 1 -03}
{2876090400 -10800 0 -03}
{2898471600 -7200 1 -03}
{2907540000 -10800 0 -03}
{2929921200 -7200 1 -03}
{2938989600 -10800 0 -03}
{2961370800 -7200 1 -03}
{2970439200 -10800 0 -03}
{2992820400 -7200 1 -03}
{3001888800 -10800 0 -03}
{3024270000 -7200 1 -03}
{3033943200 -10800 0 -03}
{3056324400 -7200 1 -03}
{3065392800 -10800 0 -03}
{3087774000 -7200 1 -03}
{3096842400 -10800 0 -03}
{3119223600 -7200 1 -03}
{3128292000 -10800 0 -03}
{3150673200 -7200 1 -03}
{3159741600 -10800 0 -03}
{3182122800 -7200 1 -03}
{3191191200 -10800 0 -03}
{3213572400 -7200 1 -03}
{3223245600 -10800 0 -03}
{3245626800 -7200 1 -03}
{3254695200 -10800 0 -03}
{3277076400 -7200 1 -03}
{3286144800 -10800 0 -03}
{3308526000 -7200 1 -03}
{3317594400 -10800 0 -03}
{3339975600 -7200 1 -03}
{3349044000 -10800 0 -03}
{3371425200 -7200 1 -03}
{3381098400 -10800 0 -03}
{3403479600 -7200 1 -03}
{3412548000 -10800 0 -03}
{3434929200 -7200 1 -03}
{3443997600 -10800 0 -03}
{3466378800 -7200 1 -03}
{3475447200 -10800 0 -03}
{3497828400 -7200 1 -03}
{3506896800 -10800 0 -03}
{3529278000 -7200 1 -03}
{3538346400 -10800 0 -03}
{3560727600 -7200 1 -03}
{3570400800 -10800 0 -03}
{3592782000 -7200 1 -03}
{3601850400 -10800 0 -03}
{3624231600 -7200 1 -03}
{3633300000 -10800 0 -03}
{3655681200 -7200 1 -03}
{3664749600 -10800 0 -03}
{3687130800 -7200 1 -03}
{3696199200 -10800 0 -03}
{3718580400 -7200 1 -03}
{3727648800 -10800 0 -03}
{3750634800 -7200 1 -03}
{3759703200 -10800 0 -03}
{3782084400 -7200 1 -03}
{3791152800 -10800 0 -03}
{3813534000 -7200 1 -03}
{3822602400 -10800 0 -03}
{3844983600 -7200 1 -03}
{3854052000 -10800 0 -03}
{3876433200 -7200 1 -03}
{3885501600 -10800 0 -03}
{3907882800 -7200 1 -03}
{3917556000 -10800 0 -03}
{3939937200 -7200 1 -03}
{3949005600 -10800 0 -03}
{3971386800 -7200 1 -03}
{3980455200 -10800 0 -03}
{4002836400 -7200 1 -03}
{4011904800 -10800 0 -03}
{4034286000 -7200 1 -03}
{4043354400 -10800 0 -03}
{4065735600 -7200 1 -03}
{4074804000 -10800 0 -03}
{4097185200 -7200 1 -03}
}
|
Changes to library/tzdata/Antarctica/Casey.
1 2 3 4 5 6 7 8 9 10 11 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Antarctica/Casey) {
{-9223372036854775808 0 0 -00}
{-31536000 28800 0 +08}
{1255802400 39600 0 +11}
{1267714800 28800 0 +08}
{1319738400 39600 0 +11}
{1329843600 28800 0 +08}
{1477065600 39600 0 +11}
}
| > | 1 2 3 4 5 6 7 8 9 10 11 12 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Antarctica/Casey) {
{-9223372036854775808 0 0 -00}
{-31536000 28800 0 +08}
{1255802400 39600 0 +11}
{1267714800 28800 0 +08}
{1319738400 39600 0 +11}
{1329843600 28800 0 +08}
{1477065600 39600 0 +11}
{1520701200 28800 0 +08}
}
|
Changes to library/tzdata/Antarctica/Palmer.
1 2 3 4 5 6 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Antarctica/Palmer) {
{-9223372036854775808 0 0 -00}
{-157766400 -14400 0 -04}
{-152654400 -14400 0 -04}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Antarctica/Palmer) {
{-9223372036854775808 0 0 -00}
{-157766400 -14400 0 -04}
{-152654400 -14400 0 -04}
{-132955200 -10800 1 -04}
{-121122000 -14400 0 -04}
{-101419200 -10800 1 -04}
{-86821200 -14400 0 -04}
{-71092800 -10800 1 -04}
{-54766800 -14400 0 -04}
{-39038400 -10800 1 -04}
{-23317200 -14400 0 -04}
{-7588800 -10800 0 -03}
{128142000 -7200 1 -03}
{136605600 -10800 0 -03}
{389070000 -14400 0 -04}
{403070400 -10800 1 -04}
{416372400 -14400 0 -04}
{434520000 -10800 1 -04}
{447822000 -14400 0 -04}
{466574400 -10800 1 -04}
{479271600 -14400 0 -04}
{498024000 -10800 1 -04}
{510721200 -14400 0 -04}
{529473600 -10800 1 -04}
{545194800 -14400 0 -04}
{560923200 -10800 1 -04}
{574225200 -14400 0 -04}
{592372800 -10800 1 -04}
{605674800 -14400 0 -04}
{624427200 -10800 1 -04}
{637124400 -14400 0 -04}
{653457600 -10800 1 -04}
{668574000 -14400 0 -04}
{687326400 -10800 1 -04}
{700628400 -14400 0 -04}
{718776000 -10800 1 -04}
{732078000 -14400 0 -04}
{750225600 -10800 1 -04}
{763527600 -14400 0 -04}
{781675200 -10800 1 -04}
{794977200 -14400 0 -04}
{813729600 -10800 1 -04}
{826426800 -14400 0 -04}
{845179200 -10800 1 -04}
{859690800 -14400 0 -04}
{876628800 -10800 1 -04}
{889930800 -14400 0 -04}
{906868800 -10800 1 -04}
{923194800 -14400 0 -04}
{939528000 -10800 1 -04}
{952830000 -14400 0 -04}
{971582400 -10800 1 -04}
{984279600 -14400 0 -04}
{1003032000 -10800 1 -04}
{1015729200 -14400 0 -04}
{1034481600 -10800 1 -04}
{1047178800 -14400 0 -04}
{1065931200 -10800 1 -04}
{1079233200 -14400 0 -04}
{1097380800 -10800 1 -04}
{1110682800 -14400 0 -04}
{1128830400 -10800 1 -04}
{1142132400 -14400 0 -04}
{1160884800 -10800 1 -04}
{1173582000 -14400 0 -04}
{1192334400 -10800 1 -04}
{1206846000 -14400 0 -04}
{1223784000 -10800 1 -04}
{1237086000 -14400 0 -04}
{1255233600 -10800 1 -04}
{1270350000 -14400 0 -04}
{1286683200 -10800 1 -04}
{1304823600 -14400 0 -04}
{1313899200 -10800 1 -04}
{1335668400 -14400 0 -04}
{1346558400 -10800 1 -04}
{1367118000 -14400 0 -04}
{1378612800 -10800 1 -04}
{1398567600 -14400 0 -04}
{1410062400 -10800 1 -04}
{1463281200 -14400 0 -04}
{1471147200 -10800 1 -04}
{1480820400 -10800 0 -03}
}
|
Changes to library/tzdata/Asia/Almaty.
1 2 3 4 5 6 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Almaty) {
{-9223372036854775808 18468 0 LMT}
{-1441170468 18000 0 +05}
{-1247547600 21600 0 +06}
| | | | | | | | | | | | | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Almaty) {
{-9223372036854775808 18468 0 LMT}
{-1441170468 18000 0 +05}
{-1247547600 21600 0 +06}
{354909600 25200 1 +06}
{370717200 21600 0 +06}
{386445600 25200 1 +06}
{402253200 21600 0 +06}
{417981600 25200 1 +06}
{433789200 21600 0 +06}
{449604000 25200 1 +06}
{465336000 21600 0 +06}
{481060800 25200 1 +06}
{496785600 21600 0 +06}
{512510400 25200 1 +06}
{528235200 21600 0 +06}
{543960000 25200 1 +06}
{559684800 21600 0 +06}
{575409600 25200 1 +06}
{591134400 21600 0 +06}
{606859200 25200 1 +06}
{622584000 21600 0 +06}
{638308800 25200 1 +06}
{654638400 21600 0 +06}
{670363200 18000 0 +05}
{670366800 21600 1 +05}
{686091600 18000 0 +05}
{695768400 21600 0 +06}
{701812800 25200 1 +06}
{717537600 21600 0 +06}
{733262400 25200 1 +06}
{748987200 21600 0 +06}
{764712000 25200 1 +06}
{780436800 21600 0 +06}
{796161600 25200 1 +06}
{811886400 21600 0 +06}
{828216000 25200 1 +06}
{846360000 21600 0 +06}
{859665600 25200 1 +06}
{877809600 21600 0 +06}
{891115200 25200 1 +06}
{909259200 21600 0 +06}
{922564800 25200 1 +06}
{941313600 21600 0 +06}
{954014400 25200 1 +06}
{972763200 21600 0 +06}
{985464000 25200 1 +06}
{1004212800 21600 0 +06}
{1017518400 25200 1 +06}
{1035662400 21600 0 +06}
{1048968000 25200 1 +06}
{1067112000 21600 0 +06}
{1080417600 25200 1 +06}
{1099166400 21600 0 +06}
}
|
Changes to library/tzdata/Asia/Aqtau.
1 2 3 4 5 6 7 8 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Aqtau) {
{-9223372036854775808 12064 0 LMT}
{-1441164064 14400 0 +04}
{-1247544000 18000 0 +05}
{370724400 21600 0 +06}
{386445600 18000 0 +05}
| | | | | | | | | | | | | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Aqtau) {
{-9223372036854775808 12064 0 LMT}
{-1441164064 14400 0 +04}
{-1247544000 18000 0 +05}
{370724400 21600 0 +06}
{386445600 18000 0 +05}
{386449200 21600 1 +05}
{402256800 18000 0 +05}
{417985200 21600 1 +05}
{433792800 18000 0 +05}
{449607600 21600 1 +05}
{465339600 18000 0 +05}
{481064400 21600 1 +05}
{496789200 18000 0 +05}
{512514000 21600 1 +05}
{528238800 18000 0 +05}
{543963600 21600 1 +05}
{559688400 18000 0 +05}
{575413200 21600 1 +05}
{591138000 18000 0 +05}
{606862800 21600 1 +05}
{622587600 18000 0 +05}
{638312400 21600 1 +05}
{654642000 18000 0 +05}
{670366800 14400 0 +04}
{670370400 18000 1 +04}
{686095200 14400 0 +04}
{695772000 18000 0 +05}
{701816400 21600 1 +05}
{717541200 18000 0 +05}
{733266000 21600 1 +05}
{748990800 18000 0 +05}
{764715600 21600 1 +05}
{780440400 18000 0 +04}
{780444000 14400 0 +04}
{796168800 18000 1 +04}
{811893600 14400 0 +04}
{828223200 18000 1 +04}
{846367200 14400 0 +04}
{859672800 18000 1 +04}
{877816800 14400 0 +04}
{891122400 18000 1 +04}
{909266400 14400 0 +04}
{922572000 18000 1 +04}
{941320800 14400 0 +04}
{954021600 18000 1 +04}
{972770400 14400 0 +04}
{985471200 18000 1 +04}
{1004220000 14400 0 +04}
{1017525600 18000 1 +04}
{1035669600 14400 0 +04}
{1048975200 18000 1 +04}
{1067119200 14400 0 +04}
{1080424800 18000 1 +04}
{1099173600 18000 0 +05}
}
|
Changes to library/tzdata/Asia/Aqtobe.
1 2 3 4 5 6 7 8 9 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Aqtobe) {
{-9223372036854775808 13720 0 LMT}
{-1441165720 14400 0 +04}
{-1247544000 18000 0 +05}
{354913200 21600 1 +06}
{370720800 21600 0 +06}
{386445600 18000 0 +05}
| | | | | | | | | | | | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Aqtobe) {
{-9223372036854775808 13720 0 LMT}
{-1441165720 14400 0 +04}
{-1247544000 18000 0 +05}
{354913200 21600 1 +06}
{370720800 21600 0 +06}
{386445600 18000 0 +05}
{386449200 21600 1 +05}
{402256800 18000 0 +05}
{417985200 21600 1 +05}
{433792800 18000 0 +05}
{449607600 21600 1 +05}
{465339600 18000 0 +05}
{481064400 21600 1 +05}
{496789200 18000 0 +05}
{512514000 21600 1 +05}
{528238800 18000 0 +05}
{543963600 21600 1 +05}
{559688400 18000 0 +05}
{575413200 21600 1 +05}
{591138000 18000 0 +05}
{606862800 21600 1 +05}
{622587600 18000 0 +05}
{638312400 21600 1 +05}
{654642000 18000 0 +05}
{670366800 14400 0 +04}
{670370400 18000 1 +04}
{686095200 14400 0 +04}
{695772000 18000 0 +05}
{701816400 21600 1 +05}
{717541200 18000 0 +05}
{733266000 21600 1 +05}
{748990800 18000 0 +05}
{764715600 21600 1 +05}
{780440400 18000 0 +05}
{796165200 21600 1 +05}
{811890000 18000 0 +05}
{828219600 21600 1 +05}
{846363600 18000 0 +05}
{859669200 21600 1 +05}
{877813200 18000 0 +05}
{891118800 21600 1 +05}
{909262800 18000 0 +05}
{922568400 21600 1 +05}
{941317200 18000 0 +05}
{954018000 21600 1 +05}
{972766800 18000 0 +05}
{985467600 21600 1 +05}
{1004216400 18000 0 +05}
{1017522000 21600 1 +05}
{1035666000 18000 0 +05}
{1048971600 21600 1 +05}
{1067115600 18000 0 +05}
{1080421200 21600 1 +05}
{1099170000 18000 0 +05}
}
|
Changes to library/tzdata/Asia/Ashgabat.
1 2 3 4 5 6 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Ashgabat) {
{-9223372036854775808 14012 0 LMT}
{-1441166012 14400 0 +04}
{-1247544000 18000 0 +05}
| | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Ashgabat) {
{-9223372036854775808 14012 0 LMT}
{-1441166012 14400 0 +04}
{-1247544000 18000 0 +05}
{354913200 21600 1 +05}
{370720800 18000 0 +05}
{386449200 21600 1 +05}
{402256800 18000 0 +05}
{417985200 21600 1 +05}
{433792800 18000 0 +05}
{449607600 21600 1 +05}
{465339600 18000 0 +05}
{481064400 21600 1 +05}
{496789200 18000 0 +05}
{512514000 21600 1 +05}
{528238800 18000 0 +05}
{543963600 21600 1 +05}
{559688400 18000 0 +05}
{575413200 21600 1 +05}
{591138000 18000 0 +05}
{606862800 21600 1 +05}
{622587600 18000 0 +05}
{638312400 21600 1 +05}
{654642000 18000 0 +05}
{670366800 14400 0 +04}
{670370400 18000 1 +04}
{686095200 14400 0 +04}
{695772000 18000 0 +05}
}
|
Changes to library/tzdata/Asia/Atyrau.
1 2 3 4 5 6 7 8 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Atyrau) {
{-9223372036854775808 12464 0 LMT}
{-1441164464 10800 0 +03}
{-1247540400 18000 0 +05}
{370724400 21600 0 +06}
{386445600 18000 0 +05}
| | | | | | | | | | | | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Atyrau) {
{-9223372036854775808 12464 0 LMT}
{-1441164464 10800 0 +03}
{-1247540400 18000 0 +05}
{370724400 21600 0 +06}
{386445600 18000 0 +05}
{386449200 21600 1 +05}
{402256800 18000 0 +05}
{417985200 21600 1 +05}
{433792800 18000 0 +05}
{449607600 21600 1 +05}
{465339600 18000 0 +05}
{481064400 21600 1 +05}
{496789200 18000 0 +05}
{512514000 21600 1 +05}
{528238800 18000 0 +05}
{543963600 21600 1 +05}
{559688400 18000 0 +05}
{575413200 21600 1 +05}
{591138000 18000 0 +05}
{606862800 21600 1 +05}
{622587600 18000 0 +05}
{638312400 21600 1 +05}
{654642000 18000 0 +05}
{670366800 14400 0 +04}
{670370400 18000 1 +04}
{686095200 14400 0 +04}
{695772000 18000 0 +05}
{701816400 21600 1 +05}
{717541200 18000 0 +05}
{733266000 21600 1 +05}
{748990800 18000 0 +05}
{764715600 21600 1 +05}
{780440400 18000 0 +05}
{796165200 21600 1 +05}
{811890000 18000 0 +05}
{828219600 21600 1 +05}
{846363600 18000 0 +05}
{859669200 21600 1 +05}
{877813200 18000 0 +05}
{891118800 21600 1 +05}
{909262800 18000 0 +05}
{922568400 14400 0 +04}
{922572000 18000 1 +04}
{941320800 14400 0 +04}
{954021600 18000 1 +04}
{972770400 14400 0 +04}
{985471200 18000 1 +04}
{1004220000 14400 0 +04}
{1017525600 18000 1 +04}
{1035669600 14400 0 +04}
{1048975200 18000 1 +04}
{1067119200 14400 0 +04}
{1080424800 18000 1 +04}
{1099173600 18000 0 +05}
}
|
Changes to library/tzdata/Asia/Baghdad.
1 2 3 4 5 6 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Baghdad) {
{-9223372036854775808 10660 0 LMT}
{-2524532260 10656 0 BMT}
{-1641005856 10800 0 +03}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Baghdad) {
{-9223372036854775808 10660 0 LMT}
{-2524532260 10656 0 BMT}
{-1641005856 10800 0 +03}
{389048400 14400 0 +03}
{402264000 10800 0 +03}
{417906000 14400 1 +03}
{433800000 10800 0 +03}
{449614800 14400 1 +03}
{465422400 10800 0 +03}
{481150800 14400 1 +03}
{496792800 10800 0 +03}
{512517600 14400 1 +03}
{528242400 10800 0 +03}
{543967200 14400 1 +03}
{559692000 10800 0 +03}
{575416800 14400 1 +03}
{591141600 10800 0 +03}
{606866400 14400 1 +03}
{622591200 10800 0 +03}
{638316000 14400 1 +03}
{654645600 10800 0 +03}
{670464000 14400 1 +03}
{686275200 10800 0 +03}
{702086400 14400 1 +03}
{717897600 10800 0 +03}
{733622400 14400 1 +03}
{749433600 10800 0 +03}
{765158400 14400 1 +03}
{780969600 10800 0 +03}
{796694400 14400 1 +03}
{812505600 10800 0 +03}
{828316800 14400 1 +03}
{844128000 10800 0 +03}
{859852800 14400 1 +03}
{875664000 10800 0 +03}
{891388800 14400 1 +03}
{907200000 10800 0 +03}
{922924800 14400 1 +03}
{938736000 10800 0 +03}
{954547200 14400 1 +03}
{970358400 10800 0 +03}
{986083200 14400 1 +03}
{1001894400 10800 0 +03}
{1017619200 14400 1 +03}
{1033430400 10800 0 +03}
{1049155200 14400 1 +03}
{1064966400 10800 0 +03}
{1080777600 14400 1 +03}
{1096588800 10800 0 +03}
{1112313600 14400 1 +03}
{1128124800 10800 0 +03}
{1143849600 14400 1 +03}
{1159660800 10800 0 +03}
{1175385600 14400 1 +03}
{1191196800 10800 0 +03}
}
|
Changes to library/tzdata/Asia/Baku.
1 2 3 4 5 6 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Baku) {
{-9223372036854775808 11964 0 LMT}
{-1441163964 10800 0 +03}
{-405140400 14400 0 +04}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Baku) {
{-9223372036854775808 11964 0 LMT}
{-1441163964 10800 0 +03}
{-405140400 14400 0 +04}
{354916800 18000 1 +04}
{370724400 14400 0 +04}
{386452800 18000 1 +04}
{402260400 14400 0 +04}
{417988800 18000 1 +04}
{433796400 14400 0 +04}
{449611200 18000 1 +04}
{465343200 14400 0 +04}
{481068000 18000 1 +04}
{496792800 14400 0 +04}
{512517600 18000 1 +04}
{528242400 14400 0 +04}
{543967200 18000 1 +04}
{559692000 14400 0 +04}
{575416800 18000 1 +04}
{591141600 14400 0 +04}
{606866400 18000 1 +04}
{622591200 14400 0 +04}
{638316000 18000 1 +04}
{654645600 14400 0 +04}
{670370400 10800 0 +03}
{670374000 14400 1 +03}
{686098800 10800 0 +03}
{701823600 14400 1 +03}
{717548400 14400 0 +04}
{820440000 14400 0 +04}
{828234000 18000 1 +05}
{846378000 14400 0 +04}
{852062400 14400 0 +04}
{859680000 18000 1 +04}
{877824000 14400 0 +04}
{891129600 18000 1 +04}
{909273600 14400 0 +04}
{922579200 18000 1 +04}
{941328000 14400 0 +04}
{954028800 18000 1 +04}
{972777600 14400 0 +04}
{985478400 18000 1 +04}
{1004227200 14400 0 +04}
{1017532800 18000 1 +04}
{1035676800 14400 0 +04}
{1048982400 18000 1 +04}
{1067126400 14400 0 +04}
{1080432000 18000 1 +04}
{1099180800 14400 0 +04}
{1111881600 18000 1 +04}
{1130630400 14400 0 +04}
{1143331200 18000 1 +04}
{1162080000 14400 0 +04}
{1174780800 18000 1 +04}
{1193529600 14400 0 +04}
{1206835200 18000 1 +04}
{1224979200 14400 0 +04}
{1238284800 18000 1 +04}
{1256428800 14400 0 +04}
{1269734400 18000 1 +04}
{1288483200 14400 0 +04}
{1301184000 18000 1 +04}
{1319932800 14400 0 +04}
{1332633600 18000 1 +04}
{1351382400 14400 0 +04}
{1364688000 18000 1 +04}
{1382832000 14400 0 +04}
{1396137600 18000 1 +04}
{1414281600 14400 0 +04}
{1427587200 18000 1 +04}
{1445731200 14400 0 +04}
}
|
Changes to library/tzdata/Asia/Bishkek.
1 2 3 4 5 6 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Bishkek) {
{-9223372036854775808 17904 0 LMT}
{-1441169904 18000 0 +05}
{-1247547600 21600 0 +06}
| | | | | | | | | | | | | | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Bishkek) {
{-9223372036854775808 17904 0 LMT}
{-1441169904 18000 0 +05}
{-1247547600 21600 0 +06}
{354909600 25200 1 +06}
{370717200 21600 0 +06}
{386445600 25200 1 +06}
{402253200 21600 0 +06}
{417981600 25200 1 +06}
{433789200 21600 0 +06}
{449604000 25200 1 +06}
{465336000 21600 0 +06}
{481060800 25200 1 +06}
{496785600 21600 0 +06}
{512510400 25200 1 +06}
{528235200 21600 0 +06}
{543960000 25200 1 +06}
{559684800 21600 0 +06}
{575409600 25200 1 +06}
{591134400 21600 0 +06}
{606859200 25200 1 +06}
{622584000 21600 0 +06}
{638308800 25200 1 +06}
{654638400 21600 0 +06}
{670363200 18000 0 +05}
{670366800 21600 1 +05}
{683586000 18000 0 +05}
{703018800 21600 1 +05}
{717530400 18000 0 +05}
{734468400 21600 1 +05}
{748980000 18000 0 +05}
{765918000 21600 1 +05}
{780429600 18000 0 +05}
{797367600 21600 1 +05}
{811879200 18000 0 +05}
{828817200 21600 1 +05}
{843933600 18000 0 +05}
{859671000 21600 1 +05}
{877811400 18000 0 +05}
{891120600 21600 1 +05}
{909261000 18000 0 +05}
{922570200 21600 1 +05}
{941315400 18000 0 +05}
{954019800 21600 1 +05}
{972765000 18000 0 +05}
{985469400 21600 1 +05}
{1004214600 18000 0 +05}
{1017523800 21600 1 +05}
{1035664200 18000 0 +05}
{1048973400 21600 1 +05}
{1067113800 18000 0 +05}
{1080423000 21600 1 +05}
{1099168200 18000 0 +05}
{1111872600 21600 1 +05}
{1123783200 21600 0 +06}
}
|
Changes to library/tzdata/Asia/Choibalsan.
1 2 3 4 5 6 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Choibalsan) {
{-9223372036854775808 27480 0 LMT}
{-2032933080 25200 0 +07}
{252435600 28800 0 +08}
| | | | | | | | | | | | | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Choibalsan) {
{-9223372036854775808 27480 0 LMT}
{-2032933080 25200 0 +07}
{252435600 28800 0 +08}
{417974400 36000 0 +09}
{433778400 32400 0 +09}
{449593200 36000 1 +09}
{465314400 32400 0 +09}
{481042800 36000 1 +09}
{496764000 32400 0 +09}
{512492400 36000 1 +09}
{528213600 32400 0 +09}
{543942000 36000 1 +09}
{559663200 32400 0 +09}
{575391600 36000 1 +09}
{591112800 32400 0 +09}
{606841200 36000 1 +09}
{622562400 32400 0 +09}
{638290800 36000 1 +09}
{654616800 32400 0 +09}
{670345200 36000 1 +09}
{686066400 32400 0 +09}
{701794800 36000 1 +09}
{717516000 32400 0 +09}
{733244400 36000 1 +09}
{748965600 32400 0 +09}
{764694000 36000 1 +09}
{780415200 32400 0 +09}
{796143600 36000 1 +09}
{811864800 32400 0 +09}
{828198000 36000 1 +09}
{843919200 32400 0 +09}
{859647600 36000 1 +09}
{875368800 32400 0 +09}
{891097200 36000 1 +09}
{906818400 32400 0 +09}
{988390800 36000 1 +09}
{1001692800 32400 0 +09}
{1017421200 36000 1 +09}
{1033142400 32400 0 +09}
{1048870800 36000 1 +09}
{1064592000 32400 0 +09}
{1080320400 36000 1 +09}
{1096041600 32400 0 +09}
{1111770000 36000 1 +09}
{1127491200 32400 0 +09}
{1143219600 36000 1 +09}
{1159545600 32400 0 +09}
{1206889200 28800 0 +08}
{1427479200 32400 1 +08}
{1443193200 28800 0 +08}
{1458928800 32400 1 +08}
{1474642800 28800 0 +08}
}
|
Changes to library/tzdata/Asia/Dhaka.
1 2 3 4 5 6 7 8 9 10 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Dhaka) {
{-9223372036854775808 21700 0 LMT}
{-2524543300 21200 0 HMT}
{-891582800 23400 0 +0630}
{-872058600 19800 0 +0530}
{-862637400 23400 0 +0630}
{-576138600 21600 0 +06}
{1230746400 21600 0 +06}
| | | 1 2 3 4 5 6 7 8 9 10 11 12 13 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Dhaka) {
{-9223372036854775808 21700 0 LMT}
{-2524543300 21200 0 HMT}
{-891582800 23400 0 +0630}
{-872058600 19800 0 +0530}
{-862637400 23400 0 +0630}
{-576138600 21600 0 +06}
{1230746400 21600 0 +06}
{1245430800 25200 1 +06}
{1262278800 21600 0 +06}
}
|
Changes to library/tzdata/Asia/Dushanbe.
1 2 3 4 5 6 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Dushanbe) {
{-9223372036854775808 16512 0 LMT}
{-1441168512 18000 0 +05}
{-1247547600 21600 0 +06}
| | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Dushanbe) {
{-9223372036854775808 16512 0 LMT}
{-1441168512 18000 0 +05}
{-1247547600 21600 0 +06}
{354909600 25200 1 +06}
{370717200 21600 0 +06}
{386445600 25200 1 +06}
{402253200 21600 0 +06}
{417981600 25200 1 +06}
{433789200 21600 0 +06}
{449604000 25200 1 +06}
{465336000 21600 0 +06}
{481060800 25200 1 +06}
{496785600 21600 0 +06}
{512510400 25200 1 +06}
{528235200 21600 0 +06}
{543960000 25200 1 +06}
{559684800 21600 0 +06}
{575409600 25200 1 +06}
{591134400 21600 0 +06}
{606859200 25200 1 +06}
{622584000 21600 0 +06}
{638308800 25200 1 +06}
{654638400 21600 0 +06}
{670363200 21600 1 +06}
{684363600 18000 0 +05}
}
|
Changes to library/tzdata/Asia/Gaza.
| ︙ | ︙ | |||
36 37 38 39 40 41 42 43 44 45 46 47 48 49 |
{-102643200 7200 0 EET}
{-84330000 10800 1 EEST}
{-81313200 10800 0 IST}
{142376400 10800 1 IDT}
{150843600 7200 0 IST}
{167176800 10800 1 IDT}
{178664400 7200 0 IST}
{482277600 10800 1 IDT}
{495579600 7200 0 IST}
{516751200 10800 1 IDT}
{526424400 7200 0 IST}
{545436000 10800 1 IDT}
{558478800 7200 0 IST}
{576626400 10800 1 IDT}
| > > > > | 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 |
{-102643200 7200 0 EET}
{-84330000 10800 1 EEST}
{-81313200 10800 0 IST}
{142376400 10800 1 IDT}
{150843600 7200 0 IST}
{167176800 10800 1 IDT}
{178664400 7200 0 IST}
{334015200 10800 1 IDT}
{337644000 7200 0 IST}
{452556000 10800 1 IDT}
{462232800 7200 0 IST}
{482277600 10800 1 IDT}
{495579600 7200 0 IST}
{516751200 10800 1 IDT}
{526424400 7200 0 IST}
{545436000 10800 1 IDT}
{558478800 7200 0 IST}
{576626400 10800 1 IDT}
|
| ︙ | ︙ | |||
107 108 109 110 111 112 113 |
{1414098000 7200 0 EET}
{1427493600 10800 1 EEST}
{1445547600 7200 0 EET}
{1458946800 10800 1 EEST}
{1477692000 7200 0 EET}
{1490396400 10800 1 EEST}
{1509141600 7200 0 EET}
| | | 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 |
{1414098000 7200 0 EET}
{1427493600 10800 1 EEST}
{1445547600 7200 0 EET}
{1458946800 10800 1 EEST}
{1477692000 7200 0 EET}
{1490396400 10800 1 EEST}
{1509141600 7200 0 EET}
{1521846000 10800 1 EEST}
{1540591200 7200 0 EET}
{1553900400 10800 1 EEST}
{1572040800 7200 0 EET}
{1585350000 10800 1 EEST}
{1604095200 7200 0 EET}
{1616799600 10800 1 EEST}
{1635544800 7200 0 EET}
|
| ︙ | ︙ | |||
129 130 131 132 133 134 135 |
{1761343200 7200 0 EET}
{1774652400 10800 1 EEST}
{1793397600 7200 0 EET}
{1806102000 10800 1 EEST}
{1824847200 7200 0 EET}
{1837551600 10800 1 EEST}
{1856296800 7200 0 EET}
| | | | | | 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 |
{1761343200 7200 0 EET}
{1774652400 10800 1 EEST}
{1793397600 7200 0 EET}
{1806102000 10800 1 EEST}
{1824847200 7200 0 EET}
{1837551600 10800 1 EEST}
{1856296800 7200 0 EET}
{1869001200 10800 1 EEST}
{1887746400 7200 0 EET}
{1901055600 10800 1 EEST}
{1919196000 7200 0 EET}
{1932505200 10800 1 EEST}
{1950645600 7200 0 EET}
{1963954800 10800 1 EEST}
{1982700000 7200 0 EET}
{1995404400 10800 1 EEST}
{2014149600 7200 0 EET}
{2026854000 10800 1 EEST}
{2045599200 7200 0 EET}
{2058303600 10800 1 EEST}
{2077048800 7200 0 EET}
{2090358000 10800 1 EEST}
{2108498400 7200 0 EET}
{2121807600 10800 1 EEST}
{2140552800 7200 0 EET}
{2153257200 10800 1 EEST}
{2172002400 7200 0 EET}
{2184706800 10800 1 EEST}
{2203452000 7200 0 EET}
{2216156400 10800 1 EEST}
{2234901600 7200 0 EET}
{2248210800 10800 1 EEST}
{2266351200 7200 0 EET}
{2279660400 10800 1 EEST}
{2297800800 7200 0 EET}
{2311110000 10800 1 EEST}
{2329855200 7200 0 EET}
{2342559600 10800 1 EEST}
{2361304800 7200 0 EET}
{2374009200 10800 1 EEST}
{2392754400 7200 0 EET}
{2405458800 10800 1 EEST}
{2424204000 7200 0 EET}
{2437513200 10800 1 EEST}
{2455653600 7200 0 EET}
{2468962800 10800 1 EEST}
{2487708000 7200 0 EET}
{2500412400 10800 1 EEST}
{2519157600 7200 0 EET}
|
| ︙ | ︙ | |||
185 186 187 188 189 190 191 |
{2644956000 7200 0 EET}
{2658265200 10800 1 EEST}
{2677010400 7200 0 EET}
{2689714800 10800 1 EEST}
{2708460000 7200 0 EET}
{2721164400 10800 1 EEST}
{2739909600 7200 0 EET}
| | | | | | 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 |
{2644956000 7200 0 EET}
{2658265200 10800 1 EEST}
{2677010400 7200 0 EET}
{2689714800 10800 1 EEST}
{2708460000 7200 0 EET}
{2721164400 10800 1 EEST}
{2739909600 7200 0 EET}
{2752614000 10800 1 EEST}
{2771359200 7200 0 EET}
{2784668400 10800 1 EEST}
{2802808800 7200 0 EET}
{2816118000 10800 1 EEST}
{2834258400 7200 0 EET}
{2847567600 10800 1 EEST}
{2866312800 7200 0 EET}
{2879017200 10800 1 EEST}
{2897762400 7200 0 EET}
{2910466800 10800 1 EEST}
{2929212000 7200 0 EET}
{2941916400 10800 1 EEST}
{2960661600 7200 0 EET}
{2973970800 10800 1 EEST}
{2992111200 7200 0 EET}
{3005420400 10800 1 EEST}
{3024165600 7200 0 EET}
{3036870000 10800 1 EEST}
{3055615200 7200 0 EET}
{3068319600 10800 1 EEST}
{3087064800 7200 0 EET}
{3099769200 10800 1 EEST}
{3118514400 7200 0 EET}
{3131823600 10800 1 EEST}
{3149964000 7200 0 EET}
{3163273200 10800 1 EEST}
{3181413600 7200 0 EET}
{3194722800 10800 1 EEST}
{3213468000 7200 0 EET}
{3226172400 10800 1 EEST}
{3244917600 7200 0 EET}
{3257622000 10800 1 EEST}
{3276367200 7200 0 EET}
{3289071600 10800 1 EEST}
{3307816800 7200 0 EET}
{3321126000 10800 1 EEST}
{3339266400 7200 0 EET}
{3352575600 10800 1 EEST}
{3371320800 7200 0 EET}
{3384025200 10800 1 EEST}
{3402770400 7200 0 EET}
|
| ︙ | ︙ | |||
241 242 243 244 245 246 247 |
{3528568800 7200 0 EET}
{3541878000 10800 1 EEST}
{3560623200 7200 0 EET}
{3573327600 10800 1 EEST}
{3592072800 7200 0 EET}
{3604777200 10800 1 EEST}
{3623522400 7200 0 EET}
| | | | | 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 |
{3528568800 7200 0 EET}
{3541878000 10800 1 EEST}
{3560623200 7200 0 EET}
{3573327600 10800 1 EEST}
{3592072800 7200 0 EET}
{3604777200 10800 1 EEST}
{3623522400 7200 0 EET}
{3636226800 10800 1 EEST}
{3654972000 7200 0 EET}
{3668281200 10800 1 EEST}
{3686421600 7200 0 EET}
{3699730800 10800 1 EEST}
{3717871200 7200 0 EET}
{3731180400 10800 1 EEST}
{3749925600 7200 0 EET}
{3762630000 10800 1 EEST}
{3781375200 7200 0 EET}
{3794079600 10800 1 EEST}
{3812824800 7200 0 EET}
{3825529200 10800 1 EEST}
{3844274400 7200 0 EET}
{3857583600 10800 1 EEST}
{3875724000 7200 0 EET}
{3889033200 10800 1 EEST}
{3907778400 7200 0 EET}
{3920482800 10800 1 EEST}
{3939228000 7200 0 EET}
{3951932400 10800 1 EEST}
{3970677600 7200 0 EET}
{3983382000 10800 1 EEST}
{4002127200 7200 0 EET}
{4015436400 10800 1 EEST}
{4033576800 7200 0 EET}
{4046886000 10800 1 EEST}
{4065026400 7200 0 EET}
{4078335600 10800 1 EEST}
{4097080800 7200 0 EET}
}
|
Changes to library/tzdata/Asia/Hebron.
| ︙ | ︙ | |||
36 37 38 39 40 41 42 43 44 45 46 47 48 49 |
{-102643200 7200 0 EET}
{-84330000 10800 1 EEST}
{-81313200 10800 0 IST}
{142376400 10800 1 IDT}
{150843600 7200 0 IST}
{167176800 10800 1 IDT}
{178664400 7200 0 IST}
{482277600 10800 1 IDT}
{495579600 7200 0 IST}
{516751200 10800 1 IDT}
{526424400 7200 0 IST}
{545436000 10800 1 IDT}
{558478800 7200 0 IST}
{576626400 10800 1 IDT}
| > > > > | 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 |
{-102643200 7200 0 EET}
{-84330000 10800 1 EEST}
{-81313200 10800 0 IST}
{142376400 10800 1 IDT}
{150843600 7200 0 IST}
{167176800 10800 1 IDT}
{178664400 7200 0 IST}
{334015200 10800 1 IDT}
{337644000 7200 0 IST}
{452556000 10800 1 IDT}
{462232800 7200 0 IST}
{482277600 10800 1 IDT}
{495579600 7200 0 IST}
{516751200 10800 1 IDT}
{526424400 7200 0 IST}
{545436000 10800 1 IDT}
{558478800 7200 0 IST}
{576626400 10800 1 IDT}
|
| ︙ | ︙ | |||
106 107 108 109 110 111 112 |
{1414098000 7200 0 EET}
{1427493600 10800 1 EEST}
{1445547600 7200 0 EET}
{1458946800 10800 1 EEST}
{1477692000 7200 0 EET}
{1490396400 10800 1 EEST}
{1509141600 7200 0 EET}
| | | 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 |
{1414098000 7200 0 EET}
{1427493600 10800 1 EEST}
{1445547600 7200 0 EET}
{1458946800 10800 1 EEST}
{1477692000 7200 0 EET}
{1490396400 10800 1 EEST}
{1509141600 7200 0 EET}
{1521846000 10800 1 EEST}
{1540591200 7200 0 EET}
{1553900400 10800 1 EEST}
{1572040800 7200 0 EET}
{1585350000 10800 1 EEST}
{1604095200 7200 0 EET}
{1616799600 10800 1 EEST}
{1635544800 7200 0 EET}
|
| ︙ | ︙ | |||
128 129 130 131 132 133 134 |
{1761343200 7200 0 EET}
{1774652400 10800 1 EEST}
{1793397600 7200 0 EET}
{1806102000 10800 1 EEST}
{1824847200 7200 0 EET}
{1837551600 10800 1 EEST}
{1856296800 7200 0 EET}
| | | | | | 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 |
{1761343200 7200 0 EET}
{1774652400 10800 1 EEST}
{1793397600 7200 0 EET}
{1806102000 10800 1 EEST}
{1824847200 7200 0 EET}
{1837551600 10800 1 EEST}
{1856296800 7200 0 EET}
{1869001200 10800 1 EEST}
{1887746400 7200 0 EET}
{1901055600 10800 1 EEST}
{1919196000 7200 0 EET}
{1932505200 10800 1 EEST}
{1950645600 7200 0 EET}
{1963954800 10800 1 EEST}
{1982700000 7200 0 EET}
{1995404400 10800 1 EEST}
{2014149600 7200 0 EET}
{2026854000 10800 1 EEST}
{2045599200 7200 0 EET}
{2058303600 10800 1 EEST}
{2077048800 7200 0 EET}
{2090358000 10800 1 EEST}
{2108498400 7200 0 EET}
{2121807600 10800 1 EEST}
{2140552800 7200 0 EET}
{2153257200 10800 1 EEST}
{2172002400 7200 0 EET}
{2184706800 10800 1 EEST}
{2203452000 7200 0 EET}
{2216156400 10800 1 EEST}
{2234901600 7200 0 EET}
{2248210800 10800 1 EEST}
{2266351200 7200 0 EET}
{2279660400 10800 1 EEST}
{2297800800 7200 0 EET}
{2311110000 10800 1 EEST}
{2329855200 7200 0 EET}
{2342559600 10800 1 EEST}
{2361304800 7200 0 EET}
{2374009200 10800 1 EEST}
{2392754400 7200 0 EET}
{2405458800 10800 1 EEST}
{2424204000 7200 0 EET}
{2437513200 10800 1 EEST}
{2455653600 7200 0 EET}
{2468962800 10800 1 EEST}
{2487708000 7200 0 EET}
{2500412400 10800 1 EEST}
{2519157600 7200 0 EET}
|
| ︙ | ︙ | |||
184 185 186 187 188 189 190 |
{2644956000 7200 0 EET}
{2658265200 10800 1 EEST}
{2677010400 7200 0 EET}
{2689714800 10800 1 EEST}
{2708460000 7200 0 EET}
{2721164400 10800 1 EEST}
{2739909600 7200 0 EET}
| | | | | | 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 |
{2644956000 7200 0 EET}
{2658265200 10800 1 EEST}
{2677010400 7200 0 EET}
{2689714800 10800 1 EEST}
{2708460000 7200 0 EET}
{2721164400 10800 1 EEST}
{2739909600 7200 0 EET}
{2752614000 10800 1 EEST}
{2771359200 7200 0 EET}
{2784668400 10800 1 EEST}
{2802808800 7200 0 EET}
{2816118000 10800 1 EEST}
{2834258400 7200 0 EET}
{2847567600 10800 1 EEST}
{2866312800 7200 0 EET}
{2879017200 10800 1 EEST}
{2897762400 7200 0 EET}
{2910466800 10800 1 EEST}
{2929212000 7200 0 EET}
{2941916400 10800 1 EEST}
{2960661600 7200 0 EET}
{2973970800 10800 1 EEST}
{2992111200 7200 0 EET}
{3005420400 10800 1 EEST}
{3024165600 7200 0 EET}
{3036870000 10800 1 EEST}
{3055615200 7200 0 EET}
{3068319600 10800 1 EEST}
{3087064800 7200 0 EET}
{3099769200 10800 1 EEST}
{3118514400 7200 0 EET}
{3131823600 10800 1 EEST}
{3149964000 7200 0 EET}
{3163273200 10800 1 EEST}
{3181413600 7200 0 EET}
{3194722800 10800 1 EEST}
{3213468000 7200 0 EET}
{3226172400 10800 1 EEST}
{3244917600 7200 0 EET}
{3257622000 10800 1 EEST}
{3276367200 7200 0 EET}
{3289071600 10800 1 EEST}
{3307816800 7200 0 EET}
{3321126000 10800 1 EEST}
{3339266400 7200 0 EET}
{3352575600 10800 1 EEST}
{3371320800 7200 0 EET}
{3384025200 10800 1 EEST}
{3402770400 7200 0 EET}
|
| ︙ | ︙ | |||
240 241 242 243 244 245 246 |
{3528568800 7200 0 EET}
{3541878000 10800 1 EEST}
{3560623200 7200 0 EET}
{3573327600 10800 1 EEST}
{3592072800 7200 0 EET}
{3604777200 10800 1 EEST}
{3623522400 7200 0 EET}
| | | | | 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 |
{3528568800 7200 0 EET}
{3541878000 10800 1 EEST}
{3560623200 7200 0 EET}
{3573327600 10800 1 EEST}
{3592072800 7200 0 EET}
{3604777200 10800 1 EEST}
{3623522400 7200 0 EET}
{3636226800 10800 1 EEST}
{3654972000 7200 0 EET}
{3668281200 10800 1 EEST}
{3686421600 7200 0 EET}
{3699730800 10800 1 EEST}
{3717871200 7200 0 EET}
{3731180400 10800 1 EEST}
{3749925600 7200 0 EET}
{3762630000 10800 1 EEST}
{3781375200 7200 0 EET}
{3794079600 10800 1 EEST}
{3812824800 7200 0 EET}
{3825529200 10800 1 EEST}
{3844274400 7200 0 EET}
{3857583600 10800 1 EEST}
{3875724000 7200 0 EET}
{3889033200 10800 1 EEST}
{3907778400 7200 0 EET}
{3920482800 10800 1 EEST}
{3939228000 7200 0 EET}
{3951932400 10800 1 EEST}
{3970677600 7200 0 EET}
{3983382000 10800 1 EEST}
{4002127200 7200 0 EET}
{4015436400 10800 1 EEST}
{4033576800 7200 0 EET}
{4046886000 10800 1 EEST}
{4065026400 7200 0 EET}
{4078335600 10800 1 EEST}
{4097080800 7200 0 EET}
}
|
Changes to library/tzdata/Asia/Hong_Kong.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Hong_Kong) {
{-9223372036854775808 27402 0 LMT}
| | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Hong_Kong) {
{-9223372036854775808 27402 0 LMT}
{-2056690800 28800 0 HKT}
{-900909000 32400 1 HKST}
{-891579600 30600 0 HKT}
{-884248200 32400 0 JST}
{-766659600 28800 0 HKT}
{-747981000 32400 1 HKST}
{-728544600 28800 0 HKT}
{-717049800 32400 1 HKST}
{-694503000 28800 0 HKT}
{-683785800 32400 1 HKST}
{-668064600 28800 0 HKT}
{-654755400 32400 1 HKST}
{-636615000 28800 0 HKT}
{-623305800 32400 1 HKST}
{-605165400 28800 0 HKT}
{-591856200 32400 1 HKST}
{-573715800 28800 0 HKT}
{-559801800 32400 1 HKST}
{-541661400 28800 0 HKT}
{-528352200 32400 1 HKST}
{-510211800 28800 0 HKT}
{-498112200 32400 1 HKST}
{-478762200 28800 0 HKT}
{-466662600 32400 1 HKST}
{-446707800 28800 0 HKT}
{-435213000 32400 1 HKST}
|
| ︙ | ︙ |
Changes to library/tzdata/Asia/Hovd.
1 2 3 4 5 6 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Hovd) {
{-9223372036854775808 21996 0 LMT}
{-2032927596 21600 0 +06}
{252439200 25200 0 +07}
| | | | | | | | | | | | | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Hovd) {
{-9223372036854775808 21996 0 LMT}
{-2032927596 21600 0 +06}
{252439200 25200 0 +07}
{417978000 28800 1 +07}
{433785600 25200 0 +07}
{449600400 28800 1 +07}
{465321600 25200 0 +07}
{481050000 28800 1 +07}
{496771200 25200 0 +07}
{512499600 28800 1 +07}
{528220800 25200 0 +07}
{543949200 28800 1 +07}
{559670400 25200 0 +07}
{575398800 28800 1 +07}
{591120000 25200 0 +07}
{606848400 28800 1 +07}
{622569600 25200 0 +07}
{638298000 28800 1 +07}
{654624000 25200 0 +07}
{670352400 28800 1 +07}
{686073600 25200 0 +07}
{701802000 28800 1 +07}
{717523200 25200 0 +07}
{733251600 28800 1 +07}
{748972800 25200 0 +07}
{764701200 28800 1 +07}
{780422400 25200 0 +07}
{796150800 28800 1 +07}
{811872000 25200 0 +07}
{828205200 28800 1 +07}
{843926400 25200 0 +07}
{859654800 28800 1 +07}
{875376000 25200 0 +07}
{891104400 28800 1 +07}
{906825600 25200 0 +07}
{988398000 28800 1 +07}
{1001700000 25200 0 +07}
{1017428400 28800 1 +07}
{1033149600 25200 0 +07}
{1048878000 28800 1 +07}
{1064599200 25200 0 +07}
{1080327600 28800 1 +07}
{1096048800 25200 0 +07}
{1111777200 28800 1 +07}
{1127498400 25200 0 +07}
{1143226800 28800 1 +07}
{1159552800 25200 0 +07}
{1427482800 28800 1 +07}
{1443196800 25200 0 +07}
{1458932400 28800 1 +07}
{1474646400 25200 0 +07}
}
|
Changes to library/tzdata/Asia/Jerusalem.
| ︙ | ︙ | |||
35 36 37 38 39 40 41 42 43 44 45 46 47 48 |
{-418262400 7200 0 IST}
{-400032000 10800 1 IDT}
{-387428400 7200 0 IST}
{142380000 10800 1 IDT}
{150843600 7200 0 IST}
{167176800 10800 1 IDT}
{178664400 7200 0 IST}
{482277600 10800 1 IDT}
{495579600 7200 0 IST}
{516751200 10800 1 IDT}
{526424400 7200 0 IST}
{545436000 10800 1 IDT}
{558478800 7200 0 IST}
{576626400 10800 1 IDT}
| > > > > | 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 |
{-418262400 7200 0 IST}
{-400032000 10800 1 IDT}
{-387428400 7200 0 IST}
{142380000 10800 1 IDT}
{150843600 7200 0 IST}
{167176800 10800 1 IDT}
{178664400 7200 0 IST}
{334015200 10800 1 IDT}
{337644000 7200 0 IST}
{452556000 10800 1 IDT}
{462232800 7200 0 IST}
{482277600 10800 1 IDT}
{495579600 7200 0 IST}
{516751200 10800 1 IDT}
{526424400 7200 0 IST}
{545436000 10800 1 IDT}
{558478800 7200 0 IST}
{576626400 10800 1 IDT}
|
| ︙ | ︙ |
Changes to library/tzdata/Asia/Kuching.
1 2 3 4 5 6 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Kuching) {
{-9223372036854775808 26480 0 LMT}
{-1383463280 27000 0 +0730}
{-1167636600 28800 0 +08}
| | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Kuching) {
{-9223372036854775808 26480 0 LMT}
{-1383463280 27000 0 +0730}
{-1167636600 28800 0 +08}
{-1082448000 30000 1 +08}
{-1074586800 28800 0 +08}
{-1050825600 30000 1 +08}
{-1042964400 28800 0 +08}
{-1019289600 30000 1 +08}
{-1011428400 28800 0 +08}
{-987753600 30000 1 +08}
{-979892400 28800 0 +08}
{-956217600 30000 1 +08}
{-948356400 28800 0 +08}
{-924595200 30000 1 +08}
{-916734000 28800 0 +08}
{-893059200 30000 1 +08}
{-885198000 28800 0 +08}
{-879667200 32400 0 +09}
{-767005200 28800 0 +08}
}
|
Changes to library/tzdata/Asia/Macau.
1 2 3 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Macau) {
| | > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | | | | | | < < < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Macau) {
{-9223372036854775808 27250 0 LMT}
{-2056692850 28800 0 CST}
{-884509200 32400 0 +09}
{-873280800 36000 1 +09}
{-855918000 32400 0 +09}
{-841744800 36000 1 +09}
{-828529200 32400 0 +10}
{-765363600 28800 0 CT}
{-747046800 32400 1 CDT}
{-733827600 28800 0 CST}
{-716461200 32400 1 CDT}
{-697021200 28800 0 CST}
{-683715600 32400 1 CDT}
{-667990800 28800 0 CST}
{-654771600 32400 1 CDT}
{-636627600 28800 0 CST}
{-623322000 32400 1 CDT}
{-605178000 28800 0 CST}
{-591872400 32400 1 CDT}
{-573642000 28800 0 CST}
{-559818000 32400 1 CDT}
{-541674000 28800 0 CST}
{-528368400 32400 1 CDT}
{-510224400 28800 0 CST}
{-498128400 32400 1 CDT}
{-478774800 28800 0 CST}
{-466678800 32400 1 CDT}
{-446720400 28800 0 CST}
{-435229200 32400 1 CDT}
{-415258200 28800 0 CST}
{-403158600 32400 1 CDT}
{-383808600 28800 0 CST}
{-371709000 32400 1 CDT}
{-352359000 28800 0 CST}
{-340259400 32400 1 CDT}
{-320909400 28800 0 CST}
{-308809800 32400 1 CDT}
{-288855000 28800 0 CST}
{-277360200 32400 1 CDT}
{-257405400 28800 0 CST}
{-245910600 32400 1 CDT}
{-225955800 28800 0 CST}
{-213856200 32400 1 CDT}
{-194506200 28800 0 CST}
{-182406600 32400 1 CDT}
{-163056600 28800 0 CST}
{-148537800 32400 1 CDT}
{-132820200 28800 0 CST}
{-117088200 32400 1 CDT}
{-101370600 28800 0 CST}
{-85638600 32400 1 CDT}
{-69312600 28800 0 CST}
{-53584200 32400 1 CDT}
{-37863000 28800 0 CST}
{-22134600 32400 1 CDT}
{-6413400 28800 0 CST}
{9315000 32400 1 CDT}
{25036200 28800 0 CST}
{40764600 32400 1 CDT}
{56485800 28800 0 CST}
{72214200 32400 1 CDT}
{88540200 28800 0 CST}
{104268600 32400 1 CDT}
{119989800 28800 0 CST}
{126041400 32400 1 CDT}
{151439400 28800 0 CST}
{167167800 32400 1 CDT}
{182889000 28800 0 CST}
{198617400 32400 1 CDT}
{214338600 28800 0 CST}
{295385400 32400 1 CDT}
{309292200 28800 0 CST}
}
|
Changes to library/tzdata/Asia/Manila.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Manila) {
{-9223372036854775808 -57360 0 LMT}
{-3944621040 29040 0 LMT}
| | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Manila) {
{-9223372036854775808 -57360 0 LMT}
{-3944621040 29040 0 LMT}
{-2229321840 28800 0 PST}
{-1046678400 32400 1 PDT}
{-1038733200 28800 0 PST}
{-873273600 32400 0 JST}
{-794221200 28800 0 PST}
{-496224000 32400 1 PDT}
{-489315600 28800 0 PST}
{259344000 32400 1 PDT}
{275151600 28800 0 PST}
}
|
Changes to library/tzdata/Asia/Oral.
1 2 3 4 5 6 7 8 9 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Oral) {
{-9223372036854775808 12324 0 LMT}
{-1441164324 10800 0 +03}
{-1247540400 18000 0 +05}
{354913200 21600 1 +06}
{370720800 21600 0 +06}
{386445600 18000 0 +05}
| | | | | | | | | | | | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Oral) {
{-9223372036854775808 12324 0 LMT}
{-1441164324 10800 0 +03}
{-1247540400 18000 0 +05}
{354913200 21600 1 +06}
{370720800 21600 0 +06}
{386445600 18000 0 +05}
{386449200 21600 1 +05}
{402256800 18000 0 +05}
{417985200 21600 1 +05}
{433792800 18000 0 +05}
{449607600 21600 1 +05}
{465339600 18000 0 +05}
{481064400 21600 1 +05}
{496789200 18000 0 +05}
{512514000 21600 1 +05}
{528238800 18000 0 +05}
{543963600 21600 1 +05}
{559688400 18000 0 +05}
{575413200 21600 1 +05}
{591138000 18000 0 +05}
{606862800 14400 0 +04}
{606866400 18000 1 +04}
{622591200 14400 0 +04}
{638316000 18000 1 +04}
{654645600 14400 0 +04}
{670370400 18000 1 +04}
{686095200 14400 0 +04}
{701816400 14400 0 +04}
{701820000 18000 1 +04}
{717544800 14400 0 +04}
{733269600 18000 1 +04}
{748994400 14400 0 +04}
{764719200 18000 1 +04}
{780444000 14400 0 +04}
{796168800 18000 1 +04}
{811893600 14400 0 +04}
{828223200 18000 1 +04}
{846367200 14400 0 +04}
{859672800 18000 1 +04}
{877816800 14400 0 +04}
{891122400 18000 1 +04}
{909266400 14400 0 +04}
{922572000 18000 1 +04}
{941320800 14400 0 +04}
{954021600 18000 1 +04}
{972770400 14400 0 +04}
{985471200 18000 1 +04}
{1004220000 14400 0 +04}
{1017525600 18000 1 +04}
{1035669600 14400 0 +04}
{1048975200 18000 1 +04}
{1067119200 14400 0 +04}
{1080424800 18000 1 +04}
{1099173600 18000 0 +05}
}
|
Changes to library/tzdata/Asia/Pyongyang.
1 2 3 4 5 6 7 8 9 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Pyongyang) {
{-9223372036854775808 30180 0 LMT}
{-1948782180 30600 0 KST}
{-1830414600 32400 0 JST}
{-768646800 32400 0 KST}
{1439564400 30600 0 KST}
}
| > | 1 2 3 4 5 6 7 8 9 10 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Pyongyang) {
{-9223372036854775808 30180 0 LMT}
{-1948782180 30600 0 KST}
{-1830414600 32400 0 JST}
{-768646800 32400 0 KST}
{1439564400 30600 0 KST}
{1525446000 32400 0 KST}
}
|
Added library/tzdata/Asia/Qostanay.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Qostanay) {
{-9223372036854775808 15268 0 LMT}
{-1441167268 14400 0 +04}
{-1247544000 18000 0 +05}
{354913200 21600 1 +06}
{370720800 21600 0 +06}
{386445600 18000 0 +05}
{386449200 21600 1 +05}
{402256800 18000 0 +05}
{417985200 21600 1 +05}
{433792800 18000 0 +05}
{449607600 21600 1 +05}
{465339600 18000 0 +05}
{481064400 21600 1 +05}
{496789200 18000 0 +05}
{512514000 21600 1 +05}
{528238800 18000 0 +05}
{543963600 21600 1 +05}
{559688400 18000 0 +05}
{575413200 21600 1 +05}
{591138000 18000 0 +05}
{606862800 21600 1 +05}
{622587600 18000 0 +05}
{638312400 21600 1 +05}
{654642000 18000 0 +05}
{670366800 14400 0 +04}
{670370400 18000 1 +04}
{686095200 14400 0 +04}
{695772000 18000 0 +05}
{701816400 21600 1 +05}
{717541200 18000 0 +05}
{733266000 21600 1 +05}
{748990800 18000 0 +05}
{764715600 21600 1 +05}
{780440400 18000 0 +05}
{796165200 21600 1 +05}
{811890000 18000 0 +05}
{828219600 21600 1 +05}
{846363600 18000 0 +05}
{859669200 21600 1 +05}
{877813200 18000 0 +05}
{891118800 21600 1 +05}
{909262800 18000 0 +05}
{922568400 21600 1 +05}
{941317200 18000 0 +05}
{954018000 21600 1 +05}
{972766800 18000 0 +05}
{985467600 21600 1 +05}
{1004216400 18000 0 +05}
{1017522000 21600 1 +05}
{1035666000 18000 0 +05}
{1048971600 21600 1 +05}
{1067115600 18000 0 +05}
{1080421200 21600 1 +05}
{1099170000 21600 0 +06}
}
|
Changes to library/tzdata/Asia/Qyzylorda.
1 2 3 4 5 6 7 8 9 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Qyzylorda) {
{-9223372036854775808 15712 0 LMT}
{-1441167712 14400 0 +04}
{-1247544000 18000 0 +05}
{354913200 21600 1 +06}
{370720800 21600 0 +06}
{386445600 18000 0 +05}
| | | | | | | | | | | | | | | | | | | | | | | | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Qyzylorda) {
{-9223372036854775808 15712 0 LMT}
{-1441167712 14400 0 +04}
{-1247544000 18000 0 +05}
{354913200 21600 1 +06}
{370720800 21600 0 +06}
{386445600 18000 0 +05}
{386449200 21600 1 +05}
{402256800 18000 0 +05}
{417985200 21600 1 +05}
{433792800 18000 0 +05}
{449607600 21600 1 +05}
{465339600 18000 0 +05}
{481064400 21600 1 +05}
{496789200 18000 0 +05}
{512514000 21600 1 +05}
{528238800 18000 0 +05}
{543963600 21600 1 +05}
{559688400 18000 0 +05}
{575413200 21600 1 +05}
{591138000 18000 0 +05}
{606862800 21600 1 +05}
{622587600 18000 0 +05}
{638312400 21600 1 +05}
{654642000 18000 0 +05}
{670366800 14400 0 +04}
{670370400 18000 1 +04}
{701812800 18000 0 +05}
{701816400 21600 1 +05}
{717541200 18000 0 +05}
{733266000 21600 1 +05}
{748990800 18000 0 +05}
{764715600 21600 1 +05}
{780440400 18000 0 +05}
{796165200 21600 1 +05}
{811890000 18000 0 +05}
{828219600 21600 1 +05}
{846363600 18000 0 +05}
{859669200 21600 1 +05}
{877813200 18000 0 +05}
{891118800 21600 1 +05}
{909262800 18000 0 +05}
{922568400 21600 1 +05}
{941317200 18000 0 +05}
{954018000 21600 1 +05}
{972766800 18000 0 +05}
{985467600 21600 1 +05}
{1004216400 18000 0 +05}
{1017522000 21600 1 +05}
{1035666000 18000 0 +05}
{1048971600 21600 1 +05}
{1067115600 18000 0 +05}
{1080421200 21600 1 +05}
{1099170000 21600 0 +06}
{1545328800 18000 0 +05}
}
|
Changes to library/tzdata/Asia/Samarkand.
1 2 3 4 5 6 7 8 9 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Samarkand) {
{-9223372036854775808 16073 0 LMT}
{-1441168073 14400 0 +04}
{-1247544000 18000 0 +05}
{354913200 21600 1 +06}
{370720800 21600 0 +06}
{386445600 18000 0 +05}
| | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Samarkand) {
{-9223372036854775808 16073 0 LMT}
{-1441168073 14400 0 +04}
{-1247544000 18000 0 +05}
{354913200 21600 1 +06}
{370720800 21600 0 +06}
{386445600 18000 0 +05}
{386449200 21600 1 +05}
{402256800 18000 0 +05}
{417985200 21600 1 +05}
{433792800 18000 0 +05}
{449607600 21600 1 +05}
{465339600 18000 0 +05}
{481064400 21600 1 +05}
{496789200 18000 0 +05}
{512514000 21600 1 +05}
{528238800 18000 0 +05}
{543963600 21600 1 +05}
{559688400 18000 0 +05}
{575413200 21600 1 +05}
{591138000 18000 0 +05}
{606862800 21600 1 +05}
{622587600 18000 0 +05}
{638312400 21600 1 +05}
{654642000 18000 0 +05}
{670366800 21600 1 +05}
{686091600 18000 0 +05}
{694206000 18000 0 +05}
}
|
Changes to library/tzdata/Asia/Shanghai.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Shanghai) {
{-9223372036854775808 29143 0 LMT}
{-2177481943 28800 0 CST}
| | | | | > | | | | | | > > > > | | | | | | | > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Shanghai) {
{-9223372036854775808 29143 0 LMT}
{-2177481943 28800 0 CST}
{-933667200 32400 1 CDT}
{-922093200 28800 0 CST}
{-908870400 32400 1 CDT}
{-888829200 28800 0 CST}
{-881049600 32400 1 CDT}
{-767869200 28800 0 CST}
{-745833600 32400 1 CDT}
{-733827600 28800 0 CST}
{-716889600 32400 1 CDT}
{-699613200 28800 0 CST}
{-683884800 32400 1 CDT}
{-670669200 28800 0 CST}
{-652348800 32400 1 CDT}
{-650016000 28800 0 CST}
{515527200 32400 1 CDT}
{527014800 28800 0 CST}
{545162400 32400 1 CDT}
{558464400 28800 0 CST}
{577216800 32400 1 CDT}
{589914000 28800 0 CST}
{608666400 32400 1 CDT}
{621968400 28800 0 CST}
{640116000 32400 1 CDT}
{653418000 28800 0 CST}
{671565600 32400 1 CDT}
{684867600 28800 0 CST}
}
|
Changes to library/tzdata/Asia/Tashkent.
1 2 3 4 5 6 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Tashkent) {
{-9223372036854775808 16631 0 LMT}
{-1441168631 18000 0 +05}
{-1247547600 21600 0 +06}
| | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Tashkent) {
{-9223372036854775808 16631 0 LMT}
{-1441168631 18000 0 +05}
{-1247547600 21600 0 +06}
{354909600 25200 1 +06}
{370717200 21600 0 +06}
{386445600 25200 1 +06}
{402253200 21600 0 +06}
{417981600 25200 1 +06}
{433789200 21600 0 +06}
{449604000 25200 1 +06}
{465336000 21600 0 +06}
{481060800 25200 1 +06}
{496785600 21600 0 +06}
{512510400 25200 1 +06}
{528235200 21600 0 +06}
{543960000 25200 1 +06}
{559684800 21600 0 +06}
{575409600 25200 1 +06}
{591134400 21600 0 +06}
{606859200 25200 1 +06}
{622584000 21600 0 +06}
{638308800 25200 1 +06}
{654638400 21600 0 +06}
{670363200 18000 0 +05}
{670366800 21600 1 +05}
{686091600 18000 0 +05}
{694206000 18000 0 +05}
}
|
Changes to library/tzdata/Asia/Tbilisi.
1 2 3 4 5 6 7 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Tbilisi) {
{-9223372036854775808 10751 0 LMT}
{-2840151551 10751 0 TBMT}
{-1441162751 10800 0 +03}
{-405140400 14400 0 +04}
| | | | | | | | | | | | | | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Tbilisi) {
{-9223372036854775808 10751 0 LMT}
{-2840151551 10751 0 TBMT}
{-1441162751 10800 0 +03}
{-405140400 14400 0 +04}
{354916800 18000 1 +04}
{370724400 14400 0 +04}
{386452800 18000 1 +04}
{402260400 14400 0 +04}
{417988800 18000 1 +04}
{433796400 14400 0 +04}
{449611200 18000 1 +04}
{465343200 14400 0 +04}
{481068000 18000 1 +04}
{496792800 14400 0 +04}
{512517600 18000 1 +04}
{528242400 14400 0 +04}
{543967200 18000 1 +04}
{559692000 14400 0 +04}
{575416800 18000 1 +04}
{591141600 14400 0 +04}
{606866400 18000 1 +04}
{622591200 14400 0 +04}
{638316000 18000 1 +04}
{654645600 14400 0 +04}
{670370400 10800 0 +03}
{670374000 14400 1 +03}
{686098800 10800 0 +03}
{694213200 10800 0 +03}
{701816400 14400 1 +03}
{717537600 10800 0 +03}
{733266000 14400 1 +03}
{748987200 10800 0 +03}
{764715600 14400 1 +03}
{780440400 14400 0 +04}
{796161600 18000 1 +04}
{811882800 14400 0 +04}
{828216000 18000 1 +04}
{846360000 18000 1 +05}
{859662000 18000 0 +04}
{877806000 14400 0 +04}
{891115200 18000 1 +04}
{909255600 14400 0 +04}
{922564800 18000 1 +04}
{941310000 14400 0 +04}
{954014400 18000 1 +04}
{972759600 14400 0 +04}
{985464000 18000 1 +04}
{1004209200 14400 0 +04}
{1017518400 18000 1 +04}
{1035658800 14400 0 +04}
{1048968000 18000 1 +04}
{1067108400 14400 0 +04}
{1080417600 18000 1 +04}
{1088280000 14400 0 +03}
{1099177200 10800 0 +03}
{1111878000 14400 0 +04}
}
|
Changes to library/tzdata/Asia/Tehran.
1 2 3 4 5 6 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Tehran) {
{-9223372036854775808 12344 0 LMT}
{-1704165944 12344 0 TMT}
{-757394744 12600 0 +0330}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Tehran) {
{-9223372036854775808 12344 0 LMT}
{-1704165944 12344 0 TMT}
{-757394744 12600 0 +0330}
{247177800 14400 0 +04}
{259272000 18000 1 +04}
{277758000 14400 0 +04}
{283982400 12600 0 +0330}
{290809800 16200 1 +0330}
{306531000 12600 0 +0330}
{322432200 16200 1 +0330}
{338499000 12600 0 +0330}
{673216200 16200 1 +0330}
{685481400 12600 0 +0330}
{701209800 16200 1 +0330}
{717103800 12600 0 +0330}
{732745800 16200 1 +0330}
{748639800 12600 0 +0330}
{764281800 16200 1 +0330}
{780175800 12600 0 +0330}
{795817800 16200 1 +0330}
{811711800 12600 0 +0330}
{827353800 16200 1 +0330}
{843247800 12600 0 +0330}
{858976200 16200 1 +0330}
{874870200 12600 0 +0330}
{890512200 16200 1 +0330}
{906406200 12600 0 +0330}
{922048200 16200 1 +0330}
{937942200 12600 0 +0330}
{953584200 16200 1 +0330}
{969478200 12600 0 +0330}
{985206600 16200 1 +0330}
{1001100600 12600 0 +0330}
{1016742600 16200 1 +0330}
{1032636600 12600 0 +0330}
{1048278600 16200 1 +0330}
{1064172600 12600 0 +0330}
{1079814600 16200 1 +0330}
{1095708600 12600 0 +0330}
{1111437000 16200 1 +0330}
{1127331000 12600 0 +0330}
{1206045000 16200 1 +0330}
{1221939000 12600 0 +0330}
{1237667400 16200 1 +0330}
{1253561400 12600 0 +0330}
{1269203400 16200 1 +0330}
{1285097400 12600 0 +0330}
{1300739400 16200 1 +0330}
{1316633400 12600 0 +0330}
{1332275400 16200 1 +0330}
{1348169400 12600 0 +0330}
{1363897800 16200 1 +0330}
{1379791800 12600 0 +0330}
{1395433800 16200 1 +0330}
{1411327800 12600 0 +0330}
{1426969800 16200 1 +0330}
{1442863800 12600 0 +0330}
{1458505800 16200 1 +0330}
{1474399800 12600 0 +0330}
{1490128200 16200 1 +0330}
{1506022200 12600 0 +0330}
{1521664200 16200 1 +0330}
{1537558200 12600 0 +0330}
{1553200200 16200 1 +0330}
{1569094200 12600 0 +0330}
{1584736200 16200 1 +0330}
{1600630200 12600 0 +0330}
{1616358600 16200 1 +0330}
{1632252600 12600 0 +0330}
{1647894600 16200 1 +0330}
{1663788600 12600 0 +0330}
{1679430600 16200 1 +0330}
{1695324600 12600 0 +0330}
{1710966600 16200 1 +0330}
{1726860600 12600 0 +0330}
{1742589000 16200 1 +0330}
{1758483000 12600 0 +0330}
{1774125000 16200 1 +0330}
{1790019000 12600 0 +0330}
{1805661000 16200 1 +0330}
{1821555000 12600 0 +0330}
{1837197000 16200 1 +0330}
{1853091000 12600 0 +0330}
{1868733000 16200 1 +0330}
{1884627000 12600 0 +0330}
{1900355400 16200 1 +0330}
{1916249400 12600 0 +0330}
{1931891400 16200 1 +0330}
{1947785400 12600 0 +0330}
{1963427400 16200 1 +0330}
{1979321400 12600 0 +0330}
{1994963400 16200 1 +0330}
{2010857400 12600 0 +0330}
{2026585800 16200 1 +0330}
{2042479800 12600 0 +0330}
{2058121800 16200 1 +0330}
{2074015800 12600 0 +0330}
{2089657800 16200 1 +0330}
{2105551800 12600 0 +0330}
{2121193800 16200 1 +0330}
{2137087800 12600 0 +0330}
{2152816200 16200 1 +0330}
{2168710200 12600 0 +0330}
{2184352200 16200 1 +0330}
{2200246200 12600 0 +0330}
{2215888200 16200 1 +0330}
{2231782200 12600 0 +0330}
{2247424200 16200 1 +0330}
{2263318200 12600 0 +0330}
{2279046600 16200 1 +0330}
{2294940600 12600 0 +0330}
{2310582600 16200 1 +0330}
{2326476600 12600 0 +0330}
{2342118600 16200 1 +0330}
{2358012600 12600 0 +0330}
{2373654600 16200 1 +0330}
{2389548600 12600 0 +0330}
{2405277000 16200 1 +0330}
{2421171000 12600 0 +0330}
{2436813000 16200 1 +0330}
{2452707000 12600 0 +0330}
{2468349000 16200 1 +0330}
{2484243000 12600 0 +0330}
{2499885000 16200 1 +0330}
{2515779000 12600 0 +0330}
{2531507400 16200 1 +0330}
{2547401400 12600 0 +0330}
{2563043400 16200 1 +0330}
{2578937400 12600 0 +0330}
{2594579400 16200 1 +0330}
{2610473400 12600 0 +0330}
{2626115400 16200 1 +0330}
{2642009400 12600 0 +0330}
{2657737800 16200 1 +0330}
{2673631800 12600 0 +0330}
{2689273800 16200 1 +0330}
{2705167800 12600 0 +0330}
{2720809800 16200 1 +0330}
{2736703800 12600 0 +0330}
{2752345800 16200 1 +0330}
{2768239800 12600 0 +0330}
{2783968200 16200 1 +0330}
{2799862200 12600 0 +0330}
{2815504200 16200 1 +0330}
{2831398200 12600 0 +0330}
{2847040200 16200 1 +0330}
{2862934200 12600 0 +0330}
{2878576200 16200 1 +0330}
{2894470200 12600 0 +0330}
{2910112200 16200 1 +0330}
{2926006200 12600 0 +0330}
{2941734600 16200 1 +0330}
{2957628600 12600 0 +0330}
{2973270600 16200 1 +0330}
{2989164600 12600 0 +0330}
{3004806600 16200 1 +0330}
{3020700600 12600 0 +0330}
{3036342600 16200 1 +0330}
{3052236600 12600 0 +0330}
{3067965000 16200 1 +0330}
{3083859000 12600 0 +0330}
{3099501000 16200 1 +0330}
{3115395000 12600 0 +0330}
{3131037000 16200 1 +0330}
{3146931000 12600 0 +0330}
{3162573000 16200 1 +0330}
{3178467000 12600 0 +0330}
{3194195400 16200 1 +0330}
{3210089400 12600 0 +0330}
{3225731400 16200 1 +0330}
{3241625400 12600 0 +0330}
{3257267400 16200 1 +0330}
{3273161400 12600 0 +0330}
{3288803400 16200 1 +0330}
{3304697400 12600 0 +0330}
{3320425800 16200 1 +0330}
{3336319800 12600 0 +0330}
{3351961800 16200 1 +0330}
{3367855800 12600 0 +0330}
{3383497800 16200 1 +0330}
{3399391800 12600 0 +0330}
{3415033800 16200 1 +0330}
{3430927800 12600 0 +0330}
{3446656200 16200 1 +0330}
{3462550200 12600 0 +0330}
{3478192200 16200 1 +0330}
{3494086200 12600 0 +0330}
{3509728200 16200 1 +0330}
{3525622200 12600 0 +0330}
{3541264200 16200 1 +0330}
{3557158200 12600 0 +0330}
{3572886600 16200 1 +0330}
{3588780600 12600 0 +0330}
{3604422600 16200 1 +0330}
{3620316600 12600 0 +0330}
{3635958600 16200 1 +0330}
{3651852600 12600 0 +0330}
{3667494600 16200 1 +0330}
{3683388600 12600 0 +0330}
{3699117000 16200 1 +0330}
{3715011000 12600 0 +0330}
{3730653000 16200 1 +0330}
{3746547000 12600 0 +0330}
{3762189000 16200 1 +0330}
{3778083000 12600 0 +0330}
{3793725000 16200 1 +0330}
{3809619000 12600 0 +0330}
{3825261000 16200 1 +0330}
{3841155000 12600 0 +0330}
{3856883400 16200 1 +0330}
{3872777400 12600 0 +0330}
{3888419400 16200 1 +0330}
{3904313400 12600 0 +0330}
{3919955400 16200 1 +0330}
{3935849400 12600 0 +0330}
{3951491400 16200 1 +0330}
{3967385400 12600 0 +0330}
{3983113800 16200 1 +0330}
{3999007800 12600 0 +0330}
{4014649800 16200 1 +0330}
{4030543800 12600 0 +0330}
{4046185800 16200 1 +0330}
{4062079800 12600 0 +0330}
{4077721800 16200 1 +0330}
{4093615800 12600 0 +0330}
}
|
Changes to library/tzdata/Asia/Tokyo.
1 2 3 4 5 6 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Tokyo) {
{-9223372036854775808 33539 0 LMT}
{-2587712400 32400 0 JST}
{-683802000 36000 1 JDT}
| | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Tokyo) {
{-9223372036854775808 33539 0 LMT}
{-2587712400 32400 0 JST}
{-683802000 36000 1 JDT}
{-672310800 32400 0 JST}
{-654771600 36000 1 JDT}
{-640861200 32400 0 JST}
{-620298000 36000 1 JDT}
{-609411600 32400 0 JST}
{-588848400 36000 1 JDT}
{-577962000 32400 0 JST}
}
|
Changes to library/tzdata/Asia/Ulaanbaatar.
1 2 3 4 5 6 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Ulaanbaatar) {
{-9223372036854775808 25652 0 LMT}
{-2032931252 25200 0 +07}
{252435600 28800 0 +08}
| | | | | | | | | | | | | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Ulaanbaatar) {
{-9223372036854775808 25652 0 LMT}
{-2032931252 25200 0 +07}
{252435600 28800 0 +08}
{417974400 32400 1 +08}
{433782000 28800 0 +08}
{449596800 32400 1 +08}
{465318000 28800 0 +08}
{481046400 32400 1 +08}
{496767600 28800 0 +08}
{512496000 32400 1 +08}
{528217200 28800 0 +08}
{543945600 32400 1 +08}
{559666800 28800 0 +08}
{575395200 32400 1 +08}
{591116400 28800 0 +08}
{606844800 32400 1 +08}
{622566000 28800 0 +08}
{638294400 32400 1 +08}
{654620400 28800 0 +08}
{670348800 32400 1 +08}
{686070000 28800 0 +08}
{701798400 32400 1 +08}
{717519600 28800 0 +08}
{733248000 32400 1 +08}
{748969200 28800 0 +08}
{764697600 32400 1 +08}
{780418800 28800 0 +08}
{796147200 32400 1 +08}
{811868400 28800 0 +08}
{828201600 32400 1 +08}
{843922800 28800 0 +08}
{859651200 32400 1 +08}
{875372400 28800 0 +08}
{891100800 32400 1 +08}
{906822000 28800 0 +08}
{988394400 32400 1 +08}
{1001696400 28800 0 +08}
{1017424800 32400 1 +08}
{1033146000 28800 0 +08}
{1048874400 32400 1 +08}
{1064595600 28800 0 +08}
{1080324000 32400 1 +08}
{1096045200 28800 0 +08}
{1111773600 32400 1 +08}
{1127494800 28800 0 +08}
{1143223200 32400 1 +08}
{1159549200 28800 0 +08}
{1427479200 32400 1 +08}
{1443193200 28800 0 +08}
{1458928800 32400 1 +08}
{1474642800 28800 0 +08}
}
|
Changes to library/tzdata/Asia/Yerevan.
1 2 3 4 5 6 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Yerevan) {
{-9223372036854775808 10680 0 LMT}
{-1441162680 10800 0 +03}
{-405140400 14400 0 +04}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Yerevan) {
{-9223372036854775808 10680 0 LMT}
{-1441162680 10800 0 +03}
{-405140400 14400 0 +04}
{354916800 18000 1 +04}
{370724400 14400 0 +04}
{386452800 18000 1 +04}
{402260400 14400 0 +04}
{417988800 18000 1 +04}
{433796400 14400 0 +04}
{449611200 18000 1 +04}
{465343200 14400 0 +04}
{481068000 18000 1 +04}
{496792800 14400 0 +04}
{512517600 18000 1 +04}
{528242400 14400 0 +04}
{543967200 18000 1 +04}
{559692000 14400 0 +04}
{575416800 18000 1 +04}
{591141600 14400 0 +04}
{606866400 18000 1 +04}
{622591200 14400 0 +04}
{638316000 18000 1 +04}
{654645600 14400 0 +04}
{670370400 10800 0 +03}
{670374000 14400 1 +03}
{686098800 10800 0 +03}
{701823600 14400 1 +03}
{717548400 10800 0 +03}
{733273200 14400 1 +03}
{748998000 10800 0 +03}
{764722800 14400 1 +03}
{780447600 10800 0 +03}
{796172400 14400 1 +03}
{811897200 14400 0 +04}
{852062400 14400 0 +04}
{859672800 18000 1 +04}
{877816800 14400 0 +04}
{891122400 18000 1 +04}
{909266400 14400 0 +04}
{922572000 18000 1 +04}
{941320800 14400 0 +04}
{954021600 18000 1 +04}
{972770400 14400 0 +04}
{985471200 18000 1 +04}
{1004220000 14400 0 +04}
{1017525600 18000 1 +04}
{1035669600 14400 0 +04}
{1048975200 18000 1 +04}
{1067119200 14400 0 +04}
{1080424800 18000 1 +04}
{1099173600 14400 0 +04}
{1111874400 18000 1 +04}
{1130623200 14400 0 +04}
{1143324000 18000 1 +04}
{1162072800 14400 0 +04}
{1174773600 18000 1 +04}
{1193522400 14400 0 +04}
{1206828000 18000 1 +04}
{1224972000 14400 0 +04}
{1238277600 18000 1 +04}
{1256421600 14400 0 +04}
{1269727200 18000 1 +04}
{1288476000 14400 0 +04}
{1293825600 14400 0 +04}
{1301176800 18000 1 +04}
{1319925600 14400 0 +04}
}
|
Changes to library/tzdata/Atlantic/Azores.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Atlantic/Azores) {
{-9223372036854775808 -6160 0 LMT}
{-2713904240 -6872 0 HMT}
| | | 1 2 3 4 5 6 7 8 9 10 11 12 13 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Atlantic/Azores) {
{-9223372036854775808 -6160 0 LMT}
{-2713904240 -6872 0 HMT}
{-1830376800 -7200 0 -02}
{-1689548400 -3600 1 -01}
{-1677794400 -7200 0 -02}
{-1667430000 -3600 1 -01}
{-1647730800 -7200 0 -02}
{-1635807600 -3600 1 -01}
{-1616194800 -7200 0 -02}
{-1604358000 -3600 1 -01}
|
| ︙ | ︙ |
Changes to library/tzdata/Atlantic/Cape_Verde.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Atlantic/Cape_Verde) {
{-9223372036854775808 -5644 0 LMT}
| | | 1 2 3 4 5 6 7 8 9 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Atlantic/Cape_Verde) {
{-9223372036854775808 -5644 0 LMT}
{-1830376800 -7200 0 -02}
{-862610400 -3600 1 -01}
{-764118000 -7200 0 -02}
{186120000 -3600 0 -01}
}
|
Changes to library/tzdata/Atlantic/Madeira.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Atlantic/Madeira) {
{-9223372036854775808 -4056 0 LMT}
{-2713906344 -4056 0 FMT}
| | | 1 2 3 4 5 6 7 8 9 10 11 12 13 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Atlantic/Madeira) {
{-9223372036854775808 -4056 0 LMT}
{-2713906344 -4056 0 FMT}
{-1830380400 -3600 0 -01}
{-1689552000 0 1 +00}
{-1677798000 -3600 0 -01}
{-1667433600 0 1 +00}
{-1647734400 -3600 0 -01}
{-1635811200 0 1 +00}
{-1616198400 -3600 0 -01}
{-1604361600 0 1 +00}
|
| ︙ | ︙ |
Changes to library/tzdata/Atlantic/Reykjavik.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Atlantic/Reykjavik) {
{-9223372036854775808 -5280 0 LMT}
{-1956609120 -3600 0 -01}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Atlantic/Reykjavik) {
{-9223372036854775808 -5280 0 LMT}
{-1956609120 -3600 0 -01}
{-1668211200 0 1 -01}
{-1647212400 -3600 0 -01}
{-1636675200 0 1 -01}
{-1613430000 -3600 0 -01}
{-1605139200 0 1 -01}
{-1581894000 -3600 0 -01}
{-1539561600 0 1 -01}
{-1531350000 -3600 0 -01}
{-968025600 0 1 -01}
{-952293600 -3600 0 -01}
{-942008400 0 1 -01}
{-920239200 -3600 0 -01}
{-909957600 0 1 -01}
{-888789600 -3600 0 -01}
{-877903200 0 1 -01}
{-857944800 -3600 0 -01}
{-846453600 0 1 -01}
{-826495200 -3600 0 -01}
{-815004000 0 1 -01}
{-795045600 -3600 0 -01}
{-783554400 0 1 -01}
{-762991200 -3600 0 -01}
{-752104800 0 1 -01}
{-731541600 -3600 0 -01}
{-717631200 0 1 -01}
{-700092000 -3600 0 -01}
{-686181600 0 1 -01}
{-668642400 -3600 0 -01}
{-654732000 0 1 -01}
{-636588000 -3600 0 -01}
{-623282400 0 1 -01}
{-605743200 -3600 0 -01}
{-591832800 0 1 -01}
{-573688800 -3600 0 -01}
{-559778400 0 1 -01}
{-542239200 -3600 0 -01}
{-528328800 0 1 -01}
{-510789600 -3600 0 -01}
{-496879200 0 1 -01}
{-479340000 -3600 0 -01}
{-465429600 0 1 -01}
{-447890400 -3600 0 -01}
{-433980000 0 1 -01}
{-415836000 -3600 0 -01}
{-401925600 0 1 -01}
{-384386400 -3600 0 -01}
{-370476000 0 1 -01}
{-352936800 -3600 0 -01}
{-339026400 0 1 -01}
{-321487200 -3600 0 -01}
{-307576800 0 1 -01}
{-290037600 -3600 0 -01}
{-276127200 0 1 -01}
{-258588000 -3600 0 -01}
{-244677600 0 1 -01}
{-226533600 -3600 0 -01}
{-212623200 0 1 -01}
{-195084000 -3600 0 -01}
{-181173600 0 1 -01}
{-163634400 -3600 0 -01}
{-149724000 0 1 -01}
{-132184800 -3600 0 -01}
{-118274400 0 1 -01}
{-100735200 -3600 0 -01}
{-86824800 0 1 -01}
{-68680800 -3600 0 -01}
{-54770400 0 0 GMT}
}
|
Changes to library/tzdata/Atlantic/Stanley.
1 2 3 4 5 6 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Atlantic/Stanley) {
{-9223372036854775808 -13884 0 LMT}
{-2524507716 -13884 0 SMT}
{-1824235716 -14400 0 -04}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Atlantic/Stanley) {
{-9223372036854775808 -13884 0 LMT}
{-2524507716 -13884 0 SMT}
{-1824235716 -14400 0 -04}
{-1018209600 -10800 1 -04}
{-1003093200 -14400 0 -04}
{-986760000 -10800 1 -04}
{-971643600 -14400 0 -04}
{-954705600 -10800 1 -04}
{-939589200 -14400 0 -04}
{-923256000 -10800 1 -04}
{-908139600 -14400 0 -04}
{-891806400 -10800 1 -04}
{-876690000 -14400 0 -04}
{-860356800 -10800 1 -04}
{420606000 -7200 0 -03}
{433303200 -7200 1 -03}
{452052000 -10800 0 -03}
{464151600 -7200 1 -03}
{483501600 -10800 0 -03}
{495597600 -14400 0 -04}
{495604800 -10800 1 -04}
{514350000 -14400 0 -04}
{527054400 -10800 1 -04}
{545799600 -14400 0 -04}
{558504000 -10800 1 -04}
{577249200 -14400 0 -04}
{589953600 -10800 1 -04}
{608698800 -14400 0 -04}
{621403200 -10800 1 -04}
{640753200 -14400 0 -04}
{652852800 -10800 1 -04}
{672202800 -14400 0 -04}
{684907200 -10800 1 -04}
{703652400 -14400 0 -04}
{716356800 -10800 1 -04}
{735102000 -14400 0 -04}
{747806400 -10800 1 -04}
{766551600 -14400 0 -04}
{779256000 -10800 1 -04}
{798001200 -14400 0 -04}
{810705600 -10800 1 -04}
{830055600 -14400 0 -04}
{842760000 -10800 1 -04}
{861505200 -14400 0 -04}
{874209600 -10800 1 -04}
{892954800 -14400 0 -04}
{905659200 -10800 1 -04}
{924404400 -14400 0 -04}
{937108800 -10800 1 -04}
{955854000 -14400 0 -04}
{968558400 -10800 1 -04}
{987310800 -14400 0 -04}
{999410400 -10800 1 -04}
{1019365200 -14400 0 -04}
{1030860000 -10800 1 -04}
{1050814800 -14400 0 -04}
{1062914400 -10800 1 -04}
{1082264400 -14400 0 -04}
{1094364000 -10800 1 -04}
{1113714000 -14400 0 -04}
{1125813600 -10800 1 -04}
{1145163600 -14400 0 -04}
{1157263200 -10800 1 -04}
{1176613200 -14400 0 -04}
{1188712800 -10800 1 -04}
{1208667600 -14400 0 -04}
{1220767200 -10800 1 -04}
{1240117200 -14400 0 -04}
{1252216800 -10800 1 -04}
{1271566800 -14400 0 -04}
{1283662800 -10800 0 -03}
}
|
Changes to library/tzdata/Australia/Lord_Howe.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Australia/Lord_Howe) {
{-9223372036854775808 38180 0 LMT}
{-2364114980 36000 0 AEST}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Australia/Lord_Howe) {
{-9223372036854775808 38180 0 LMT}
{-2364114980 36000 0 AEST}
{352216800 37800 0 +1030}
{372785400 41400 1 +1030}
{384273000 37800 0 +1030}
{404839800 41400 1 +1030}
{415722600 37800 0 +1030}
{436289400 41400 1 +1030}
{447172200 37800 0 +1030}
{467739000 41400 1 +1030}
{478621800 37800 0 +1030}
{488984400 37800 0 +1030}
{499188600 39600 1 +1030}
{511282800 37800 0 +1030}
{530033400 39600 1 +1030}
{542732400 37800 0 +1030}
{562087800 39600 1 +1030}
{574786800 37800 0 +1030}
{594142200 39600 1 +1030}
{606236400 37800 0 +1030}
{625591800 39600 1 +1030}
{636476400 37800 0 +1030}
{657041400 39600 1 +1030}
{667926000 37800 0 +1030}
{688491000 39600 1 +1030}
{699375600 37800 0 +1030}
{719940600 39600 1 +1030}
{731430000 37800 0 +1030}
{751995000 39600 1 +1030}
{762879600 37800 0 +1030}
{783444600 39600 1 +1030}
{794329200 37800 0 +1030}
{814894200 39600 1 +1030}
{828198000 37800 0 +1030}
{846343800 39600 1 +1030}
{859647600 37800 0 +1030}
{877793400 39600 1 +1030}
{891097200 37800 0 +1030}
{909243000 39600 1 +1030}
{922546800 37800 0 +1030}
{941297400 39600 1 +1030}
{953996400 37800 0 +1030}
{967303800 39600 1 +1030}
{985446000 37800 0 +1030}
{1004196600 39600 1 +1030}
{1017500400 37800 0 +1030}
{1035646200 39600 1 +1030}
{1048950000 37800 0 +1030}
{1067095800 39600 1 +1030}
{1080399600 37800 0 +1030}
{1099150200 39600 1 +1030}
{1111849200 37800 0 +1030}
{1130599800 39600 1 +1030}
{1143903600 37800 0 +1030}
{1162049400 39600 1 +1030}
{1174748400 37800 0 +1030}
{1193499000 39600 1 +1030}
{1207407600 37800 0 +1030}
{1223134200 39600 1 +1030}
{1238857200 37800 0 +1030}
{1254583800 39600 1 +1030}
{1270306800 37800 0 +1030}
{1286033400 39600 1 +1030}
{1301756400 37800 0 +1030}
{1317483000 39600 1 +1030}
{1333206000 37800 0 +1030}
{1349537400 39600 1 +1030}
{1365260400 37800 0 +1030}
{1380987000 39600 1 +1030}
{1396710000 37800 0 +1030}
{1412436600 39600 1 +1030}
{1428159600 37800 0 +1030}
{1443886200 39600 1 +1030}
{1459609200 37800 0 +1030}
{1475335800 39600 1 +1030}
{1491058800 37800 0 +1030}
{1506785400 39600 1 +1030}
{1522508400 37800 0 +1030}
{1538839800 39600 1 +1030}
{1554562800 37800 0 +1030}
{1570289400 39600 1 +1030}
{1586012400 37800 0 +1030}
{1601739000 39600 1 +1030}
{1617462000 37800 0 +1030}
{1633188600 39600 1 +1030}
{1648911600 37800 0 +1030}
{1664638200 39600 1 +1030}
{1680361200 37800 0 +1030}
{1696087800 39600 1 +1030}
{1712415600 37800 0 +1030}
{1728142200 39600 1 +1030}
{1743865200 37800 0 +1030}
{1759591800 39600 1 +1030}
{1775314800 37800 0 +1030}
{1791041400 39600 1 +1030}
{1806764400 37800 0 +1030}
{1822491000 39600 1 +1030}
{1838214000 37800 0 +1030}
{1853940600 39600 1 +1030}
{1869663600 37800 0 +1030}
{1885995000 39600 1 +1030}
{1901718000 37800 0 +1030}
{1917444600 39600 1 +1030}
{1933167600 37800 0 +1030}
{1948894200 39600 1 +1030}
{1964617200 37800 0 +1030}
{1980343800 39600 1 +1030}
{1996066800 37800 0 +1030}
{2011793400 39600 1 +1030}
{2027516400 37800 0 +1030}
{2043243000 39600 1 +1030}
{2058966000 37800 0 +1030}
{2075297400 39600 1 +1030}
{2091020400 37800 0 +1030}
{2106747000 39600 1 +1030}
{2122470000 37800 0 +1030}
{2138196600 39600 1 +1030}
{2153919600 37800 0 +1030}
{2169646200 39600 1 +1030}
{2185369200 37800 0 +1030}
{2201095800 39600 1 +1030}
{2216818800 37800 0 +1030}
{2233150200 39600 1 +1030}
{2248873200 37800 0 +1030}
{2264599800 39600 1 +1030}
{2280322800 37800 0 +1030}
{2296049400 39600 1 +1030}
{2311772400 37800 0 +1030}
{2327499000 39600 1 +1030}
{2343222000 37800 0 +1030}
{2358948600 39600 1 +1030}
{2374671600 37800 0 +1030}
{2390398200 39600 1 +1030}
{2406121200 37800 0 +1030}
{2422452600 39600 1 +1030}
{2438175600 37800 0 +1030}
{2453902200 39600 1 +1030}
{2469625200 37800 0 +1030}
{2485351800 39600 1 +1030}
{2501074800 37800 0 +1030}
{2516801400 39600 1 +1030}
{2532524400 37800 0 +1030}
{2548251000 39600 1 +1030}
{2563974000 37800 0 +1030}
{2579700600 39600 1 +1030}
{2596028400 37800 0 +1030}
{2611755000 39600 1 +1030}
{2627478000 37800 0 +1030}
{2643204600 39600 1 +1030}
{2658927600 37800 0 +1030}
{2674654200 39600 1 +1030}
{2690377200 37800 0 +1030}
{2706103800 39600 1 +1030}
{2721826800 37800 0 +1030}
{2737553400 39600 1 +1030}
{2753276400 37800 0 +1030}
{2769607800 39600 1 +1030}
{2785330800 37800 0 +1030}
{2801057400 39600 1 +1030}
{2816780400 37800 0 +1030}
{2832507000 39600 1 +1030}
{2848230000 37800 0 +1030}
{2863956600 39600 1 +1030}
{2879679600 37800 0 +1030}
{2895406200 39600 1 +1030}
{2911129200 37800 0 +1030}
{2926855800 39600 1 +1030}
{2942578800 37800 0 +1030}
{2958910200 39600 1 +1030}
{2974633200 37800 0 +1030}
{2990359800 39600 1 +1030}
{3006082800 37800 0 +1030}
{3021809400 39600 1 +1030}
{3037532400 37800 0 +1030}
{3053259000 39600 1 +1030}
{3068982000 37800 0 +1030}
{3084708600 39600 1 +1030}
{3100431600 37800 0 +1030}
{3116763000 39600 1 +1030}
{3132486000 37800 0 +1030}
{3148212600 39600 1 +1030}
{3163935600 37800 0 +1030}
{3179662200 39600 1 +1030}
{3195385200 37800 0 +1030}
{3211111800 39600 1 +1030}
{3226834800 37800 0 +1030}
{3242561400 39600 1 +1030}
{3258284400 37800 0 +1030}
{3274011000 39600 1 +1030}
{3289734000 37800 0 +1030}
{3306065400 39600 1 +1030}
{3321788400 37800 0 +1030}
{3337515000 39600 1 +1030}
{3353238000 37800 0 +1030}
{3368964600 39600 1 +1030}
{3384687600 37800 0 +1030}
{3400414200 39600 1 +1030}
{3416137200 37800 0 +1030}
{3431863800 39600 1 +1030}
{3447586800 37800 0 +1030}
{3463313400 39600 1 +1030}
{3479641200 37800 0 +1030}
{3495367800 39600 1 +1030}
{3511090800 37800 0 +1030}
{3526817400 39600 1 +1030}
{3542540400 37800 0 +1030}
{3558267000 39600 1 +1030}
{3573990000 37800 0 +1030}
{3589716600 39600 1 +1030}
{3605439600 37800 0 +1030}
{3621166200 39600 1 +1030}
{3636889200 37800 0 +1030}
{3653220600 39600 1 +1030}
{3668943600 37800 0 +1030}
{3684670200 39600 1 +1030}
{3700393200 37800 0 +1030}
{3716119800 39600 1 +1030}
{3731842800 37800 0 +1030}
{3747569400 39600 1 +1030}
{3763292400 37800 0 +1030}
{3779019000 39600 1 +1030}
{3794742000 37800 0 +1030}
{3810468600 39600 1 +1030}
{3826191600 37800 0 +1030}
{3842523000 39600 1 +1030}
{3858246000 37800 0 +1030}
{3873972600 39600 1 +1030}
{3889695600 37800 0 +1030}
{3905422200 39600 1 +1030}
{3921145200 37800 0 +1030}
{3936871800 39600 1 +1030}
{3952594800 37800 0 +1030}
{3968321400 39600 1 +1030}
{3984044400 37800 0 +1030}
{4000375800 39600 1 +1030}
{4016098800 37800 0 +1030}
{4031825400 39600 1 +1030}
{4047548400 37800 0 +1030}
{4063275000 39600 1 +1030}
{4078998000 37800 0 +1030}
{4094724600 39600 1 +1030}
}
|
Changes to library/tzdata/Etc/UCT.
1 | # created by tools/tclZIC.tcl - do not edit | > > | | < < | 1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
if {![info exists TZData(Etc/UTC)]} {
LoadTimeZoneFile Etc/UTC
}
set TZData(:Etc/UCT) $TZData(:Etc/UTC)
|
Changes to library/tzdata/Europe/Dublin.
| ︙ | ︙ | |||
94 95 96 97 98 99 100 |
{-132184800 0 0 IST}
{-119484000 3600 1 IST}
{-100735200 0 0 IST}
{-88034400 3600 1 IST}
{-68680800 0 0 IST}
{-59004000 3600 1 IST}
{-37238400 3600 0 IST}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 |
{-132184800 0 0 IST}
{-119484000 3600 1 IST}
{-100735200 0 0 IST}
{-88034400 3600 1 IST}
{-68680800 0 0 IST}
{-59004000 3600 1 IST}
{-37238400 3600 0 IST}
{57722400 0 1 IST}
{69818400 3600 0 IST}
{89172000 0 1 IST}
{101268000 3600 0 IST}
{120621600 0 1 IST}
{132717600 3600 0 IST}
{152071200 0 1 IST}
{164167200 3600 0 IST}
{183520800 0 1 IST}
{196221600 3600 0 IST}
{214970400 0 1 IST}
{227671200 3600 0 IST}
{246420000 0 1 IST}
{259120800 3600 0 IST}
{278474400 0 1 IST}
{290570400 3600 0 IST}
{309924000 0 1 IST}
{322020000 3600 0 IST}
{341373600 0 1 IST}
{354675600 3600 0 IST}
{372819600 0 1 IST}
{386125200 3600 0 IST}
{404269200 0 1 IST}
{417574800 3600 0 IST}
{435718800 0 1 IST}
{449024400 3600 0 IST}
{467773200 0 1 IST}
{481078800 3600 0 IST}
{499222800 0 1 IST}
{512528400 3600 0 IST}
{530672400 0 1 IST}
{543978000 3600 0 IST}
{562122000 0 1 IST}
{575427600 3600 0 IST}
{593571600 0 1 IST}
{606877200 3600 0 IST}
{625626000 0 1 IST}
{638326800 3600 0 IST}
{657075600 0 1 IST}
{670381200 3600 0 IST}
{688525200 0 1 IST}
{701830800 3600 0 IST}
{719974800 0 1 IST}
{733280400 3600 0 IST}
{751424400 0 1 IST}
{764730000 3600 0 IST}
{782874000 0 1 IST}
{796179600 3600 0 IST}
{814323600 0 1 IST}
{828234000 3600 0 IST}
{846378000 0 1 IST}
{859683600 3600 0 IST}
{877827600 0 1 IST}
{891133200 3600 0 IST}
{909277200 0 1 IST}
{922582800 3600 0 IST}
{941331600 0 1 IST}
{954032400 3600 0 IST}
{972781200 0 1 IST}
{985482000 3600 0 IST}
{1004230800 0 1 IST}
{1017536400 3600 0 IST}
{1035680400 0 1 IST}
{1048986000 3600 0 IST}
{1067130000 0 1 IST}
{1080435600 3600 0 IST}
{1099184400 0 1 IST}
{1111885200 3600 0 IST}
{1130634000 0 1 IST}
{1143334800 3600 0 IST}
{1162083600 0 1 IST}
{1174784400 3600 0 IST}
{1193533200 0 1 IST}
{1206838800 3600 0 IST}
{1224982800 0 1 IST}
{1238288400 3600 0 IST}
{1256432400 0 1 IST}
{1269738000 3600 0 IST}
{1288486800 0 1 IST}
{1301187600 3600 0 IST}
{1319936400 0 1 IST}
{1332637200 3600 0 IST}
{1351386000 0 1 IST}
{1364691600 3600 0 IST}
{1382835600 0 1 IST}
{1396141200 3600 0 IST}
{1414285200 0 1 IST}
{1427590800 3600 0 IST}
{1445734800 0 1 IST}
{1459040400 3600 0 IST}
{1477789200 0 1 IST}
{1490490000 3600 0 IST}
{1509238800 0 1 IST}
{1521939600 3600 0 IST}
{1540688400 0 1 IST}
{1553994000 3600 0 IST}
{1572138000 0 1 IST}
{1585443600 3600 0 IST}
{1603587600 0 1 IST}
{1616893200 3600 0 IST}
{1635642000 0 1 IST}
{1648342800 3600 0 IST}
{1667091600 0 1 IST}
{1679792400 3600 0 IST}
{1698541200 0 1 IST}
{1711846800 3600 0 IST}
{1729990800 0 1 IST}
{1743296400 3600 0 IST}
{1761440400 0 1 IST}
{1774746000 3600 0 IST}
{1792890000 0 1 IST}
{1806195600 3600 0 IST}
{1824944400 0 1 IST}
{1837645200 3600 0 IST}
{1856394000 0 1 IST}
{1869094800 3600 0 IST}
{1887843600 0 1 IST}
{1901149200 3600 0 IST}
{1919293200 0 1 IST}
{1932598800 3600 0 IST}
{1950742800 0 1 IST}
{1964048400 3600 0 IST}
{1982797200 0 1 IST}
{1995498000 3600 0 IST}
{2014246800 0 1 IST}
{2026947600 3600 0 IST}
{2045696400 0 1 IST}
{2058397200 3600 0 IST}
{2077146000 0 1 IST}
{2090451600 3600 0 IST}
{2108595600 0 1 IST}
{2121901200 3600 0 IST}
{2140045200 0 1 IST}
{2153350800 3600 0 IST}
{2172099600 0 1 IST}
{2184800400 3600 0 IST}
{2203549200 0 1 IST}
{2216250000 3600 0 IST}
{2234998800 0 1 IST}
{2248304400 3600 0 IST}
{2266448400 0 1 IST}
{2279754000 3600 0 IST}
{2297898000 0 1 IST}
{2311203600 3600 0 IST}
{2329347600 0 1 IST}
{2342653200 3600 0 IST}
{2361402000 0 1 IST}
{2374102800 3600 0 IST}
{2392851600 0 1 IST}
{2405552400 3600 0 IST}
{2424301200 0 1 IST}
{2437606800 3600 0 IST}
{2455750800 0 1 IST}
{2469056400 3600 0 IST}
{2487200400 0 1 IST}
{2500506000 3600 0 IST}
{2519254800 0 1 IST}
{2531955600 3600 0 IST}
{2550704400 0 1 IST}
{2563405200 3600 0 IST}
{2582154000 0 1 IST}
{2595459600 3600 0 IST}
{2613603600 0 1 IST}
{2626909200 3600 0 IST}
{2645053200 0 1 IST}
{2658358800 3600 0 IST}
{2676502800 0 1 IST}
{2689808400 3600 0 IST}
{2708557200 0 1 IST}
{2721258000 3600 0 IST}
{2740006800 0 1 IST}
{2752707600 3600 0 IST}
{2771456400 0 1 IST}
{2784762000 3600 0 IST}
{2802906000 0 1 IST}
{2816211600 3600 0 IST}
{2834355600 0 1 IST}
{2847661200 3600 0 IST}
{2866410000 0 1 IST}
{2879110800 3600 0 IST}
{2897859600 0 1 IST}
{2910560400 3600 0 IST}
{2929309200 0 1 IST}
{2942010000 3600 0 IST}
{2960758800 0 1 IST}
{2974064400 3600 0 IST}
{2992208400 0 1 IST}
{3005514000 3600 0 IST}
{3023658000 0 1 IST}
{3036963600 3600 0 IST}
{3055712400 0 1 IST}
{3068413200 3600 0 IST}
{3087162000 0 1 IST}
{3099862800 3600 0 IST}
{3118611600 0 1 IST}
{3131917200 3600 0 IST}
{3150061200 0 1 IST}
{3163366800 3600 0 IST}
{3181510800 0 1 IST}
{3194816400 3600 0 IST}
{3212960400 0 1 IST}
{3226266000 3600 0 IST}
{3245014800 0 1 IST}
{3257715600 3600 0 IST}
{3276464400 0 1 IST}
{3289165200 3600 0 IST}
{3307914000 0 1 IST}
{3321219600 3600 0 IST}
{3339363600 0 1 IST}
{3352669200 3600 0 IST}
{3370813200 0 1 IST}
{3384118800 3600 0 IST}
{3402867600 0 1 IST}
{3415568400 3600 0 IST}
{3434317200 0 1 IST}
{3447018000 3600 0 IST}
{3465766800 0 1 IST}
{3479072400 3600 0 IST}
{3497216400 0 1 IST}
{3510522000 3600 0 IST}
{3528666000 0 1 IST}
{3541971600 3600 0 IST}
{3560115600 0 1 IST}
{3573421200 3600 0 IST}
{3592170000 0 1 IST}
{3604870800 3600 0 IST}
{3623619600 0 1 IST}
{3636320400 3600 0 IST}
{3655069200 0 1 IST}
{3668374800 3600 0 IST}
{3686518800 0 1 IST}
{3699824400 3600 0 IST}
{3717968400 0 1 IST}
{3731274000 3600 0 IST}
{3750022800 0 1 IST}
{3762723600 3600 0 IST}
{3781472400 0 1 IST}
{3794173200 3600 0 IST}
{3812922000 0 1 IST}
{3825622800 3600 0 IST}
{3844371600 0 1 IST}
{3857677200 3600 0 IST}
{3875821200 0 1 IST}
{3889126800 3600 0 IST}
{3907270800 0 1 IST}
{3920576400 3600 0 IST}
{3939325200 0 1 IST}
{3952026000 3600 0 IST}
{3970774800 0 1 IST}
{3983475600 3600 0 IST}
{4002224400 0 1 IST}
{4015530000 3600 0 IST}
{4033674000 0 1 IST}
{4046979600 3600 0 IST}
{4065123600 0 1 IST}
{4078429200 3600 0 IST}
{4096573200 0 1 IST}
}
|
Changes to library/tzdata/Europe/Lisbon.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Europe/Lisbon) {
{-9223372036854775808 -2205 0 LMT}
{-2713908195 -2205 0 LMT}
| | | 1 2 3 4 5 6 7 8 9 10 11 12 13 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Europe/Lisbon) {
{-9223372036854775808 -2205 0 LMT}
{-2713908195 -2205 0 LMT}
{-1830384000 0 0 WET}
{-1689555600 3600 1 WEST}
{-1677801600 0 0 WET}
{-1667437200 3600 1 WEST}
{-1647738000 0 0 WET}
{-1635814800 3600 1 WEST}
{-1616202000 0 0 WET}
{-1604365200 3600 1 WEST}
|
| ︙ | ︙ |
Changes to library/tzdata/Europe/Prague.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 |
{-1632006000 7200 1 CEST}
{-1618700400 3600 0 CET}
{-938905200 7200 1 CEST}
{-857257200 3600 0 CET}
{-844556400 7200 1 CEST}
{-828226800 3600 0 CET}
{-812502000 7200 1 CEST}
| | | > | > > | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 |
{-1632006000 7200 1 CEST}
{-1618700400 3600 0 CET}
{-938905200 7200 1 CEST}
{-857257200 3600 0 CET}
{-844556400 7200 1 CEST}
{-828226800 3600 0 CET}
{-812502000 7200 1 CEST}
{-796777200 3600 0 CET}
{-781052400 7200 1 CEST}
{-777862800 7200 0 CEST}
{-765327600 3600 0 CET}
{-746578800 7200 1 CEST}
{-733359600 3600 0 CET}
{-728517600 0 1 GMT}
{-721260000 0 0 CET}
{-716425200 7200 1 CEST}
{-701910000 3600 0 CET}
{-684975600 7200 1 CEST}
{-670460400 3600 0 CET}
{-654217200 7200 1 CEST}
{-639010800 3600 0 CET}
{283993200 3600 0 CET}
|
| ︙ | ︙ |
Changes to library/tzdata/Europe/Volgograd.
| ︙ | ︙ | |||
64 65 66 67 68 69 70 71 |
{1224975600 10800 0 +03}
{1238281200 14400 1 +04}
{1256425200 10800 0 +03}
{1269730800 14400 1 +04}
{1288479600 10800 0 +03}
{1301180400 14400 0 +04}
{1414274400 10800 0 +03}
}
| > | 64 65 66 67 68 69 70 71 72 |
{1224975600 10800 0 +03}
{1238281200 14400 1 +04}
{1256425200 10800 0 +03}
{1269730800 14400 1 +04}
{1288479600 10800 0 +03}
{1301180400 14400 0 +04}
{1414274400 10800 0 +03}
{1540681200 14400 0 +04}
}
|
Changes to library/tzdata/Indian/Mauritius.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Indian/Mauritius) {
{-9223372036854775808 13800 0 LMT}
{-1988164200 14400 0 +04}
| | | | 1 2 3 4 5 6 7 8 9 10 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Indian/Mauritius) {
{-9223372036854775808 13800 0 LMT}
{-1988164200 14400 0 +04}
{403041600 18000 1 +04}
{417034800 14400 0 +04}
{1224972000 18000 1 +04}
{1238274000 14400 0 +04}
}
|
Changes to library/tzdata/Pacific/Apia.
1 2 3 4 5 6 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Apia) {
{-9223372036854775808 45184 0 LMT}
{-2445424384 -41216 0 LMT}
{-1861878784 -41400 0 -1130}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Apia) {
{-9223372036854775808 45184 0 LMT}
{-2445424384 -41216 0 LMT}
{-1861878784 -41400 0 -1130}
{-631110600 -39600 0 -11}
{1285498800 -36000 1 -11}
{1301752800 -39600 0 -11}
{1316872800 -36000 1 -11}
{1325239200 50400 0 +13}
{1333202400 46800 0 +13}
{1348927200 50400 1 +13}
{1365256800 46800 0 +13}
{1380376800 50400 1 +13}
{1396706400 46800 0 +13}
{1411826400 50400 1 +13}
{1428156000 46800 0 +13}
{1443276000 50400 1 +13}
{1459605600 46800 0 +13}
{1474725600 50400 1 +13}
{1491055200 46800 0 +13}
{1506175200 50400 1 +13}
{1522504800 46800 0 +13}
{1538229600 50400 1 +13}
{1554559200 46800 0 +13}
{1569679200 50400 1 +13}
{1586008800 46800 0 +13}
{1601128800 50400 1 +13}
{1617458400 46800 0 +13}
{1632578400 50400 1 +13}
{1648908000 46800 0 +13}
{1664028000 50400 1 +13}
{1680357600 46800 0 +13}
{1695477600 50400 1 +13}
{1712412000 46800 0 +13}
{1727532000 50400 1 +13}
{1743861600 46800 0 +13}
{1758981600 50400 1 +13}
{1775311200 46800 0 +13}
{1790431200 50400 1 +13}
{1806760800 46800 0 +13}
{1821880800 50400 1 +13}
{1838210400 46800 0 +13}
{1853330400 50400 1 +13}
{1869660000 46800 0 +13}
{1885384800 50400 1 +13}
{1901714400 46800 0 +13}
{1916834400 50400 1 +13}
{1933164000 46800 0 +13}
{1948284000 50400 1 +13}
{1964613600 46800 0 +13}
{1979733600 50400 1 +13}
{1996063200 46800 0 +13}
{2011183200 50400 1 +13}
{2027512800 46800 0 +13}
{2042632800 50400 1 +13}
{2058962400 46800 0 +13}
{2074687200 50400 1 +13}
{2091016800 46800 0 +13}
{2106136800 50400 1 +13}
{2122466400 46800 0 +13}
{2137586400 50400 1 +13}
{2153916000 46800 0 +13}
{2169036000 50400 1 +13}
{2185365600 46800 0 +13}
{2200485600 50400 1 +13}
{2216815200 46800 0 +13}
{2232540000 50400 1 +13}
{2248869600 46800 0 +13}
{2263989600 50400 1 +13}
{2280319200 46800 0 +13}
{2295439200 50400 1 +13}
{2311768800 46800 0 +13}
{2326888800 50400 1 +13}
{2343218400 46800 0 +13}
{2358338400 50400 1 +13}
{2374668000 46800 0 +13}
{2389788000 50400 1 +13}
{2406117600 46800 0 +13}
{2421842400 50400 1 +13}
{2438172000 46800 0 +13}
{2453292000 50400 1 +13}
{2469621600 46800 0 +13}
{2484741600 50400 1 +13}
{2501071200 46800 0 +13}
{2516191200 50400 1 +13}
{2532520800 46800 0 +13}
{2547640800 50400 1 +13}
{2563970400 46800 0 +13}
{2579090400 50400 1 +13}
{2596024800 46800 0 +13}
{2611144800 50400 1 +13}
{2627474400 46800 0 +13}
{2642594400 50400 1 +13}
{2658924000 46800 0 +13}
{2674044000 50400 1 +13}
{2690373600 46800 0 +13}
{2705493600 50400 1 +13}
{2721823200 46800 0 +13}
{2736943200 50400 1 +13}
{2753272800 46800 0 +13}
{2768997600 50400 1 +13}
{2785327200 46800 0 +13}
{2800447200 50400 1 +13}
{2816776800 46800 0 +13}
{2831896800 50400 1 +13}
{2848226400 46800 0 +13}
{2863346400 50400 1 +13}
{2879676000 46800 0 +13}
{2894796000 50400 1 +13}
{2911125600 46800 0 +13}
{2926245600 50400 1 +13}
{2942575200 46800 0 +13}
{2958300000 50400 1 +13}
{2974629600 46800 0 +13}
{2989749600 50400 1 +13}
{3006079200 46800 0 +13}
{3021199200 50400 1 +13}
{3037528800 46800 0 +13}
{3052648800 50400 1 +13}
{3068978400 46800 0 +13}
{3084098400 50400 1 +13}
{3100428000 46800 0 +13}
{3116152800 50400 1 +13}
{3132482400 46800 0 +13}
{3147602400 50400 1 +13}
{3163932000 46800 0 +13}
{3179052000 50400 1 +13}
{3195381600 46800 0 +13}
{3210501600 50400 1 +13}
{3226831200 46800 0 +13}
{3241951200 50400 1 +13}
{3258280800 46800 0 +13}
{3273400800 50400 1 +13}
{3289730400 46800 0 +13}
{3305455200 50400 1 +13}
{3321784800 46800 0 +13}
{3336904800 50400 1 +13}
{3353234400 46800 0 +13}
{3368354400 50400 1 +13}
{3384684000 46800 0 +13}
{3399804000 50400 1 +13}
{3416133600 46800 0 +13}
{3431253600 50400 1 +13}
{3447583200 46800 0 +13}
{3462703200 50400 1 +13}
{3479637600 46800 0 +13}
{3494757600 50400 1 +13}
{3511087200 46800 0 +13}
{3526207200 50400 1 +13}
{3542536800 46800 0 +13}
{3557656800 50400 1 +13}
{3573986400 46800 0 +13}
{3589106400 50400 1 +13}
{3605436000 46800 0 +13}
{3620556000 50400 1 +13}
{3636885600 46800 0 +13}
{3652610400 50400 1 +13}
{3668940000 46800 0 +13}
{3684060000 50400 1 +13}
{3700389600 46800 0 +13}
{3715509600 50400 1 +13}
{3731839200 46800 0 +13}
{3746959200 50400 1 +13}
{3763288800 46800 0 +13}
{3778408800 50400 1 +13}
{3794738400 46800 0 +13}
{3809858400 50400 1 +13}
{3826188000 46800 0 +13}
{3841912800 50400 1 +13}
{3858242400 46800 0 +13}
{3873362400 50400 1 +13}
{3889692000 46800 0 +13}
{3904812000 50400 1 +13}
{3921141600 46800 0 +13}
{3936261600 50400 1 +13}
{3952591200 46800 0 +13}
{3967711200 50400 1 +13}
{3984040800 46800 0 +13}
{3999765600 50400 1 +13}
{4016095200 46800 0 +13}
{4031215200 50400 1 +13}
{4047544800 46800 0 +13}
{4062664800 50400 1 +13}
{4078994400 46800 0 +13}
{4094114400 50400 1 +13}
}
|
Changes to library/tzdata/Pacific/Chatham.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Chatham) {
{-9223372036854775808 44028 0 LMT}
{-3192437628 44100 0 +1215}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Chatham) {
{-9223372036854775808 44028 0 LMT}
{-3192437628 44100 0 +1215}
{-757426500 45900 0 +1245}
{152632800 49500 1 +1245}
{162309600 45900 0 +1245}
{183477600 49500 1 +1245}
{194968800 45900 0 +1245}
{215532000 49500 1 +1245}
{226418400 45900 0 +1245}
{246981600 49500 1 +1245}
{257868000 45900 0 +1245}
{278431200 49500 1 +1245}
{289317600 45900 0 +1245}
{309880800 49500 1 +1245}
{320767200 45900 0 +1245}
{341330400 49500 1 +1245}
{352216800 45900 0 +1245}
{372780000 49500 1 +1245}
{384271200 45900 0 +1245}
{404834400 49500 1 +1245}
{415720800 45900 0 +1245}
{436284000 49500 1 +1245}
{447170400 45900 0 +1245}
{467733600 49500 1 +1245}
{478620000 45900 0 +1245}
{499183200 49500 1 +1245}
{510069600 45900 0 +1245}
{530632800 49500 1 +1245}
{541519200 45900 0 +1245}
{562082400 49500 1 +1245}
{573573600 45900 0 +1245}
{594136800 49500 1 +1245}
{605023200 45900 0 +1245}
{623772000 49500 1 +1245}
{637682400 45900 0 +1245}
{655221600 49500 1 +1245}
{669132000 45900 0 +1245}
{686671200 49500 1 +1245}
{700581600 45900 0 +1245}
{718120800 49500 1 +1245}
{732636000 45900 0 +1245}
{749570400 49500 1 +1245}
{764085600 45900 0 +1245}
{781020000 49500 1 +1245}
{795535200 45900 0 +1245}
{812469600 49500 1 +1245}
{826984800 45900 0 +1245}
{844524000 49500 1 +1245}
{858434400 45900 0 +1245}
{875973600 49500 1 +1245}
{889884000 45900 0 +1245}
{907423200 49500 1 +1245}
{921938400 45900 0 +1245}
{938872800 49500 1 +1245}
{953388000 45900 0 +1245}
{970322400 49500 1 +1245}
{984837600 45900 0 +1245}
{1002376800 49500 1 +1245}
{1016287200 45900 0 +1245}
{1033826400 49500 1 +1245}
{1047736800 45900 0 +1245}
{1065276000 49500 1 +1245}
{1079791200 45900 0 +1245}
{1096725600 49500 1 +1245}
{1111240800 45900 0 +1245}
{1128175200 49500 1 +1245}
{1142690400 45900 0 +1245}
{1159624800 49500 1 +1245}
{1174140000 45900 0 +1245}
{1191074400 49500 1 +1245}
{1207404000 45900 0 +1245}
{1222524000 49500 1 +1245}
{1238853600 45900 0 +1245}
{1253973600 49500 1 +1245}
{1270303200 45900 0 +1245}
{1285423200 49500 1 +1245}
{1301752800 45900 0 +1245}
{1316872800 49500 1 +1245}
{1333202400 45900 0 +1245}
{1348927200 49500 1 +1245}
{1365256800 45900 0 +1245}
{1380376800 49500 1 +1245}
{1396706400 45900 0 +1245}
{1411826400 49500 1 +1245}
{1428156000 45900 0 +1245}
{1443276000 49500 1 +1245}
{1459605600 45900 0 +1245}
{1474725600 49500 1 +1245}
{1491055200 45900 0 +1245}
{1506175200 49500 1 +1245}
{1522504800 45900 0 +1245}
{1538229600 49500 1 +1245}
{1554559200 45900 0 +1245}
{1569679200 49500 1 +1245}
{1586008800 45900 0 +1245}
{1601128800 49500 1 +1245}
{1617458400 45900 0 +1245}
{1632578400 49500 1 +1245}
{1648908000 45900 0 +1245}
{1664028000 49500 1 +1245}
{1680357600 45900 0 +1245}
{1695477600 49500 1 +1245}
{1712412000 45900 0 +1245}
{1727532000 49500 1 +1245}
{1743861600 45900 0 +1245}
{1758981600 49500 1 +1245}
{1775311200 45900 0 +1245}
{1790431200 49500 1 +1245}
{1806760800 45900 0 +1245}
{1821880800 49500 1 +1245}
{1838210400 45900 0 +1245}
{1853330400 49500 1 +1245}
{1869660000 45900 0 +1245}
{1885384800 49500 1 +1245}
{1901714400 45900 0 +1245}
{1916834400 49500 1 +1245}
{1933164000 45900 0 +1245}
{1948284000 49500 1 +1245}
{1964613600 45900 0 +1245}
{1979733600 49500 1 +1245}
{1996063200 45900 0 +1245}
{2011183200 49500 1 +1245}
{2027512800 45900 0 +1245}
{2042632800 49500 1 +1245}
{2058962400 45900 0 +1245}
{2074687200 49500 1 +1245}
{2091016800 45900 0 +1245}
{2106136800 49500 1 +1245}
{2122466400 45900 0 +1245}
{2137586400 49500 1 +1245}
{2153916000 45900 0 +1245}
{2169036000 49500 1 +1245}
{2185365600 45900 0 +1245}
{2200485600 49500 1 +1245}
{2216815200 45900 0 +1245}
{2232540000 49500 1 +1245}
{2248869600 45900 0 +1245}
{2263989600 49500 1 +1245}
{2280319200 45900 0 +1245}
{2295439200 49500 1 +1245}
{2311768800 45900 0 +1245}
{2326888800 49500 1 +1245}
{2343218400 45900 0 +1245}
{2358338400 49500 1 +1245}
{2374668000 45900 0 +1245}
{2389788000 49500 1 +1245}
{2406117600 45900 0 +1245}
{2421842400 49500 1 +1245}
{2438172000 45900 0 +1245}
{2453292000 49500 1 +1245}
{2469621600 45900 0 +1245}
{2484741600 49500 1 +1245}
{2501071200 45900 0 +1245}
{2516191200 49500 1 +1245}
{2532520800 45900 0 +1245}
{2547640800 49500 1 +1245}
{2563970400 45900 0 +1245}
{2579090400 49500 1 +1245}
{2596024800 45900 0 +1245}
{2611144800 49500 1 +1245}
{2627474400 45900 0 +1245}
{2642594400 49500 1 +1245}
{2658924000 45900 0 +1245}
{2674044000 49500 1 +1245}
{2690373600 45900 0 +1245}
{2705493600 49500 1 +1245}
{2721823200 45900 0 +1245}
{2736943200 49500 1 +1245}
{2753272800 45900 0 +1245}
{2768997600 49500 1 +1245}
{2785327200 45900 0 +1245}
{2800447200 49500 1 +1245}
{2816776800 45900 0 +1245}
{2831896800 49500 1 +1245}
{2848226400 45900 0 +1245}
{2863346400 49500 1 +1245}
{2879676000 45900 0 +1245}
{2894796000 49500 1 +1245}
{2911125600 45900 0 +1245}
{2926245600 49500 1 +1245}
{2942575200 45900 0 +1245}
{2958300000 49500 1 +1245}
{2974629600 45900 0 +1245}
{2989749600 49500 1 +1245}
{3006079200 45900 0 +1245}
{3021199200 49500 1 +1245}
{3037528800 45900 0 +1245}
{3052648800 49500 1 +1245}
{3068978400 45900 0 +1245}
{3084098400 49500 1 +1245}
{3100428000 45900 0 +1245}
{3116152800 49500 1 +1245}
{3132482400 45900 0 +1245}
{3147602400 49500 1 +1245}
{3163932000 45900 0 +1245}
{3179052000 49500 1 +1245}
{3195381600 45900 0 +1245}
{3210501600 49500 1 +1245}
{3226831200 45900 0 +1245}
{3241951200 49500 1 +1245}
{3258280800 45900 0 +1245}
{3273400800 49500 1 +1245}
{3289730400 45900 0 +1245}
{3305455200 49500 1 +1245}
{3321784800 45900 0 +1245}
{3336904800 49500 1 +1245}
{3353234400 45900 0 +1245}
{3368354400 49500 1 +1245}
{3384684000 45900 0 +1245}
{3399804000 49500 1 +1245}
{3416133600 45900 0 +1245}
{3431253600 49500 1 +1245}
{3447583200 45900 0 +1245}
{3462703200 49500 1 +1245}
{3479637600 45900 0 +1245}
{3494757600 49500 1 +1245}
{3511087200 45900 0 +1245}
{3526207200 49500 1 +1245}
{3542536800 45900 0 +1245}
{3557656800 49500 1 +1245}
{3573986400 45900 0 +1245}
{3589106400 49500 1 +1245}
{3605436000 45900 0 +1245}
{3620556000 49500 1 +1245}
{3636885600 45900 0 +1245}
{3652610400 49500 1 +1245}
{3668940000 45900 0 +1245}
{3684060000 49500 1 +1245}
{3700389600 45900 0 +1245}
{3715509600 49500 1 +1245}
{3731839200 45900 0 +1245}
{3746959200 49500 1 +1245}
{3763288800 45900 0 +1245}
{3778408800 49500 1 +1245}
{3794738400 45900 0 +1245}
{3809858400 49500 1 +1245}
{3826188000 45900 0 +1245}
{3841912800 49500 1 +1245}
{3858242400 45900 0 +1245}
{3873362400 49500 1 +1245}
{3889692000 45900 0 +1245}
{3904812000 49500 1 +1245}
{3921141600 45900 0 +1245}
{3936261600 49500 1 +1245}
{3952591200 45900 0 +1245}
{3967711200 49500 1 +1245}
{3984040800 45900 0 +1245}
{3999765600 49500 1 +1245}
{4016095200 45900 0 +1245}
{4031215200 49500 1 +1245}
{4047544800 45900 0 +1245}
{4062664800 49500 1 +1245}
{4078994400 45900 0 +1245}
{4094114400 49500 1 +1245}
}
|
Changes to library/tzdata/Pacific/Chuuk.
1 2 3 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Chuuk) {
| | > > > > > | 1 2 3 4 5 6 7 8 9 10 11 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Chuuk) {
{-9223372036854775808 -49972 0 LMT}
{-3944628428 36428 0 LMT}
{-2177489228 36000 0 +10}
{-1743674400 32400 0 +09}
{-1606813200 36000 0 +10}
{-907408800 32400 0 +09}
{-770634000 36000 0 +10}
}
|
Changes to library/tzdata/Pacific/Easter.
1 2 3 4 5 6 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Easter) {
{-9223372036854775808 -26248 0 LMT}
{-2524495352 -26248 0 EMT}
{-1178124152 -25200 0 -07}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > | | | | | | | | | | | | | < < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < < | | | | | | | | | | | | | | > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > | | | | > > | | | | | | | | | | | | | | | | | | | | | < < < < | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Easter) {
{-9223372036854775808 -26248 0 LMT}
{-2524495352 -26248 0 EMT}
{-1178124152 -25200 0 -07}
{-36619200 -21600 1 -07}
{-23922000 -25200 0 -07}
{-3355200 -21600 1 -07}
{7527600 -25200 0 -07}
{24465600 -21600 1 -07}
{37767600 -25200 0 -07}
{55915200 -21600 1 -07}
{69217200 -25200 0 -07}
{87969600 -21600 1 -07}
{100666800 -25200 0 -07}
{118209600 -21600 1 -07}
{132116400 -25200 0 -07}
{150868800 -21600 1 -07}
{163566000 -25200 0 -07}
{182318400 -21600 1 -07}
{195620400 -25200 0 -07}
{213768000 -21600 1 -07}
{227070000 -25200 0 -07}
{245217600 -21600 1 -07}
{258519600 -25200 0 -07}
{277272000 -21600 1 -07}
{289969200 -25200 0 -07}
{308721600 -21600 1 -07}
{321418800 -25200 0 -07}
{340171200 -21600 1 -07}
{353473200 -25200 0 -07}
{371620800 -21600 1 -07}
{384922800 -21600 0 -06}
{403070400 -18000 1 -06}
{416372400 -21600 0 -06}
{434520000 -18000 1 -06}
{447822000 -21600 0 -06}
{466574400 -18000 1 -06}
{479271600 -21600 0 -06}
{498024000 -18000 1 -06}
{510721200 -21600 0 -06}
{529473600 -18000 1 -06}
{545194800 -21600 0 -06}
{560923200 -18000 1 -06}
{574225200 -21600 0 -06}
{592372800 -18000 1 -06}
{605674800 -21600 0 -06}
{624427200 -18000 1 -06}
{637124400 -21600 0 -06}
{653457600 -18000 1 -06}
{668574000 -21600 0 -06}
{687326400 -18000 1 -06}
{700628400 -21600 0 -06}
{718776000 -18000 1 -06}
{732078000 -21600 0 -06}
{750225600 -18000 1 -06}
{763527600 -21600 0 -06}
{781675200 -18000 1 -06}
{794977200 -21600 0 -06}
{813729600 -18000 1 -06}
{826426800 -21600 0 -06}
{845179200 -18000 1 -06}
{859690800 -21600 0 -06}
{876628800 -18000 1 -06}
{889930800 -21600 0 -06}
{906868800 -18000 1 -06}
{923194800 -21600 0 -06}
{939528000 -18000 1 -06}
{952830000 -21600 0 -06}
{971582400 -18000 1 -06}
{984279600 -21600 0 -06}
{1003032000 -18000 1 -06}
{1015729200 -21600 0 -06}
{1034481600 -18000 1 -06}
{1047178800 -21600 0 -06}
{1065931200 -18000 1 -06}
{1079233200 -21600 0 -06}
{1097380800 -18000 1 -06}
{1110682800 -21600 0 -06}
{1128830400 -18000 1 -06}
{1142132400 -21600 0 -06}
{1160884800 -18000 1 -06}
{1173582000 -21600 0 -06}
{1192334400 -18000 1 -06}
{1206846000 -21600 0 -06}
{1223784000 -18000 1 -06}
{1237086000 -21600 0 -06}
{1255233600 -18000 1 -06}
{1270350000 -21600 0 -06}
{1286683200 -18000 1 -06}
{1304823600 -21600 0 -06}
{1313899200 -18000 1 -06}
{1335668400 -21600 0 -06}
{1346558400 -18000 1 -06}
{1367118000 -21600 0 -06}
{1378612800 -18000 1 -06}
{1398567600 -21600 0 -06}
{1410062400 -18000 1 -06}
{1463281200 -21600 0 -06}
{1471147200 -18000 1 -06}
{1494730800 -21600 0 -06}
{1502596800 -18000 1 -06}
{1526180400 -21600 0 -06}
{1534046400 -18000 1 -06}
{1554606000 -21600 0 -06}
{1567915200 -18000 1 -06}
{1586055600 -21600 0 -06}
{1599364800 -18000 1 -06}
{1617505200 -21600 0 -06}
{1630814400 -18000 1 -06}
{1648954800 -21600 0 -06}
{1662264000 -18000 1 -06}
{1680404400 -21600 0 -06}
{1693713600 -18000 1 -06}
{1712458800 -21600 0 -06}
{1725768000 -18000 1 -06}
{1743908400 -21600 0 -06}
{1757217600 -18000 1 -06}
{1775358000 -21600 0 -06}
{1788667200 -18000 1 -06}
{1806807600 -21600 0 -06}
{1820116800 -18000 1 -06}
{1838257200 -21600 0 -06}
{1851566400 -18000 1 -06}
{1870311600 -21600 0 -06}
{1883016000 -18000 1 -06}
{1901761200 -21600 0 -06}
{1915070400 -18000 1 -06}
{1933210800 -21600 0 -06}
{1946520000 -18000 1 -06}
{1964660400 -21600 0 -06}
{1977969600 -18000 1 -06}
{1996110000 -21600 0 -06}
{2009419200 -18000 1 -06}
{2027559600 -21600 0 -06}
{2040868800 -18000 1 -06}
{2059614000 -21600 0 -06}
{2072318400 -18000 1 -06}
{2091063600 -21600 0 -06}
{2104372800 -18000 1 -06}
{2122513200 -21600 0 -06}
{2135822400 -18000 1 -06}
{2153962800 -21600 0 -06}
{2167272000 -18000 1 -06}
{2185412400 -21600 0 -06}
{2198721600 -18000 1 -06}
{2217466800 -21600 0 -06}
{2230171200 -18000 1 -06}
{2248916400 -21600 0 -06}
{2262225600 -18000 1 -06}
{2280366000 -21600 0 -06}
{2293675200 -18000 1 -06}
{2311815600 -21600 0 -06}
{2325124800 -18000 1 -06}
{2343265200 -21600 0 -06}
{2356574400 -18000 1 -06}
{2374714800 -21600 0 -06}
{2388024000 -18000 1 -06}
{2406769200 -21600 0 -06}
{2419473600 -18000 1 -06}
{2438218800 -21600 0 -06}
{2451528000 -18000 1 -06}
{2469668400 -21600 0 -06}
{2482977600 -18000 1 -06}
{2501118000 -21600 0 -06}
{2514427200 -18000 1 -06}
{2532567600 -21600 0 -06}
{2545876800 -18000 1 -06}
{2564017200 -21600 0 -06}
{2577326400 -18000 1 -06}
{2596071600 -21600 0 -06}
{2609380800 -18000 1 -06}
{2627521200 -21600 0 -06}
{2640830400 -18000 1 -06}
{2658970800 -21600 0 -06}
{2672280000 -18000 1 -06}
{2690420400 -21600 0 -06}
{2703729600 -18000 1 -06}
{2721870000 -21600 0 -06}
{2735179200 -18000 1 -06}
{2753924400 -21600 0 -06}
{2766628800 -18000 1 -06}
{2785374000 -21600 0 -06}
{2798683200 -18000 1 -06}
{2816823600 -21600 0 -06}
{2830132800 -18000 1 -06}
{2848273200 -21600 0 -06}
{2861582400 -18000 1 -06}
{2879722800 -21600 0 -06}
{2893032000 -18000 1 -06}
{2911172400 -21600 0 -06}
{2924481600 -18000 1 -06}
{2943226800 -21600 0 -06}
{2955931200 -18000 1 -06}
{2974676400 -21600 0 -06}
{2987985600 -18000 1 -06}
{3006126000 -21600 0 -06}
{3019435200 -18000 1 -06}
{3037575600 -21600 0 -06}
{3050884800 -18000 1 -06}
{3069025200 -21600 0 -06}
{3082334400 -18000 1 -06}
{3101079600 -21600 0 -06}
{3113784000 -18000 1 -06}
{3132529200 -21600 0 -06}
{3145838400 -18000 1 -06}
{3163978800 -21600 0 -06}
{3177288000 -18000 1 -06}
{3195428400 -21600 0 -06}
{3208737600 -18000 1 -06}
{3226878000 -21600 0 -06}
{3240187200 -18000 1 -06}
{3258327600 -21600 0 -06}
{3271636800 -18000 1 -06}
{3290382000 -21600 0 -06}
{3303086400 -18000 1 -06}
{3321831600 -21600 0 -06}
{3335140800 -18000 1 -06}
{3353281200 -21600 0 -06}
{3366590400 -18000 1 -06}
{3384730800 -21600 0 -06}
{3398040000 -18000 1 -06}
{3416180400 -21600 0 -06}
{3429489600 -18000 1 -06}
{3447630000 -21600 0 -06}
{3460939200 -18000 1 -06}
{3479684400 -21600 0 -06}
{3492993600 -18000 1 -06}
{3511134000 -21600 0 -06}
{3524443200 -18000 1 -06}
{3542583600 -21600 0 -06}
{3555892800 -18000 1 -06}
{3574033200 -21600 0 -06}
{3587342400 -18000 1 -06}
{3605482800 -21600 0 -06}
{3618792000 -18000 1 -06}
{3637537200 -21600 0 -06}
{3650241600 -18000 1 -06}
{3668986800 -21600 0 -06}
{3682296000 -18000 1 -06}
{3700436400 -21600 0 -06}
{3713745600 -18000 1 -06}
{3731886000 -21600 0 -06}
{3745195200 -18000 1 -06}
{3763335600 -21600 0 -06}
{3776644800 -18000 1 -06}
{3794785200 -21600 0 -06}
{3808094400 -18000 1 -06}
{3826839600 -21600 0 -06}
{3839544000 -18000 1 -06}
{3858289200 -21600 0 -06}
{3871598400 -18000 1 -06}
{3889738800 -21600 0 -06}
{3903048000 -18000 1 -06}
{3921188400 -21600 0 -06}
{3934497600 -18000 1 -06}
{3952638000 -21600 0 -06}
{3965947200 -18000 1 -06}
{3984692400 -21600 0 -06}
{3997396800 -18000 1 -06}
{4016142000 -21600 0 -06}
{4029451200 -18000 1 -06}
{4047591600 -21600 0 -06}
{4060900800 -18000 1 -06}
{4079041200 -21600 0 -06}
{4092350400 -18000 1 -06}
}
|
Changes to library/tzdata/Pacific/Efate.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Efate) {
{-9223372036854775808 40396 0 LMT}
{-1829387596 39600 0 +11}
| | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Efate) {
{-9223372036854775808 40396 0 LMT}
{-1829387596 39600 0 +11}
{433256400 43200 1 +11}
{448977600 39600 0 +11}
{467298000 43200 1 +11}
{480427200 39600 0 +11}
{496760400 43200 1 +11}
{511876800 39600 0 +11}
{528210000 43200 1 +11}
{543931200 39600 0 +11}
{559659600 43200 1 +11}
{575380800 39600 0 +11}
{591109200 43200 1 +11}
{606830400 39600 0 +11}
{622558800 43200 1 +11}
{638280000 39600 0 +11}
{654008400 43200 1 +11}
{669729600 39600 0 +11}
{686062800 43200 1 +11}
{696340800 39600 0 +11}
{719931600 43200 1 +11}
{727790400 39600 0 +11}
}
|
Changes to library/tzdata/Pacific/Enderbury.
1 2 3 4 5 6 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Enderbury) {
{-9223372036854775808 -41060 0 LMT}
{-2177411740 -43200 0 -12}
{307627200 -39600 0 -11}
| | | 1 2 3 4 5 6 7 8 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Enderbury) {
{-9223372036854775808 -41060 0 LMT}
{-2177411740 -43200 0 -12}
{307627200 -39600 0 -11}
{788871600 46800 0 +13}
}
|
Changes to library/tzdata/Pacific/Fiji.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Fiji) {
{-9223372036854775808 42944 0 LMT}
{-1709985344 43200 0 +12}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Fiji) {
{-9223372036854775808 42944 0 LMT}
{-1709985344 43200 0 +12}
{909842400 46800 1 +12}
{920124000 43200 0 +12}
{941896800 46800 1 +12}
{951573600 43200 0 +12}
{1259416800 46800 1 +12}
{1269698400 43200 0 +12}
{1287842400 46800 1 +12}
{1299333600 43200 0 +12}
{1319292000 46800 1 +12}
{1327154400 43200 0 +12}
{1350741600 46800 1 +12}
{1358604000 43200 0 +12}
{1382796000 46800 1 +12}
{1390050000 43200 0 +12}
{1414850400 46800 1 +12}
{1421503200 43200 0 +12}
{1446300000 46800 1 +12}
{1452952800 43200 0 +12}
{1478354400 46800 1 +12}
{1484402400 43200 0 +12}
{1509804000 46800 1 +12}
{1515852000 43200 0 +12}
{1541253600 46800 1 +12}
{1547301600 43200 0 +12}
{1572703200 46800 1 +12}
{1579356000 43200 0 +12}
{1604152800 46800 1 +12}
{1610805600 43200 0 +12}
{1636207200 46800 1 +12}
{1642255200 43200 0 +12}
{1667656800 46800 1 +12}
{1673704800 43200 0 +12}
{1699106400 46800 1 +12}
{1705154400 43200 0 +12}
{1730556000 46800 1 +12}
{1737208800 43200 0 +12}
{1762005600 46800 1 +12}
{1768658400 43200 0 +12}
{1793455200 46800 1 +12}
{1800108000 43200 0 +12}
{1825509600 46800 1 +12}
{1831557600 43200 0 +12}
{1856959200 46800 1 +12}
{1863007200 43200 0 +12}
{1888408800 46800 1 +12}
{1894456800 43200 0 +12}
{1919858400 46800 1 +12}
{1926511200 43200 0 +12}
{1951308000 46800 1 +12}
{1957960800 43200 0 +12}
{1983362400 46800 1 +12}
{1989410400 43200 0 +12}
{2014812000 46800 1 +12}
{2020860000 43200 0 +12}
{2046261600 46800 1 +12}
{2052309600 43200 0 +12}
{2077711200 46800 1 +12}
{2083759200 43200 0 +12}
{2109160800 46800 1 +12}
{2115813600 43200 0 +12}
{2140610400 46800 1 +12}
{2147263200 43200 0 +12}
{2172664800 46800 1 +12}
{2178712800 43200 0 +12}
{2204114400 46800 1 +12}
{2210162400 43200 0 +12}
{2235564000 46800 1 +12}
{2241612000 43200 0 +12}
{2267013600 46800 1 +12}
{2273666400 43200 0 +12}
{2298463200 46800 1 +12}
{2305116000 43200 0 +12}
{2329912800 46800 1 +12}
{2336565600 43200 0 +12}
{2361967200 46800 1 +12}
{2368015200 43200 0 +12}
{2393416800 46800 1 +12}
{2399464800 43200 0 +12}
{2424866400 46800 1 +12}
{2430914400 43200 0 +12}
{2456316000 46800 1 +12}
{2462968800 43200 0 +12}
{2487765600 46800 1 +12}
{2494418400 43200 0 +12}
{2519820000 46800 1 +12}
{2525868000 43200 0 +12}
{2551269600 46800 1 +12}
{2557317600 43200 0 +12}
{2582719200 46800 1 +12}
{2588767200 43200 0 +12}
{2614168800 46800 1 +12}
{2620821600 43200 0 +12}
{2645618400 46800 1 +12}
{2652271200 43200 0 +12}
{2677068000 46800 1 +12}
{2683720800 43200 0 +12}
{2709122400 46800 1 +12}
{2715170400 43200 0 +12}
{2740572000 46800 1 +12}
{2746620000 43200 0 +12}
{2772021600 46800 1 +12}
{2778069600 43200 0 +12}
{2803471200 46800 1 +12}
{2810124000 43200 0 +12}
{2834920800 46800 1 +12}
{2841573600 43200 0 +12}
{2866975200 46800 1 +12}
{2873023200 43200 0 +12}
{2898424800 46800 1 +12}
{2904472800 43200 0 +12}
{2929874400 46800 1 +12}
{2935922400 43200 0 +12}
{2961324000 46800 1 +12}
{2967372000 43200 0 +12}
{2992773600 46800 1 +12}
{2999426400 43200 0 +12}
{3024223200 46800 1 +12}
{3030876000 43200 0 +12}
{3056277600 46800 1 +12}
{3062325600 43200 0 +12}
{3087727200 46800 1 +12}
{3093775200 43200 0 +12}
{3119176800 46800 1 +12}
{3125224800 43200 0 +12}
{3150626400 46800 1 +12}
{3157279200 43200 0 +12}
{3182076000 46800 1 +12}
{3188728800 43200 0 +12}
{3213525600 46800 1 +12}
{3220178400 43200 0 +12}
{3245580000 46800 1 +12}
{3251628000 43200 0 +12}
{3277029600 46800 1 +12}
{3283077600 43200 0 +12}
{3308479200 46800 1 +12}
{3314527200 43200 0 +12}
{3339928800 46800 1 +12}
{3346581600 43200 0 +12}
{3371378400 46800 1 +12}
{3378031200 43200 0 +12}
{3403432800 46800 1 +12}
{3409480800 43200 0 +12}
{3434882400 46800 1 +12}
{3440930400 43200 0 +12}
{3466332000 46800 1 +12}
{3472380000 43200 0 +12}
{3497781600 46800 1 +12}
{3504434400 43200 0 +12}
{3529231200 46800 1 +12}
{3535884000 43200 0 +12}
{3560680800 46800 1 +12}
{3567333600 43200 0 +12}
{3592735200 46800 1 +12}
{3598783200 43200 0 +12}
{3624184800 46800 1 +12}
{3630232800 43200 0 +12}
{3655634400 46800 1 +12}
{3661682400 43200 0 +12}
{3687084000 46800 1 +12}
{3693736800 43200 0 +12}
{3718533600 46800 1 +12}
{3725186400 43200 0 +12}
{3750588000 46800 1 +12}
{3756636000 43200 0 +12}
{3782037600 46800 1 +12}
{3788085600 43200 0 +12}
{3813487200 46800 1 +12}
{3819535200 43200 0 +12}
{3844936800 46800 1 +12}
{3850984800 43200 0 +12}
{3876386400 46800 1 +12}
{3883039200 43200 0 +12}
{3907836000 46800 1 +12}
{3914488800 43200 0 +12}
{3939890400 46800 1 +12}
{3945938400 43200 0 +12}
{3971340000 46800 1 +12}
{3977388000 43200 0 +12}
{4002789600 46800 1 +12}
{4008837600 43200 0 +12}
{4034239200 46800 1 +12}
{4040892000 43200 0 +12}
{4065688800 46800 1 +12}
{4072341600 43200 0 +12}
{4097138400 46800 1 +12}
}
|
Changes to library/tzdata/Pacific/Galapagos.
1 2 3 4 5 6 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Galapagos) {
{-9223372036854775808 -21504 0 LMT}
{-1230746496 -18000 0 -05}
{504939600 -21600 0 -06}
| | | 1 2 3 4 5 6 7 8 9 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Galapagos) {
{-9223372036854775808 -21504 0 LMT}
{-1230746496 -18000 0 -05}
{504939600 -21600 0 -06}
{722930400 -18000 1 -06}
{728888400 -21600 0 -06}
}
|
Changes to library/tzdata/Pacific/Guam.
1 2 3 4 5 6 7 8 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Guam) {
{-9223372036854775808 -51660 0 LMT}
{-3944626740 34740 0 LMT}
{-2177487540 36000 0 GST}
{977493600 36000 0 ChST}
}
| > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Guam) {
{-9223372036854775808 -51660 0 LMT}
{-3944626740 34740 0 LMT}
{-2177487540 36000 0 GST}
{-885549600 32400 0 +09}
{-802256400 36000 0 GST}
{-331891200 39600 1 GDT}
{-281610000 36000 0 GST}
{-73728000 39600 1 GDT}
{-29415540 36000 0 GST}
{-16704000 39600 1 GDT}
{-10659600 36000 0 GST}
{9907200 39600 1 GDT}
{21394800 36000 0 GST}
{41356800 39600 1 GDT}
{52844400 36000 0 GST}
{124819200 39600 1 GDT}
{130863600 36000 0 GST}
{201888000 39600 1 GDT}
{209487660 36000 0 GST}
{230659200 39600 1 GDT}
{241542000 36000 0 GST}
{977493600 36000 0 ChST}
}
|
Changes to library/tzdata/Pacific/Honolulu.
1 2 3 4 5 6 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Honolulu) {
{-9223372036854775808 -37886 0 LMT}
{-2334101314 -37800 0 HST}
{-1157283000 -34200 1 HDT}
| | > | | 1 2 3 4 5 6 7 8 9 10 11 12 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Honolulu) {
{-9223372036854775808 -37886 0 LMT}
{-2334101314 -37800 0 HST}
{-1157283000 -34200 1 HDT}
{-1155436200 -34200 0 HST}
{-880201800 -34200 1 HWT}
{-769395600 -34200 1 HPT}
{-765376200 -37800 0 HST}
{-712150200 -36000 0 HST}
}
|
Changes to library/tzdata/Pacific/Kiritimati.
1 2 3 4 5 6 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Kiritimati) {
{-9223372036854775808 -37760 0 LMT}
{-2177415040 -38400 0 -1040}
{307622400 -36000 0 -10}
| | | 1 2 3 4 5 6 7 8 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Kiritimati) {
{-9223372036854775808 -37760 0 LMT}
{-2177415040 -38400 0 -1040}
{307622400 -36000 0 -10}
{788868000 50400 0 +14}
}
|
Changes to library/tzdata/Pacific/Kosrae.
1 2 3 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Kosrae) {
| | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Kosrae) {
{-9223372036854775808 -47284 0 LMT}
{-3944631116 39116 0 LMT}
{-2177491916 39600 0 +11}
{-1743678000 32400 0 +09}
{-1606813200 39600 0 +11}
{-1041418800 36000 0 +10}
{-907408800 32400 0 +09}
{-770634000 39600 0 +11}
{-7988400 43200 0 +12}
{915105600 39600 0 +11}
}
|
Changes to library/tzdata/Pacific/Kwajalein.
1 2 3 4 5 6 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Kwajalein) {
{-9223372036854775808 40160 0 LMT}
{-2177492960 39600 0 +11}
{-7988400 -43200 0 -12}
| > > > | | 1 2 3 4 5 6 7 8 9 10 11 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Kwajalein) {
{-9223372036854775808 40160 0 LMT}
{-2177492960 39600 0 +11}
{-1041418800 36000 0 +10}
{-907408800 32400 0 +09}
{-817462800 39600 0 +11}
{-7988400 -43200 0 -12}
{745934400 43200 0 +12}
}
|
Changes to library/tzdata/Pacific/Majuro.
1 2 3 4 5 6 7 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Majuro) {
{-9223372036854775808 41088 0 LMT}
{-2177493888 39600 0 +11}
{-7988400 43200 0 +12}
}
| > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Majuro) {
{-9223372036854775808 41088 0 LMT}
{-2177493888 39600 0 +11}
{-1743678000 32400 0 +09}
{-1606813200 39600 0 +11}
{-1041418800 36000 0 +10}
{-907408800 32400 0 +09}
{-818067600 39600 0 +11}
{-7988400 43200 0 +12}
}
|
Changes to library/tzdata/Pacific/Nauru.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Nauru) {
{-9223372036854775808 40060 0 LMT}
{-1545131260 41400 0 +1130}
| | | | | 1 2 3 4 5 6 7 8 9 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Nauru) {
{-9223372036854775808 40060 0 LMT}
{-1545131260 41400 0 +1130}
{-862918200 32400 0 +09}
{-767350800 41400 0 +1130}
{287418600 43200 0 +12}
}
|
Changes to library/tzdata/Pacific/Noumea.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Noumea) {
{-9223372036854775808 39948 0 LMT}
{-1829387148 39600 0 +11}
| | | | | 1 2 3 4 5 6 7 8 9 10 11 12 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Noumea) {
{-9223372036854775808 39948 0 LMT}
{-1829387148 39600 0 +11}
{250002000 43200 1 +11}
{257342400 39600 0 +11}
{281451600 43200 1 +11}
{288878400 39600 0 +11}
{849366000 43200 1 +11}
{857228400 39600 0 +11}
}
|
Changes to library/tzdata/Pacific/Palau.
1 2 3 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Palau) {
| | > | 1 2 3 4 5 6 7 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Palau) {
{-9223372036854775808 -54124 0 LMT}
{-3944624276 32276 0 LMT}
{-2177485076 32400 0 +09}
}
|
Changes to library/tzdata/Pacific/Pohnpei.
1 2 3 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Pohnpei) {
| | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Pohnpei) {
{-9223372036854775808 -48428 0 LMT}
{-3944629972 37972 0 LMT}
{-2177490772 39600 0 +11}
{-1743678000 32400 0 +09}
{-1606813200 39600 0 +11}
{-1041418800 36000 0 +10}
{-907408800 32400 0 +09}
{-770634000 39600 0 +11}
}
|
Changes to library/tzdata/Pacific/Rarotonga.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Rarotonga) {
{-9223372036854775808 -38344 0 LMT}
{-2177414456 -37800 0 -1030}
| | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Rarotonga) {
{-9223372036854775808 -38344 0 LMT}
{-2177414456 -37800 0 -1030}
{279714600 -34200 0 -10}
{289387800 -36000 0 -10}
{309952800 -34200 1 -10}
{320837400 -36000 0 -10}
{341402400 -34200 1 -10}
{352287000 -36000 0 -10}
{372852000 -34200 1 -10}
{384341400 -36000 0 -10}
{404906400 -34200 1 -10}
{415791000 -36000 0 -10}
{436356000 -34200 1 -10}
{447240600 -36000 0 -10}
{467805600 -34200 1 -10}
{478690200 -36000 0 -10}
{499255200 -34200 1 -10}
{510139800 -36000 0 -10}
{530704800 -34200 1 -10}
{541589400 -36000 0 -10}
{562154400 -34200 1 -10}
{573643800 -36000 0 -10}
{594208800 -34200 1 -10}
{605093400 -36000 0 -10}
{625658400 -34200 1 -10}
{636543000 -36000 0 -10}
{657108000 -34200 1 -10}
{667992600 -36000 0 -10}
}
|
Changes to library/tzdata/Pacific/Tongatapu.
1 2 3 4 5 6 7 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Tongatapu) {
{-9223372036854775808 44360 0 LMT}
{-2177497160 44400 0 +1220}
{-915193200 46800 0 +13}
{915102000 46800 0 +13}
| | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Tongatapu) {
{-9223372036854775808 44360 0 LMT}
{-2177497160 44400 0 +1220}
{-915193200 46800 0 +13}
{915102000 46800 0 +13}
{939214800 50400 1 +13}
{953384400 46800 0 +13}
{973342800 50400 1 +13}
{980596800 46800 0 +13}
{1004792400 50400 1 +13}
{1012046400 46800 0 +13}
{1478350800 50400 1 +13}
{1484398800 46800 0 +13}
}
|
Changes to library/tzdata/UCT.
1 | # created by tools/tclZIC.tcl - do not edit | | | | | 1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
if {![info exists TZData(Etc/UTC)]} {
LoadTimeZoneFile Etc/UTC
}
set TZData(:UCT) $TZData(:Etc/UTC)
|
Changes to libtommath/LICENSE.
|
| | | < | | | | > | | | | < < | | > > | | | | | < < | < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 |
The LibTom license
This is free and unencumbered software released into the public domain.
Anyone is free to copy, modify, publish, use, compile, sell, or
distribute this software, either in source code form or as a compiled
binary, for any purpose, commercial or non-commercial, and by any
means.
In jurisdictions that recognize copyright laws, the author or authors
of this software dedicate any and all copyright interest in the
software to the public domain. We make this dedication for the benefit
of the public at large and to the detriment of our heirs and
successors. We intend this dedication to be an overt act of
relinquishment in perpetuity of all present and future rights to this
software under copyright law.
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 AND NONINFRINGEMENT.
IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR
OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE,
ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
OTHER DEALINGS IN THE SOFTWARE.
For more information, please refer to <http://unlicense.org/>
|
Changes to libtommath/README.md.
1 2 3 4 5 6 | # libtommath This is the git repository for [LibTomMath](http://www.libtom.net/LibTomMath/), a free open source portable number theoretic multiple-precision integer (MPI) library written entirely in C. ## Build Status | | | > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | # libtommath This is the git repository for [LibTomMath](http://www.libtom.net/LibTomMath/), a free open source portable number theoretic multiple-precision integer (MPI) library written entirely in C. ## Build Status master: [](https://travis-ci.org/libtom/libtommath) develop: [](https://travis-ci.org/libtom/libtommath) API/ABI changes: [check here](https://abi-laboratory.pro/tracker/timeline/libtommath/) ## Summary The `develop` branch contains the in-development version. Stable releases are tagged. Documentation is built from the LaTeX file `bn.tex`. There is also limited documentation in `tommath.h`. There is also a document, `tommath.pdf`, which describes the goals of the project and many of the algorithms used. |
| ︙ | ︙ |
Changes to libtommath/bn_error.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
#include "tommath_private.h"
#ifdef BN_ERROR_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
static const struct {
int code;
const char *msg;
} msgs[] = {
{ MP_OKAY, "Successful" },
|
| ︙ | ︙ |
Changes to libtommath/bn_fast_mp_invmod.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | #include "tommath_private.h" #ifdef BN_FAST_MP_INVMOD_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * SPDX-License-Identifier: Unlicense */ /* computes the modular inverse via binary extended euclidean algorithm, * that is c = 1/a mod b * * Based on slow invmod except this is optimized for the case where b is * odd as per HAC Note 14.64 on pp. 610 |
| ︙ | ︙ | |||
136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 |
/* b is now the inverse */
neg = a->sign;
while (D.sign == MP_NEG) {
if ((res = mp_add(&D, b, &D)) != MP_OKAY) {
goto LBL_ERR;
}
}
mp_exch(&D, c);
c->sign = neg;
res = MP_OKAY;
LBL_ERR:
mp_clear_multi(&x, &y, &u, &v, &B, &D, NULL);
return res;
}
#endif
/* ref: $Format:%D$ */
/* git commit: $Format:%H$ */
/* commit time: $Format:%ai$ */
| > > > > > > > > | 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 |
/* b is now the inverse */
neg = a->sign;
while (D.sign == MP_NEG) {
if ((res = mp_add(&D, b, &D)) != MP_OKAY) {
goto LBL_ERR;
}
}
/* too big */
while (mp_cmp_mag(&D, b) != MP_LT) {
if ((res = mp_sub(&D, b, &D)) != MP_OKAY) {
goto LBL_ERR;
}
}
mp_exch(&D, c);
c->sign = neg;
res = MP_OKAY;
LBL_ERR:
mp_clear_multi(&x, &y, &u, &v, &B, &D, NULL);
return res;
}
#endif
/* ref: $Format:%D$ */
/* git commit: $Format:%H$ */
/* commit time: $Format:%ai$ */
|
Changes to libtommath/bn_fast_mp_montgomery_reduce.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | #include "tommath_private.h" #ifdef BN_FAST_MP_MONTGOMERY_REDUCE_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * SPDX-License-Identifier: Unlicense */ /* computes xR**-1 == x (mod N) via Montgomery Reduction * * This is an optimized implementation of montgomery_reduce * which uses the comba method to quickly calculate the columns of the * reduction. |
| ︙ | ︙ |
Changes to libtommath/bn_fast_s_mp_mul_digs.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | #include "tommath_private.h" #ifdef BN_FAST_S_MP_MUL_DIGS_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * SPDX-License-Identifier: Unlicense */ /* Fast (comba) multiplier * * This is the fast column-array [comba] multiplier. It is * designed to compute the columns of the product first * then handle the carries afterwards. This has the effect |
| ︙ | ︙ |
Changes to libtommath/bn_fast_s_mp_mul_high_digs.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | #include "tommath_private.h" #ifdef BN_FAST_S_MP_MUL_HIGH_DIGS_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * SPDX-License-Identifier: Unlicense */ /* this is a modified version of fast_s_mul_digs that only produces * output digits *above* digs. See the comments for fast_s_mul_digs * to see how it works. * * This is used in the Barrett reduction since for one of the multiplications |
| ︙ | ︙ |
Changes to libtommath/bn_fast_s_mp_sqr.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | #include "tommath_private.h" #ifdef BN_FAST_S_MP_SQR_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * SPDX-License-Identifier: Unlicense */ /* the jist of squaring... * you do like mult except the offset of the tmpx [one that * starts closer to zero] can't equal the offset of tmpy. * So basically you set up iy like before then you min it with * (ty-tx) so that it never happens. You double all those |
| ︙ | ︙ |
Changes to libtommath/bn_mp_2expt.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | #include "tommath_private.h" #ifdef BN_MP_2EXPT_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * SPDX-License-Identifier: Unlicense */ /* computes a = 2**b * * Simple algorithm which zeroes the int, grows it then just sets one bit * as required. */ |
| ︙ | ︙ |
Changes to libtommath/bn_mp_abs.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | #include "tommath_private.h" #ifdef BN_MP_ABS_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * SPDX-License-Identifier: Unlicense */ /* b = |a| * * Simple function copies the input and fixes the sign to positive */ int mp_abs(const mp_int *a, mp_int *b) |
| ︙ | ︙ |
Changes to libtommath/bn_mp_add.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
#include "tommath_private.h"
#ifdef BN_MP_ADD_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* high level addition (handles signs) */
int mp_add(const mp_int *a, const mp_int *b, mp_int *c)
{
int sa, sb, res;
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_add_d.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
#include "tommath_private.h"
#ifdef BN_MP_ADD_D_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* single digit addition */
int mp_add_d(const mp_int *a, mp_digit b, mp_int *c)
{
int res, ix, oldused;
mp_digit *tmpa, *tmpc, mu;
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_addmod.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
#include "tommath_private.h"
#ifdef BN_MP_ADDMOD_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* d = a + b (mod c) */
int mp_addmod(const mp_int *a, const mp_int *b, const mp_int *c, mp_int *d)
{
int res;
mp_int t;
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_and.c.
|
| | | > | < | | < > | | < < | > | > | < > | < < > | > | | | > > > > > > | < < < | > > | | > | < < > < < | > < > > > | > | | < < < | | > | < < < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 |
#include "tommath_private.h"
#ifdef BN_MP_AND_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* two complement and */
mp_err mp_and(const mp_int *a, const mp_int *b, mp_int *c)
{
int used = MAX(a->used, b->used) + 1, i;
mp_err err;
mp_digit ac = 1, bc = 1, cc = 1;
mp_sign csign = ((a->sign == MP_NEG) && (b->sign == MP_NEG)) ? MP_NEG : MP_ZPOS;
if (c->alloc < used) {
if ((err = mp_grow(c, used)) != MP_OKAY) {
return err;
}
}
for (i = 0; i < used; i++) {
mp_digit x, y;
/* convert to two complement if negative */
if (a->sign == MP_NEG) {
ac += (i >= a->used) ? MP_MASK : (~a->dp[i] & MP_MASK);
x = ac & MP_MASK;
ac >>= MP_DIGIT_BIT;
} else {
x = (i >= a->used) ? 0uL : a->dp[i];
}
/* convert to two complement if negative */
if (b->sign == MP_NEG) {
bc += (i >= b->used) ? MP_MASK : (~b->dp[i] & MP_MASK);
y = bc & MP_MASK;
bc >>= MP_DIGIT_BIT;
} else {
y = (i >= b->used) ? 0uL : b->dp[i];
}
c->dp[i] = x & y;
/* convert to to sign-magnitude if negative */
if (csign == MP_NEG) {
cc += ~c->dp[i] & MP_MASK;
c->dp[i] = cc & MP_MASK;
cc >>= MP_DIGIT_BIT;
}
}
c->used = used;
c->sign = csign;
mp_clamp(c);
return MP_OKAY;
}
#endif
|
Changes to libtommath/bn_mp_clamp.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | #include "tommath_private.h" #ifdef BN_MP_CLAMP_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * SPDX-License-Identifier: Unlicense */ /* trim unused digits * * This is used to ensure that leading zero digits are * trimed and the leading "used" digit will be non-zero * Typically very fast. Also fixes the sign if there |
| ︙ | ︙ |
Changes to libtommath/bn_mp_clear.c.
|
| | | < < < | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 |
#include "tommath_private.h"
#ifdef BN_MP_CLEAR_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* clear one (frees) */
void mp_clear(mp_int *a)
{
int i;
/* only do anything if a hasn't been freed previously */
if (a->dp != NULL) {
/* first zero the digits */
for (i = 0; i < a->used; i++) {
a->dp[i] = 0;
}
/* free ram */
XFREE(a->dp, sizeof (mp_digit) * (size_t)a->alloc);
/* reset members to make debugging easier */
a->dp = NULL;
a->alloc = a->used = 0;
a->sign = MP_ZPOS;
}
}
#endif
/* ref: $Format:%D$ */
/* git commit: $Format:%H$ */
/* commit time: $Format:%ai$ */
|
Changes to libtommath/bn_mp_clear_multi.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
#include "tommath_private.h"
#ifdef BN_MP_CLEAR_MULTI_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
#include <stdarg.h>
void mp_clear_multi(mp_int *mp, ...)
{
mp_int *next_mp = mp;
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_cmp.c.
|
| | | | < < | < < < < < < < < < < | < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 |
#include "tommath_private.h"
#ifdef BN_MP_CMP_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* compare two ints (signed)*/
mp_ord mp_cmp(const mp_int *a, const mp_int *b)
{
/* compare based on sign */
if (a->sign != b->sign) {
if (a->sign == MP_NEG) {
return MP_LT;
} else {
return MP_GT;
}
}
/* compare digits */
if (a->sign == MP_NEG) {
/* if negative compare opposite direction */
return mp_cmp_mag(b, a);
} else {
return mp_cmp_mag(a, b);
}
}
#endif
|
Changes to libtommath/bn_mp_cmp_d.c.
|
| | | | < < | < < < < < < < < < < | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 |
#include "tommath_private.h"
#ifdef BN_MP_CMP_D_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* compare a digit */
mp_ord mp_cmp_d(const mp_int *a, mp_digit b)
{
/* compare based on sign */
if (a->sign == MP_NEG) {
return MP_LT;
}
/* compare based on magnitude */
|
| ︙ | ︙ | |||
34 35 36 37 38 39 40 |
} else if (a->dp[0] < b) {
return MP_LT;
} else {
return MP_EQ;
}
}
#endif
| < < < < | 22 23 24 25 26 27 28 |
} else if (a->dp[0] < b) {
return MP_LT;
} else {
return MP_EQ;
}
}
#endif
|
Changes to libtommath/bn_mp_cmp_mag.c.
|
| | | | < < | < < < < < < < < < < | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 |
#include "tommath_private.h"
#ifdef BN_MP_CMP_MAG_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* compare maginitude of two ints (unsigned) */
mp_ord mp_cmp_mag(const mp_int *a, const mp_int *b)
{
int n;
const mp_digit *tmpa, *tmpb;
/* compare based on # of non-zero digits */
if (a->used > b->used) {
return MP_GT;
}
if (a->used < b->used) {
|
| ︙ | ︙ | |||
45 46 47 48 49 50 51 |
if (*tmpa < *tmpb) {
return MP_LT;
}
}
return MP_EQ;
}
#endif
| < < < < | 33 34 35 36 37 38 39 |
if (*tmpa < *tmpb) {
return MP_LT;
}
}
return MP_EQ;
}
#endif
|
Changes to libtommath/bn_mp_cnt_lsb.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
#include "tommath_private.h"
#ifdef BN_MP_CNT_LSB_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
static const int lnz[16] = {
4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0
};
/* Counts the number of lsbs which are zero before the first zero bit */
|
| ︙ | ︙ |
Added libtommath/bn_mp_complement.c.
> > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
#include "tommath_private.h"
#ifdef BN_MP_COMPLEMENT_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* b = ~a */
int mp_complement(const mp_int *a, mp_int *b)
{
int res = mp_neg(a, b);
return (res == MP_OKAY) ? mp_sub_d(b, 1uL, b) : res;
}
#endif
/* ref: $Format:%D$ */
/* git commit: $Format:%H$ */
/* commit time: $Format:%ai$ */
|
Changes to libtommath/bn_mp_copy.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
#include "tommath_private.h"
#ifdef BN_MP_COPY_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* copy, b = a */
int mp_copy(const mp_int *a, mp_int *b)
{
int res, n;
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_count_bits.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
#include "tommath_private.h"
#ifdef BN_MP_COUNT_BITS_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* returns the number of bits in an int */
int mp_count_bits(const mp_int *a)
{
int r;
mp_digit q;
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_div.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
#include "tommath_private.h"
#ifdef BN_MP_DIV_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
#ifdef BN_MP_DIV_SMALL
/* slower bit-bang division... also smaller */
int mp_div(const mp_int *a, const mp_int *b, mp_int *c, mp_int *d)
{
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_div_2.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
#include "tommath_private.h"
#ifdef BN_MP_DIV_2_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* b = a/2 */
int mp_div_2(const mp_int *a, mp_int *b)
{
int x, res, oldused;
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_div_2d.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
#include "tommath_private.h"
#ifdef BN_MP_DIV_2D_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* shift right by a certain bit count (store quotient in c, optional remainder in d) */
int mp_div_2d(const mp_int *a, int b, mp_int *c, mp_int *d)
{
mp_digit D, r, rr;
int x, res;
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_div_3.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
#include "tommath_private.h"
#ifdef BN_MP_DIV_3_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* divide by three (based on routine from MPI and the GMP manual) */
int mp_div_3(const mp_int *a, mp_int *c, mp_digit *d)
{
mp_int q;
mp_word w, t;
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_div_d.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
#include "tommath_private.h"
#ifdef BN_MP_DIV_D_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* single digit division (based on routine from MPI) */
int mp_div_d(const mp_int *a, mp_digit b, mp_int *c, mp_digit *d)
{
mp_int q;
mp_word w;
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_dr_is_modulus.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
#include "tommath_private.h"
#ifdef BN_MP_DR_IS_MODULUS_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* determines if a number is a valid DR modulus */
int mp_dr_is_modulus(const mp_int *a)
{
int ix;
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_dr_reduce.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | #include "tommath_private.h" #ifdef BN_MP_DR_REDUCE_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * SPDX-License-Identifier: Unlicense */ /* reduce "x" in place modulo "n" using the Diminished Radix algorithm. * * Based on algorithm from the paper * * "Generating Efficient Primes for Discrete Log Cryptosystems" |
| ︙ | ︙ |
Changes to libtommath/bn_mp_dr_setup.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
#include "tommath_private.h"
#ifdef BN_MP_DR_SETUP_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* determines the setup value */
void mp_dr_setup(const mp_int *a, mp_digit *d)
{
/* the casts are required if DIGIT_BIT is one less than
* the number of bits in a mp_digit [e.g. DIGIT_BIT==31]
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_exch.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
#include "tommath_private.h"
#ifdef BN_MP_EXCH_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* swap the elements of two integers, for cases where you can't simply swap the
* mp_int pointers around
*/
void mp_exch(mp_int *a, mp_int *b)
{
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_export.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
#include "tommath_private.h"
#ifdef BN_MP_EXPORT_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* based on gmp's mpz_export.
* see http://gmplib.org/manual/Integer-Import-and-Export.html
*/
int mp_export(void *rop, size_t *countp, int order, size_t size,
int endian, size_t nails, const mp_int *op)
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_expt_d.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
#include "tommath_private.h"
#ifdef BN_MP_EXPT_D_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* wrapper function for mp_expt_d_ex() */
int mp_expt_d(const mp_int *a, mp_digit b, mp_int *c)
{
return mp_expt_d_ex(a, b, c, 0);
}
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_expt_d_ex.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
#include "tommath_private.h"
#ifdef BN_MP_EXPT_D_EX_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* calculate c = a**b using a square-multiply algorithm */
int mp_expt_d_ex(const mp_int *a, mp_digit b, mp_int *c, int fast)
{
int res;
unsigned int x;
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_exptmod.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | #include "tommath_private.h" #ifdef BN_MP_EXPTMOD_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * SPDX-License-Identifier: Unlicense */ /* this is a shell function that calls either the normal or Montgomery * exptmod functions. Originally the call to the montgomery code was * embedded in the normal function but that wasted alot of stack space * for nothing (since 99% of the time the Montgomery code would be called) |
| ︙ | ︙ |
Changes to libtommath/bn_mp_exptmod_fast.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | #include "tommath_private.h" #ifdef BN_MP_EXPTMOD_FAST_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * SPDX-License-Identifier: Unlicense */ /* computes Y == G**X mod P, HAC pp.616, Algorithm 14.85 * * Uses a left-to-right k-ary sliding window to compute the modular exponentiation. * The value of k changes based on the size of the exponent. * |
| ︙ | ︙ | |||
163 164 165 166 167 168 169 |
mp_set(&res, 1uL);
if ((err = mp_mod(G, P, &M[1])) != MP_OKAY) {
goto LBL_RES;
}
}
/* compute the value at M[1<<(winsize-1)] by squaring M[1] (winsize-1) times */
| | | | | 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 |
mp_set(&res, 1uL);
if ((err = mp_mod(G, P, &M[1])) != MP_OKAY) {
goto LBL_RES;
}
}
/* compute the value at M[1<<(winsize-1)] by squaring M[1] (winsize-1) times */
if ((err = mp_copy(&M[1], &M[(size_t)1 << (winsize - 1)])) != MP_OKAY) {
goto LBL_RES;
}
for (x = 0; x < (winsize - 1); x++) {
if ((err = mp_sqr(&M[(size_t)1 << (winsize - 1)], &M[(size_t)1 << (winsize - 1)])) != MP_OKAY) {
goto LBL_RES;
}
if ((err = redux(&M[(size_t)1 << (winsize - 1)], P, mp)) != MP_OKAY) {
goto LBL_RES;
}
}
/* create upper table */
for (x = (1 << (winsize - 1)) + 1; x < (1 << winsize); x++) {
if ((err = mp_mul(&M[x - 1], &M[1], &M[x])) != MP_OKAY) {
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_exteuclid.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
#include "tommath_private.h"
#ifdef BN_MP_EXTEUCLID_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* Extended euclidean algorithm of (a, b) produces
a*u1 + b*u2 = u3
*/
int mp_exteuclid(const mp_int *a, const mp_int *b, mp_int *U1, mp_int *U2, mp_int *U3)
{
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_fread.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
#include "tommath_private.h"
#ifdef BN_MP_FREAD_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
#ifndef LTM_NO_FILE
/* read a bigint from a file stream in ASCII */
int mp_fread(mp_int *a, int radix, FILE *stream)
{
int err, ch, neg, y;
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_fwrite.c.
|
| | | < < < | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 |
#include "tommath_private.h"
#ifdef BN_MP_FWRITE_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
#ifndef LTM_NO_FILE
int mp_fwrite(const mp_int *a, int radix, FILE *stream)
{
char *buf;
int err, len, x;
if ((err = mp_radix_size(a, radix, &len)) != MP_OKAY) {
return err;
}
buf = (char *) XMALLOC((size_t)len);
if (buf == NULL) {
return MP_MEM;
}
if ((err = mp_toradix(a, buf, radix)) != MP_OKAY) {
XFREE(buf, len);
return err;
}
for (x = 0; x < len; x++) {
if (fputc((int)buf[x], stream) == EOF) {
XFREE(buf, len);
return MP_VAL;
}
}
XFREE(buf, len);
return MP_OKAY;
}
#endif
#endif
/* ref: $Format:%D$ */
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_gcd.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
#include "tommath_private.h"
#ifdef BN_MP_GCD_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* Greatest Common Divisor using the binary method */
int mp_gcd(const mp_int *a, const mp_int *b, mp_int *c)
{
mp_int u, v;
int k, u_lsb, v_lsb, res;
|
| ︙ | ︙ |
Added libtommath/bn_mp_get_double.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 |
#include "tommath_private.h"
#ifdef BN_MP_GET_DOUBLE_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
double mp_get_double(const mp_int *a)
{
int i;
double d = 0.0, fac = 1.0;
for (i = 0; i < DIGIT_BIT; ++i) {
fac *= 2.0;
}
for (i = a->used; i --> 0;) {
d = (d * fac) + (double)a->dp[i];
}
return (a->sign == MP_NEG) ? -d : d;
}
#endif
/* ref: $Format:%D$ */
/* git commit: $Format:%H$ */
/* commit time: $Format:%ai$ */
|
Changes to libtommath/bn_mp_get_int.c.
|
| | | < < < < < < < < < < < < < < < < < < < < | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
#include "tommath_private.h"
#ifdef BN_MP_GET_INT_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* get the lower 32-bits of an mp_int */
unsigned long mp_get_int(const mp_int *a)
{
/* force result to 32-bits always so it is consistent on non 32-bit platforms */
return mp_get_long(a) & 0xFFFFFFFFUL;
}
#endif
/* ref: $Format:%D$ */
/* git commit: $Format:%H$ */
/* commit time: $Format:%ai$ */
|
Changes to libtommath/bn_mp_get_long.c.
|
| | | < < < | | | | | > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 |
#include "tommath_private.h"
#ifdef BN_MP_GET_LONG_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* get the lower unsigned long of an mp_int, platform dependent */
unsigned long mp_get_long(const mp_int *a)
{
int i;
unsigned long res;
if (IS_ZERO(a)) {
return 0;
}
/* get number of digits of the lsb we have to read */
i = MIN(a->used, (((CHAR_BIT * (int)sizeof(unsigned long)) + DIGIT_BIT - 1) / DIGIT_BIT)) - 1;
/* get most significant digit of result */
res = (unsigned long)a->dp[i];
#if (ULONG_MAX != 0xFFFFFFFFUL) || (DIGIT_BIT < 32)
while (--i >= 0) {
res = (res << DIGIT_BIT) | (unsigned long)a->dp[i];
}
#endif
return res;
}
#endif
/* ref: $Format:%D$ */
/* git commit: $Format:%H$ */
/* commit time: $Format:%ai$ */
|
Changes to libtommath/bn_mp_get_long_long.c.
|
| | | < < < | | | | > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 |
#include "tommath_private.h"
#ifdef BN_MP_GET_LONG_LONG_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* get the lower unsigned long long of an mp_int, platform dependent */
Tcl_WideUInt mp_get_long_long(const mp_int *a)
{
int i;
Tcl_WideUInt res;
if (IS_ZERO(a)) {
return 0;
}
/* get number of digits of the lsb we have to read */
i = MIN(a->used, (((CHAR_BIT * (int)sizeof(Tcl_WideUInt)) + DIGIT_BIT - 1) / DIGIT_BIT)) - 1;
/* get most significant digit of result */
res = (unsigned long long)a->dp[i];
#if DIGIT_BIT < 64
while (--i >= 0) {
res = (res << DIGIT_BIT) | (unsigned long long)a->dp[i];
}
#endif
return res;
}
#endif
/* ref: $Format:%D$ */
/* git commit: $Format:%H$ */
/* commit time: $Format:%ai$ */
|
Changes to libtommath/bn_mp_grow.c.
|
| | | < < < | > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 |
#include "tommath_private.h"
#ifdef BN_MP_GROW_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* grow as required */
int mp_grow(mp_int *a, int size)
{
int i;
mp_digit *tmp;
/* if the alloc size is smaller alloc more ram */
if (a->alloc < size) {
/* ensure there are always at least MP_PREC digits extra on top */
size += (MP_PREC * 2) - (size % MP_PREC);
/* reallocate the array a->dp
*
* We store the return in a temporary variable
* in case the operation failed we don't want
* to overwrite the dp member of a.
*/
tmp = (mp_digit *) XREALLOC(a->dp,
(size_t)a->alloc * sizeof (mp_digit),
(size_t)size * sizeof(mp_digit));
if (tmp == NULL) {
/* reallocation failed but "a" is still valid [can be freed] */
return MP_MEM;
}
/* reallocation succeeded so set a->dp */
a->dp = tmp;
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_import.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
#include "tommath_private.h"
#ifdef BN_MP_IMPORT_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* based on gmp's mpz_import.
* see http://gmplib.org/manual/Integer-Import-and-Export.html
*/
int mp_import(mp_int *rop, size_t count, int order, size_t size,
int endian, size_t nails, const void *op)
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_init.c.
|
| | | < < < | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 |
#include "tommath_private.h"
#ifdef BN_MP_INIT_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* init a new mp_int */
int mp_init(mp_int *a)
{
int i;
/* allocate memory required and clear it */
a->dp = (mp_digit *) XMALLOC(MP_PREC * sizeof(mp_digit));
if (a->dp == NULL) {
return MP_MEM;
}
/* set the digits to zero */
for (i = 0; i < MP_PREC; i++) {
a->dp[i] = 0;
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_init_copy.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
#include "tommath_private.h"
#ifdef BN_MP_INIT_COPY_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* creates "a" then copies b into it */
int mp_init_copy(mp_int *a, const mp_int *b)
{
int res;
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_init_multi.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
#include "tommath_private.h"
#ifdef BN_MP_INIT_MULTI_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
#include <stdarg.h>
int mp_init_multi(mp_int *mp, ...)
{
mp_err res = MP_OKAY; /* Assume ok until proven otherwise */
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_init_set.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
#include "tommath_private.h"
#ifdef BN_MP_INIT_SET_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* initialize and set a digit */
int mp_init_set(mp_int *a, mp_digit b)
{
int err;
if ((err = mp_init(a)) != MP_OKAY) {
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_init_set_int.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
#include "tommath_private.h"
#ifdef BN_MP_INIT_SET_INT_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* initialize and set a digit */
int mp_init_set_int(mp_int *a, unsigned long b)
{
int err;
if ((err = mp_init(a)) != MP_OKAY) {
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_init_size.c.
|
| | | < < < | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 |
#include "tommath_private.h"
#ifdef BN_MP_INIT_SIZE_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* init an mp_init for a given size */
int mp_init_size(mp_int *a, int size)
{
int x;
/* pad size so there are always extra digits */
size += (MP_PREC * 2) - (size % MP_PREC);
/* alloc mem */
a->dp = (mp_digit *) XMALLOC((size_t)size * sizeof(mp_digit));
if (a->dp == NULL) {
return MP_MEM;
}
/* set the members */
a->used = 0;
a->alloc = size;
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_invmod.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
#include "tommath_private.h"
#ifdef BN_MP_INVMOD_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* hac 14.61, pp608 */
int mp_invmod(const mp_int *a, const mp_int *b, mp_int *c)
{
/* b cannot be negative and has to be >1 */
if ((b->sign == MP_NEG) || (mp_cmp_d(b, 1uL) != MP_GT)) {
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_invmod_slow.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
#include "tommath_private.h"
#ifdef BN_MP_INVMOD_SLOW_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* hac 14.61, pp608 */
int mp_invmod_slow(const mp_int *a, const mp_int *b, mp_int *c)
{
mp_int x, y, u, v, A, B, C, D;
int res;
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_is_square.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
#include "tommath_private.h"
#ifdef BN_MP_IS_SQUARE_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* Check if remainders are possible squares - fast exclude non-squares */
static const char rem_128[128] = {
0, 0, 1, 1, 0, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1,
0, 0, 1, 1, 1, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1,
1, 0, 1, 1, 0, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1,
|
| ︙ | ︙ | |||
48 49 50 51 52 53 54 |
/* Default to Non-square :) */
*ret = MP_NO;
if (arg->sign == MP_NEG) {
return MP_VAL;
}
| < | | | | | | | | | | | | | | | 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 |
/* Default to Non-square :) */
*ret = MP_NO;
if (arg->sign == MP_NEG) {
return MP_VAL;
}
if (IS_ZERO(arg)) {
return MP_OKAY;
}
/* First check mod 128 (suppose that DIGIT_BIT is at least 7) */
if (rem_128[127u & arg->dp[0]] == (char)1) {
return MP_OKAY;
}
/* Next check mod 105 (3*5*7) */
if ((res = mp_mod_d(arg, 105uL, &c)) != MP_OKAY) {
return res;
}
if (rem_105[c] == (char)1) {
return MP_OKAY;
}
if ((res = mp_init_set_int(&t, 11L*13L*17L*19L*23L*29L*31L)) != MP_OKAY) {
return res;
}
if ((res = mp_mod(arg, &t, &t)) != MP_OKAY) {
goto LBL_ERR;
}
r = mp_get_int(&t);
/* Check for other prime modules, note it's not an ERROR but we must
* free "t" so the easiest way is to goto LBL_ERR. We know that res
* is already equal to MP_OKAY from the mp_mod call
*/
if (((1uL<<(r%11uL)) & 0x5C4uL) != 0uL) goto LBL_ERR;
if (((1uL<<(r%13uL)) & 0x9E4uL) != 0uL) goto LBL_ERR;
if (((1uL<<(r%17uL)) & 0x5CE8uL) != 0uL) goto LBL_ERR;
if (((1uL<<(r%19uL)) & 0x4F50CuL) != 0uL) goto LBL_ERR;
if (((1uL<<(r%23uL)) & 0x7ACCA0uL) != 0uL) goto LBL_ERR;
if (((1uL<<(r%29uL)) & 0xC2EDD0CuL) != 0uL) goto LBL_ERR;
if (((1uL<<(r%31uL)) & 0x6DE2B848uL) != 0uL) goto LBL_ERR;
/* Final check - is sqr(sqrt(arg)) == arg ? */
if ((res = mp_sqrt(arg, &t)) != MP_OKAY) {
goto LBL_ERR;
}
if ((res = mp_sqr(&t, &t)) != MP_OKAY) {
goto LBL_ERR;
}
*ret = (mp_cmp_mag(&t, arg) == MP_EQ) ? MP_YES : MP_NO;
LBL_ERR:
mp_clear(&t);
return res;
}
#endif
/* ref: $Format:%D$ */
/* git commit: $Format:%H$ */
/* commit time: $Format:%ai$ */
|
Changes to libtommath/bn_mp_jacobi.c.
|
| | | < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 |
#include "tommath_private.h"
#ifdef BN_MP_JACOBI_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* computes the jacobi c = (a | n) (or Legendre if n is prime)
* Kept for legacy reasons, please use mp_kronecker() instead
*/
int mp_jacobi(const mp_int *a, const mp_int *n, int *c)
{
/* if a < 0 return MP_VAL */
if (mp_isneg(a) == MP_YES) {
return MP_VAL;
}
/* if n <= 0 return MP_VAL */
if (mp_cmp_d(n, 0uL) != MP_GT) {
return MP_VAL;
}
return mp_kronecker(a, n, c);
}
#endif
/* ref: $Format:%D$ */
/* git commit: $Format:%H$ */
/* commit time: $Format:%ai$ */
|
Changes to libtommath/bn_mp_karatsuba_mul.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | #include "tommath_private.h" #ifdef BN_MP_KARATSUBA_MUL_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * SPDX-License-Identifier: Unlicense */ /* c = |a| * |b| using Karatsuba Multiplication using * three half size multiplications * * Let B represent the radix [e.g. 2**DIGIT_BIT] and * let n represent half of the number of digits in |
| ︙ | ︙ | |||
56 57 58 59 60 61 62 | B = MIN(a->used, b->used); /* now divide in two */ B = B >> 1; /* init copy all the temps */ if (mp_init_size(&x0, B) != MP_OKAY) | | | 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 |
B = MIN(a->used, b->used);
/* now divide in two */
B = B >> 1;
/* init copy all the temps */
if (mp_init_size(&x0, B) != MP_OKAY)
goto LBL_ERR;
if (mp_init_size(&x1, a->used - B) != MP_OKAY)
goto X0;
if (mp_init_size(&y0, B) != MP_OKAY)
goto X1;
if (mp_init_size(&y1, b->used - B) != MP_OKAY)
goto Y0;
|
| ︙ | ︙ | |||
160 161 162 163 164 165 166 | mp_clear(&y1); Y0: mp_clear(&y0); X1: mp_clear(&x1); X0: mp_clear(&x0); | | | 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 | mp_clear(&y1); Y0: mp_clear(&y0); X1: mp_clear(&x1); X0: mp_clear(&x0); LBL_ERR: return err; } #endif /* ref: $Format:%D$ */ /* git commit: $Format:%H$ */ /* commit time: $Format:%ai$ */ |
Changes to libtommath/bn_mp_karatsuba_sqr.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | #include "tommath_private.h" #ifdef BN_MP_KARATSUBA_SQR_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * SPDX-License-Identifier: Unlicense */ /* Karatsuba squaring, computes b = a*a using three * half size squarings * * See comments of karatsuba_mul for details. It * is essentially the same algorithm but merely |
| ︙ | ︙ | |||
33 34 35 36 37 38 39 | B = a->used; /* now divide in two */ B = B >> 1; /* init copy all the temps */ if (mp_init_size(&x0, B) != MP_OKAY) | | | 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 |
B = a->used;
/* now divide in two */
B = B >> 1;
/* init copy all the temps */
if (mp_init_size(&x0, B) != MP_OKAY)
goto LBL_ERR;
if (mp_init_size(&x1, a->used - B) != MP_OKAY)
goto X0;
/* init temps */
if (mp_init_size(&t1, a->used * 2) != MP_OKAY)
goto X1;
if (mp_init_size(&t2, a->used * 2) != MP_OKAY)
|
| ︙ | ︙ | |||
113 114 115 116 117 118 119 | mp_clear(&t2); T1: mp_clear(&t1); X1: mp_clear(&x1); X0: mp_clear(&x0); | | | 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 | mp_clear(&t2); T1: mp_clear(&t1); X1: mp_clear(&x1); X0: mp_clear(&x0); LBL_ERR: return err; } #endif /* ref: $Format:%D$ */ /* git commit: $Format:%H$ */ /* commit time: $Format:%ai$ */ |
Added libtommath/bn_mp_kronecker.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 |
#include "tommath_private.h"
#ifdef BN_MP_KRONECKER_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/*
Kronecker symbol (a|p)
Straightforward implementation of algorithm 1.4.10 in
Henri Cohen: "A Course in Computational Algebraic Number Theory"
@book{cohen2013course,
title={A course in computational algebraic number theory},
author={Cohen, Henri},
volume={138},
year={2013},
publisher={Springer Science \& Business Media}
}
*/
int mp_kronecker(const mp_int *a, const mp_int *p, int *c)
{
mp_int a1, p1, r;
int e = MP_OKAY;
int v, k;
static const int table[8] = {0, 1, 0, -1, 0, -1, 0, 1};
if (mp_iszero(p) != MP_NO) {
if ((a->used == 1) && (a->dp[0] == 1u)) {
*c = 1;
return e;
} else {
*c = 0;
return e;
}
}
if ((mp_iseven(a) != MP_NO) && (mp_iseven(p) != MP_NO)) {
*c = 0;
return e;
}
if ((e = mp_init_copy(&a1, a)) != MP_OKAY) {
return e;
}
if ((e = mp_init_copy(&p1, p)) != MP_OKAY) {
goto LBL_KRON_0;
}
v = mp_cnt_lsb(&p1);
if ((e = mp_div_2d(&p1, v, &p1, NULL)) != MP_OKAY) {
goto LBL_KRON_1;
}
if ((v & 0x1) == 0) {
k = 1;
} else {
k = table[a->dp[0] & 7u];
}
if (p1.sign == MP_NEG) {
p1.sign = MP_ZPOS;
if (a1.sign == MP_NEG) {
k = -k;
}
}
if ((e = mp_init(&r)) != MP_OKAY) {
goto LBL_KRON_1;
}
for (;;) {
if (mp_iszero(&a1) != MP_NO) {
if (mp_cmp_d(&p1, 1uL) == MP_EQ) {
*c = k;
goto LBL_KRON;
} else {
*c = 0;
goto LBL_KRON;
}
}
v = mp_cnt_lsb(&a1);
if ((e = mp_div_2d(&a1, v, &a1, NULL)) != MP_OKAY) {
goto LBL_KRON;
}
if ((v & 0x1) == 1) {
k = k * table[p1.dp[0] & 7u];
}
if (a1.sign == MP_NEG) {
/*
* Compute k = (-1)^((a1)*(p1-1)/4) * k
* a1.dp[0] + 1 cannot overflow because the MSB
* of the type mp_digit is not set by definition
*/
if (((a1.dp[0] + 1u) & p1.dp[0] & 2u) != 0u) {
k = -k;
}
} else {
/* compute k = (-1)^((a1-1)*(p1-1)/4) * k */
if ((a1.dp[0] & p1.dp[0] & 2u) != 0u) {
k = -k;
}
}
if ((e = mp_copy(&a1, &r)) != MP_OKAY) {
goto LBL_KRON;
}
r.sign = MP_ZPOS;
if ((e = mp_mod(&p1, &r, &a1)) != MP_OKAY) {
goto LBL_KRON;
}
if ((e = mp_copy(&r, &p1)) != MP_OKAY) {
goto LBL_KRON;
}
}
LBL_KRON:
mp_clear(&r);
LBL_KRON_1:
mp_clear(&p1);
LBL_KRON_0:
mp_clear(&a1);
return e;
}
#endif
/* ref: $Format:%D$ */
/* git commit: $Format:%H$ */
/* commit time: $Format:%ai$ */
|
Changes to libtommath/bn_mp_lcm.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
#include "tommath_private.h"
#ifdef BN_MP_LCM_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* computes least common multiple as |a*b|/(a, b) */
int mp_lcm(const mp_int *a, const mp_int *b, mp_int *c)
{
int res;
mp_int t1, t2;
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_lshd.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
#include "tommath_private.h"
#ifdef BN_MP_LSHD_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* shift left a certain amount of digits */
int mp_lshd(mp_int *a, int b)
{
int x, res;
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_mod.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
#include "tommath_private.h"
#ifdef BN_MP_MOD_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* c = a mod b, 0 <= c < b if b > 0, b < c <= 0 if b < 0 */
int mp_mod(const mp_int *a, const mp_int *b, mp_int *c)
{
mp_int t;
int res;
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_mod_2d.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
#include "tommath_private.h"
#ifdef BN_MP_MOD_2D_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* calc a value mod 2**b */
int mp_mod_2d(const mp_int *a, int b, mp_int *c)
{
int x, res;
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_mod_d.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
#include "tommath_private.h"
#ifdef BN_MP_MOD_D_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
int mp_mod_d(const mp_int *a, mp_digit b, mp_digit *c)
{
return mp_div_d(a, b, NULL, c);
}
#endif
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_montgomery_calc_normalization.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | #include "tommath_private.h" #ifdef BN_MP_MONTGOMERY_CALC_NORMALIZATION_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * SPDX-License-Identifier: Unlicense */ /* * shifts with subtractions when the result is greater than b. * * The method is slightly modified to shift B unconditionally upto just under * the leading bit of b. This saves alot of multiple precision shifting. |
| ︙ | ︙ |
Changes to libtommath/bn_mp_montgomery_reduce.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
#include "tommath_private.h"
#ifdef BN_MP_MONTGOMERY_REDUCE_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* computes xR**-1 == x (mod N) via Montgomery Reduction */
int mp_montgomery_reduce(mp_int *x, const mp_int *n, mp_digit rho)
{
int ix, res, digs;
mp_digit mu;
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_montgomery_setup.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
#include "tommath_private.h"
#ifdef BN_MP_MONTGOMERY_SETUP_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* setups the montgomery reduction stuff */
int mp_montgomery_setup(const mp_int *n, mp_digit *rho)
{
mp_digit x, b;
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_mul.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
#include "tommath_private.h"
#ifdef BN_MP_MUL_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* high level multiplication (handles sign) */
int mp_mul(const mp_int *a, const mp_int *b, mp_int *c)
{
int res, neg;
neg = (a->sign == b->sign) ? MP_ZPOS : MP_NEG;
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_mul_2.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
#include "tommath_private.h"
#ifdef BN_MP_MUL_2_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* b = a*2 */
int mp_mul_2(const mp_int *a, mp_int *b)
{
int x, res, oldused;
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_mul_2d.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
#include "tommath_private.h"
#ifdef BN_MP_MUL_2D_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* shift left by a certain bit count */
int mp_mul_2d(const mp_int *a, int b, mp_int *c)
{
mp_digit d;
int res;
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_mul_d.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
#include "tommath_private.h"
#ifdef BN_MP_MUL_D_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* multiply by a digit */
int mp_mul_d(const mp_int *a, mp_digit b, mp_int *c)
{
mp_digit u, *tmpa, *tmpc;
mp_word r;
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_mulmod.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
#include "tommath_private.h"
#ifdef BN_MP_MULMOD_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* d = a * b (mod c) */
int mp_mulmod(const mp_int *a, const mp_int *b, const mp_int *c, mp_int *d)
{
int res;
mp_int t;
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_n_root.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
#include "tommath_private.h"
#ifdef BN_MP_N_ROOT_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* wrapper function for mp_n_root_ex()
* computes c = (a)**(1/b) such that (c)**b <= a and (c+1)**b > a
*/
int mp_n_root(const mp_int *a, mp_digit b, mp_int *c)
{
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_n_root_ex.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | #include "tommath_private.h" #ifdef BN_MP_N_ROOT_EX_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * SPDX-License-Identifier: Unlicense */ /* find the n'th root of an integer * * Result found such that (c)**b <= a and (c+1)**b > a * * This algorithm uses Newton's approximation |
| ︙ | ︙ |
Changes to libtommath/bn_mp_neg.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
#include "tommath_private.h"
#ifdef BN_MP_NEG_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* b = -a */
int mp_neg(const mp_int *a, mp_int *b)
{
int res;
if (a != b) {
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_or.c.
|
| | | > | < | | < > | | < < | > | > | < > | < < > | > | | | > > > > > > | < < < | > > | | > | < < > | > | > > > > > | | < < | > > | < < < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 |
#include "tommath_private.h"
#ifdef BN_MP_OR_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* two complement or */
mp_err mp_or(const mp_int *a, const mp_int *b, mp_int *c)
{
int used = MAX(a->used, b->used) + 1, i;
mp_err err;
mp_digit ac = 1, bc = 1, cc = 1;
mp_sign csign = ((a->sign == MP_NEG) || (b->sign == MP_NEG)) ? MP_NEG : MP_ZPOS;
if (c->alloc < used) {
if ((err = mp_grow(c, used)) != MP_OKAY) {
return err;
}
}
for (i = 0; i < used; i++) {
mp_digit x, y;
/* convert to two complement if negative */
if (a->sign == MP_NEG) {
ac += (i >= a->used) ? MP_MASK : (~a->dp[i] & MP_MASK);
x = ac & MP_MASK;
ac >>= MP_DIGIT_BIT;
} else {
x = (i >= a->used) ? 0uL : a->dp[i];
}
/* convert to two complement if negative */
if (b->sign == MP_NEG) {
bc += (i >= b->used) ? MP_MASK : (~b->dp[i] & MP_MASK);
y = bc & MP_MASK;
bc >>= MP_DIGIT_BIT;
} else {
y = (i >= b->used) ? 0uL : b->dp[i];
}
c->dp[i] = x | y;
/* convert to to sign-magnitude if negative */
if (csign == MP_NEG) {
cc += ~c->dp[i] & MP_MASK;
c->dp[i] = cc & MP_MASK;
cc >>= MP_DIGIT_BIT;
}
}
c->used = used;
c->sign = csign;
mp_clamp(c);
return MP_OKAY;
}
#endif
|
Changes to libtommath/bn_mp_prime_fermat.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | #include "tommath_private.h" #ifdef BN_MP_PRIME_FERMAT_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * SPDX-License-Identifier: Unlicense */ /* performs one Fermat test. * * If "a" were prime then b**a == b (mod a) since the order of * the multiplicative sub-group would be phi(a) = a-1. That means * it would be the same as b**(a mod (a-1)) == b**1 == b (mod a). |
| ︙ | ︙ |
Added libtommath/bn_mp_prime_frobenius_underwood.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 |
#include "tommath_private.h"
#ifdef BN_MP_PRIME_FROBENIUS_UNDERWOOD_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/*
* See file bn_mp_prime_is_prime.c or the documentation in doc/bn.tex for the details
*/
#ifndef LTM_USE_FIPS_ONLY
#ifdef MP_8BIT
/*
* floor of positive solution of
* (2^16)-1 = (a+4)*(2*a+5)
* TODO: Both values are smaller than N^(1/4), would have to use a bigint
* for a instead but any a biger than about 120 are already so rare that
* it is possible to ignore them and still get enough pseudoprimes.
* But it is still a restriction of the set of available pseudoprimes
* which makes this implementation less secure if used stand-alone.
*/
#define LTM_FROBENIUS_UNDERWOOD_A 177
#else
#define LTM_FROBENIUS_UNDERWOOD_A 32764
#endif
int mp_prime_frobenius_underwood(const mp_int *N, int *result)
{
mp_int T1z, T2z, Np1z, sz, tz;
int a, ap2, length, i, j, isset;
int e;
*result = MP_NO;
if ((e = mp_init_multi(&T1z, &T2z, &Np1z, &sz, &tz, NULL)) != MP_OKAY) {
return e;
}
for (a = 0; a < LTM_FROBENIUS_UNDERWOOD_A; a++) {
/* TODO: That's ugly! No, really, it is! */
if ((a==2) || (a==4) || (a==7) || (a==8) || (a==10) ||
(a==14) || (a==18) || (a==23) || (a==26) || (a==28)) {
continue;
}
/* (32764^2 - 4) < 2^31, no bigint for >MP_8BIT needed) */
if ((e = mp_set_long(&T1z, (unsigned long)a)) != MP_OKAY) {
goto LBL_FU_ERR;
}
if ((e = mp_sqr(&T1z, &T1z)) != MP_OKAY) {
goto LBL_FU_ERR;
}
if ((e = mp_sub_d(&T1z, 4uL, &T1z)) != MP_OKAY) {
goto LBL_FU_ERR;
}
if ((e = mp_kronecker(&T1z, N, &j)) != MP_OKAY) {
goto LBL_FU_ERR;
}
if (j == -1) {
break;
}
if (j == 0) {
/* composite */
goto LBL_FU_ERR;
}
}
/* Tell it a composite and set return value accordingly */
if (a >= LTM_FROBENIUS_UNDERWOOD_A) {
e = MP_ITER;
goto LBL_FU_ERR;
}
/* Composite if N and (a+4)*(2*a+5) are not coprime */
if ((e = mp_set_long(&T1z, (unsigned long)((a+4)*((2*a)+5)))) != MP_OKAY) {
goto LBL_FU_ERR;
}
if ((e = mp_gcd(N, &T1z, &T1z)) != MP_OKAY) {
goto LBL_FU_ERR;
}
if (!((T1z.used == 1) && (T1z.dp[0] == 1u))) {
goto LBL_FU_ERR;
}
ap2 = a + 2;
if ((e = mp_add_d(N, 1uL, &Np1z)) != MP_OKAY) {
goto LBL_FU_ERR;
}
mp_set(&sz, 1uL);
mp_set(&tz, 2uL);
length = mp_count_bits(&Np1z);
for (i = length - 2; i >= 0; i--) {
/*
* temp = (sz*(a*sz+2*tz))%N;
* tz = ((tz-sz)*(tz+sz))%N;
* sz = temp;
*/
if ((e = mp_mul_2(&tz, &T2z)) != MP_OKAY) {
goto LBL_FU_ERR;
}
/* a = 0 at about 50% of the cases (non-square and odd input) */
if (a != 0) {
if ((e = mp_mul_d(&sz, (mp_digit)a, &T1z)) != MP_OKAY) {
goto LBL_FU_ERR;
}
if ((e = mp_add(&T1z, &T2z, &T2z)) != MP_OKAY) {
goto LBL_FU_ERR;
}
}
if ((e = mp_mul(&T2z, &sz, &T1z)) != MP_OKAY) {
goto LBL_FU_ERR;
}
if ((e = mp_sub(&tz, &sz, &T2z)) != MP_OKAY) {
goto LBL_FU_ERR;
}
if ((e = mp_add(&sz, &tz, &sz)) != MP_OKAY) {
goto LBL_FU_ERR;
}
if ((e = mp_mul(&sz, &T2z, &tz)) != MP_OKAY) {
goto LBL_FU_ERR;
}
if ((e = mp_mod(&tz, N, &tz)) != MP_OKAY) {
goto LBL_FU_ERR;
}
if ((e = mp_mod(&T1z, N, &sz)) != MP_OKAY) {
goto LBL_FU_ERR;
}
if ((isset = mp_get_bit(&Np1z, i)) == MP_VAL) {
e = isset;
goto LBL_FU_ERR;
}
if (isset == MP_YES) {
/*
* temp = (a+2) * sz + tz
* tz = 2 * tz - sz
* sz = temp
*/
if (a == 0) {
if ((e = mp_mul_2(&sz, &T1z)) != MP_OKAY) {
goto LBL_FU_ERR;
}
} else {
if ((e = mp_mul_d(&sz, (mp_digit)ap2, &T1z)) != MP_OKAY) {
goto LBL_FU_ERR;
}
}
if ((e = mp_add(&T1z, &tz, &T1z)) != MP_OKAY) {
goto LBL_FU_ERR;
}
if ((e = mp_mul_2(&tz, &T2z)) != MP_OKAY) {
goto LBL_FU_ERR;
}
if ((e = mp_sub(&T2z, &sz, &tz)) != MP_OKAY) {
goto LBL_FU_ERR;
}
mp_exch(&sz, &T1z);
}
}
if ((e = mp_set_long(&T1z, (unsigned long)((2 * a) + 5))) != MP_OKAY) {
goto LBL_FU_ERR;
}
if ((e = mp_mod(&T1z, N, &T1z)) != MP_OKAY) {
goto LBL_FU_ERR;
}
if ((mp_iszero(&sz) != MP_NO) && (mp_cmp(&tz, &T1z) == MP_EQ)) {
*result = MP_YES;
goto LBL_FU_ERR;
}
LBL_FU_ERR:
mp_clear_multi(&tz, &sz, &Np1z, &T2z, &T1z, NULL);
return e;
}
#endif
#endif
/* ref: $Format:%D$ */
/* git commit: $Format:%H$ */
/* commit time: $Format:%ai$ */
|
Changes to libtommath/bn_mp_prime_is_divisible.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | #include "tommath_private.h" #ifdef BN_MP_PRIME_IS_DIVISIBLE_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * SPDX-License-Identifier: Unlicense */ /* determines if an integers is divisible by one * of the first PRIME_SIZE primes or not * * sets result to 0 if not, 1 if yes */ |
| ︙ | ︙ |
Changes to libtommath/bn_mp_prime_is_prime.c.
|
| | | < | | < > > | | < > | | > > | | < | > | > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > | > | < < | > | > > > > > > > > > | | | > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 |
#include "tommath_private.h"
#ifdef BN_MP_PRIME_IS_PRIME_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* portable integer log of two with small footprint */
static unsigned int s_floor_ilog2(int value)
{
unsigned int r = 0;
while ((value >>= 1) != 0) {
r++;
}
return r;
}
int mp_prime_is_prime(const mp_int *a, int t, int *result)
{
mp_int b;
int ix, err, res, p_max = 0, size_a, len;
unsigned int fips_rand, mask;
/* default to no */
*result = MP_NO;
/* valid value of t? */
if (t > PRIME_SIZE) {
return MP_VAL;
}
/* Some shortcuts */
/* N > 3 */
if (a->used == 1) {
if ((a->dp[0] == 0u) || (a->dp[0] == 1u)) {
*result = 0;
return MP_OKAY;
}
if (a->dp[0] == 2u) {
*result = 1;
return MP_OKAY;
}
}
/* N must be odd */
if (mp_iseven(a) == MP_YES) {
return MP_OKAY;
}
/* N is not a perfect square: floor(sqrt(N))^2 != N */
if ((err = mp_is_square(a, &res)) != MP_OKAY) {
return err;
}
if (res != 0) {
return MP_OKAY;
}
/* is the input equal to one of the primes in the table? */
for (ix = 0; ix < PRIME_SIZE; ix++) {
if (mp_cmp_d(a, ltm_prime_tab[ix]) == MP_EQ) {
*result = MP_YES;
return MP_OKAY;
}
}
#ifdef MP_8BIT
/* The search in the loop above was exhaustive in this case */
if ((a->used == 1) && (PRIME_SIZE >= 31)) {
return MP_OKAY;
}
#endif
/* first perform trial division */
if ((err = mp_prime_is_divisible(a, &res)) != MP_OKAY) {
return err;
}
/* return if it was trivially divisible */
if (res == MP_YES) {
return MP_OKAY;
}
/*
Run the Miller-Rabin test with base 2 for the BPSW test.
*/
if ((err = mp_init_set(&b, 2uL)) != MP_OKAY) {
return err;
}
if ((err = mp_prime_miller_rabin(a, &b, &res)) != MP_OKAY) {
goto LBL_B;
}
if (res == MP_NO) {
goto LBL_B;
}
/*
Rumours have it that Mathematica does a second M-R test with base 3.
Other rumours have it that their strong L-S test is slightly different.
It does not hurt, though, beside a bit of extra runtime.
*/
b.dp[0]++;
if ((err = mp_prime_miller_rabin(a, &b, &res)) != MP_OKAY) {
goto LBL_B;
}
if (res == MP_NO) {
goto LBL_B;
}
/*
* Both, the Frobenius-Underwood test and the the Lucas-Selfridge test are quite
* slow so if speed is an issue, define LTM_USE_FIPS_ONLY to use M-R tests with
* bases 2, 3 and t random bases.
*/
#ifndef LTM_USE_FIPS_ONLY
if (t >= 0) {
/*
* Use a Frobenius-Underwood test instead of the Lucas-Selfridge test for
* MP_8BIT (It is unknown if the Lucas-Selfridge test works with 16-bit
* integers but the necesssary analysis is on the todo-list).
*/
#if defined (MP_8BIT) || defined (LTM_USE_FROBENIUS_TEST)
err = mp_prime_frobenius_underwood(a, &res);
if ((err != MP_OKAY) && (err != MP_ITER)) {
goto LBL_B;
}
if (res == MP_NO) {
goto LBL_B;
}
#else
if ((err = mp_prime_strong_lucas_selfridge(a, &res)) != MP_OKAY) {
goto LBL_B;
}
if (res == MP_NO) {
goto LBL_B;
}
#endif
}
#endif
/* run at least one Miller-Rabin test with a random base */
if (t == 0) {
t = 1;
}
/*
abs(t) extra rounds of M-R to extend the range of primes it can find if t < 0.
Only recommended if the input range is known to be < 3317044064679887385961981
It uses the bases for a deterministic M-R test if input < 3317044064679887385961981
The caller has to check the size.
Not for cryptographic use because with known bases strong M-R pseudoprimes can
be constructed. Use at least one M-R test with a random base (t >= 1).
The 1119 bit large number
80383745745363949125707961434194210813883768828755814583748891752229742737653\
33652186502336163960045457915042023603208766569966760987284043965408232928738\
79185086916685732826776177102938969773947016708230428687109997439976544144845\
34115587245063340927902227529622941498423068816854043264575340183297861112989\
60644845216191652872597534901
has been constructed by F. Arnault (F. Arnault, "Rabin-Miller primality test:
composite numbers which pass it.", Mathematics of Computation, 1995, 64. Jg.,
Nr. 209, S. 355-361), is a semiprime with the two factors
40095821663949960541830645208454685300518816604113250877450620473800321707011\
96242716223191597219733582163165085358166969145233813917169287527980445796800\
452592031836601
20047910831974980270915322604227342650259408302056625438725310236900160853505\
98121358111595798609866791081582542679083484572616906958584643763990222898400\
226296015918301
and it is a strong pseudoprime to all forty-six prime M-R bases up to 200
It does not fail the strong Bailley-PSP test as implemented here, it is just
given as an example, if not the reason to use the BPSW-test instead of M-R-tests
with a sequence of primes 2...n.
*/
if (t < 0) {
t = -t;
/*
Sorenson, Jonathan; Webster, Jonathan (2015).
"Strong Pseudoprimes to Twelve Prime Bases".
*/
/* 0x437ae92817f9fc85b7e5 = 318665857834031151167461 */
if ((err = mp_read_radix(&b, "437ae92817f9fc85b7e5", 16)) != MP_OKAY) {
goto LBL_B;
}
if (mp_cmp(a, &b) == MP_LT) {
p_max = 12;
} else {
/* 0x2be6951adc5b22410a5fd = 3317044064679887385961981 */
if ((err = mp_read_radix(&b, "2be6951adc5b22410a5fd", 16)) != MP_OKAY) {
goto LBL_B;
}
if (mp_cmp(a, &b) == MP_LT) {
p_max = 13;
} else {
err = MP_VAL;
goto LBL_B;
}
}
/* for compatibility with the current API (well, compatible within a sign's width) */
if (p_max < t) {
p_max = t;
}
if (p_max > PRIME_SIZE) {
err = MP_VAL;
goto LBL_B;
}
/* we did bases 2 and 3 already, skip them */
for (ix = 2; ix < p_max; ix++) {
mp_set(&b, ltm_prime_tab[ix]);
if ((err = mp_prime_miller_rabin(a, &b, &res)) != MP_OKAY) {
goto LBL_B;
}
if (res == MP_NO) {
goto LBL_B;
}
}
}
/*
Do "t" M-R tests with random bases between 3 and "a".
See Fips 186.4 p. 126ff
*/
else if (t > 0) {
/*
* The mp_digit's have a defined bit-size but the size of the
* array a.dp is a simple 'int' and this library can not assume full
* compliance to the current C-standard (ISO/IEC 9899:2011) because
* it gets used for small embeded processors, too. Some of those MCUs
* have compilers that one cannot call standard compliant by any means.
* Hence the ugly type-fiddling in the following code.
*/
size_a = mp_count_bits(a);
mask = (1u << s_floor_ilog2(size_a)) - 1u;
/*
Assuming the General Rieman hypothesis (never thought to write that in a
comment) the upper bound can be lowered to 2*(log a)^2.
E. Bach, "Explicit bounds for primality testing and related problems,"
Math. Comp. 55 (1990), 355-380.
size_a = (size_a/10) * 7;
len = 2 * (size_a * size_a);
E.g.: a number of size 2^2048 would be reduced to the upper limit
floor(2048/10)*7 = 1428
2 * 1428^2 = 4078368
(would have been ~4030331.9962 with floats and natural log instead)
That number is smaller than 2^28, the default bit-size of mp_digit.
*/
/*
How many tests, you might ask? Dana Jacobsen of Math::Prime::Util fame
does exactly 1. In words: one. Look at the end of _GMP_is_prime() in
Math-Prime-Util-GMP-0.50/primality.c if you do not believe it.
The function mp_rand() goes to some length to use a cryptographically
good PRNG. That also means that the chance to always get the same base
in the loop is non-zero, although very low.
If the BPSW test and/or the addtional Frobenious test have been
performed instead of just the Miller-Rabin test with the bases 2 and 3,
a single extra test should suffice, so such a very unlikely event
will not do much harm.
To preemptivly answer the dangling question: no, a witness does not
need to be prime.
*/
for (ix = 0; ix < t; ix++) {
/* mp_rand() guarantees the first digit to be non-zero */
if ((err = mp_rand(&b, 1)) != MP_OKAY) {
goto LBL_B;
}
/*
* Reduce digit before casting because mp_digit might be bigger than
* an unsigned int and "mask" on the other side is most probably not.
*/
fips_rand = (unsigned int)(b.dp[0] & (mp_digit) mask);
#ifdef MP_8BIT
/*
* One 8-bit digit is too small, so concatenate two if the size of
* unsigned int allows for it.
*/
if (((sizeof(unsigned int) * CHAR_BIT)/2) >= (sizeof(mp_digit) * CHAR_BIT)) {
if ((err = mp_rand(&b, 1)) != MP_OKAY) {
goto LBL_B;
}
fips_rand <<= sizeof(mp_digit) * CHAR_BIT;
fips_rand |= (unsigned int) b.dp[0];
fips_rand &= mask;
}
#endif
if (fips_rand > (unsigned int)(INT_MAX - DIGIT_BIT)) {
len = INT_MAX / DIGIT_BIT;
} else {
len = (((int)fips_rand + DIGIT_BIT) / DIGIT_BIT);
}
/* Unlikely. */
if (len < 0) {
ix--;
continue;
}
/*
* As mentioned above, one 8-bit digit is too small and
* although it can only happen in the unlikely case that
* an "unsigned int" is smaller than 16 bit a simple test
* is cheap and the correction even cheaper.
*/
#ifdef MP_8BIT
/* All "a" < 2^8 have been caught before */
if (len == 1) {
len++;
}
#endif
if ((err = mp_rand(&b, len)) != MP_OKAY) {
goto LBL_B;
}
/*
* That number might got too big and the witness has to be
* smaller than or equal to "a"
*/
len = mp_count_bits(&b);
if (len > size_a) {
len = len - size_a;
if ((err = mp_div_2d(&b, len, &b, NULL)) != MP_OKAY) {
goto LBL_B;
}
}
/* Although the chance for b <= 3 is miniscule, try again. */
if (mp_cmp_d(&b, 3uL) != MP_GT) {
ix--;
continue;
}
if ((err = mp_prime_miller_rabin(a, &b, &res)) != MP_OKAY) {
goto LBL_B;
}
if (res == MP_NO) {
goto LBL_B;
}
}
}
/* passed the test */
*result = MP_YES;
LBL_B:
mp_clear(&b);
return err;
}
#endif
/* ref: $Format:%D$ */
/* git commit: $Format:%H$ */
/* commit time: $Format:%ai$ */
|
Changes to libtommath/bn_mp_prime_miller_rabin.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | #include "tommath_private.h" #ifdef BN_MP_PRIME_MILLER_RABIN_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * SPDX-License-Identifier: Unlicense */ /* Miller-Rabin test of "a" to the base of "b" as described in * HAC pp. 139 Algorithm 4.24 * * Sets result to 0 if definitely composite or 1 if probably prime. * Randomly the chance of error is no more than 1/4 and often |
| ︙ | ︙ |
Changes to libtommath/bn_mp_prime_next_prime.c.
|
| | | < < < < < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 |
#include "tommath_private.h"
#ifdef BN_MP_PRIME_NEXT_PRIME_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* finds the next prime after the number "a" using "t" trials
* of Miller-Rabin.
*
* bbs_style = 1 means the prime must be congruent to 3 mod 4
*/
int mp_prime_next_prime(mp_int *a, int t, int bbs_style)
{
int err, res = MP_NO, x, y;
mp_digit res_tab[PRIME_SIZE], step, kstep;
mp_int b;
/* force positive */
a->sign = MP_ZPOS;
/* simple algo if a is less than the largest prime in the table */
if (mp_cmp_d(a, ltm_prime_tab[PRIME_SIZE-1]) == MP_LT) {
/* find which prime it is bigger than */
for (x = PRIME_SIZE - 2; x >= 0; x--) {
|
| ︙ | ︙ | |||
139 140 141 142 143 144 145 |
}
/* if didn't pass sieve and step == MAX then skip test */
if ((y == 1) && (step >= (((mp_digit)1 << DIGIT_BIT) - kstep))) {
continue;
}
| < < < | | | < < < < < | 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 |
}
/* if didn't pass sieve and step == MAX then skip test */
if ((y == 1) && (step >= (((mp_digit)1 << DIGIT_BIT) - kstep))) {
continue;
}
if ((err = mp_prime_is_prime(a, t, &res)) != MP_OKAY) {
goto LBL_ERR;
}
if (res == MP_YES) {
break;
}
}
err = MP_OKAY;
LBL_ERR:
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_prime_rabin_miller_trials.c.
|
| | | < < < > > > | > > | > > | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 |
#include "tommath_private.h"
#ifdef BN_MP_PRIME_RABIN_MILLER_TRIALS_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
static const struct {
int k, t;
} sizes[] = {
{ 80, -1 }, /* Use deterministic algorithm for size <= 80 bits */
{ 81, 39 },
{ 96, 37 },
{ 128, 32 },
{ 160, 27 },
{ 192, 21 },
{ 256, 16 },
{ 384, 10 },
{ 512, 7 },
{ 640, 6 },
{ 768, 5 },
{ 896, 4 },
{ 1024, 4 },
{ 2048, 2 },
{ 4096, 1 },
};
/* returns # of RM trials required for a given bit size and max. error of 2^(-96)*/
int mp_prime_rabin_miller_trials(int size)
{
int x;
for (x = 0; x < (int)(sizeof(sizes)/(sizeof(sizes[0]))); x++) {
if (sizes[x].k == size) {
return sizes[x].t;
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_prime_random_ex.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | #include "tommath_private.h" #ifdef BN_MP_PRIME_RANDOM_EX_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * SPDX-License-Identifier: Unlicense */ /* makes a truly random prime of a given size (bits), * * Flags are as follows: * * LTM_PRIME_BBS - make prime congruent to 3 mod 4 |
| ︙ | ︙ | |||
45 46 47 48 49 50 51 |
flags |= LTM_PRIME_BBS;
}
/* calc the byte size */
bsize = (size>>3) + ((size&7)?1:0);
/* we need a buffer of bsize bytes */
| | | | | | 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 |
flags |= LTM_PRIME_BBS;
}
/* calc the byte size */
bsize = (size>>3) + ((size&7)?1:0);
/* we need a buffer of bsize bytes */
tmp = (unsigned char *) XMALLOC((size_t)bsize);
if (tmp == NULL) {
return MP_MEM;
}
/* calc the maskAND value for the MSbyte*/
maskAND = ((size&7) == 0) ? 0xFF : (unsigned char)(0xFF >> (8 - (size & 7)));
/* calc the maskOR_msb */
maskOR_msb = 0;
maskOR_msb_offset = ((size & 7) == 1) ? 1 : 0;
if ((flags & LTM_PRIME_2MSB_ON) != 0) {
maskOR_msb |= (unsigned char)(0x80 >> ((9 - size) & 7));
}
/* get the maskOR_lsb */
maskOR_lsb = 1;
if ((flags & LTM_PRIME_BBS) != 0) {
maskOR_lsb |= 3;
}
do {
/* read the bytes */
if (cb(tmp, bsize, dat) != bsize) {
err = MP_VAL;
goto error;
}
/* work over the MSbyte */
tmp[0] &= maskAND;
tmp[0] |= (unsigned char)(1 << ((size - 1) & 7));
/* mix in the maskORs */
tmp[maskOR_msb_offset] |= maskOR_msb;
tmp[bsize-1] |= maskOR_lsb;
/* read it in */
if ((err = mp_read_unsigned_bin(a, tmp, bsize)) != MP_OKAY) {
|
| ︙ | ︙ | |||
122 123 124 125 126 127 128 |
if ((err = mp_add_d(a, 1uL, a)) != MP_OKAY) {
goto error;
}
}
err = MP_OKAY;
error:
| | | 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 |
if ((err = mp_add_d(a, 1uL, a)) != MP_OKAY) {
goto error;
}
}
err = MP_OKAY;
error:
XFREE(tmp, bsize);
return err;
}
#endif
/* ref: $Format:%D$ */
/* git commit: $Format:%H$ */
/* commit time: $Format:%ai$ */
|
Added libtommath/bn_mp_prime_strong_lucas_selfridge.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 |
#include "tommath_private.h"
#ifdef BN_MP_PRIME_STRONG_LUCAS_SELFRIDGE_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/*
* See file bn_mp_prime_is_prime.c or the documentation in doc/bn.tex for the details
*/
#ifndef LTM_USE_FIPS_ONLY
/*
* 8-bit is just too small. You can try the Frobenius test
* but that frobenius test can fail, too, for the same reason.
*/
#ifndef MP_8BIT
/*
* multiply bigint a with int d and put the result in c
* Like mp_mul_d() but with a signed long as the small input
*/
static int s_mp_mul_si(const mp_int *a, long d, mp_int *c)
{
mp_int t;
int err, neg = 0;
if ((err = mp_init(&t)) != MP_OKAY) {
return err;
}
if (d < 0) {
neg = 1;
d = -d;
}
/*
* mp_digit might be smaller than a long, which excludes
* the use of mp_mul_d() here.
*/
if ((err = mp_set_long(&t, (unsigned long) d)) != MP_OKAY) {
goto LBL_MPMULSI_ERR;
}
if ((err = mp_mul(a, &t, c)) != MP_OKAY) {
goto LBL_MPMULSI_ERR;
}
if (neg == 1) {
c->sign = (a->sign == MP_NEG) ? MP_ZPOS: MP_NEG;
}
LBL_MPMULSI_ERR:
mp_clear(&t);
return err;
}
/*
Strong Lucas-Selfridge test.
returns MP_YES if it is a strong L-S prime, MP_NO if it is composite
Code ported from Thomas Ray Nicely's implementation of the BPSW test
at http://www.trnicely.net/misc/bpsw.html
Freeware copyright (C) 2016 Thomas R. Nicely <http://www.trnicely.net>.
Released into the public domain by the author, who disclaims any legal
liability arising from its use
The multi-line comments are made by Thomas R. Nicely and are copied verbatim.
Additional comments marked "CZ" (without the quotes) are by the code-portist.
(If that name sounds familiar, he is the guy who found the fdiv bug in the
Pentium (P5x, I think) Intel processor)
*/
int mp_prime_strong_lucas_selfridge(const mp_int *a, int *result)
{
/* CZ TODO: choose better variable names! */
mp_int Dz, gcd, Np1, Uz, Vz, U2mz, V2mz, Qmz, Q2mz, Qkdz, T1z, T2z, T3z, T4z, Q2kdz;
/* CZ TODO: Some of them need the full 32 bit, hence the (temporary) exclusion of MP_8BIT */
int32_t D, Ds, J, sign, P, Q, r, s, u, Nbits;
int e;
int isset, oddness;
*result = MP_NO;
/*
Find the first element D in the sequence {5, -7, 9, -11, 13, ...}
such that Jacobi(D,N) = -1 (Selfridge's algorithm). Theory
indicates that, if N is not a perfect square, D will "nearly
always" be "small." Just in case, an overflow trap for D is
included.
*/
if ((e = mp_init_multi(&Dz, &gcd, &Np1, &Uz, &Vz, &U2mz, &V2mz, &Qmz, &Q2mz, &Qkdz, &T1z, &T2z, &T3z, &T4z, &Q2kdz,
NULL)) != MP_OKAY) {
return e;
}
D = 5;
sign = 1;
for (;;) {
Ds = sign * D;
sign = -sign;
if ((e = mp_set_long(&Dz, (unsigned long)D)) != MP_OKAY) {
goto LBL_LS_ERR;
}
if ((e = mp_gcd(a, &Dz, &gcd)) != MP_OKAY) {
goto LBL_LS_ERR;
}
/* if 1 < GCD < N then N is composite with factor "D", and
Jacobi(D,N) is technically undefined (but often returned
as zero). */
if ((mp_cmp_d(&gcd, 1uL) == MP_GT) && (mp_cmp(&gcd, a) == MP_LT)) {
goto LBL_LS_ERR;
}
if (Ds < 0) {
Dz.sign = MP_NEG;
}
if ((e = mp_kronecker(&Dz, a, &J)) != MP_OKAY) {
goto LBL_LS_ERR;
}
if (J == -1) {
break;
}
D += 2;
if (D > (INT_MAX - 2)) {
e = MP_VAL;
goto LBL_LS_ERR;
}
}
P = 1; /* Selfridge's choice */
Q = (1 - Ds) / 4; /* Required so D = P*P - 4*Q */
/* NOTE: The conditions (a) N does not divide Q, and
(b) D is square-free or not a perfect square, are included by
some authors; e.g., "Prime numbers and computer methods for
factorization," Hans Riesel (2nd ed., 1994, Birkhauser, Boston),
p. 130. For this particular application of Lucas sequences,
these conditions were found to be immaterial. */
/* Now calculate N - Jacobi(D,N) = N + 1 (even), and calculate the
odd positive integer d and positive integer s for which
N + 1 = 2^s*d (similar to the step for N - 1 in Miller's test).
The strong Lucas-Selfridge test then returns N as a strong
Lucas probable prime (slprp) if any of the following
conditions is met: U_d=0, V_d=0, V_2d=0, V_4d=0, V_8d=0,
V_16d=0, ..., etc., ending with V_{2^(s-1)*d}=V_{(N+1)/2}=0
(all equalities mod N). Thus d is the highest index of U that
must be computed (since V_2m is independent of U), compared
to U_{N+1} for the standard Lucas-Selfridge test; and no
index of V beyond (N+1)/2 is required, just as in the
standard Lucas-Selfridge test. However, the quantity Q^d must
be computed for use (if necessary) in the latter stages of
the test. The result is that the strong Lucas-Selfridge test
has a running time only slightly greater (order of 10 %) than
that of the standard Lucas-Selfridge test, while producing
only (roughly) 30 % as many pseudoprimes (and every strong
Lucas pseudoprime is also a standard Lucas pseudoprime). Thus
the evidence indicates that the strong Lucas-Selfridge test is
more effective than the standard Lucas-Selfridge test, and a
Baillie-PSW test based on the strong Lucas-Selfridge test
should be more reliable. */
if ((e = mp_add_d(a, 1uL, &Np1)) != MP_OKAY) {
goto LBL_LS_ERR;
}
s = mp_cnt_lsb(&Np1);
/* CZ
* This should round towards zero because
* Thomas R. Nicely used GMP's mpz_tdiv_q_2exp()
* and mp_div_2d() is equivalent. Additionally:
* dividing an even number by two does not produce
* any leftovers.
*/
if ((e = mp_div_2d(&Np1, s, &Dz, NULL)) != MP_OKAY) {
goto LBL_LS_ERR;
}
/* We must now compute U_d and V_d. Since d is odd, the accumulated
values U and V are initialized to U_1 and V_1 (if the target
index were even, U and V would be initialized instead to U_0=0
and V_0=2). The values of U_2m and V_2m are also initialized to
U_1 and V_1; the FOR loop calculates in succession U_2 and V_2,
U_4 and V_4, U_8 and V_8, etc. If the corresponding bits
(1, 2, 3, ...) of t are on (the zero bit having been accounted
for in the initialization of U and V), these values are then
combined with the previous totals for U and V, using the
composition formulas for addition of indices. */
mp_set(&Uz, 1uL); /* U=U_1 */
mp_set(&Vz, (mp_digit)P); /* V=V_1 */
mp_set(&U2mz, 1uL); /* U_1 */
mp_set(&V2mz, (mp_digit)P); /* V_1 */
if (Q < 0) {
Q = -Q;
if ((e = mp_set_long(&Qmz, (unsigned long)Q)) != MP_OKAY) {
goto LBL_LS_ERR;
}
if ((e = mp_mul_2(&Qmz, &Q2mz)) != MP_OKAY) {
goto LBL_LS_ERR;
}
/* Initializes calculation of Q^d */
if ((e = mp_set_long(&Qkdz, (unsigned long)Q)) != MP_OKAY) {
goto LBL_LS_ERR;
}
Qmz.sign = MP_NEG;
Q2mz.sign = MP_NEG;
Qkdz.sign = MP_NEG;
Q = -Q;
} else {
if ((e = mp_set_long(&Qmz, (unsigned long)Q)) != MP_OKAY) {
goto LBL_LS_ERR;
}
if ((e = mp_mul_2(&Qmz, &Q2mz)) != MP_OKAY) {
goto LBL_LS_ERR;
}
/* Initializes calculation of Q^d */
if ((e = mp_set_long(&Qkdz, (unsigned long)Q)) != MP_OKAY) {
goto LBL_LS_ERR;
}
}
Nbits = mp_count_bits(&Dz);
for (u = 1; u < Nbits; u++) { /* zero bit off, already accounted for */
/* Formulas for doubling of indices (carried out mod N). Note that
* the indices denoted as "2m" are actually powers of 2, specifically
* 2^(ul-1) beginning each loop and 2^ul ending each loop.
*
* U_2m = U_m*V_m
* V_2m = V_m*V_m - 2*Q^m
*/
if ((e = mp_mul(&U2mz, &V2mz, &U2mz)) != MP_OKAY) {
goto LBL_LS_ERR;
}
if ((e = mp_mod(&U2mz, a, &U2mz)) != MP_OKAY) {
goto LBL_LS_ERR;
}
if ((e = mp_sqr(&V2mz, &V2mz)) != MP_OKAY) {
goto LBL_LS_ERR;
}
if ((e = mp_sub(&V2mz, &Q2mz, &V2mz)) != MP_OKAY) {
goto LBL_LS_ERR;
}
if ((e = mp_mod(&V2mz, a, &V2mz)) != MP_OKAY) {
goto LBL_LS_ERR;
}
/* Must calculate powers of Q for use in V_2m, also for Q^d later */
if ((e = mp_sqr(&Qmz, &Qmz)) != MP_OKAY) {
goto LBL_LS_ERR;
}
/* prevents overflow */ /* CZ still necessary without a fixed prealloc'd mem.? */
if ((e = mp_mod(&Qmz, a, &Qmz)) != MP_OKAY) {
goto LBL_LS_ERR;
}
if ((e = mp_mul_2(&Qmz, &Q2mz)) != MP_OKAY) {
goto LBL_LS_ERR;
}
if ((isset = mp_get_bit(&Dz, u)) == MP_VAL) {
e = isset;
goto LBL_LS_ERR;
}
if (isset == MP_YES) {
/* Formulas for addition of indices (carried out mod N);
*
* U_(m+n) = (U_m*V_n + U_n*V_m)/2
* V_(m+n) = (V_m*V_n + D*U_m*U_n)/2
*
* Be careful with division by 2 (mod N)!
*/
if ((e = mp_mul(&U2mz, &Vz, &T1z)) != MP_OKAY) {
goto LBL_LS_ERR;
}
if ((e = mp_mul(&Uz, &V2mz, &T2z)) != MP_OKAY) {
goto LBL_LS_ERR;
}
if ((e = mp_mul(&V2mz, &Vz, &T3z)) != MP_OKAY) {
goto LBL_LS_ERR;
}
if ((e = mp_mul(&U2mz, &Uz, &T4z)) != MP_OKAY) {
goto LBL_LS_ERR;
}
if ((e = s_mp_mul_si(&T4z, (long)Ds, &T4z)) != MP_OKAY) {
goto LBL_LS_ERR;
}
if ((e = mp_add(&T1z, &T2z, &Uz)) != MP_OKAY) {
goto LBL_LS_ERR;
}
if (mp_isodd(&Uz) != MP_NO) {
if ((e = mp_add(&Uz, a, &Uz)) != MP_OKAY) {
goto LBL_LS_ERR;
}
}
/* CZ
* This should round towards negative infinity because
* Thomas R. Nicely used GMP's mpz_fdiv_q_2exp().
* But mp_div_2() does not do so, it is truncating instead.
*/
oddness = mp_isodd(&Uz);
if ((e = mp_div_2(&Uz, &Uz)) != MP_OKAY) {
goto LBL_LS_ERR;
}
if ((Uz.sign == MP_NEG) && (oddness != MP_NO)) {
if ((e = mp_sub_d(&Uz, 1uL, &Uz)) != MP_OKAY) {
goto LBL_LS_ERR;
}
}
if ((e = mp_add(&T3z, &T4z, &Vz)) != MP_OKAY) {
goto LBL_LS_ERR;
}
if (mp_isodd(&Vz) != MP_NO) {
if ((e = mp_add(&Vz, a, &Vz)) != MP_OKAY) {
goto LBL_LS_ERR;
}
}
oddness = mp_isodd(&Vz);
if ((e = mp_div_2(&Vz, &Vz)) != MP_OKAY) {
goto LBL_LS_ERR;
}
if ((Vz.sign == MP_NEG) && (oddness != MP_NO)) {
if ((e = mp_sub_d(&Vz, 1uL, &Vz)) != MP_OKAY) {
goto LBL_LS_ERR;
}
}
if ((e = mp_mod(&Uz, a, &Uz)) != MP_OKAY) {
goto LBL_LS_ERR;
}
if ((e = mp_mod(&Vz, a, &Vz)) != MP_OKAY) {
goto LBL_LS_ERR;
}
/* Calculating Q^d for later use */
if ((e = mp_mul(&Qkdz, &Qmz, &Qkdz)) != MP_OKAY) {
goto LBL_LS_ERR;
}
if ((e = mp_mod(&Qkdz, a, &Qkdz)) != MP_OKAY) {
goto LBL_LS_ERR;
}
}
}
/* If U_d or V_d is congruent to 0 mod N, then N is a prime or a
strong Lucas pseudoprime. */
if ((mp_iszero(&Uz) != MP_NO) || (mp_iszero(&Vz) != MP_NO)) {
*result = MP_YES;
goto LBL_LS_ERR;
}
/* NOTE: Ribenboim ("The new book of prime number records," 3rd ed.,
1995/6) omits the condition V0 on p.142, but includes it on
p. 130. The condition is NECESSARY; otherwise the test will
return false negatives---e.g., the primes 29 and 2000029 will be
returned as composite. */
/* Otherwise, we must compute V_2d, V_4d, V_8d, ..., V_{2^(s-1)*d}
by repeated use of the formula V_2m = V_m*V_m - 2*Q^m. If any of
these are congruent to 0 mod N, then N is a prime or a strong
Lucas pseudoprime. */
/* Initialize 2*Q^(d*2^r) for V_2m */
if ((e = mp_mul_2(&Qkdz, &Q2kdz)) != MP_OKAY) {
goto LBL_LS_ERR;
}
for (r = 1; r < s; r++) {
if ((e = mp_sqr(&Vz, &Vz)) != MP_OKAY) {
goto LBL_LS_ERR;
}
if ((e = mp_sub(&Vz, &Q2kdz, &Vz)) != MP_OKAY) {
goto LBL_LS_ERR;
}
if ((e = mp_mod(&Vz, a, &Vz)) != MP_OKAY) {
goto LBL_LS_ERR;
}
if (mp_iszero(&Vz) != MP_NO) {
*result = MP_YES;
goto LBL_LS_ERR;
}
/* Calculate Q^{d*2^r} for next r (final iteration irrelevant). */
if (r < (s - 1)) {
if ((e = mp_sqr(&Qkdz, &Qkdz)) != MP_OKAY) {
goto LBL_LS_ERR;
}
if ((e = mp_mod(&Qkdz, a, &Qkdz)) != MP_OKAY) {
goto LBL_LS_ERR;
}
if ((e = mp_mul_2(&Qkdz, &Q2kdz)) != MP_OKAY) {
goto LBL_LS_ERR;
}
}
}
LBL_LS_ERR:
mp_clear_multi(&Q2kdz, &T4z, &T3z, &T2z, &T1z, &Qkdz, &Q2mz, &Qmz, &V2mz, &U2mz, &Vz, &Uz, &Np1, &gcd, &Dz, NULL);
return e;
}
#endif
#endif
#endif
/* ref: $Format:%D$ */
/* git commit: $Format:%H$ */
/* commit time: $Format:%ai$ */
|
Changes to libtommath/bn_mp_radix_size.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
#include "tommath_private.h"
#ifdef BN_MP_RADIX_SIZE_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* returns size of ASCII reprensentation */
int mp_radix_size(const mp_int *a, int radix, int *size)
{
int res, digs;
mp_int t;
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_radix_smap.c.
|
| | | < < < | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 |
#include "tommath_private.h"
#ifdef BN_MP_RADIX_SMAP_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* chars used in radix conversions */
const char *const mp_s_rmap = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz+/";
const unsigned char mp_s_rmap_reverse[] = {
0xff, 0xff, 0xff, 0x3e, 0xff, 0xff, 0xff, 0x3f, /* ()*+,-./ */
0x00, 0x01, 0x02, 0x03, 0x04, 0x05, 0x06, 0x07, /* 01234567 */
0x08, 0x09, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, /* 89:;<=>? */
0xff, 0x0a, 0x0b, 0x0c, 0x0d, 0x0e, 0x0f, 0x10, /* @ABCDEFG */
0x11, 0x12, 0x13, 0x14, 0x15, 0x16, 0x17, 0x18, /* HIJKLMNO */
0x19, 0x1a, 0x1b, 0x1c, 0x1d, 0x1e, 0x1f, 0x20, /* PQRSTUVW */
0x21, 0x22, 0x23, 0xff, 0xff, 0xff, 0xff, 0xff, /* XYZ[\]^_ */
0xff, 0x24, 0x25, 0x26, 0x27, 0x28, 0x29, 0x2a, /* `abcdefg */
0x2b, 0x2c, 0x2d, 0x2e, 0x2f, 0x30, 0x31, 0x32, /* hijklmno */
0x33, 0x34, 0x35, 0x36, 0x37, 0x38, 0x39, 0x3a, /* pqrstuvw */
0x3b, 0x3c, 0x3d, 0xff, 0xff, 0xff, 0xff, 0xff, /* xyz{|}~. */
};
const size_t mp_s_rmap_reverse_sz = sizeof(mp_s_rmap_reverse);
#endif
/* ref: $Format:%D$ */
/* git commit: $Format:%H$ */
/* commit time: $Format:%ai$ */
|
Changes to libtommath/bn_mp_rand.c.
|
| | | < | | > > > | < < < < | < < | < < | < < < < < | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | > > > > > | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 |
#include "tommath_private.h"
#ifdef BN_MP_RAND_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* First the OS-specific special cases
* - *BSD
* - Windows
*/
#if defined(__FreeBSD__) || defined(__OpenBSD__) || defined(__NetBSD__) || defined(__DragonFly__)
#define MP_ARC4RANDOM
#define MP_GEN_RANDOM_MAX 0xffffffffu
#define MP_GEN_RANDOM_SHIFT 32
static int s_read_arc4random(mp_digit *p)
{
mp_digit d = 0, msk = 0;
do {
d <<= MP_GEN_RANDOM_SHIFT;
d |= ((mp_digit) arc4random());
msk <<= MP_GEN_RANDOM_SHIFT;
msk |= (MP_MASK & MP_GEN_RANDOM_MAX);
} while ((MP_MASK & msk) != MP_MASK);
*p = d;
return MP_OKAY;
}
#endif
#if defined(_WIN32) || defined(_WIN32_WCE)
#define MP_WIN_CSP
#ifndef _WIN32_WINNT
#define _WIN32_WINNT 0x0400
#endif
#ifdef _WIN32_WCE
#define UNDER_CE
#define ARM
#endif
#define WIN32_LEAN_AND_MEAN
#include <windows.h>
#include <wincrypt.h>
static HCRYPTPROV hProv = 0;
static void s_cleanup_win_csp(void)
{
CryptReleaseContext(hProv, 0);
hProv = 0;
}
static int s_read_win_csp(mp_digit *p)
{
int ret = -1;
if (hProv == 0) {
if (!CryptAcquireContext(&hProv, NULL, MS_DEF_PROV, PROV_RSA_FULL,
(CRYPT_VERIFYCONTEXT | CRYPT_MACHINE_KEYSET)) &&
!CryptAcquireContext(&hProv, NULL, MS_DEF_PROV, PROV_RSA_FULL,
CRYPT_VERIFYCONTEXT | CRYPT_MACHINE_KEYSET | CRYPT_NEWKEYSET)) {
hProv = 0;
return ret;
}
atexit(s_cleanup_win_csp);
}
if (CryptGenRandom(hProv, sizeof(*p), (void *)p) == TRUE) {
ret = MP_OKAY;
}
return ret;
}
#endif /* WIN32 */
#if !defined(MP_WIN_CSP) && defined(__linux__) && defined(__GLIBC_PREREQ)
#if __GLIBC_PREREQ(2, 25)
#define MP_GETRANDOM
#include <sys/random.h>
#include <errno.h>
static int s_read_getrandom(mp_digit *p)
{
int ret;
do {
ret = getrandom(p, sizeof(*p), 0);
} while ((ret == -1) && (errno == EINTR));
if (ret == sizeof(*p)) return MP_OKAY;
return -1;
}
#endif
#endif
/* We assume all platforms besides windows provide "/dev/urandom".
* In case yours doesn't, define MP_NO_DEV_URANDOM at compile-time.
*/
#if !defined(MP_WIN_CSP) && !defined(MP_NO_DEV_URANDOM)
#ifndef MP_DEV_URANDOM
#define MP_DEV_URANDOM "/dev/urandom"
#endif
#include <fcntl.h>
#include <errno.h>
#include <unistd.h>
static int s_read_dev_urandom(mp_digit *p)
{
ssize_t r;
int fd;
do {
fd = open(MP_DEV_URANDOM, O_RDONLY);
} while ((fd == -1) && (errno == EINTR));
if (fd == -1) return -1;
do {
r = read(fd, p, sizeof(*p));
} while ((r == -1) && (errno == EINTR));
close(fd);
if (r != sizeof(*p)) return -1;
return MP_OKAY;
}
#endif
#if defined(MP_PRNG_ENABLE_LTM_RNG)
unsigned long (*ltm_rng)(unsigned char *out, unsigned long outlen, void (*callback)(void));
void (*ltm_rng_callback)(void);
static int s_read_ltm_rng(mp_digit *p)
{
unsigned long ret;
if (ltm_rng == NULL) return -1;
ret = ltm_rng((void *)p, sizeof(*p), ltm_rng_callback);
if (ret != sizeof(*p)) return -1;
return MP_OKAY;
}
#endif
static int s_rand_digit(mp_digit *p)
{
int ret = -1;
#if defined(MP_ARC4RANDOM)
ret = s_read_arc4random(p);
if (ret == MP_OKAY) return ret;
#endif
#if defined(MP_WIN_CSP)
ret = s_read_win_csp(p);
if (ret == MP_OKAY) return ret;
#else
#if defined(MP_GETRANDOM)
ret = s_read_getrandom(p);
if (ret == MP_OKAY) return ret;
#endif
#if defined(MP_DEV_URANDOM)
ret = s_read_dev_urandom(p);
if (ret == MP_OKAY) return ret;
#endif
#endif /* MP_WIN_CSP */
#if defined(MP_PRNG_ENABLE_LTM_RNG)
ret = s_read_ltm_rng(p);
if (ret == MP_OKAY) return ret;
#endif
return ret;
}
/* makes a pseudo-random int of a given size */
int mp_rand_digit(mp_digit *r)
{
int ret = s_rand_digit(r);
*r &= MP_MASK;
return ret;
}
int mp_rand(mp_int *a, int digits)
{
int res;
mp_digit d;
mp_zero(a);
if (digits <= 0) {
return MP_OKAY;
}
/* first place a random non-zero digit */
do {
if (mp_rand_digit(&d) != MP_OKAY) {
return MP_VAL;
}
} while (d == 0u);
if ((res = mp_add_d(a, d, a)) != MP_OKAY) {
return res;
}
while (--digits > 0) {
if ((res = mp_lshd(a, 1)) != MP_OKAY) {
return res;
}
if (mp_rand_digit(&d) != MP_OKAY) {
return MP_VAL;
}
if ((res = mp_add_d(a, d, a)) != MP_OKAY) {
return res;
}
}
return MP_OKAY;
}
#endif
/* ref: $Format:%D$ */
/* git commit: $Format:%H$ */
/* commit time: $Format:%ai$ */
|
Changes to libtommath/bn_mp_read_radix.c.
|
| | | < | | < > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
#include "tommath_private.h"
#ifdef BN_MP_READ_RADIX_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
#define MP_TOUPPER(c) ((((c) >= 'a') && ((c) <= 'z')) ? (((c) + 'A') - 'a') : (c))
/* read a string [ASCII] in a given radix */
int mp_read_radix(mp_int *a, const char *str, int radix)
{
int y, res, neg;
unsigned pos;
char ch;
|
| ︙ | ︙ | |||
45 46 47 48 49 50 51 |
/* process each digit of the string */
while (*str != '\0') {
/* if the radix <= 36 the conversion is case insensitive
* this allows numbers like 1AB and 1ab to represent the same value
* [e.g. in hex]
*/
| | | 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 |
/* process each digit of the string */
while (*str != '\0') {
/* if the radix <= 36 the conversion is case insensitive
* this allows numbers like 1AB and 1ab to represent the same value
* [e.g. in hex]
*/
ch = (radix <= 36) ? (char)MP_TOUPPER((int)*str) : *str;
pos = (unsigned)(ch - '(');
if (mp_s_rmap_reverse_sz < pos) {
break;
}
y = (int)mp_s_rmap_reverse[pos];
/* if the char was found in the map
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_read_signed_bin.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
#include "tommath_private.h"
#ifdef BN_MP_READ_SIGNED_BIN_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* read signed bin, big endian, first byte is 0==positive or 1==negative */
int mp_read_signed_bin(mp_int *a, const unsigned char *b, int c)
{
int res;
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_read_unsigned_bin.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
#include "tommath_private.h"
#ifdef BN_MP_READ_UNSIGNED_BIN_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* reads a unsigned char array, assumes the msb is stored first [big endian] */
int mp_read_unsigned_bin(mp_int *a, const unsigned char *b, int c)
{
int res;
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_reduce.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | #include "tommath_private.h" #ifdef BN_MP_REDUCE_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * SPDX-License-Identifier: Unlicense */ /* reduces x mod m, assumes 0 < x < m**2, mu is * precomputed via mp_reduce_setup. * From HAC pp.604 Algorithm 14.42 */ int mp_reduce(mp_int *x, const mp_int *m, const mp_int *mu) |
| ︙ | ︙ |
Changes to libtommath/bn_mp_reduce_2k.c.
|
| | | < < < | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 |
#include "tommath_private.h"
#ifdef BN_MP_REDUCE_2K_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* reduces a modulo n where n is of the form 2**p - d */
int mp_reduce_2k(mp_int *a, const mp_int *n, mp_digit d)
{
mp_int q;
int p, res;
if ((res = mp_init(&q)) != MP_OKAY) {
return res;
}
p = mp_count_bits(n);
top:
/* q = a/2**p, a = a mod 2**p */
if ((res = mp_div_2d(a, p, &q, a)) != MP_OKAY) {
goto LBL_ERR;
}
if (d != 1u) {
/* q = q * d */
if ((res = mp_mul_d(&q, d, &q)) != MP_OKAY) {
goto LBL_ERR;
}
}
/* a = a + q */
if ((res = s_mp_add(a, &q, a)) != MP_OKAY) {
goto LBL_ERR;
}
if (mp_cmp_mag(a, n) != MP_LT) {
if ((res = s_mp_sub(a, n, a)) != MP_OKAY) {
goto LBL_ERR;
}
goto top;
}
LBL_ERR:
mp_clear(&q);
return res;
}
#endif
/* ref: $Format:%D$ */
/* git commit: $Format:%H$ */
/* commit time: $Format:%ai$ */
|
Changes to libtommath/bn_mp_reduce_2k_l.c.
|
| | | < < < | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 |
#include "tommath_private.h"
#ifdef BN_MP_REDUCE_2K_L_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* reduces a modulo n where n is of the form 2**p - d
This differs from reduce_2k since "d" can be larger
than a single digit.
*/
int mp_reduce_2k_l(mp_int *a, const mp_int *n, const mp_int *d)
{
mp_int q;
int p, res;
if ((res = mp_init(&q)) != MP_OKAY) {
return res;
}
p = mp_count_bits(n);
top:
/* q = a/2**p, a = a mod 2**p */
if ((res = mp_div_2d(a, p, &q, a)) != MP_OKAY) {
goto LBL_ERR;
}
/* q = q * d */
if ((res = mp_mul(&q, d, &q)) != MP_OKAY) {
goto LBL_ERR;
}
/* a = a + q */
if ((res = s_mp_add(a, &q, a)) != MP_OKAY) {
goto LBL_ERR;
}
if (mp_cmp_mag(a, n) != MP_LT) {
if ((res = s_mp_sub(a, n, a)) != MP_OKAY) {
goto LBL_ERR;
}
goto top;
}
LBL_ERR:
mp_clear(&q);
return res;
}
#endif
/* ref: $Format:%D$ */
/* git commit: $Format:%H$ */
/* commit time: $Format:%ai$ */
|
Changes to libtommath/bn_mp_reduce_2k_setup.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
#include "tommath_private.h"
#ifdef BN_MP_REDUCE_2K_SETUP_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* determines the setup value */
int mp_reduce_2k_setup(const mp_int *a, mp_digit *d)
{
int res, p;
mp_int tmp;
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_reduce_2k_setup_l.c.
|
| | | < < < | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 |
#include "tommath_private.h"
#ifdef BN_MP_REDUCE_2K_SETUP_L_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* determines the setup value */
int mp_reduce_2k_setup_l(const mp_int *a, mp_int *d)
{
int res;
mp_int tmp;
if ((res = mp_init(&tmp)) != MP_OKAY) {
return res;
}
if ((res = mp_2expt(&tmp, mp_count_bits(a))) != MP_OKAY) {
goto LBL_ERR;
}
if ((res = s_mp_sub(&tmp, a, d)) != MP_OKAY) {
goto LBL_ERR;
}
LBL_ERR:
mp_clear(&tmp);
return res;
}
#endif
/* ref: $Format:%D$ */
/* git commit: $Format:%H$ */
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_reduce_is_2k.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
#include "tommath_private.h"
#ifdef BN_MP_REDUCE_IS_2K_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* determines if mp_reduce_2k can be used */
int mp_reduce_is_2k(const mp_int *a)
{
int ix, iy, iw;
mp_digit iz;
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_reduce_is_2k_l.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
#include "tommath_private.h"
#ifdef BN_MP_REDUCE_IS_2K_L_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* determines if reduce_2k_l can be used */
int mp_reduce_is_2k_l(const mp_int *a)
{
int ix, iy;
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_reduce_setup.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
#include "tommath_private.h"
#ifdef BN_MP_REDUCE_SETUP_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* pre-calculate the value required for Barrett reduction
* For a given modulus "b" it calulates the value required in "a"
*/
int mp_reduce_setup(mp_int *a, const mp_int *b)
{
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_rshd.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
#include "tommath_private.h"
#ifdef BN_MP_RSHD_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* shift right a certain amount of digits */
void mp_rshd(mp_int *a, int b)
{
int x;
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_set.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
#include "tommath_private.h"
#ifdef BN_MP_SET_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* set to a digit */
void mp_set(mp_int *a, mp_digit b)
{
mp_zero(a);
a->dp[0] = b & MP_MASK;
|
| ︙ | ︙ |
Added libtommath/bn_mp_set_double.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 |
#include "tommath_private.h"
#ifdef BN_MP_SET_DOUBLE_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
#if defined(__STDC_IEC_559__) || defined(__GCC_IEC_559)
int mp_set_double(mp_int *a, double b)
{
unsigned long long frac;
int exp, res;
union {
double dbl;
unsigned long long bits;
} cast;
cast.dbl = b;
exp = (int)((unsigned)(cast.bits >> 52) & 0x7FFU);
frac = (cast.bits & ((1ULL << 52) - 1ULL)) | (1ULL << 52);
if (exp == 0x7FF) { /* +-inf, NaN */
return MP_VAL;
}
exp -= 1023 + 52;
res = mp_set_long_long(a, frac);
if (res != MP_OKAY) {
return res;
}
res = (exp < 0) ? mp_div_2d(a, -exp, a, NULL) : mp_mul_2d(a, exp, a);
if (res != MP_OKAY) {
return res;
}
if (((cast.bits >> 63) != 0ULL) && !IS_ZERO(a)) {
a->sign = MP_NEG;
}
return MP_OKAY;
}
#else
/* pragma message() not supported by several compilers (in mostly older but still used versions) */
# ifdef _MSC_VER
# pragma message("mp_set_double implementation is only available on platforms with IEEE754 floating point format")
# else
# warning "mp_set_double implementation is only available on platforms with IEEE754 floating point format"
# endif
#endif
#endif
/* ref: $Format:%D$ */
/* git commit: $Format:%H$ */
/* commit time: $Format:%ai$ */
|
Changes to libtommath/bn_mp_set_int.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
#include "tommath_private.h"
#ifdef BN_MP_SET_INT_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* set a 32-bit const */
int mp_set_int(mp_int *a, unsigned long b)
{
int x, res;
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_set_long.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | #include "tommath_private.h" #ifdef BN_MP_SET_LONG_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * SPDX-License-Identifier: Unlicense */ /* set a platform dependent unsigned long int */ MP_SET_XLONG(mp_set_long, unsigned long) #endif /* ref: $Format:%D$ */ |
| ︙ | ︙ |
Changes to libtommath/bn_mp_set_long_long.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | #include "tommath_private.h" #ifdef BN_MP_SET_LONG_LONG_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * SPDX-License-Identifier: Unlicense */ /* set a platform dependent unsigned long long int */ MP_SET_XLONG(mp_set_long_long, Tcl_WideUInt) #endif /* ref: $Format:%D$ */ |
| ︙ | ︙ |
Changes to libtommath/bn_mp_shrink.c.
|
| | | < < < | > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 |
#include "tommath_private.h"
#ifdef BN_MP_SHRINK_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* shrink a bignum */
int mp_shrink(mp_int *a)
{
mp_digit *tmp;
int used = 1;
if (a->used > 0) {
used = a->used;
}
if (a->alloc != used) {
if ((tmp = (mp_digit *) XREALLOC(a->dp,
(size_t)a->alloc * sizeof (mp_digit),
(size_t)used * sizeof(mp_digit))) == NULL) {
return MP_MEM;
}
a->dp = tmp;
a->alloc = used;
}
return MP_OKAY;
}
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_signed_bin_size.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
#include "tommath_private.h"
#ifdef BN_MP_SIGNED_BIN_SIZE_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* get the size for an signed equivalent */
int mp_signed_bin_size(const mp_int *a)
{
return 1 + mp_unsigned_bin_size(a);
}
|
| ︙ | ︙ |
Added libtommath/bn_mp_signed_rsh.c.
> > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
#include "tommath_private.h"
#ifdef BN_MP_SIGNED_RSH_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* shift right by a certain bit count with sign extension */
mp_err mp_signed_rsh(const mp_int *a, int b, mp_int *c)
{
mp_err res;
if (a->sign == MP_ZPOS) {
return mp_div_2d(a, b, c, NULL);
}
res = mp_add_d(a, 1uL, c);
if (res != MP_OKAY) {
return res;
}
res = mp_div_2d(c, b, c, NULL);
return (res == MP_OKAY) ? mp_sub_d(c, 1uL, c) : res;
}
#endif
|
Changes to libtommath/bn_mp_sqr.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
#include "tommath_private.h"
#ifdef BN_MP_SQR_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* computes b = a*a */
int mp_sqr(const mp_int *a, mp_int *b)
{
int res;
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_sqrmod.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
#include "tommath_private.h"
#ifdef BN_MP_SQRMOD_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* c = a * a (mod b) */
int mp_sqrmod(const mp_int *a, const mp_int *b, mp_int *c)
{
int res;
mp_int t;
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_sqrt.c.
|
| | | < < < > > > | < > > > < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 |
#include "tommath_private.h"
#ifdef BN_MP_SQRT_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
#ifndef NO_FLOATING_POINT
#include <math.h>
#if (DIGIT_BIT != 28) || (FLT_RADIX != 2) || (DBL_MANT_DIG != 53) || (DBL_MAX_EXP != 1024)
#define NO_FLOATING_POINT
#endif
#endif
/* this function is less generic than mp_n_root, simpler and faster */
int mp_sqrt(const mp_int *arg, mp_int *ret)
{
int res;
mp_int t1, t2;
#ifndef NO_FLOATING_POINT
int i, j, k;
volatile double d;
mp_digit dig;
#endif
/* must be positive */
if (arg->sign == MP_NEG) {
return MP_VAL;
}
/* easy out */
if (mp_iszero(arg) == MP_YES) {
mp_zero(ret);
return MP_OKAY;
}
#ifndef NO_FLOATING_POINT
i = (arg->used / 2) - 1;
j = 2 * i;
if ((res = mp_init_size(&t1, i+2)) != MP_OKAY) {
return res;
}
if ((res = mp_init(&t2)) != MP_OKAY) {
goto E2;
}
for (k = 0; k < i; ++k) {
t1.dp[k] = (mp_digit) 0;
}
/* Estimate the square root using the hardware floating point unit. */
d = 0.0;
for (k = arg->used-1; k >= j; --k) {
d = ldexp(d, DIGIT_BIT) + (double)(arg->dp[k]);
}
|
| ︙ | ︙ | |||
95 96 97 98 99 100 101 |
} else {
t1.used = i+1;
t1.dp[i] = ((mp_digit) d) - 1;
}
#else
| | > | | > > > | > | | | | | | | | | | 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 |
} else {
t1.used = i+1;
t1.dp[i] = ((mp_digit) d) - 1;
}
#else
if ((res = mp_init_copy(&t1, arg)) != MP_OKAY) {
return res;
}
if ((res = mp_init(&t2)) != MP_OKAY) {
goto E2;
}
/* First approx. (not very bad for large arg) */
mp_rshd(&t1, t1.used/2);
#endif
/* t1 > 0 */
if ((res = mp_div(arg, &t1, &t2, NULL)) != MP_OKAY) {
goto E1;
}
if ((res = mp_add(&t1, &t2, &t1)) != MP_OKAY) {
goto E1;
}
if ((res = mp_div_2(&t1, &t1)) != MP_OKAY) {
goto E1;
}
/* And now t1 > sqrt(arg) */
do {
if ((res = mp_div(arg, &t1, &t2, NULL)) != MP_OKAY) {
goto E1;
}
if ((res = mp_add(&t1, &t2, &t1)) != MP_OKAY) {
goto E1;
}
if ((res = mp_div_2(&t1, &t1)) != MP_OKAY) {
goto E1;
}
/* t1 >= sqrt(arg) >= t2 at this point */
} while (mp_cmp_mag(&t1, &t2) == MP_GT);
mp_exch(&t1, ret);
E1:
mp_clear(&t2);
E2:
mp_clear(&t1);
return res;
}
#endif
/* ref: $Format:%D$ */
/* git commit: $Format:%H$ */
/* commit time: $Format:%ai$ */
|
Changes to libtommath/bn_mp_sqrtmod_prime.c.
|
| | | | > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | #include "tommath_private.h" #ifdef BN_MP_SQRTMOD_PRIME_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * SPDX-License-Identifier: Unlicense */ /* Tonelli-Shanks algorithm * https://en.wikipedia.org/wiki/Tonelli%E2%80%93Shanks_algorithm * https://gmplib.org/list-archives/gmp-discuss/2013-April/005300.html * */ |
| ︙ | ︙ | |||
118 119 120 121 122 123 124 | cleanup: mp_clear_multi(&t1, &C, &Q, &S, &Z, &M, &T, &R, &two, NULL); return res; } #endif | > > > > | 121 122 123 124 125 126 127 128 129 130 131 | cleanup: mp_clear_multi(&t1, &C, &Q, &S, &Z, &M, &T, &R, &two, NULL); return res; } #endif /* ref: $Format:%D$ */ /* git commit: $Format:%H$ */ /* commit time: $Format:%ai$ */ |
Changes to libtommath/bn_mp_sub.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
#include "tommath_private.h"
#ifdef BN_MP_SUB_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* high level subtraction (handles signs) */
int mp_sub(const mp_int *a, const mp_int *b, mp_int *c)
{
int sa, sb, res;
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_sub_d.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
#include "tommath_private.h"
#ifdef BN_MP_SUB_D_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* single digit subtraction */
int mp_sub_d(const mp_int *a, mp_digit b, mp_int *c)
{
mp_digit *tmpa, *tmpc, mu;
int res, ix, oldused;
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_submod.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
#include "tommath_private.h"
#ifdef BN_MP_SUBMOD_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* d = a - b (mod c) */
int mp_submod(const mp_int *a, const mp_int *b, const mp_int *c, mp_int *d)
{
int res;
mp_int t;
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_to_signed_bin.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
#include "tommath_private.h"
#ifdef BN_MP_TO_SIGNED_BIN_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* store in signed [big endian] format */
int mp_to_signed_bin(const mp_int *a, unsigned char *b)
{
int res;
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_to_signed_bin_n.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
#include "tommath_private.h"
#ifdef BN_MP_TO_SIGNED_BIN_N_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* store in signed [big endian] format */
int mp_to_signed_bin_n(const mp_int *a, unsigned char *b, unsigned long *outlen)
{
if (*outlen < (unsigned long)mp_signed_bin_size(a)) {
return MP_VAL;
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_to_unsigned_bin.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
#include "tommath_private.h"
#ifdef BN_MP_TO_UNSIGNED_BIN_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* store in unsigned [big endian] format */
int mp_to_unsigned_bin(const mp_int *a, unsigned char *b)
{
int x, res;
mp_int t;
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_to_unsigned_bin_n.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
#include "tommath_private.h"
#ifdef BN_MP_TO_UNSIGNED_BIN_N_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* store in unsigned [big endian] format */
int mp_to_unsigned_bin_n(const mp_int *a, unsigned char *b, unsigned long *outlen)
{
if (*outlen < (unsigned long)mp_unsigned_bin_size(a)) {
return MP_VAL;
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_toom_mul.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | #include "tommath_private.h" #ifdef BN_MP_TOOM_MUL_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * SPDX-License-Identifier: Unlicense */ /* multiplication using the Toom-Cook 3-way algorithm * * Much more complicated than Karatsuba but has a lower * asymptotic running time of O(N**1.464). This algorithm is * only particularly useful on VERY large inputs |
| ︙ | ︙ | |||
35 36 37 38 39 40 41 |
}
/* B */
B = MIN(a->used, b->used) / 3;
/* a = a2 * B**2 + a1 * B + a0 */
if ((res = mp_mod_2d(a, DIGIT_BIT * B, &a0)) != MP_OKAY) {
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 |
}
/* B */
B = MIN(a->used, b->used) / 3;
/* a = a2 * B**2 + a1 * B + a0 */
if ((res = mp_mod_2d(a, DIGIT_BIT * B, &a0)) != MP_OKAY) {
goto LBL_ERR;
}
if ((res = mp_copy(a, &a1)) != MP_OKAY) {
goto LBL_ERR;
}
mp_rshd(&a1, B);
if ((res = mp_mod_2d(&a1, DIGIT_BIT * B, &a1)) != MP_OKAY) {
goto LBL_ERR;
}
if ((res = mp_copy(a, &a2)) != MP_OKAY) {
goto LBL_ERR;
}
mp_rshd(&a2, B*2);
/* b = b2 * B**2 + b1 * B + b0 */
if ((res = mp_mod_2d(b, DIGIT_BIT * B, &b0)) != MP_OKAY) {
goto LBL_ERR;
}
if ((res = mp_copy(b, &b1)) != MP_OKAY) {
goto LBL_ERR;
}
mp_rshd(&b1, B);
(void)mp_mod_2d(&b1, DIGIT_BIT * B, &b1);
if ((res = mp_copy(b, &b2)) != MP_OKAY) {
goto LBL_ERR;
}
mp_rshd(&b2, B*2);
/* w0 = a0*b0 */
if ((res = mp_mul(&a0, &b0, &w0)) != MP_OKAY) {
goto LBL_ERR;
}
/* w4 = a2 * b2 */
if ((res = mp_mul(&a2, &b2, &w4)) != MP_OKAY) {
goto LBL_ERR;
}
/* w1 = (a2 + 2(a1 + 2a0))(b2 + 2(b1 + 2b0)) */
if ((res = mp_mul_2(&a0, &tmp1)) != MP_OKAY) {
goto LBL_ERR;
}
if ((res = mp_add(&tmp1, &a1, &tmp1)) != MP_OKAY) {
goto LBL_ERR;
}
if ((res = mp_mul_2(&tmp1, &tmp1)) != MP_OKAY) {
goto LBL_ERR;
}
if ((res = mp_add(&tmp1, &a2, &tmp1)) != MP_OKAY) {
goto LBL_ERR;
}
if ((res = mp_mul_2(&b0, &tmp2)) != MP_OKAY) {
goto LBL_ERR;
}
if ((res = mp_add(&tmp2, &b1, &tmp2)) != MP_OKAY) {
goto LBL_ERR;
}
if ((res = mp_mul_2(&tmp2, &tmp2)) != MP_OKAY) {
goto LBL_ERR;
}
if ((res = mp_add(&tmp2, &b2, &tmp2)) != MP_OKAY) {
goto LBL_ERR;
}
if ((res = mp_mul(&tmp1, &tmp2, &w1)) != MP_OKAY) {
goto LBL_ERR;
}
/* w3 = (a0 + 2(a1 + 2a2))(b0 + 2(b1 + 2b2)) */
if ((res = mp_mul_2(&a2, &tmp1)) != MP_OKAY) {
goto LBL_ERR;
}
if ((res = mp_add(&tmp1, &a1, &tmp1)) != MP_OKAY) {
goto LBL_ERR;
}
if ((res = mp_mul_2(&tmp1, &tmp1)) != MP_OKAY) {
goto LBL_ERR;
}
if ((res = mp_add(&tmp1, &a0, &tmp1)) != MP_OKAY) {
goto LBL_ERR;
}
if ((res = mp_mul_2(&b2, &tmp2)) != MP_OKAY) {
goto LBL_ERR;
}
if ((res = mp_add(&tmp2, &b1, &tmp2)) != MP_OKAY) {
goto LBL_ERR;
}
if ((res = mp_mul_2(&tmp2, &tmp2)) != MP_OKAY) {
goto LBL_ERR;
}
if ((res = mp_add(&tmp2, &b0, &tmp2)) != MP_OKAY) {
goto LBL_ERR;
}
if ((res = mp_mul(&tmp1, &tmp2, &w3)) != MP_OKAY) {
goto LBL_ERR;
}
/* w2 = (a2 + a1 + a0)(b2 + b1 + b0) */
if ((res = mp_add(&a2, &a1, &tmp1)) != MP_OKAY) {
goto LBL_ERR;
}
if ((res = mp_add(&tmp1, &a0, &tmp1)) != MP_OKAY) {
goto LBL_ERR;
}
if ((res = mp_add(&b2, &b1, &tmp2)) != MP_OKAY) {
goto LBL_ERR;
}
if ((res = mp_add(&tmp2, &b0, &tmp2)) != MP_OKAY) {
goto LBL_ERR;
}
if ((res = mp_mul(&tmp1, &tmp2, &w2)) != MP_OKAY) {
goto LBL_ERR;
}
/* now solve the matrix
0 0 0 0 1
1 2 4 8 16
1 1 1 1 1
16 8 4 2 1
1 0 0 0 0
using 12 subtractions, 4 shifts,
2 small divisions and 1 small multiplication
*/
/* r1 - r4 */
if ((res = mp_sub(&w1, &w4, &w1)) != MP_OKAY) {
goto LBL_ERR;
}
/* r3 - r0 */
if ((res = mp_sub(&w3, &w0, &w3)) != MP_OKAY) {
goto LBL_ERR;
}
/* r1/2 */
if ((res = mp_div_2(&w1, &w1)) != MP_OKAY) {
goto LBL_ERR;
}
/* r3/2 */
if ((res = mp_div_2(&w3, &w3)) != MP_OKAY) {
goto LBL_ERR;
}
/* r2 - r0 - r4 */
if ((res = mp_sub(&w2, &w0, &w2)) != MP_OKAY) {
goto LBL_ERR;
}
if ((res = mp_sub(&w2, &w4, &w2)) != MP_OKAY) {
goto LBL_ERR;
}
/* r1 - r2 */
if ((res = mp_sub(&w1, &w2, &w1)) != MP_OKAY) {
goto LBL_ERR;
}
/* r3 - r2 */
if ((res = mp_sub(&w3, &w2, &w3)) != MP_OKAY) {
goto LBL_ERR;
}
/* r1 - 8r0 */
if ((res = mp_mul_2d(&w0, 3, &tmp1)) != MP_OKAY) {
goto LBL_ERR;
}
if ((res = mp_sub(&w1, &tmp1, &w1)) != MP_OKAY) {
goto LBL_ERR;
}
/* r3 - 8r4 */
if ((res = mp_mul_2d(&w4, 3, &tmp1)) != MP_OKAY) {
goto LBL_ERR;
}
if ((res = mp_sub(&w3, &tmp1, &w3)) != MP_OKAY) {
goto LBL_ERR;
}
/* 3r2 - r1 - r3 */
if ((res = mp_mul_d(&w2, 3uL, &w2)) != MP_OKAY) {
goto LBL_ERR;
}
if ((res = mp_sub(&w2, &w1, &w2)) != MP_OKAY) {
goto LBL_ERR;
}
if ((res = mp_sub(&w2, &w3, &w2)) != MP_OKAY) {
goto LBL_ERR;
}
/* r1 - r2 */
if ((res = mp_sub(&w1, &w2, &w1)) != MP_OKAY) {
goto LBL_ERR;
}
/* r3 - r2 */
if ((res = mp_sub(&w3, &w2, &w3)) != MP_OKAY) {
goto LBL_ERR;
}
/* r1/3 */
if ((res = mp_div_3(&w1, &w1, NULL)) != MP_OKAY) {
goto LBL_ERR;
}
/* r3/3 */
if ((res = mp_div_3(&w3, &w3, NULL)) != MP_OKAY) {
goto LBL_ERR;
}
/* at this point shift W[n] by B*n */
if ((res = mp_lshd(&w1, 1*B)) != MP_OKAY) {
goto LBL_ERR;
}
if ((res = mp_lshd(&w2, 2*B)) != MP_OKAY) {
goto LBL_ERR;
}
if ((res = mp_lshd(&w3, 3*B)) != MP_OKAY) {
goto LBL_ERR;
}
if ((res = mp_lshd(&w4, 4*B)) != MP_OKAY) {
goto LBL_ERR;
}
if ((res = mp_add(&w0, &w1, c)) != MP_OKAY) {
goto LBL_ERR;
}
if ((res = mp_add(&w2, &w3, &tmp1)) != MP_OKAY) {
goto LBL_ERR;
}
if ((res = mp_add(&w4, &tmp1, &tmp1)) != MP_OKAY) {
goto LBL_ERR;
}
if ((res = mp_add(&tmp1, c, c)) != MP_OKAY) {
goto LBL_ERR;
}
LBL_ERR:
mp_clear_multi(&w0, &w1, &w2, &w3, &w4,
&a0, &a1, &a2, &b0, &b1,
&b2, &tmp1, &tmp2, NULL);
return res;
}
#endif
/* ref: $Format:%D$ */
/* git commit: $Format:%H$ */
/* commit time: $Format:%ai$ */
|
Changes to libtommath/bn_mp_toom_sqr.c.
|
| | | < < < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 |
#include "tommath_private.h"
#ifdef BN_MP_TOOM_SQR_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* squaring using Toom-Cook 3-way algorithm */
int mp_toom_sqr(const mp_int *a, mp_int *b)
{
mp_int w0, w1, w2, w3, w4, tmp1, a0, a1, a2;
int res, B;
/* init temps */
if ((res = mp_init_multi(&w0, &w1, &w2, &w3, &w4, &a0, &a1, &a2, &tmp1, NULL)) != MP_OKAY) {
return res;
}
/* B */
B = a->used / 3;
/* a = a2 * B**2 + a1 * B + a0 */
if ((res = mp_mod_2d(a, DIGIT_BIT * B, &a0)) != MP_OKAY) {
goto LBL_ERR;
}
if ((res = mp_copy(a, &a1)) != MP_OKAY) {
goto LBL_ERR;
}
mp_rshd(&a1, B);
if ((res = mp_mod_2d(&a1, DIGIT_BIT * B, &a1)) != MP_OKAY) {
goto LBL_ERR;
}
if ((res = mp_copy(a, &a2)) != MP_OKAY) {
goto LBL_ERR;
}
mp_rshd(&a2, B*2);
/* w0 = a0*a0 */
if ((res = mp_sqr(&a0, &w0)) != MP_OKAY) {
goto LBL_ERR;
}
/* w4 = a2 * a2 */
if ((res = mp_sqr(&a2, &w4)) != MP_OKAY) {
goto LBL_ERR;
}
/* w1 = (a2 + 2(a1 + 2a0))**2 */
if ((res = mp_mul_2(&a0, &tmp1)) != MP_OKAY) {
goto LBL_ERR;
}
if ((res = mp_add(&tmp1, &a1, &tmp1)) != MP_OKAY) {
goto LBL_ERR;
}
if ((res = mp_mul_2(&tmp1, &tmp1)) != MP_OKAY) {
goto LBL_ERR;
}
if ((res = mp_add(&tmp1, &a2, &tmp1)) != MP_OKAY) {
goto LBL_ERR;
}
if ((res = mp_sqr(&tmp1, &w1)) != MP_OKAY) {
goto LBL_ERR;
}
/* w3 = (a0 + 2(a1 + 2a2))**2 */
if ((res = mp_mul_2(&a2, &tmp1)) != MP_OKAY) {
goto LBL_ERR;
}
if ((res = mp_add(&tmp1, &a1, &tmp1)) != MP_OKAY) {
goto LBL_ERR;
}
if ((res = mp_mul_2(&tmp1, &tmp1)) != MP_OKAY) {
goto LBL_ERR;
}
if ((res = mp_add(&tmp1, &a0, &tmp1)) != MP_OKAY) {
goto LBL_ERR;
}
if ((res = mp_sqr(&tmp1, &w3)) != MP_OKAY) {
goto LBL_ERR;
}
/* w2 = (a2 + a1 + a0)**2 */
if ((res = mp_add(&a2, &a1, &tmp1)) != MP_OKAY) {
goto LBL_ERR;
}
if ((res = mp_add(&tmp1, &a0, &tmp1)) != MP_OKAY) {
goto LBL_ERR;
}
if ((res = mp_sqr(&tmp1, &w2)) != MP_OKAY) {
goto LBL_ERR;
}
/* now solve the matrix
0 0 0 0 1
1 2 4 8 16
1 1 1 1 1
16 8 4 2 1
1 0 0 0 0
using 12 subtractions, 4 shifts, 2 small divisions and 1 small multiplication.
*/
/* r1 - r4 */
if ((res = mp_sub(&w1, &w4, &w1)) != MP_OKAY) {
goto LBL_ERR;
}
/* r3 - r0 */
if ((res = mp_sub(&w3, &w0, &w3)) != MP_OKAY) {
goto LBL_ERR;
}
/* r1/2 */
if ((res = mp_div_2(&w1, &w1)) != MP_OKAY) {
goto LBL_ERR;
}
/* r3/2 */
if ((res = mp_div_2(&w3, &w3)) != MP_OKAY) {
goto LBL_ERR;
}
/* r2 - r0 - r4 */
if ((res = mp_sub(&w2, &w0, &w2)) != MP_OKAY) {
goto LBL_ERR;
}
if ((res = mp_sub(&w2, &w4, &w2)) != MP_OKAY) {
goto LBL_ERR;
}
/* r1 - r2 */
if ((res = mp_sub(&w1, &w2, &w1)) != MP_OKAY) {
goto LBL_ERR;
}
/* r3 - r2 */
if ((res = mp_sub(&w3, &w2, &w3)) != MP_OKAY) {
goto LBL_ERR;
}
/* r1 - 8r0 */
if ((res = mp_mul_2d(&w0, 3, &tmp1)) != MP_OKAY) {
goto LBL_ERR;
}
if ((res = mp_sub(&w1, &tmp1, &w1)) != MP_OKAY) {
goto LBL_ERR;
}
/* r3 - 8r4 */
if ((res = mp_mul_2d(&w4, 3, &tmp1)) != MP_OKAY) {
goto LBL_ERR;
}
if ((res = mp_sub(&w3, &tmp1, &w3)) != MP_OKAY) {
goto LBL_ERR;
}
/* 3r2 - r1 - r3 */
if ((res = mp_mul_d(&w2, 3uL, &w2)) != MP_OKAY) {
goto LBL_ERR;
}
if ((res = mp_sub(&w2, &w1, &w2)) != MP_OKAY) {
goto LBL_ERR;
}
if ((res = mp_sub(&w2, &w3, &w2)) != MP_OKAY) {
goto LBL_ERR;
}
/* r1 - r2 */
if ((res = mp_sub(&w1, &w2, &w1)) != MP_OKAY) {
goto LBL_ERR;
}
/* r3 - r2 */
if ((res = mp_sub(&w3, &w2, &w3)) != MP_OKAY) {
goto LBL_ERR;
}
/* r1/3 */
if ((res = mp_div_3(&w1, &w1, NULL)) != MP_OKAY) {
goto LBL_ERR;
}
/* r3/3 */
if ((res = mp_div_3(&w3, &w3, NULL)) != MP_OKAY) {
goto LBL_ERR;
}
/* at this point shift W[n] by B*n */
if ((res = mp_lshd(&w1, 1*B)) != MP_OKAY) {
goto LBL_ERR;
}
if ((res = mp_lshd(&w2, 2*B)) != MP_OKAY) {
goto LBL_ERR;
}
if ((res = mp_lshd(&w3, 3*B)) != MP_OKAY) {
goto LBL_ERR;
}
if ((res = mp_lshd(&w4, 4*B)) != MP_OKAY) {
goto LBL_ERR;
}
if ((res = mp_add(&w0, &w1, b)) != MP_OKAY) {
goto LBL_ERR;
}
if ((res = mp_add(&w2, &w3, &tmp1)) != MP_OKAY) {
goto LBL_ERR;
}
if ((res = mp_add(&w4, &tmp1, &tmp1)) != MP_OKAY) {
goto LBL_ERR;
}
if ((res = mp_add(&tmp1, b, b)) != MP_OKAY) {
goto LBL_ERR;
}
LBL_ERR:
mp_clear_multi(&w0, &w1, &w2, &w3, &w4, &a0, &a1, &a2, &tmp1, NULL);
return res;
}
#endif
/* ref: $Format:%D$ */
/* git commit: $Format:%H$ */
/* commit time: $Format:%ai$ */
|
Changes to libtommath/bn_mp_toradix.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
#include "tommath_private.h"
#ifdef BN_MP_TORADIX_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* stores a bignum as a ASCII string in a given radix (2..64) */
int mp_toradix(const mp_int *a, char *str, int radix)
{
int res, digs;
mp_int t;
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_toradix_n.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | #include "tommath_private.h" #ifdef BN_MP_TORADIX_N_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * SPDX-License-Identifier: Unlicense */ /* stores a bignum as a ASCII string in a given radix (2..64) * * Stores upto maxlen-1 chars and always a NULL byte */ int mp_toradix_n(const mp_int *a, char *str, int radix, int maxlen) |
| ︙ | ︙ |
Changes to libtommath/bn_mp_unsigned_bin_size.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
#include "tommath_private.h"
#ifdef BN_MP_UNSIGNED_BIN_SIZE_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* get the size for an unsigned equivalent */
int mp_unsigned_bin_size(const mp_int *a)
{
int size = mp_count_bits(a);
return (size / 8) + ((((unsigned)size & 7u) != 0u) ? 1 : 0);
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_xor.c.
|
| | | > | < | | < > | | < < | > | > | < > | < < > | > | | | > > > > > > | < < < | > > | | > | < < > | > | > > > > > | | < < | > > | < < < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 |
#include "tommath_private.h"
#ifdef BN_MP_XOR_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* two complement xor */
mp_err mp_xor(const mp_int *a, const mp_int *b, mp_int *c)
{
int used = MAX(a->used, b->used) + 1, i;
mp_err err;
mp_digit ac = 1, bc = 1, cc = 1;
mp_sign csign = (a->sign != b->sign) ? MP_NEG : MP_ZPOS;
if (c->alloc < used) {
if ((err = mp_grow(c, used)) != MP_OKAY) {
return err;
}
}
for (i = 0; i < used; i++) {
mp_digit x, y;
/* convert to two complement if negative */
if (a->sign == MP_NEG) {
ac += (i >= a->used) ? MP_MASK : (~a->dp[i] & MP_MASK);
x = ac & MP_MASK;
ac >>= MP_DIGIT_BIT;
} else {
x = (i >= a->used) ? 0uL : a->dp[i];
}
/* convert to two complement if negative */
if (b->sign == MP_NEG) {
bc += (i >= b->used) ? MP_MASK : (~b->dp[i] & MP_MASK);
y = bc & MP_MASK;
bc >>= MP_DIGIT_BIT;
} else {
y = (i >= b->used) ? 0uL : b->dp[i];
}
c->dp[i] = x ^ y;
/* convert to to sign-magnitude if negative */
if (csign == MP_NEG) {
cc += ~c->dp[i] & MP_MASK;
c->dp[i] = cc & MP_MASK;
cc >>= MP_DIGIT_BIT;
}
}
c->used = used;
c->sign = csign;
mp_clamp(c);
return MP_OKAY;
}
#endif
|
Changes to libtommath/bn_mp_zero.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
#include "tommath_private.h"
#ifdef BN_MP_ZERO_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* set to zero */
void mp_zero(mp_int *a)
{
int n;
mp_digit *tmp;
|
| ︙ | ︙ |
Changes to libtommath/bn_prime_tab.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
#include "tommath_private.h"
#ifdef BN_PRIME_TAB_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
const mp_digit ltm_prime_tab[] = {
0x0002, 0x0003, 0x0005, 0x0007, 0x000B, 0x000D, 0x0011, 0x0013,
0x0017, 0x001D, 0x001F, 0x0025, 0x0029, 0x002B, 0x002F, 0x0035,
0x003B, 0x003D, 0x0043, 0x0047, 0x0049, 0x004F, 0x0053, 0x0059,
0x0061, 0x0065, 0x0067, 0x006B, 0x006D, 0x0071, 0x007F,
|
| ︙ | ︙ |
Changes to libtommath/bn_reverse.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
#include "tommath_private.h"
#ifdef BN_REVERSE_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* reverse an array, used for radix code */
void bn_reverse(unsigned char *s, int len)
{
int ix, iy;
unsigned char t;
|
| ︙ | ︙ |
Changes to libtommath/bn_s_mp_add.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
#include "tommath_private.h"
#ifdef BN_S_MP_ADD_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* low level addition, based on HAC pp.594, Algorithm 14.7 */
int s_mp_add(const mp_int *a, const mp_int *b, mp_int *c)
{
const mp_int *x;
int olduse, res, min, max;
|
| ︙ | ︙ |
Changes to libtommath/bn_s_mp_exptmod.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | #include "tommath_private.h" #ifdef BN_S_MP_EXPTMOD_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * SPDX-License-Identifier: Unlicense */ #ifdef MP_LOW_MEM # define TAB_SIZE 32 #else # define TAB_SIZE 256 #endif |
| ︙ | ︙ | |||
97 98 99 100 101 102 103 |
if ((err = mp_mod(G, P, &M[1])) != MP_OKAY) {
goto LBL_MU;
}
/* compute the value at M[1<<(winsize-1)] by squaring
* M[1] (winsize-1) times
*/
| | | | | | 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 |
if ((err = mp_mod(G, P, &M[1])) != MP_OKAY) {
goto LBL_MU;
}
/* compute the value at M[1<<(winsize-1)] by squaring
* M[1] (winsize-1) times
*/
if ((err = mp_copy(&M[1], &M[(size_t)1 << (winsize - 1)])) != MP_OKAY) {
goto LBL_MU;
}
for (x = 0; x < (winsize - 1); x++) {
/* square it */
if ((err = mp_sqr(&M[(size_t)1 << (winsize - 1)],
&M[(size_t)1 << (winsize - 1)])) != MP_OKAY) {
goto LBL_MU;
}
/* reduce modulo P */
if ((err = redux(&M[(size_t)1 << (winsize - 1)], P, &mu)) != MP_OKAY) {
goto LBL_MU;
}
}
/* create upper table, that is M[x] = M[x-1] * M[1] (mod P)
* for x = (2**(winsize - 1) + 1) to (2**winsize - 1)
*/
|
| ︙ | ︙ |
Added libtommath/bn_s_mp_get_bit.c.
> > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
#include "tommath_private.h"
#ifdef BN_S_MP_GET_BIT_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* Get bit at position b and return MP_YES if the bit is 1, MP_NO if it is 0 */
mp_bool s_mp_get_bit(const mp_int *a, int b)
{
mp_digit bit;
int limb = (int)((unsigned)b / MP_DIGIT_BIT);
if (limb >= a->used) {
return MP_NO;
}
bit = (mp_digit)1 << ((unsigned)b % MP_DIGIT_BIT);
return ((a->dp[limb] & bit) != 0u) ? MP_YES : MP_NO;
}
#endif
|
Changes to libtommath/bn_s_mp_mul_digs.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | #include "tommath_private.h" #ifdef BN_S_MP_MUL_DIGS_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * SPDX-License-Identifier: Unlicense */ /* multiplies |a| * |b| and only computes upto digs digits of result * HAC pp. 595, Algorithm 14.12 Modified so you can control how * many digits of output are created. */ int s_mp_mul_digs(const mp_int *a, const mp_int *b, mp_int *c, int digs) |
| ︙ | ︙ |
Changes to libtommath/bn_s_mp_mul_high_digs.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
#include "tommath_private.h"
#ifdef BN_S_MP_MUL_HIGH_DIGS_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* multiplies |a| * |b| and does not compute the lower digs digits
* [meant to get the higher part of the product]
*/
int s_mp_mul_high_digs(const mp_int *a, const mp_int *b, mp_int *c, int digs)
{
|
| ︙ | ︙ |
Changes to libtommath/bn_s_mp_sqr.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
#include "tommath_private.h"
#ifdef BN_S_MP_SQR_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* low level squaring, b = a*a, HAC pp.596-597, Algorithm 14.16 */
int s_mp_sqr(const mp_int *a, mp_int *b)
{
mp_int t;
int res, ix, iy, pa;
|
| ︙ | ︙ |
Changes to libtommath/bn_s_mp_sub.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
#include "tommath_private.h"
#ifdef BN_S_MP_SUB_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* low level subtraction (assumes |a| > |b|), HAC pp.595 Algorithm 14.9 */
int s_mp_sub(const mp_int *a, const mp_int *b, mp_int *c)
{
int olduse, res, min, max;
|
| ︙ | ︙ |
Changes to libtommath/bncore.c.
|
| | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | #include "tommath_private.h" #ifdef BNCORE_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * SPDX-License-Identifier: Unlicense */ /* Known optimal configurations CPU /Compiler /MUL CUTOFF/SQR CUTOFF ------------------------------------------------------------- Intel P4 Northwood /GCC v3.4.1 / 88/ 128/LTM 0.32 ;-) |
| ︙ | ︙ |
Deleted libtommath/callgraph.txt.
more than 10,000 changes
Changes to libtommath/changes.txt.
1 2 3 4 5 6 7 |
Aug 29th, 2017
v1.0.1
-- Dmitry Kovalenko provided fixes to mp_add_d() and mp_init_copy()
-- Matt Johnston contributed some improvements to mp_div_2d(),
mp_exptmod_fast(), mp_mod() and mp_mulmod()
-- Julien Nabet provided a fix to the error handling in mp_init_multi()
-- Ben Gardner provided a fix regarding usage of reserved keywords
| > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 |
Jan 28th, 2019
v1.1.0
-- Christoph Zurnieden contributed FIPS 186.4 compliant
prime-checking (PR #113), several other fixes and a load of documentation
-- Daniel Mendler provided two's-complement functions (PR #124)
and mp_{set,get}_double() (PR #123)
-- Francois Perrad took care of linting the sources, provided all fixes and
a astylerc to auto-format the sources.
-- A bunch of patches by Kevin B Kenny have been back-ported from TCL
-- Jan Nijtmans provided the patches to `const`ify all API
function arguments (also from TCL)
-- mp_rand() has now several native random provider implementations
and doesn't rely on `rand()` anymore
-- Karel Miko provided fixes when building for MS Windows
and re-worked the makefile generating process
-- The entire environment and build logic has been extended and improved
regarding auto-detection of platforms, libtool and a lot more
-- Prevent some potential BOF cases
-- Improved/fixed mp_lshd() and mp_invmod()
-- A load more bugs were fixed by various contributors
Aug 29th, 2017
v1.0.1
-- Dmitry Kovalenko provided fixes to mp_add_d() and mp_init_copy()
-- Matt Johnston contributed some improvements to mp_div_2d(),
mp_exptmod_fast(), mp_mod() and mp_mulmod()
-- Julien Nabet provided a fix to the error handling in mp_init_multi()
-- Ben Gardner provided a fix regarding usage of reserved keywords
|
| ︙ | ︙ |
Deleted libtommath/libtommath.dsp.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Deleted libtommath/libtommath_VS2005.sln.
|
| < < < < < < < < < < < < < < < < < < < < |
Deleted libtommath/libtommath_VS2005.vcproj.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Changes to libtommath/libtommath_VS2008.sln.
1 2 3 | Microsoft Visual Studio Solution File, Format Version 10.00 # Visual Studio 2008 | | > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 |
Microsoft Visual Studio Solution File, Format Version 10.00
# Visual Studio 2008
Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "tommath", "libtommath_VS2008.vcproj", "{42109FEE-B0B9-4FCD-9E56-2863BF8C55D2}"
EndProject
Global
GlobalSection(SolutionConfigurationPlatforms) = preSolution
Debug|Win32 = Debug|Win32
Debug|x64 = Debug|x64
Release|Win32 = Release|Win32
Release|x64 = Release|x64
EndGlobalSection
GlobalSection(ProjectConfigurationPlatforms) = postSolution
{42109FEE-B0B9-4FCD-9E56-2863BF8C55D2}.Debug|Win32.ActiveCfg = Debug|Win32
{42109FEE-B0B9-4FCD-9E56-2863BF8C55D2}.Debug|Win32.Build.0 = Debug|Win32
{42109FEE-B0B9-4FCD-9E56-2863BF8C55D2}.Debug|x64.ActiveCfg = Debug|x64
{42109FEE-B0B9-4FCD-9E56-2863BF8C55D2}.Debug|x64.Build.0 = Debug|x64
{42109FEE-B0B9-4FCD-9E56-2863BF8C55D2}.Release|Win32.ActiveCfg = Release|Win32
{42109FEE-B0B9-4FCD-9E56-2863BF8C55D2}.Release|Win32.Build.0 = Release|Win32
{42109FEE-B0B9-4FCD-9E56-2863BF8C55D2}.Release|x64.ActiveCfg = Release|x64
{42109FEE-B0B9-4FCD-9E56-2863BF8C55D2}.Release|x64.Build.0 = Release|x64
EndGlobalSection
GlobalSection(SolutionProperties) = preSolution
HideSolutionNode = FALSE
EndGlobalSection
GlobalSection(ExtensibilityGlobals) = postSolution
SolutionGuid = {83B84178-7B4F-4B78-9C5D-17B8201D5B61}
EndGlobalSection
EndGlobal
|
Changes to libtommath/libtommath_VS2008.vcproj.
1 2 3 4 | <?xml version="1.0" encoding="Windows-1252"?> <VisualStudioProject ProjectType="Visual C++" Version="9.00" | | | > > > | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | < < < > | > | | | | | > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | < | < < < > | | | | | | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < | | | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < > | < > | < < < < < | | | | < < < < < < > | < > | < < < < < | | | | < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | < > | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | < > | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | | < < < < < < < < < < < < < < | | | | < < < < < < | < < < < < < < < | | | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < > | < > | < < < < < | | | | < < < < < < | > | < > | < < < < < | | | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 |
<?xml version="1.0" encoding="Windows-1252"?>
<VisualStudioProject
ProjectType="Visual C++"
Version="9.00"
Name="tommath"
ProjectGUID="{42109FEE-B0B9-4FCD-9E56-2863BF8C55D2}"
RootNamespace="tommath"
TargetFrameworkVersion="0"
>
<Platforms>
<Platform
Name="Win32"
/>
<Platform
Name="x64"
/>
</Platforms>
<ToolFiles>
</ToolFiles>
<Configurations>
<Configuration
Name="Debug|Win32"
OutputDirectory="MSVC_$(PlatformName)_$(ConfigurationName)"
IntermediateDirectory="MSVC_$(PlatformName)_$(ConfigurationName)\Intermediate"
ConfigurationType="4"
UseOfMFC="0"
ATLMinimizesCRunTimeLibraryUsage="false"
CharacterSet="0"
>
<Tool
Name="VCPreBuildEventTool"
/>
<Tool
Name="VCCustomBuildTool"
/>
<Tool
Name="VCXMLDataGeneratorTool"
/>
<Tool
Name="VCMIDLTool"
/>
<Tool
Name="VCCLCompilerTool"
Optimization="0"
AdditionalIncludeDirectories="."
PreprocessorDefinitions="WIN32;_DEBUG;_CRT_SECURE_NO_WARNINGS;_CRT_NONSTDC_NO_DEPRECATE"
MinimalRebuild="true"
ExceptionHandling="0"
BasicRuntimeChecks="3"
RuntimeLibrary="1"
PrecompiledHeaderFile="$(IntDir)\libtomcrypt.pch"
AssemblerListingLocation="$(IntDir)\"
ObjectFile="$(IntDir)\"
ProgramDataBaseFileName="$(IntDir)\"
WarningLevel="3"
SuppressStartupBanner="true"
DebugInformationFormat="4"
CompileAs="1"
/>
<Tool
Name="VCManagedResourceCompilerTool"
/>
<Tool
Name="VCResourceCompilerTool"
PreprocessorDefinitions="_DEBUG"
Culture="1033"
/>
<Tool
Name="VCPreLinkEventTool"
/>
<Tool
Name="VCLibrarianTool"
OutputFile="$(OutDir)\tommath.lib"
SuppressStartupBanner="true"
/>
<Tool
Name="VCALinkTool"
/>
<Tool
Name="VCXDCMakeTool"
/>
<Tool
Name="VCBscMakeTool"
SuppressStartupBanner="true"
OutputFile="$(OutDir)\tommath.bsc"
/>
<Tool
Name="VCFxCopTool"
/>
<Tool
Name="VCPostBuildEventTool"
/>
</Configuration>
<Configuration
Name="Debug|x64"
OutputDirectory="MSVC_$(PlatformName)_$(ConfigurationName)"
IntermediateDirectory="MSVC_$(PlatformName)_$(ConfigurationName)\Intermediate"
ConfigurationType="4"
UseOfMFC="0"
ATLMinimizesCRunTimeLibraryUsage="false"
CharacterSet="0"
>
<Tool
Name="VCPreBuildEventTool"
/>
<Tool
Name="VCCustomBuildTool"
/>
<Tool
Name="VCXMLDataGeneratorTool"
/>
<Tool
Name="VCMIDLTool"
TargetEnvironment="3"
/>
<Tool
Name="VCCLCompilerTool"
Optimization="0"
AdditionalIncludeDirectories="."
PreprocessorDefinitions="WIN32;_DEBUG;_CRT_SECURE_NO_WARNINGS;_CRT_NONSTDC_NO_DEPRECATE"
MinimalRebuild="true"
ExceptionHandling="0"
BasicRuntimeChecks="3"
RuntimeLibrary="1"
PrecompiledHeaderFile="$(IntDir)\libtomcrypt.pch"
AssemblerListingLocation="$(IntDir)\"
ObjectFile="$(IntDir)\"
ProgramDataBaseFileName="$(IntDir)\"
WarningLevel="3"
SuppressStartupBanner="true"
DebugInformationFormat="3"
CompileAs="1"
/>
<Tool
Name="VCManagedResourceCompilerTool"
/>
<Tool
Name="VCResourceCompilerTool"
PreprocessorDefinitions="_DEBUG"
Culture="1033"
/>
<Tool
Name="VCPreLinkEventTool"
/>
<Tool
Name="VCLibrarianTool"
OutputFile="$(OutDir)\tommath.lib"
SuppressStartupBanner="true"
/>
<Tool
Name="VCALinkTool"
/>
<Tool
Name="VCXDCMakeTool"
/>
<Tool
Name="VCBscMakeTool"
SuppressStartupBanner="true"
OutputFile="$(OutDir)\tommath.bsc"
/>
<Tool
Name="VCFxCopTool"
/>
<Tool
Name="VCPostBuildEventTool"
/>
</Configuration>
<Configuration
Name="Release|Win32"
OutputDirectory="MSVC_$(PlatformName)_$(ConfigurationName)"
IntermediateDirectory="MSVC_$(PlatformName)_$(ConfigurationName)\Intermediate"
ConfigurationType="4"
UseOfMFC="0"
ATLMinimizesCRunTimeLibraryUsage="false"
CharacterSet="0"
>
<Tool
Name="VCPreBuildEventTool"
/>
<Tool
Name="VCCustomBuildTool"
/>
<Tool
Name="VCXMLDataGeneratorTool"
/>
<Tool
Name="VCMIDLTool"
/>
<Tool
Name="VCCLCompilerTool"
Optimization="2"
InlineFunctionExpansion="1"
AdditionalIncludeDirectories="."
PreprocessorDefinitions="WIN32;NDEBUG;_CRT_SECURE_NO_WARNINGS;_CRT_NONSTDC_NO_DEPRECATE"
StringPooling="true"
RuntimeLibrary="0"
EnableFunctionLevelLinking="true"
PrecompiledHeaderFile="$(IntDir)\libtomcrypt.pch"
AssemblerListingLocation="$(IntDir)\"
ObjectFile="$(IntDir)\"
ProgramDataBaseFileName="$(IntDir)\"
WarningLevel="3"
SuppressStartupBanner="true"
/>
<Tool
Name="VCManagedResourceCompilerTool"
/>
<Tool
Name="VCResourceCompilerTool"
PreprocessorDefinitions="NDEBUG"
Culture="1033"
/>
<Tool
Name="VCPreLinkEventTool"
/>
<Tool
Name="VCLibrarianTool"
OutputFile="$(OutDir)\tommath.lib"
SuppressStartupBanner="true"
/>
<Tool
Name="VCALinkTool"
/>
<Tool
Name="VCXDCMakeTool"
/>
<Tool
Name="VCBscMakeTool"
SuppressStartupBanner="true"
OutputFile="$(OutDir)\tommath.bsc"
/>
<Tool
Name="VCFxCopTool"
/>
<Tool
Name="VCPostBuildEventTool"
/>
</Configuration>
<Configuration
Name="Release|x64"
OutputDirectory="MSVC_$(PlatformName)_$(ConfigurationName)"
IntermediateDirectory="MSVC_$(PlatformName)_$(ConfigurationName)\Intermediate"
ConfigurationType="4"
UseOfMFC="0"
ATLMinimizesCRunTimeLibraryUsage="false"
CharacterSet="0"
>
<Tool
Name="VCPreBuildEventTool"
/>
<Tool
Name="VCCustomBuildTool"
/>
<Tool
Name="VCXMLDataGeneratorTool"
/>
<Tool
Name="VCMIDLTool"
TargetEnvironment="3"
/>
<Tool
Name="VCCLCompilerTool"
Optimization="2"
InlineFunctionExpansion="1"
AdditionalIncludeDirectories="."
PreprocessorDefinitions="WIN32;NDEBUG;_CRT_SECURE_NO_WARNINGS;_CRT_NONSTDC_NO_DEPRECATE"
StringPooling="true"
RuntimeLibrary="0"
EnableFunctionLevelLinking="true"
PrecompiledHeaderFile="$(IntDir)\libtomcrypt.pch"
AssemblerListingLocation="$(IntDir)\"
ObjectFile="$(IntDir)\"
ProgramDataBaseFileName="$(IntDir)\"
WarningLevel="3"
SuppressStartupBanner="true"
/>
<Tool
Name="VCManagedResourceCompilerTool"
/>
<Tool
Name="VCResourceCompilerTool"
PreprocessorDefinitions="NDEBUG"
Culture="1033"
/>
<Tool
Name="VCPreLinkEventTool"
/>
<Tool
Name="VCLibrarianTool"
OutputFile="$(OutDir)\tommath.lib"
SuppressStartupBanner="true"
/>
<Tool
Name="VCALinkTool"
/>
<Tool
Name="VCXDCMakeTool"
/>
<Tool
Name="VCBscMakeTool"
SuppressStartupBanner="true"
OutputFile="$(OutDir)\tommath.bsc"
/>
<Tool
Name="VCFxCopTool"
/>
<Tool
Name="VCPostBuildEventTool"
/>
</Configuration>
</Configurations>
<References>
</References>
<Files>
<File
RelativePath="bn_error.c"
>
</File>
<File
RelativePath="bn_fast_mp_invmod.c"
>
</File>
<File
RelativePath="bn_fast_mp_montgomery_reduce.c"
>
</File>
<File
RelativePath="bn_fast_s_mp_mul_digs.c"
>
</File>
<File
RelativePath="bn_fast_s_mp_mul_high_digs.c"
>
</File>
<File
RelativePath="bn_fast_s_mp_sqr.c"
>
</File>
<File
RelativePath="bn_mp_2expt.c"
>
</File>
<File
RelativePath="bn_mp_abs.c"
>
</File>
<File
RelativePath="bn_mp_add.c"
>
</File>
<File
RelativePath="bn_mp_add_d.c"
>
</File>
<File
RelativePath="bn_mp_addmod.c"
>
</File>
<File
RelativePath="bn_mp_and.c"
>
</File>
<File
RelativePath="bn_mp_clamp.c"
>
</File>
<File
RelativePath="bn_mp_clear.c"
>
</File>
<File
RelativePath="bn_mp_clear_multi.c"
>
</File>
<File
RelativePath="bn_mp_cmp.c"
>
</File>
<File
RelativePath="bn_mp_cmp_d.c"
>
</File>
<File
RelativePath="bn_mp_cmp_mag.c"
>
</File>
<File
RelativePath="bn_mp_cnt_lsb.c"
>
</File>
<File
RelativePath="bn_mp_complement.c"
>
</File>
<File
RelativePath="bn_mp_copy.c"
>
</File>
<File
RelativePath="bn_mp_count_bits.c"
>
</File>
<File
RelativePath="bn_mp_div.c"
>
</File>
<File
RelativePath="bn_mp_div_2.c"
>
</File>
<File
RelativePath="bn_mp_div_2d.c"
>
</File>
<File
RelativePath="bn_mp_div_3.c"
>
</File>
<File
RelativePath="bn_mp_div_d.c"
>
</File>
<File
RelativePath="bn_mp_dr_is_modulus.c"
>
</File>
<File
RelativePath="bn_mp_dr_reduce.c"
>
</File>
<File
RelativePath="bn_mp_dr_setup.c"
>
</File>
<File
RelativePath="bn_mp_exch.c"
>
</File>
<File
RelativePath="bn_mp_export.c"
>
</File>
<File
RelativePath="bn_mp_expt_d.c"
>
</File>
<File
RelativePath="bn_mp_expt_d_ex.c"
>
</File>
<File
RelativePath="bn_mp_exptmod.c"
>
</File>
<File
RelativePath="bn_mp_exptmod_fast.c"
>
</File>
<File
RelativePath="bn_mp_exteuclid.c"
>
</File>
<File
RelativePath="bn_mp_fread.c"
>
</File>
<File
RelativePath="bn_mp_fwrite.c"
>
</File>
<File
RelativePath="bn_mp_gcd.c"
>
</File>
<File
RelativePath="bn_mp_get_bit.c"
>
</File>
<File
RelativePath="bn_mp_get_double.c"
>
</File>
<File
RelativePath="bn_mp_get_int.c"
>
</File>
<File
RelativePath="bn_mp_get_long.c"
>
</File>
<File
RelativePath="bn_mp_get_long_long.c"
>
</File>
<File
RelativePath="bn_mp_grow.c"
>
</File>
<File
RelativePath="bn_mp_import.c"
>
</File>
<File
RelativePath="bn_mp_init.c"
>
</File>
<File
RelativePath="bn_mp_init_copy.c"
>
</File>
<File
RelativePath="bn_mp_init_multi.c"
>
</File>
<File
RelativePath="bn_mp_init_set.c"
>
</File>
<File
RelativePath="bn_mp_init_set_int.c"
>
</File>
<File
RelativePath="bn_mp_init_size.c"
>
</File>
<File
RelativePath="bn_mp_invmod.c"
>
</File>
<File
RelativePath="bn_mp_invmod_slow.c"
>
</File>
<File
RelativePath="bn_mp_is_square.c"
>
</File>
<File
RelativePath="bn_mp_jacobi.c"
>
</File>
<File
RelativePath="bn_mp_karatsuba_mul.c"
>
</File>
<File
RelativePath="bn_mp_karatsuba_sqr.c"
>
</File>
<File
RelativePath="bn_mp_kronecker.c"
>
</File>
<File
RelativePath="bn_mp_lcm.c"
>
</File>
<File
RelativePath="bn_mp_lshd.c"
>
</File>
<File
RelativePath="bn_mp_mod.c"
>
</File>
<File
RelativePath="bn_mp_mod_2d.c"
>
</File>
<File
RelativePath="bn_mp_mod_d.c"
>
</File>
<File
RelativePath="bn_mp_montgomery_calc_normalization.c"
>
</File>
<File
RelativePath="bn_mp_montgomery_reduce.c"
>
</File>
<File
RelativePath="bn_mp_montgomery_setup.c"
>
</File>
<File
RelativePath="bn_mp_mul.c"
>
</File>
<File
RelativePath="bn_mp_mul_2.c"
>
</File>
<File
RelativePath="bn_mp_mul_2d.c"
>
</File>
<File
RelativePath="bn_mp_mul_d.c"
>
</File>
<File
RelativePath="bn_mp_mulmod.c"
>
</File>
<File
RelativePath="bn_mp_n_root.c"
>
</File>
<File
RelativePath="bn_mp_n_root_ex.c"
>
</File>
<File
RelativePath="bn_mp_neg.c"
>
</File>
<File
RelativePath="bn_mp_or.c"
>
</File>
<File
RelativePath="bn_mp_prime_fermat.c"
>
</File>
<File
RelativePath="bn_mp_prime_frobenius_underwood.c"
>
</File>
<File
RelativePath="bn_mp_prime_is_divisible.c"
>
</File>
<File
RelativePath="bn_mp_prime_is_prime.c"
>
</File>
<File
RelativePath="bn_mp_prime_miller_rabin.c"
>
</File>
<File
RelativePath="bn_mp_prime_next_prime.c"
>
</File>
<File
RelativePath="bn_mp_prime_rabin_miller_trials.c"
>
</File>
<File
RelativePath="bn_mp_prime_random_ex.c"
>
</File>
<File
RelativePath="bn_mp_prime_strong_lucas_selfridge.c"
>
</File>
<File
RelativePath="bn_mp_radix_size.c"
>
</File>
<File
RelativePath="bn_mp_radix_smap.c"
>
</File>
<File
RelativePath="bn_mp_rand.c"
>
</File>
<File
RelativePath="bn_mp_read_radix.c"
>
</File>
<File
RelativePath="bn_mp_read_signed_bin.c"
>
</File>
<File
RelativePath="bn_mp_read_unsigned_bin.c"
>
</File>
<File
RelativePath="bn_mp_reduce.c"
>
</File>
<File
RelativePath="bn_mp_reduce_2k.c"
>
</File>
<File
RelativePath="bn_mp_reduce_2k_l.c"
>
</File>
<File
RelativePath="bn_mp_reduce_2k_setup.c"
>
</File>
<File
RelativePath="bn_mp_reduce_2k_setup_l.c"
>
</File>
<File
RelativePath="bn_mp_reduce_is_2k.c"
>
</File>
<File
RelativePath="bn_mp_reduce_is_2k_l.c"
>
</File>
<File
RelativePath="bn_mp_reduce_setup.c"
>
</File>
<File
RelativePath="bn_mp_rshd.c"
>
</File>
<File
RelativePath="bn_mp_set.c"
>
</File>
<File
RelativePath="bn_mp_set_double.c"
>
</File>
<File
RelativePath="bn_mp_set_int.c"
>
</File>
<File
RelativePath="bn_mp_set_long.c"
>
</File>
<File
RelativePath="bn_mp_set_long_long.c"
>
</File>
<File
RelativePath="bn_mp_shrink.c"
>
</File>
<File
RelativePath="bn_mp_signed_bin_size.c"
>
</File>
<File
RelativePath="bn_mp_sqr.c"
>
</File>
<File
RelativePath="bn_mp_sqrmod.c"
>
</File>
<File
RelativePath="bn_mp_sqrt.c"
>
</File>
<File
RelativePath="bn_mp_sqrtmod_prime.c"
>
</File>
<File
RelativePath="bn_mp_sub.c"
>
</File>
<File
RelativePath="bn_mp_sub_d.c"
>
</File>
<File
RelativePath="bn_mp_submod.c"
>
</File>
<File
RelativePath="bn_mp_tc_and.c"
>
</File>
<File
RelativePath="bn_mp_tc_div_2d.c"
>
</File>
<File
RelativePath="bn_mp_tc_or.c"
>
</File>
<File
RelativePath="bn_mp_tc_xor.c"
>
</File>
<File
RelativePath="bn_mp_to_signed_bin.c"
>
</File>
<File
RelativePath="bn_mp_to_signed_bin_n.c"
>
</File>
<File
RelativePath="bn_mp_to_unsigned_bin.c"
>
</File>
<File
RelativePath="bn_mp_to_unsigned_bin_n.c"
>
</File>
<File
RelativePath="bn_mp_toom_mul.c"
>
</File>
<File
RelativePath="bn_mp_toom_sqr.c"
>
</File>
<File
RelativePath="bn_mp_toradix.c"
>
</File>
<File
RelativePath="bn_mp_toradix_n.c"
>
</File>
<File
RelativePath="bn_mp_unsigned_bin_size.c"
>
</File>
<File
RelativePath="bn_mp_xor.c"
>
</File>
<File
RelativePath="bn_mp_zero.c"
>
</File>
<File
RelativePath="bn_prime_tab.c"
>
</File>
<File
RelativePath="bn_reverse.c"
>
</File>
<File
RelativePath="bn_s_mp_add.c"
>
</File>
<File
RelativePath="bn_s_mp_exptmod.c"
>
</File>
<File
RelativePath="bn_s_mp_mul_digs.c"
>
</File>
<File
RelativePath="bn_s_mp_mul_high_digs.c"
>
</File>
<File
RelativePath="bn_s_mp_sqr.c"
>
</File>
<File
RelativePath="bn_s_mp_sub.c"
>
</File>
<File
RelativePath="bncore.c"
>
</File>
<File
RelativePath="tommath.h"
>
</File>
<File
RelativePath="tommath_class.h"
>
</File>
<File
RelativePath="tommath_private.h"
>
</File>
<File
RelativePath="tommath_superclass.h"
>
</File>
</Files>
<Globals>
</Globals>
</VisualStudioProject>
|
Changes to libtommath/makefile.
| ︙ | ︙ | |||
22 23 24 25 26 27 28 |
@echo " * ${CC} $@"
endif
${silent} ${CC} -c ${CFLAGS} $< -o $@
LCOV_ARGS=--directory .
#START_INS
| | | | | > | | | | | | | | | | | > | | | | | | | | | | | | 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 |
@echo " * ${CC} $@"
endif
${silent} ${CC} -c ${CFLAGS} $< -o $@
LCOV_ARGS=--directory .
#START_INS
OBJECTS=bn_error.o bn_fast_mp_invmod.o bn_fast_mp_montgomery_reduce.o bn_fast_s_mp_mul_digs.o \
bn_fast_s_mp_mul_high_digs.o bn_fast_s_mp_sqr.o bn_mp_2expt.o bn_mp_abs.o bn_mp_add.o bn_mp_add_d.o \
bn_mp_addmod.o bn_mp_and.o bn_mp_clamp.o bn_mp_clear.o bn_mp_clear_multi.o bn_mp_cmp.o bn_mp_cmp_d.o \
bn_mp_cmp_mag.o bn_mp_cnt_lsb.o bn_mp_complement.o bn_mp_copy.o bn_mp_count_bits.o bn_mp_div.o \
bn_mp_div_2.o bn_mp_div_2d.o bn_mp_div_3.o bn_mp_div_d.o bn_mp_dr_is_modulus.o bn_mp_dr_reduce.o \
bn_mp_dr_setup.o bn_mp_exch.o bn_mp_export.o bn_mp_expt_d.o bn_mp_expt_d_ex.o bn_mp_exptmod.o \
bn_mp_exptmod_fast.o bn_mp_exteuclid.o bn_mp_fread.o bn_mp_fwrite.o bn_mp_gcd.o bn_mp_get_bit.o \
bn_mp_get_double.o bn_mp_get_int.o bn_mp_get_long.o bn_mp_get_long_long.o bn_mp_grow.o bn_mp_import.o \
bn_mp_init.o bn_mp_init_copy.o bn_mp_init_multi.o bn_mp_init_set.o bn_mp_init_set_int.o bn_mp_init_size.o \
bn_mp_invmod.o bn_mp_invmod_slow.o bn_mp_is_square.o bn_mp_jacobi.o bn_mp_karatsuba_mul.o \
bn_mp_karatsuba_sqr.o bn_mp_kronecker.o bn_mp_lcm.o bn_mp_lshd.o bn_mp_mod.o bn_mp_mod_2d.o bn_mp_mod_d.o \
bn_mp_montgomery_calc_normalization.o bn_mp_montgomery_reduce.o bn_mp_montgomery_setup.o bn_mp_mul.o \
bn_mp_mul_2.o bn_mp_mul_2d.o bn_mp_mul_d.o bn_mp_mulmod.o bn_mp_n_root.o bn_mp_n_root_ex.o bn_mp_neg.o \
bn_mp_or.o bn_mp_prime_fermat.o bn_mp_prime_frobenius_underwood.o bn_mp_prime_is_divisible.o \
bn_mp_prime_is_prime.o bn_mp_prime_miller_rabin.o bn_mp_prime_next_prime.o \
bn_mp_prime_rabin_miller_trials.o bn_mp_prime_random_ex.o bn_mp_prime_strong_lucas_selfridge.o \
bn_mp_radix_size.o bn_mp_radix_smap.o bn_mp_rand.o bn_mp_read_radix.o bn_mp_read_signed_bin.o \
bn_mp_read_unsigned_bin.o bn_mp_reduce.o bn_mp_reduce_2k.o bn_mp_reduce_2k_l.o bn_mp_reduce_2k_setup.o \
bn_mp_reduce_2k_setup_l.o bn_mp_reduce_is_2k.o bn_mp_reduce_is_2k_l.o bn_mp_reduce_setup.o bn_mp_rshd.o \
bn_mp_set.o bn_mp_set_double.o bn_mp_set_int.o bn_mp_set_long.o bn_mp_set_long_long.o bn_mp_shrink.o \
bn_mp_signed_bin_size.o bn_mp_sqr.o bn_mp_sqrmod.o bn_mp_sqrt.o bn_mp_sqrtmod_prime.o bn_mp_sub.o \
bn_mp_sub_d.o bn_mp_submod.o bn_mp_tc_and.o bn_mp_tc_div_2d.o bn_mp_tc_or.o bn_mp_tc_xor.o \
bn_mp_to_signed_bin.o bn_mp_to_signed_bin_n.o bn_mp_to_unsigned_bin.o bn_mp_to_unsigned_bin_n.o \
bn_mp_toom_mul.o bn_mp_toom_sqr.o bn_mp_toradix.o bn_mp_toradix_n.o bn_mp_unsigned_bin_size.o bn_mp_xor.o \
bn_mp_zero.o bn_prime_tab.o bn_reverse.o bn_s_mp_add.o bn_s_mp_exptmod.o bn_s_mp_mul_digs.o \
bn_s_mp_mul_high_digs.o bn_s_mp_sqr.o bn_s_mp_sub.o bncore.o
#END_INS
$(OBJECTS): $(HEADERS)
$(LIBNAME): $(OBJECTS)
$(AR) $(ARFLAGS) $@ $(OBJECTS)
$(RANLIB) $@
#make a profiled library (takes a while!!!)
#
# This will build the library with profile generation
# then run the test demo and rebuild the library.
#
# So far I've seen improvements in the MP math
profiled:
make CFLAGS="$(CFLAGS) -fprofile-arcs -DTESTING" timing
./timing
rm -f *.a *.o timing
make CFLAGS="$(CFLAGS) -fbranch-probabilities"
#make a single object profiled library
profiled_single:
perl gen.pl
$(CC) $(CFLAGS) -fprofile-arcs -DTESTING -c mpi.c -o mpi.o
$(CC) $(CFLAGS) -DTESTING -DTIMER demo/timing.c mpi.o -lgcov -o timing
./timing
rm -f *.o timing
$(CC) $(CFLAGS) -fbranch-probabilities -DTESTING -c mpi.c -o mpi.o
$(AR) $(ARFLAGS) $(LIBNAME) mpi.o
ranlib $(LIBNAME)
install: $(LIBNAME)
install -d $(DESTDIR)$(LIBPATH)
install -d $(DESTDIR)$(INCPATH)
|
| ︙ | ︙ | |||
98 99 100 101 102 103 104 | test_standalone: $(LIBNAME) demo/demo.o $(CC) $(CFLAGS) demo/demo.o $(LIBNAME) $(LFLAGS) -o test .PHONY: mtest mtest: cd mtest ; $(CC) $(CFLAGS) -O0 mtest.c $(LFLAGS) -o mtest | | | > | > > > > > | 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 | test_standalone: $(LIBNAME) demo/demo.o $(CC) $(CFLAGS) demo/demo.o $(LIBNAME) $(LFLAGS) -o test .PHONY: mtest mtest: cd mtest ; $(CC) $(CFLAGS) -O0 mtest.c $(LFLAGS) -o mtest timing: $(LIBNAME) demo/timing.c $(CC) $(CFLAGS) -DTIMER demo/timing.c $(LIBNAME) $(LFLAGS) -o timing # You have to create a file .coveralls.yml with the content "repo_token: <the token>" # in the base folder to be able to submit to coveralls coveralls: lcov coveralls-lcov docdvi poster docs mandvi manual: $(MAKE) -C doc/ $@ V=$(V) pretty: perl pretty.build .PHONY: pre_gen pre_gen: mkdir -p pre_gen perl gen.pl sed -e 's/[[:blank:]]*$$//' mpi.c > pre_gen/mpi.c rm mpi.c zipup: clean astyle new_file manual poster docs @# Update the index, so diff-index won't fail in case the pdf has been created. @# As the pdf creation modifies the tex files, git sometimes detects the @# modified files, but misses that it's put back to its original version. @git update-index --refresh @git diff-index --quiet HEAD -- || ( echo "FAILURE: uncommited changes or not a git" && exit 1 ) rm -rf libtommath-$(VERSION) ltm-$(VERSION).* @# files/dirs excluded from "git archive" are defined in .gitattributes git archive --format=tar --prefix=libtommath-$(VERSION)/ HEAD | tar x @echo 'fixme check' -@(find libtommath-$(VERSION)/ -type f | xargs grep 'FIXM[E]') && echo '############## BEWARE: the "fixme" marker was found !!! ##############' || true mkdir -p libtommath-$(VERSION)/doc cp doc/bn.pdf doc/tommath.pdf doc/poster.pdf libtommath-$(VERSION)/doc/ $(MAKE) -C libtommath-$(VERSION)/ pre_gen tar -c libtommath-$(VERSION)/ | xz -6e -c - > ltm-$(VERSION).tar.xz zip -9rq ltm-$(VERSION).zip libtommath-$(VERSION) cp doc/bn.pdf bn-$(VERSION).pdf cp doc/tommath.pdf tommath-$(VERSION).pdf rm -rf libtommath-$(VERSION) gpg -b -a ltm-$(VERSION).tar.xz gpg -b -a ltm-$(VERSION).zip new_file: bash updatemakes.sh perl dep.pl perlcritic: perlcritic *.pl doc/*.pl astyle: astyle --options=astylerc $(OBJECTS:.o=.c) tommath*.h demo/*.c etc/*.c mtest/mtest.c |
Deleted libtommath/makefile.bcc.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Deleted libtommath/makefile.cygwin_dll.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Deleted libtommath/makefile.icc.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Added libtommath/makefile.mingw.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 | # MAKEFILE for MS Windows (mingw + gcc + gmake) # # BEWARE: variable OBJECTS is updated via ./updatemakes.sh ### USAGE: # Open a command prompt with gcc + gmake in PATH and start: # # gmake -f makefile.mingw all # test.exe # gmake -f makefile.mingw PREFIX=c:\devel\libtom install #The following can be overridden from command line e.g. make -f makefile.mingw CC=gcc ARFLAGS=rcs PREFIX = c:\mingw CC = gcc AR = ar ARFLAGS = r RANLIB = ranlib STRIP = strip CFLAGS = -O2 LDFLAGS = #Compilation flags LTM_CFLAGS = -I. $(CFLAGS) LTM_LDFLAGS = $(LDFLAGS) #Libraries to be created LIBMAIN_S =libtommath.a LIBMAIN_I =libtommath.dll.a LIBMAIN_D =libtommath.dll #List of objects to compile (all goes to libtommath.a) OBJECTS=bn_error.o bn_fast_mp_invmod.o bn_fast_mp_montgomery_reduce.o bn_fast_s_mp_mul_digs.o \ bn_fast_s_mp_mul_high_digs.o bn_fast_s_mp_sqr.o bn_mp_2expt.o bn_mp_abs.o bn_mp_add.o bn_mp_add_d.o \ bn_mp_addmod.o bn_mp_and.o bn_mp_clamp.o bn_mp_clear.o bn_mp_clear_multi.o bn_mp_cmp.o bn_mp_cmp_d.o \ bn_mp_cmp_mag.o bn_mp_cnt_lsb.o bn_mp_complement.o bn_mp_copy.o bn_mp_count_bits.o bn_mp_div.o \ bn_mp_div_2.o bn_mp_div_2d.o bn_mp_div_3.o bn_mp_div_d.o bn_mp_dr_is_modulus.o bn_mp_dr_reduce.o \ bn_mp_dr_setup.o bn_mp_exch.o bn_mp_export.o bn_mp_expt_d.o bn_mp_expt_d_ex.o bn_mp_exptmod.o \ bn_mp_exptmod_fast.o bn_mp_exteuclid.o bn_mp_fread.o bn_mp_fwrite.o bn_mp_gcd.o bn_mp_get_bit.o \ bn_mp_get_double.o bn_mp_get_int.o bn_mp_get_long.o bn_mp_get_long_long.o bn_mp_grow.o bn_mp_import.o \ bn_mp_init.o bn_mp_init_copy.o bn_mp_init_multi.o bn_mp_init_set.o bn_mp_init_set_int.o bn_mp_init_size.o \ bn_mp_invmod.o bn_mp_invmod_slow.o bn_mp_is_square.o bn_mp_jacobi.o bn_mp_karatsuba_mul.o \ bn_mp_karatsuba_sqr.o bn_mp_kronecker.o bn_mp_lcm.o bn_mp_lshd.o bn_mp_mod.o bn_mp_mod_2d.o bn_mp_mod_d.o \ bn_mp_montgomery_calc_normalization.o bn_mp_montgomery_reduce.o bn_mp_montgomery_setup.o bn_mp_mul.o \ bn_mp_mul_2.o bn_mp_mul_2d.o bn_mp_mul_d.o bn_mp_mulmod.o bn_mp_n_root.o bn_mp_n_root_ex.o bn_mp_neg.o \ bn_mp_or.o bn_mp_prime_fermat.o bn_mp_prime_frobenius_underwood.o bn_mp_prime_is_divisible.o \ bn_mp_prime_is_prime.o bn_mp_prime_miller_rabin.o bn_mp_prime_next_prime.o \ bn_mp_prime_rabin_miller_trials.o bn_mp_prime_random_ex.o bn_mp_prime_strong_lucas_selfridge.o \ bn_mp_radix_size.o bn_mp_radix_smap.o bn_mp_rand.o bn_mp_read_radix.o bn_mp_read_signed_bin.o \ bn_mp_read_unsigned_bin.o bn_mp_reduce.o bn_mp_reduce_2k.o bn_mp_reduce_2k_l.o bn_mp_reduce_2k_setup.o \ bn_mp_reduce_2k_setup_l.o bn_mp_reduce_is_2k.o bn_mp_reduce_is_2k_l.o bn_mp_reduce_setup.o bn_mp_rshd.o \ bn_mp_set.o bn_mp_set_double.o bn_mp_set_int.o bn_mp_set_long.o bn_mp_set_long_long.o bn_mp_shrink.o \ bn_mp_signed_bin_size.o bn_mp_sqr.o bn_mp_sqrmod.o bn_mp_sqrt.o bn_mp_sqrtmod_prime.o bn_mp_sub.o \ bn_mp_sub_d.o bn_mp_submod.o bn_mp_tc_and.o bn_mp_tc_div_2d.o bn_mp_tc_or.o bn_mp_tc_xor.o \ bn_mp_to_signed_bin.o bn_mp_to_signed_bin_n.o bn_mp_to_unsigned_bin.o bn_mp_to_unsigned_bin_n.o \ bn_mp_toom_mul.o bn_mp_toom_sqr.o bn_mp_toradix.o bn_mp_toradix_n.o bn_mp_unsigned_bin_size.o bn_mp_xor.o \ bn_mp_zero.o bn_prime_tab.o bn_reverse.o bn_s_mp_add.o bn_s_mp_exptmod.o bn_s_mp_mul_digs.o \ bn_s_mp_mul_high_digs.o bn_s_mp_sqr.o bn_s_mp_sub.o bncore.o HEADERS_PUB=tommath.h tommath_class.h tommath_superclass.h HEADERS=tommath_private.h $(HEADERS_PUB) #The default rule for make builds the libtommath.a library (static) default: $(LIBMAIN_S) #Dependencies on *.h $(OBJECTS): $(HEADERS) .c.o: $(CC) $(LTM_CFLAGS) -c $< -o $@ #Create libtommath.a $(LIBMAIN_S): $(OBJECTS) $(AR) $(ARFLAGS) $@ $(OBJECTS) $(RANLIB) $@ #Create DLL + import library libtommath.dll.a $(LIBMAIN_D) $(LIBMAIN_I): $(OBJECTS) $(CC) -s -shared -o $(LIBMAIN_D) $^ -Wl,--enable-auto-import,--export-all -Wl,--out-implib=$(LIBMAIN_I) $(LTM_LDFLAGS) $(STRIP) -S $(LIBMAIN_D) #Build test_standalone suite test.exe: $(LIBMAIN_S) demo/demo.c $(CC) $(LTM_CFLAGS) $(LTM_LDFLAGS) demo/demo.c $(LIBMAIN_S) -DLTM_DEMO_TEST_VS_MTEST=0 -o $@ @echo NOTICE: start the tests by launching test.exe test_standalone: test.exe all: $(LIBMAIN_S) test_standalone clean: @-cmd /c del /Q /S *.o *.a *.exe *.dll 2>nul #Install the library + headers install: $(LIBMAIN_S) $(LIBMAIN_I) $(LIBMAIN_D) cmd /c if not exist "$(PREFIX)\bin" mkdir "$(PREFIX)\bin" cmd /c if not exist "$(PREFIX)\lib" mkdir "$(PREFIX)\lib" cmd /c if not exist "$(PREFIX)\include" mkdir "$(PREFIX)\include" copy /Y $(LIBMAIN_S) "$(PREFIX)\lib" copy /Y $(LIBMAIN_I) "$(PREFIX)\lib" copy /Y $(LIBMAIN_D) "$(PREFIX)\bin" copy /Y tommath*.h "$(PREFIX)\include" # ref: $Format:%D$ # git commit: $Format:%H$ # commit time: $Format:%ai$ |
Changes to libtommath/makefile.msvc.
|
| | > | > > | > > > | > > > > > | > > | > | | | | > | | | | | | | | | | | > | | | | | | > | > > > | > > > > > > | > | > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 | # MAKEFILE for MS Windows (nmake + Windows SDK) # # BEWARE: variable OBJECTS is updated via ./updatemakes.sh ### USAGE: # Open a command prompt with WinSDK variables set and start: # # nmake -f makefile.msvc all # test.exe # nmake -f makefile.msvc PREFIX=c:\devel\libtom install #The following can be overridden from command line e.g. make -f makefile.msvc CC=gcc ARFLAGS=rcs PREFIX = c:\devel CFLAGS = /Ox #Compilation flags LTM_CFLAGS = /nologo /I./ /D_CRT_SECURE_NO_WARNINGS /D_CRT_NONSTDC_NO_DEPRECATE /W3 $(CFLAGS) LTM_LDFLAGS = advapi32.lib #Libraries to be created (this makefile builds only static libraries) LIBMAIN_S =tommath.lib #List of objects to compile (all goes to tommath.lib) OBJECTS=bn_error.obj bn_fast_mp_invmod.obj bn_fast_mp_montgomery_reduce.obj bn_fast_s_mp_mul_digs.obj \ bn_fast_s_mp_mul_high_digs.obj bn_fast_s_mp_sqr.obj bn_mp_2expt.obj bn_mp_abs.obj bn_mp_add.obj bn_mp_add_d.obj \ bn_mp_addmod.obj bn_mp_and.obj bn_mp_clamp.obj bn_mp_clear.obj bn_mp_clear_multi.obj bn_mp_cmp.obj bn_mp_cmp_d.obj \ bn_mp_cmp_mag.obj bn_mp_cnt_lsb.obj bn_mp_complement.obj bn_mp_copy.obj bn_mp_count_bits.obj bn_mp_div.obj \ bn_mp_div_2.obj bn_mp_div_2d.obj bn_mp_div_3.obj bn_mp_div_d.obj bn_mp_dr_is_modulus.obj bn_mp_dr_reduce.obj \ bn_mp_dr_setup.obj bn_mp_exch.obj bn_mp_export.obj bn_mp_expt_d.obj bn_mp_expt_d_ex.obj bn_mp_exptmod.obj \ bn_mp_exptmod_fast.obj bn_mp_exteuclid.obj bn_mp_fread.obj bn_mp_fwrite.obj bn_mp_gcd.obj bn_mp_get_bit.obj \ bn_mp_get_double.obj bn_mp_get_int.obj bn_mp_get_long.obj bn_mp_get_long_long.obj bn_mp_grow.obj bn_mp_import.obj \ bn_mp_init.obj bn_mp_init_copy.obj bn_mp_init_multi.obj bn_mp_init_set.obj bn_mp_init_set_int.obj bn_mp_init_size.obj \ bn_mp_invmod.obj bn_mp_invmod_slow.obj bn_mp_is_square.obj bn_mp_jacobi.obj bn_mp_karatsuba_mul.obj \ bn_mp_karatsuba_sqr.obj bn_mp_kronecker.obj bn_mp_lcm.obj bn_mp_lshd.obj bn_mp_mod.obj bn_mp_mod_2d.obj bn_mp_mod_d.obj \ bn_mp_montgomery_calc_normalization.obj bn_mp_montgomery_reduce.obj bn_mp_montgomery_setup.obj bn_mp_mul.obj \ bn_mp_mul_2.obj bn_mp_mul_2d.obj bn_mp_mul_d.obj bn_mp_mulmod.obj bn_mp_n_root.obj bn_mp_n_root_ex.obj bn_mp_neg.obj \ bn_mp_or.obj bn_mp_prime_fermat.obj bn_mp_prime_frobenius_underwood.obj bn_mp_prime_is_divisible.obj \ bn_mp_prime_is_prime.obj bn_mp_prime_miller_rabin.obj bn_mp_prime_next_prime.obj \ bn_mp_prime_rabin_miller_trials.obj bn_mp_prime_random_ex.obj bn_mp_prime_strong_lucas_selfridge.obj \ bn_mp_radix_size.obj bn_mp_radix_smap.obj bn_mp_rand.obj bn_mp_read_radix.obj bn_mp_read_signed_bin.obj \ bn_mp_read_unsigned_bin.obj bn_mp_reduce.obj bn_mp_reduce_2k.obj bn_mp_reduce_2k_l.obj bn_mp_reduce_2k_setup.obj \ bn_mp_reduce_2k_setup_l.obj bn_mp_reduce_is_2k.obj bn_mp_reduce_is_2k_l.obj bn_mp_reduce_setup.obj bn_mp_rshd.obj \ bn_mp_set.obj bn_mp_set_double.obj bn_mp_set_int.obj bn_mp_set_long.obj bn_mp_set_long_long.obj bn_mp_shrink.obj \ bn_mp_signed_bin_size.obj bn_mp_sqr.obj bn_mp_sqrmod.obj bn_mp_sqrt.obj bn_mp_sqrtmod_prime.obj bn_mp_sub.obj \ bn_mp_sub_d.obj bn_mp_submod.obj bn_mp_tc_and.obj bn_mp_tc_div_2d.obj bn_mp_tc_or.obj bn_mp_tc_xor.obj \ bn_mp_to_signed_bin.obj bn_mp_to_signed_bin_n.obj bn_mp_to_unsigned_bin.obj bn_mp_to_unsigned_bin_n.obj \ bn_mp_toom_mul.obj bn_mp_toom_sqr.obj bn_mp_toradix.obj bn_mp_toradix_n.obj bn_mp_unsigned_bin_size.obj bn_mp_xor.obj \ bn_mp_zero.obj bn_prime_tab.obj bn_reverse.obj bn_s_mp_add.obj bn_s_mp_exptmod.obj bn_s_mp_mul_digs.obj \ bn_s_mp_mul_high_digs.obj bn_s_mp_sqr.obj bn_s_mp_sub.obj bncore.obj HEADERS_PUB=tommath.h tommath_class.h tommath_superclass.h HEADERS=tommath_private.h $(HEADERS_PUB) #The default rule for make builds the tommath.lib library (static) default: $(LIBMAIN_S) #Dependencies on *.h $(OBJECTS): $(HEADERS) .c.obj: $(CC) $(LTM_CFLAGS) /c $< /Fo$@ #Create tomcrypt.lib $(LIBMAIN_S): $(OBJECTS) lib /out:$(LIBMAIN_S) $(OBJECTS) #Build test_standalone suite test.exe: $(LIBMAIN_S) demo/demo.c cl $(LTM_CFLAGS) $(TOBJECTS) $(LIBMAIN_S) $(LTM_LDFLAGS) demo/demo.c /DLTM_DEMO_TEST_VS_MTEST=0 /Fe$@ @echo NOTICE: start the tests by launching test.exe test_standalone: test.exe all: $(LIBMAIN_S) test_standalone clean: @-cmd /c del /Q /S *.OBJ *.LIB *.EXE *.DLL 2>nul #Install the library + headers install: $(LIBMAIN_S) cmd /c if not exist "$(PREFIX)\bin" mkdir "$(PREFIX)\bin" cmd /c if not exist "$(PREFIX)\lib" mkdir "$(PREFIX)\lib" cmd /c if not exist "$(PREFIX)\include" mkdir "$(PREFIX)\include" copy /Y $(LIBMAIN_S) "$(PREFIX)\lib" copy /Y tommath*.h "$(PREFIX)\include" # ref: $Format:%D$ # git commit: $Format:%H$ # commit time: $Format:%ai$ |
Changes to libtommath/makefile.shared.
1 2 3 4 5 6 7 8 9 10 11 12 | #Makefile for GCC # #Tom St Denis #default files to install ifndef LIBNAME LIBNAME=libtommath.la endif include makefile_include.mk | | | | | | | | | > | | | | | | | | | | | > | | | | | | | | | | | > | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 |
#Makefile for GCC
#
#Tom St Denis
#default files to install
ifndef LIBNAME
LIBNAME=libtommath.la
endif
include makefile_include.mk
ifndef LIBTOOL
ifeq ($(PLATFORM), Darwin)
LIBTOOL:=glibtool
else
LIBTOOL:=libtool
endif
endif
LTCOMPILE = $(LIBTOOL) --mode=compile --tag=CC $(CC)
LCOV_ARGS=--directory .libs --directory .
#START_INS
OBJECTS=bn_error.o bn_fast_mp_invmod.o bn_fast_mp_montgomery_reduce.o bn_fast_s_mp_mul_digs.o \
bn_fast_s_mp_mul_high_digs.o bn_fast_s_mp_sqr.o bn_mp_2expt.o bn_mp_abs.o bn_mp_add.o bn_mp_add_d.o \
bn_mp_addmod.o bn_mp_and.o bn_mp_clamp.o bn_mp_clear.o bn_mp_clear_multi.o bn_mp_cmp.o bn_mp_cmp_d.o \
bn_mp_cmp_mag.o bn_mp_cnt_lsb.o bn_mp_complement.o bn_mp_copy.o bn_mp_count_bits.o bn_mp_div.o \
bn_mp_div_2.o bn_mp_div_2d.o bn_mp_div_3.o bn_mp_div_d.o bn_mp_dr_is_modulus.o bn_mp_dr_reduce.o \
bn_mp_dr_setup.o bn_mp_exch.o bn_mp_export.o bn_mp_expt_d.o bn_mp_expt_d_ex.o bn_mp_exptmod.o \
bn_mp_exptmod_fast.o bn_mp_exteuclid.o bn_mp_fread.o bn_mp_fwrite.o bn_mp_gcd.o bn_mp_get_bit.o \
bn_mp_get_double.o bn_mp_get_int.o bn_mp_get_long.o bn_mp_get_long_long.o bn_mp_grow.o bn_mp_import.o \
bn_mp_init.o bn_mp_init_copy.o bn_mp_init_multi.o bn_mp_init_set.o bn_mp_init_set_int.o bn_mp_init_size.o \
bn_mp_invmod.o bn_mp_invmod_slow.o bn_mp_is_square.o bn_mp_jacobi.o bn_mp_karatsuba_mul.o \
bn_mp_karatsuba_sqr.o bn_mp_kronecker.o bn_mp_lcm.o bn_mp_lshd.o bn_mp_mod.o bn_mp_mod_2d.o bn_mp_mod_d.o \
bn_mp_montgomery_calc_normalization.o bn_mp_montgomery_reduce.o bn_mp_montgomery_setup.o bn_mp_mul.o \
bn_mp_mul_2.o bn_mp_mul_2d.o bn_mp_mul_d.o bn_mp_mulmod.o bn_mp_n_root.o bn_mp_n_root_ex.o bn_mp_neg.o \
bn_mp_or.o bn_mp_prime_fermat.o bn_mp_prime_frobenius_underwood.o bn_mp_prime_is_divisible.o \
bn_mp_prime_is_prime.o bn_mp_prime_miller_rabin.o bn_mp_prime_next_prime.o \
bn_mp_prime_rabin_miller_trials.o bn_mp_prime_random_ex.o bn_mp_prime_strong_lucas_selfridge.o \
bn_mp_radix_size.o bn_mp_radix_smap.o bn_mp_rand.o bn_mp_read_radix.o bn_mp_read_signed_bin.o \
bn_mp_read_unsigned_bin.o bn_mp_reduce.o bn_mp_reduce_2k.o bn_mp_reduce_2k_l.o bn_mp_reduce_2k_setup.o \
bn_mp_reduce_2k_setup_l.o bn_mp_reduce_is_2k.o bn_mp_reduce_is_2k_l.o bn_mp_reduce_setup.o bn_mp_rshd.o \
bn_mp_set.o bn_mp_set_double.o bn_mp_set_int.o bn_mp_set_long.o bn_mp_set_long_long.o bn_mp_shrink.o \
bn_mp_signed_bin_size.o bn_mp_sqr.o bn_mp_sqrmod.o bn_mp_sqrt.o bn_mp_sqrtmod_prime.o bn_mp_sub.o \
bn_mp_sub_d.o bn_mp_submod.o bn_mp_tc_and.o bn_mp_tc_div_2d.o bn_mp_tc_or.o bn_mp_tc_xor.o \
bn_mp_to_signed_bin.o bn_mp_to_signed_bin_n.o bn_mp_to_unsigned_bin.o bn_mp_to_unsigned_bin_n.o \
bn_mp_toom_mul.o bn_mp_toom_sqr.o bn_mp_toradix.o bn_mp_toradix_n.o bn_mp_unsigned_bin_size.o bn_mp_xor.o \
bn_mp_zero.o bn_prime_tab.o bn_reverse.o bn_s_mp_add.o bn_s_mp_exptmod.o bn_s_mp_mul_digs.o \
bn_s_mp_mul_high_digs.o bn_s_mp_sqr.o bn_s_mp_sub.o bncore.o
#END_INS
objs: $(OBJECTS)
.c.o:
$(LTCOMPILE) $(CFLAGS) $(LDFLAGS) -o $@ -c $<
LOBJECTS = $(OBJECTS:.o=.lo)
$(LIBNAME): $(OBJECTS)
$(LIBTOOL) --mode=link --tag=CC $(CC) $(LDFLAGS) $(LOBJECTS) -o $(LIBNAME) -rpath $(LIBPATH) -version-info $(VERSION_SO) $(LIBTOOLFLAGS)
install: $(LIBNAME)
install -d $(DESTDIR)$(LIBPATH)
install -d $(DESTDIR)$(INCPATH)
$(LIBTOOL) --mode=install install -m 644 $(LIBNAME) $(DESTDIR)$(LIBPATH)/$(LIBNAME)
install -m 644 $(HEADERS_PUB) $(DESTDIR)$(INCPATH)
sed -e 's,^prefix=.*,prefix=$(PREFIX),' -e 's,^Version:.*,Version: $(VERSION_PC),' libtommath.pc.in > libtommath.pc
install -d $(DESTDIR)$(LIBPATH)/pkgconfig
install -m 644 libtommath.pc $(DESTDIR)$(LIBPATH)/pkgconfig/
uninstall:
$(LIBTOOL) --mode=uninstall rm $(DESTDIR)$(LIBPATH)/$(LIBNAME)
rm $(HEADERS_PUB:%=$(DESTDIR)$(INCPATH)/%)
rm $(DESTDIR)$(LIBPATH)/pkgconfig/libtommath.pc
test: $(LIBNAME) demo/demo.o
$(CC) $(CFLAGS) -c demo/demo.c -o demo/demo.o
$(LIBTOOL) --mode=link $(CC) $(LDFLAGS) -o test demo/demo.o $(LIBNAME)
test_standalone: $(LIBNAME) demo/demo.o
$(CC) $(CFLAGS) -c demo/demo.c -o demo/demo.o
$(LIBTOOL) --mode=link $(CC) $(LDFLAGS) -o test demo/demo.o $(LIBNAME)
.PHONY: mtest
mtest:
cd mtest ; $(CC) $(CFLAGS) $(LDFLAGS) mtest.c -o mtest
timing: $(LIBNAME) demo/timing.c
$(LIBTOOL) --mode=link $(CC) $(CFLAGS) $(LDFLAGS) -DTIMER demo/timing.c $(LIBNAME) -o timing
|
Added libtommath/makefile.unix.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 | # MAKEFILE that is intended to be compatible with any kind of make (GNU make, BSD make, ...) # works on: Linux, *BSD, Cygwin, AIX, HP-UX and hopefully other UNIX systems # # Please do not use here neither any special make syntax nor any unusual tools/utilities! # using ICC compiler: # make -f makefile.unix CC=icc CFLAGS="-O3 -xP -ip" # using Borland C++Builder: # make -f makefile.unix CC=bcc32 #The following can be overridden from command line e.g. "make -f makefile.unix CC=gcc ARFLAGS=rcs" DESTDIR = PREFIX = /usr/local LIBPATH = $(PREFIX)/lib INCPATH = $(PREFIX)/include CC = cc AR = ar ARFLAGS = r RANLIB = ranlib CFLAGS = -O2 LDFLAGS = VERSION = 1.1.0 #Compilation flags LTM_CFLAGS = -I. $(CFLAGS) LTM_LDFLAGS = $(LDFLAGS) #Library to be created (this makefile builds only static library) LIBMAIN_S = libtommath.a OBJECTS=bn_error.o bn_fast_mp_invmod.o bn_fast_mp_montgomery_reduce.o bn_fast_s_mp_mul_digs.o \ bn_fast_s_mp_mul_high_digs.o bn_fast_s_mp_sqr.o bn_mp_2expt.o bn_mp_abs.o bn_mp_add.o bn_mp_add_d.o \ bn_mp_addmod.o bn_mp_and.o bn_mp_clamp.o bn_mp_clear.o bn_mp_clear_multi.o bn_mp_cmp.o bn_mp_cmp_d.o \ bn_mp_cmp_mag.o bn_mp_cnt_lsb.o bn_mp_complement.o bn_mp_copy.o bn_mp_count_bits.o bn_mp_div.o \ bn_mp_div_2.o bn_mp_div_2d.o bn_mp_div_3.o bn_mp_div_d.o bn_mp_dr_is_modulus.o bn_mp_dr_reduce.o \ bn_mp_dr_setup.o bn_mp_exch.o bn_mp_export.o bn_mp_expt_d.o bn_mp_expt_d_ex.o bn_mp_exptmod.o \ bn_mp_exptmod_fast.o bn_mp_exteuclid.o bn_mp_fread.o bn_mp_fwrite.o bn_mp_gcd.o bn_mp_get_bit.o \ bn_mp_get_double.o bn_mp_get_int.o bn_mp_get_long.o bn_mp_get_long_long.o bn_mp_grow.o bn_mp_import.o \ bn_mp_init.o bn_mp_init_copy.o bn_mp_init_multi.o bn_mp_init_set.o bn_mp_init_set_int.o bn_mp_init_size.o \ bn_mp_invmod.o bn_mp_invmod_slow.o bn_mp_is_square.o bn_mp_jacobi.o bn_mp_karatsuba_mul.o \ bn_mp_karatsuba_sqr.o bn_mp_kronecker.o bn_mp_lcm.o bn_mp_lshd.o bn_mp_mod.o bn_mp_mod_2d.o bn_mp_mod_d.o \ bn_mp_montgomery_calc_normalization.o bn_mp_montgomery_reduce.o bn_mp_montgomery_setup.o bn_mp_mul.o \ bn_mp_mul_2.o bn_mp_mul_2d.o bn_mp_mul_d.o bn_mp_mulmod.o bn_mp_n_root.o bn_mp_n_root_ex.o bn_mp_neg.o \ bn_mp_or.o bn_mp_prime_fermat.o bn_mp_prime_frobenius_underwood.o bn_mp_prime_is_divisible.o \ bn_mp_prime_is_prime.o bn_mp_prime_miller_rabin.o bn_mp_prime_next_prime.o \ bn_mp_prime_rabin_miller_trials.o bn_mp_prime_random_ex.o bn_mp_prime_strong_lucas_selfridge.o \ bn_mp_radix_size.o bn_mp_radix_smap.o bn_mp_rand.o bn_mp_read_radix.o bn_mp_read_signed_bin.o \ bn_mp_read_unsigned_bin.o bn_mp_reduce.o bn_mp_reduce_2k.o bn_mp_reduce_2k_l.o bn_mp_reduce_2k_setup.o \ bn_mp_reduce_2k_setup_l.o bn_mp_reduce_is_2k.o bn_mp_reduce_is_2k_l.o bn_mp_reduce_setup.o bn_mp_rshd.o \ bn_mp_set.o bn_mp_set_double.o bn_mp_set_int.o bn_mp_set_long.o bn_mp_set_long_long.o bn_mp_shrink.o \ bn_mp_signed_bin_size.o bn_mp_sqr.o bn_mp_sqrmod.o bn_mp_sqrt.o bn_mp_sqrtmod_prime.o bn_mp_sub.o \ bn_mp_sub_d.o bn_mp_submod.o bn_mp_tc_and.o bn_mp_tc_div_2d.o bn_mp_tc_or.o bn_mp_tc_xor.o \ bn_mp_to_signed_bin.o bn_mp_to_signed_bin_n.o bn_mp_to_unsigned_bin.o bn_mp_to_unsigned_bin_n.o \ bn_mp_toom_mul.o bn_mp_toom_sqr.o bn_mp_toradix.o bn_mp_toradix_n.o bn_mp_unsigned_bin_size.o bn_mp_xor.o \ bn_mp_zero.o bn_prime_tab.o bn_reverse.o bn_s_mp_add.o bn_s_mp_exptmod.o bn_s_mp_mul_digs.o \ bn_s_mp_mul_high_digs.o bn_s_mp_sqr.o bn_s_mp_sub.o bncore.o HEADERS_PUB=tommath.h tommath_class.h tommath_superclass.h HEADERS=tommath_private.h $(HEADERS_PUB) #The default rule for make builds the libtommath.a library (static) default: $(LIBMAIN_S) #Dependencies on *.h $(OBJECTS): $(HEADERS) #This is necessary for compatibility with BSD make (namely on OpenBSD) .SUFFIXES: .o .c .c.o: $(CC) $(LTM_CFLAGS) -c $< -o $@ #Create libtommath.a $(LIBMAIN_S): $(OBJECTS) $(AR) $(ARFLAGS) $@ $(OBJECTS) $(RANLIB) $@ #Build test_standalone suite test: $(LIBMAIN_S) demo/demo.c $(CC) $(LTM_CFLAGS) $(LTM_LDFLAGS) demo/demo.c $(LIBMAIN_S) -DLTM_DEMO_TEST_VS_MTEST=0 -o $@ @echo "NOTICE: start the tests by: ./test" test_standalone: test all: $(LIBMAIN_S) test_standalone #NOTE: this makefile works also on cygwin, thus we need to delete *.exe clean: -@rm -f $(OBJECTS) $(LIBMAIN_S) -@rm -f demo/demo.o test test.exe #Install the library + headers install: $(LIBMAIN_S) @mkdir -p $(DESTDIR)$(INCPATH) $(DESTDIR)$(LIBPATH)/pkgconfig @cp $(LIBMAIN_S) $(DESTDIR)$(LIBPATH)/ @cp $(HEADERS_PUB) $(DESTDIR)$(INCPATH)/ @sed -e 's,^prefix=.*,prefix=$(PREFIX),' -e 's,^Version:.*,Version: $(VERSION),' libtommath.pc.in > $(DESTDIR)$(LIBPATH)/pkgconfig/libtommath.pc # ref: $Format:%D$ # git commit: $Format:%H$ # commit time: $Format:%ai$ |
Changes to libtommath/makefile_include.mk.
1 2 3 4 5 | # # Include makefile for libtommath # #version of library | | | | > > > > > | > > > > > > | | > > > > > > > | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 |
#
# Include makefile for libtommath
#
#version of library
VERSION=1.1.0
VERSION_PC=1.1.0
VERSION_SO=2:0:1
PLATFORM := $(shell uname | sed -e 's/_.*//')
# default make target
default: ${LIBNAME}
# Compiler and Linker Names
ifndef CROSS_COMPILE
CROSS_COMPILE=
endif
# We only need to go through this dance of determining the right compiler if we're using
# cross compilation, otherwise $(CC) is fine as-is.
ifneq (,$(CROSS_COMPILE))
ifeq ($(origin CC),default)
CSTR := "\#ifdef __clang__\nCLANG\n\#endif\n"
ifeq ($(PLATFORM),FreeBSD)
# XXX: FreeBSD needs extra escaping for some reason
CSTR := $$$(CSTR)
endif
ifneq (,$(shell echo $(CSTR) | $(CC) -E - | grep CLANG))
CC := $(CROSS_COMPILE)clang
else
CC := $(CROSS_COMPILE)gcc
endif # Clang
endif # cc is Make's default
endif # CROSS_COMPILE non-empty
LD=$(CROSS_COMPILE)ld
AR=$(CROSS_COMPILE)ar
RANLIB=$(CROSS_COMPILE)ranlib
ifndef MAKE
# BSDs refer to GNU Make as gmake
ifneq (,$(findstring $(PLATFORM),FreeBSD OpenBSD DragonFly NetBSD))
MAKE=gmake
else
MAKE=make
endif
endif
CFLAGS += -I./ -Wall -Wsign-compare -Wextra -Wshadow
ifndef NO_ADDTL_WARNINGS
# additional warnings
CFLAGS += -Wsystem-headers -Wdeclaration-after-statement -Wbad-function-cast -Wcast-align
|
| ︙ | ︙ | |||
62 63 64 65 66 67 68 69 70 | endif ifneq ($(findstring mingw,$(CC)),) CFLAGS += -Wno-shadow endif ifeq ($(PLATFORM), Darwin) CFLAGS += -Wno-nullability-completeness endif # adjust coverage set | > > > > > > > > > | | | 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 | endif ifneq ($(findstring mingw,$(CC)),) CFLAGS += -Wno-shadow endif ifeq ($(PLATFORM), Darwin) CFLAGS += -Wno-nullability-completeness endif ifeq ($(PLATFORM), CYGWIN) LIBTOOLFLAGS += -no-undefined endif ifeq ($(PLATFORM),FreeBSD) _ARCH := $(shell sysctl -b hw.machine_arch) else _ARCH := $(shell arch) endif # adjust coverage set ifneq ($(filter $(_ARCH), i386 i686 x86_64 amd64 ia64),) COVERAGE = test_standalone timing COVERAGE_APP = ./test && ./timing else COVERAGE = test_standalone COVERAGE_APP = ./test endif HEADERS_PUB=tommath.h tommath_class.h tommath_superclass.h HEADERS=tommath_private.h $(HEADERS_PUB) |
| ︙ | ︙ | |||
109 110 111 112 113 114 115 | rm -f `find . -type f -name "*.info" | xargs` rm -rf coverage/ # cleans everything - coverage output and standard 'clean' cleancov: cleancov-clean clean clean: | | | 137 138 139 140 141 142 143 144 145 146 147 148 |
rm -f `find . -type f -name "*.info" | xargs`
rm -rf coverage/
# cleans everything - coverage output and standard 'clean'
cleancov: cleancov-clean clean
clean:
rm -f *.gcda *.gcno *.gcov *.bat *.o *.a *.obj *.lib *.exe *.dll etclib/*.o demo/demo.o test timing mpitest mtest/mtest mtest/mtest.exe \
*.idx *.toc *.log *.aux *.dvi *.lof *.ind *.ilg *.ps *.log *.s mpi.c *.da *.dyn *.dpi tommath.tex `find . -type f | grep [~] | xargs` *.lo *.la
rm -rf .libs/
${MAKE} -C etc/ clean MAKE=${MAKE}
${MAKE} -C doc/ clean MAKE=${MAKE}
|
Changes to libtommath/tommath.h.
|
| | | < < | < < < < < < < < < < | | | > > | > > > > | | | | | < < < < < < < | | < < < < < < < < < < < < < < < < < < < < < < > < < < < < < < < < < < < < | | | | | > > > | > > > | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 |
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
#ifndef BN_H_
#define BN_H_
#include <stdio.h>
#include <stdlib.h>
#include <limits.h>
#include "tommath_class.h"
#ifdef __cplusplus
extern "C" {
#endif
/* MS Visual C++ doesn't have a 128bit type for words, so fall back to 32bit MPI's (where words are 64bit) */
#if defined(_WIN32) || defined(__LLP64__) || defined(__e2k__) || defined(__LCC__)
# define MP_32BIT
#endif
/* detect 64-bit mode if possible */
#if defined(__x86_64__) || defined(_M_X64) || defined(_M_AMD64) || \
defined(__powerpc64__) || defined(__ppc64__) || defined(__PPC64__) || \
defined(__s390x__) || defined(__arch64__) || defined(__aarch64__) || \
defined(__sparcv9) || defined(__sparc_v9__) || defined(__sparc64__) || \
defined(__ia64) || defined(__ia64__) || defined(__itanium__) || defined(_M_IA64) || \
defined(__LP64__) || defined(_LP64) || defined(__64BIT__)
# if !(defined(MP_32BIT) || defined(MP_16BIT) || defined(MP_8BIT))
# if defined(__GNUC__)
/* we support 128bit integers only via: __attribute__((mode(TI))) */
# define MP_64BIT
# else
/* otherwise we fall back to MP_32BIT even on 64bit platforms */
# define MP_32BIT
# endif
# endif
#endif
typedef unsigned long long Tcl_WideUInt;
/* 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
typedef unsigned char mp_digit;
typedef unsigned short mp_word;
# define MP_SIZEOF_MP_DIGIT 1
# ifdef DIGIT_BIT
# error You must not define DIGIT_BIT when using MP_8BIT
# endif
#elif defined(MP_16BIT)
typedef unsigned short mp_digit;
typedef unsigned int mp_word;
# define MP_SIZEOF_MP_DIGIT 2
# ifdef DIGIT_BIT
# error You must not define DIGIT_BIT when using MP_16BIT
# endif
#elif defined(MP_64BIT)
/* for GCC only on supported platforms */
typedef unsigned long long mp_digit;
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 :-) */
typedef unsigned int mp_digit;
typedef unsigned long long 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 MP_MASK ((((mp_digit)1)<<((mp_digit)DIGIT_BIT))-((mp_digit)1))
/* equalities */
#define MP_LT -1 /* less than */
#define MP_EQ 0 /* equal to */
#define MP_GT 1 /* greater than */
#define MP_ZPOS 0 /* positive integer */
#define MP_NEG 1 /* negative */
#define MP_OKAY 0 /* ok result */
#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 */
#define MP_YES 1 /* yes response */
#define MP_NO 0 /* no response */
/* 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 */
typedef int mp_err;
/* 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 */
# else
# define MP_PREC 8 /* default digits of precision */
# endif
#endif
/* the infamous mp_int structure */
typedef struct {
int used, alloc, sign;
mp_digit *dp;
} mp_int;
/* 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(int code);
/* ---> init and deinit bignum functions <--- */
/* init a bignum */
int mp_init(mp_int *a);
/* free a bignum */
void mp_clear(mp_int *a);
/* init a null terminated series of arguments */
int 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 double */
int mp_set_double(mp_int *a, double 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 double */
double mp_get_double(const mp_int *a);
/* get a 32-bit value */
unsigned long mp_get_int(const mp_int *a);
/* get a platform dependent unsigned long value */
unsigned long mp_get_long(const mp_int *a);
/* get a platform dependent unsigned long long value */
unsigned long long mp_get_long_long(const 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);
|
| ︙ | ︙ | |||
284 285 286 287 288 289 290 | 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(const mp_int *a); /* I Love Earth! */ | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 | 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(const mp_int *a); /* I Love Earth! */ /* makes a pseudo-random mp_int of a given size */ int mp_rand(mp_int *a, int digits); /* makes a pseudo-random small int of a given size */ int mp_rand_digit(mp_digit *r); #ifdef MP_PRNG_ENABLE_LTM_RNG /* A last resort to provide random data on systems without any of the other * implemented ways to gather entropy. * It is compatible with `rng_get_bytes()` from libtomcrypt so you could * provide that one and then set `ltm_rng = rng_get_bytes;` */ extern unsigned long (*ltm_rng)(unsigned char *out, unsigned long outlen, void (*callback)(void)); extern void (*ltm_rng_callback)(void); #endif /* ---> binary operations <--- */ /* c = a XOR b */ int mp_xor(const mp_int *a, const mp_int *b, mp_int *c); /* c = a OR b */ int mp_or(const mp_int *a, const mp_int *b, mp_int *c); /* c = a AND b */ int mp_and(const mp_int *a, const mp_int *b, mp_int *c); /* Checks the bit at position b and returns MP_YES if the bit is 1, MP_NO if it is 0 and MP_VAL in case of error */ int mp_get_bit(const mp_int *a, int b); /* c = a XOR b (two complement) */ int mp_tc_xor(const mp_int *a, const mp_int *b, mp_int *c); /* c = a OR b (two complement) */ int mp_tc_or(const mp_int *a, const mp_int *b, mp_int *c); /* c = a AND b (two complement) */ int mp_tc_and(const mp_int *a, const mp_int *b, mp_int *c); /* right shift (two complement) */ int mp_signed_rsh(const mp_int *a, int b, mp_int *c); /* ---> Basic arithmetic <--- */ /* b = ~a */ int mp_complement(const mp_int *a, mp_int *b); /* b = -a */ int mp_neg(const mp_int *a, mp_int *b); /* b = |a| */ int mp_abs(const mp_int *a, mp_int *b); /* compare a to b */ |
| ︙ | ︙ | |||
400 401 402 403 404 405 406 407 408 409 410 411 412 413 | int mp_sqrtmod_prime(const mp_int *n, const mp_int *prime, mp_int *ret); /* is number a square? */ int mp_is_square(const mp_int *arg, int *ret); /* computes the jacobi c = (a | n) (or Legendre if b is prime) */ int mp_jacobi(const mp_int *a, const mp_int *n, int *c); /* used to setup the Barrett reduction for a given modulus b */ int mp_reduce_setup(mp_int *a, const mp_int *b); /* Barrett Reduction, computes a (mod b) with a precomputed value c * * Assumes that 0 < x <= m*m, note if 0 > x > -(m*m) then you can merely | > > > | 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 |
int mp_sqrtmod_prime(const mp_int *n, const mp_int *prime, mp_int *ret);
/* is number a square? */
int mp_is_square(const mp_int *arg, int *ret);
/* computes the jacobi c = (a | n) (or Legendre if b is prime) */
int mp_jacobi(const mp_int *a, const mp_int *n, int *c);
/* computes the Kronecker symbol c = (a | p) (like jacobi() but with {a,p} in Z */
int mp_kronecker(const mp_int *a, const mp_int *p, int *c);
/* used to setup the Barrett reduction for a given modulus b */
int mp_reduce_setup(mp_int *a, const mp_int *b);
/* Barrett Reduction, computes a (mod b) with a precomputed value c
*
* Assumes that 0 < x <= m*m, note if 0 > x > -(m*m) then you can merely
|
| ︙ | ︙ | |||
482 483 484 485 486 487 488 | int mp_prime_miller_rabin(const mp_int *a, const mp_int *b, int *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); | > > > > > > > > > > | | > > > > > > > | 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 | int mp_prime_miller_rabin(const mp_int *a, const mp_int *b, int *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 one strong Lucas-Selfridge test of "a". * Sets result to 0 if composite or 1 if probable prime */ int mp_prime_strong_lucas_selfridge(const mp_int *a, int *result); /* performs one Frobenius test of "a" as described by Paul Underwood. * Sets result to 0 if composite or 1 if probable prime */ int mp_prime_frobenius_underwood(const mp_int *N, int *result); /* performs t random rounds of Miller-Rabin on "a" additional to * bases 2 and 3. Also performs an initial sieve of trial * division. Determines if "a" is prime with probability * of error no more than (1/4)**t. * Both a strong Lucas-Selfridge to complete the BPSW test * and a separate Frobenius test are available at compile time. * With t<0 a deterministic test is run for primes up to * 318665857834031151167461. With t<13 (abs(t)-13) additional * tests with sequential small primes are run starting at 43. * Is Fips 186.4 compliant if called with t as computed by * mp_prime_rabin_miller_trials(); * * Sets result to 1 if probably prime, 0 otherwise */ int mp_prime_is_prime(const mp_int *a, int t, int *result); /* finds the next prime after the number "a" using "t" trials * of Miller-Rabin. |
| ︙ | ︙ |
Changes to libtommath/tommath_class.h.
1 2 3 4 5 6 7 8 | #if !(defined(LTM1) && defined(LTM2) && defined(LTM3)) #if defined(LTM2) # define LTM3 #endif #if defined(LTM1) # define LTM2 #endif #define LTM1 | > > > > > > > > > > > > < > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 | /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * SPDX-License-Identifier: Unlicense */ #if !(defined(LTM1) && defined(LTM2) && defined(LTM3)) #if defined(LTM2) # define LTM3 #endif #if defined(LTM1) # define LTM2 #endif #define LTM1 #if defined(LTM_ALL) # define BN_ERROR_C # define BN_FAST_MP_INVMOD_C # define BN_FAST_MP_MONTGOMERY_REDUCE_C # define BN_FAST_S_MP_MUL_DIGS_C # define BN_FAST_S_MP_MUL_HIGH_DIGS_C # define BN_FAST_S_MP_SQR_C # define BN_MP_2EXPT_C # define BN_MP_ABS_C # define BN_MP_ADD_C # define BN_MP_ADD_D_C # define BN_MP_ADDMOD_C # define BN_MP_AND_C # define BN_MP_CLAMP_C # define BN_MP_CLEAR_C # define BN_MP_CLEAR_MULTI_C # define BN_MP_CMP_C # define BN_MP_CMP_D_C # define BN_MP_CMP_MAG_C # define BN_MP_CNT_LSB_C # define BN_MP_COMPLEMENT_C # define BN_MP_COPY_C # define BN_MP_COUNT_BITS_C # define BN_MP_DIV_C # define BN_MP_DIV_2_C # define BN_MP_DIV_2D_C # define BN_MP_DIV_3_C # define BN_MP_DIV_D_C # define BN_MP_DR_IS_MODULUS_C # define BN_MP_DR_REDUCE_C # define BN_MP_DR_SETUP_C # define BN_MP_EXCH_C # define BN_MP_EXPORT_C # define BN_MP_EXPT_D_C # define BN_MP_EXPT_D_EX_C # define BN_MP_EXPTMOD_C # define BN_MP_EXPTMOD_FAST_C # define BN_MP_EXTEUCLID_C # define BN_MP_FREAD_C # define BN_MP_FWRITE_C # define BN_MP_GCD_C # define BN_S_MP_GET_BIT_C # define BN_MP_GET_DOUBLE_C # define BN_MP_GET_INT_C # define BN_MP_GET_LONG_C # define BN_MP_GET_LONG_LONG_C # define BN_MP_GROW_C # define BN_MP_IMPORT_C # define BN_MP_INIT_C # define BN_MP_INIT_COPY_C # define BN_MP_INIT_MULTI_C # define BN_MP_INIT_SET_C # define BN_MP_INIT_SET_INT_C # define BN_MP_INIT_SIZE_C # define BN_MP_INVMOD_C # define BN_MP_INVMOD_SLOW_C # define BN_MP_IS_SQUARE_C # define BN_MP_JACOBI_C # define BN_MP_KARATSUBA_MUL_C # define BN_MP_KARATSUBA_SQR_C # define BN_MP_KRONECKER_C # define BN_MP_LCM_C # define BN_MP_LSHD_C # define BN_MP_MOD_C # define BN_MP_MOD_2D_C # define BN_MP_MOD_D_C # define BN_MP_MONTGOMERY_CALC_NORMALIZATION_C # define BN_MP_MONTGOMERY_REDUCE_C # define BN_MP_MONTGOMERY_SETUP_C # define BN_MP_MUL_C # define BN_MP_MUL_2_C # define BN_MP_MUL_2D_C # define BN_MP_MUL_D_C # define BN_MP_MULMOD_C # define BN_MP_N_ROOT_C # define BN_MP_N_ROOT_EX_C # define BN_MP_NEG_C # define BN_MP_OR_C # define BN_MP_PRIME_FERMAT_C # define BN_MP_PRIME_FROBENIUS_UNDERWOOD_C # define BN_MP_PRIME_IS_DIVISIBLE_C # define BN_MP_PRIME_IS_PRIME_C # define BN_MP_PRIME_MILLER_RABIN_C # define BN_MP_PRIME_NEXT_PRIME_C # define BN_MP_PRIME_RABIN_MILLER_TRIALS_C # define BN_MP_PRIME_RANDOM_EX_C # define BN_MP_PRIME_STRONG_LUCAS_SELFRIDGE_C # define BN_MP_RADIX_SIZE_C # define BN_MP_RADIX_SMAP_C # define BN_MP_RAND_C # define BN_MP_READ_RADIX_C # define BN_MP_READ_SIGNED_BIN_C # define BN_MP_READ_UNSIGNED_BIN_C # define BN_MP_REDUCE_C # define BN_MP_REDUCE_2K_C # define BN_MP_REDUCE_2K_L_C # define BN_MP_REDUCE_2K_SETUP_C # define BN_MP_REDUCE_2K_SETUP_L_C # define BN_MP_REDUCE_IS_2K_C # define BN_MP_REDUCE_IS_2K_L_C # define BN_MP_REDUCE_SETUP_C # define BN_MP_RSHD_C # define BN_MP_SET_C # define BN_MP_SET_DOUBLE_C # define BN_MP_SET_INT_C # define BN_MP_SET_LONG_C # define BN_MP_SET_LONG_LONG_C # define BN_MP_SHRINK_C # define BN_MP_SIGNED_BIN_SIZE_C # define BN_MP_SQR_C # define BN_MP_SQRMOD_C # define BN_MP_SQRT_C # define BN_MP_SQRTMOD_PRIME_C # define BN_MP_SUB_C # define BN_MP_SUB_D_C # define BN_MP_SUBMOD_C # define BN_MP_TC_AND_C # define BN_MP_SIGNED_RSH_C # define BN_MP_TC_OR_C # define BN_MP_TC_XOR_C # define BN_MP_TO_SIGNED_BIN_C # define BN_MP_TO_SIGNED_BIN_N_C # define BN_MP_TO_UNSIGNED_BIN_C # define BN_MP_TO_UNSIGNED_BIN_N_C # define BN_MP_TOOM_MUL_C # define BN_MP_TOOM_SQR_C # define BN_MP_TORADIX_C |
| ︙ | ︙ | |||
133 134 135 136 137 138 139 | # define BN_S_MP_EXPTMOD_C # define BN_S_MP_MUL_DIGS_C # define BN_S_MP_MUL_HIGH_DIGS_C # define BN_S_MP_SQR_C # define BN_S_MP_SUB_C # define BNCORE_C #endif | < > | | | | 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 | # define BN_S_MP_EXPTMOD_C # define BN_S_MP_MUL_DIGS_C # define BN_S_MP_MUL_HIGH_DIGS_C # define BN_S_MP_SQR_C # define BN_S_MP_SUB_C # define BNCORE_C #endif #if defined(BN_ERROR_C) # define BN_MP_ERROR_TO_STRING_C #endif #if defined(BN_FAST_MP_INVMOD_C) # define BN_MP_ISEVEN_C # define BN_MP_INIT_MULTI_C # define BN_MP_COPY_C # define BN_MP_MOD_C # define BN_MP_ISZERO_C # define BN_MP_SET_C # define BN_MP_DIV_2_C # define BN_MP_ISODD_C # define BN_MP_SUB_C # define BN_MP_CMP_C # define BN_MP_CMP_D_C # define BN_MP_ADD_C # define BN_MP_CMP_MAG_C # define BN_MP_EXCH_C # define BN_MP_CLEAR_MULTI_C #endif #if defined(BN_FAST_MP_MONTGOMERY_REDUCE_C) # define BN_MP_GROW_C # define BN_MP_RSHD_C |
| ︙ | ︙ | |||
236 237 238 239 240 241 242 243 244 245 246 247 248 249 | #if defined(BN_MP_CMP_MAG_C) #endif #if defined(BN_MP_CNT_LSB_C) # define BN_MP_ISZERO_C #endif #if defined(BN_MP_COPY_C) # define BN_MP_GROW_C #endif #if defined(BN_MP_COUNT_BITS_C) #endif | > > > > > | 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 | #if defined(BN_MP_CMP_MAG_C) #endif #if defined(BN_MP_CNT_LSB_C) # define BN_MP_ISZERO_C #endif #if defined(BN_MP_COMPLEMENT_C) # define BN_MP_NEG_C # define BN_MP_SUB_D_C #endif #if defined(BN_MP_COPY_C) # define BN_MP_GROW_C #endif #if defined(BN_MP_COUNT_BITS_C) #endif |
| ︙ | ︙ | |||
386 387 388 389 390 391 392 | # define BN_MP_NEG_C # define BN_MP_EXCH_C # define BN_MP_CLEAR_MULTI_C #endif #if defined(BN_MP_FREAD_C) # define BN_MP_ZERO_C | | > | 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 | # define BN_MP_NEG_C # define BN_MP_EXCH_C # define BN_MP_CLEAR_MULTI_C #endif #if defined(BN_MP_FREAD_C) # define BN_MP_ZERO_C # define BN_MP_S_RMAP_REVERSE_SZ_C # define BN_MP_S_RMAP_REVERSE_C # define BN_MP_MUL_D_C # define BN_MP_ADD_D_C # define BN_MP_CMP_D_C #endif #if defined(BN_MP_FWRITE_C) # define BN_MP_RADIX_SIZE_C |
| ︙ | ︙ | |||
409 410 411 412 413 414 415 416 417 418 419 420 421 422 | # define BN_MP_DIV_2D_C # define BN_MP_CMP_MAG_C # define BN_MP_EXCH_C # define BN_S_MP_SUB_C # define BN_MP_MUL_2D_C # define BN_MP_CLEAR_C #endif #if defined(BN_MP_GET_INT_C) #endif #if defined(BN_MP_GET_LONG_C) #endif | > > > > > > > > | 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 | # define BN_MP_DIV_2D_C # define BN_MP_CMP_MAG_C # define BN_MP_EXCH_C # define BN_S_MP_SUB_C # define BN_MP_MUL_2D_C # define BN_MP_CLEAR_C #endif #if defined(BN_S_MP_GET_BIT_C) # define BN_MP_ISZERO_C #endif #if defined(BN_MP_GET_DOUBLE_C) # define BN_MP_ISNEG_C #endif #if defined(BN_MP_GET_INT_C) #endif #if defined(BN_MP_GET_LONG_C) #endif |
| ︙ | ︙ | |||
458 459 460 461 462 463 464 | #endif #if defined(BN_MP_INIT_SIZE_C) # define BN_MP_INIT_C #endif #if defined(BN_MP_INVMOD_C) | | < | 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 | #endif #if defined(BN_MP_INIT_SIZE_C) # define BN_MP_INIT_C #endif #if defined(BN_MP_INVMOD_C) # define BN_MP_CMP_D_C # define BN_MP_ISODD_C # define BN_FAST_MP_INVMOD_C # define BN_MP_INVMOD_SLOW_C #endif #if defined(BN_MP_INVMOD_SLOW_C) # define BN_MP_ISZERO_C # define BN_MP_INIT_MULTI_C |
| ︙ | ︙ | |||
495 496 497 498 499 500 501 | # define BN_MP_SQRT_C # define BN_MP_SQR_C # define BN_MP_CMP_MAG_C # define BN_MP_CLEAR_C #endif #if defined(BN_MP_JACOBI_C) | | | | < < < < < | 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 | # define BN_MP_SQRT_C # define BN_MP_SQR_C # define BN_MP_CMP_MAG_C # define BN_MP_CLEAR_C #endif #if defined(BN_MP_JACOBI_C) # define BN_MP_KRONECKER_C # define BN_MP_ISNEG_C # define BN_MP_CMP_D_C #endif #if defined(BN_MP_KARATSUBA_MUL_C) # define BN_MP_MUL_C # define BN_MP_INIT_SIZE_C # define BN_MP_CLAMP_C # define BN_S_MP_ADD_C |
| ︙ | ︙ | |||
526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 | # define BN_MP_SQR_C # define BN_S_MP_ADD_C # define BN_S_MP_SUB_C # define BN_MP_LSHD_C # define BN_MP_ADD_C # define BN_MP_CLEAR_C #endif #if defined(BN_MP_LCM_C) # define BN_MP_INIT_MULTI_C # define BN_MP_GCD_C # define BN_MP_CMP_MAG_C # define BN_MP_DIV_C # define BN_MP_MUL_C # define BN_MP_CLEAR_MULTI_C #endif #if defined(BN_MP_LSHD_C) # define BN_MP_GROW_C # define BN_MP_RSHD_C #endif #if defined(BN_MP_MOD_C) # define BN_MP_INIT_SIZE_C # define BN_MP_DIV_C | > > > > > > > > > > > > > | 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 | # define BN_MP_SQR_C # define BN_S_MP_ADD_C # define BN_S_MP_SUB_C # define BN_MP_LSHD_C # define BN_MP_ADD_C # define BN_MP_CLEAR_C #endif #if defined(BN_MP_KRONECKER_C) # define BN_MP_ISZERO_C # define BN_MP_ISEVEN_C # define BN_MP_INIT_COPY_C # define BN_MP_CNT_LSB_C # define BN_MP_DIV_2D_C # define BN_MP_CMP_D_C # define BN_MP_COPY_C # define BN_MP_MOD_C # define BN_MP_CLEAR_C #endif #if defined(BN_MP_LCM_C) # define BN_MP_INIT_MULTI_C # define BN_MP_GCD_C # define BN_MP_CMP_MAG_C # define BN_MP_DIV_C # define BN_MP_MUL_C # define BN_MP_CLEAR_MULTI_C #endif #if defined(BN_MP_LSHD_C) # define BN_MP_ISZERO_C # define BN_MP_GROW_C # define BN_MP_RSHD_C #endif #if defined(BN_MP_MOD_C) # define BN_MP_INIT_SIZE_C # define BN_MP_DIV_C |
| ︙ | ︙ | |||
650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 | #if defined(BN_MP_PRIME_FERMAT_C) # define BN_MP_CMP_D_C # define BN_MP_INIT_C # define BN_MP_EXPTMOD_C # define BN_MP_CMP_C # define BN_MP_CLEAR_C #endif #if defined(BN_MP_PRIME_IS_DIVISIBLE_C) # define BN_MP_MOD_D_C #endif #if defined(BN_MP_PRIME_IS_PRIME_C) # define BN_MP_CMP_D_C # define BN_MP_PRIME_IS_DIVISIBLE_C | > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > | > | 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 | #if defined(BN_MP_PRIME_FERMAT_C) # define BN_MP_CMP_D_C # define BN_MP_INIT_C # define BN_MP_EXPTMOD_C # define BN_MP_CMP_C # define BN_MP_CLEAR_C #endif #if defined(BN_MP_PRIME_FROBENIUS_UNDERWOOD_C) # define BN_MP_PRIME_IS_PRIME_C # define BN_MP_INIT_MULTI_C # define BN_MP_SET_LONG_C # define BN_MP_SQR_C # define BN_MP_SUB_D_C # define BN_MP_KRONECKER_C # define BN_MP_GCD_C # define BN_MP_ADD_D_C # define BN_MP_SET_C # define BN_MP_COUNT_BITS_C # define BN_MP_MUL_2_C # define BN_MP_MUL_D_C # define BN_MP_ADD_C # define BN_MP_MUL_C # define BN_MP_SUB_C # define BN_MP_MOD_C # define BN_S_MP_GET_BIT_C # define BN_MP_EXCH_C # define BN_MP_ISZERO_C # define BN_MP_CMP_C # define BN_MP_CLEAR_MULTI_C #endif #if defined(BN_MP_PRIME_IS_DIVISIBLE_C) # define BN_MP_MOD_D_C #endif #if defined(BN_MP_PRIME_IS_PRIME_C) # define BN_MP_ISEVEN_C # define BN_MP_IS_SQUARE_C # define BN_MP_CMP_D_C # define BN_MP_PRIME_IS_DIVISIBLE_C # define BN_MP_INIT_SET_C # define BN_MP_PRIME_MILLER_RABIN_C # define BN_MP_PRIME_FROBENIUS_UNDERWOOD_C # define BN_MP_PRIME_STRONG_LUCAS_SELFRIDGE_C # define BN_MP_READ_RADIX_C # define BN_MP_CMP_C # define BN_MP_SET_C # define BN_MP_COUNT_BITS_C # define BN_MP_RAND_C # define BN_MP_DIV_2D_C # define BN_MP_CLEAR_C #endif #if defined(BN_MP_PRIME_MILLER_RABIN_C) # define BN_MP_CMP_D_C # define BN_MP_INIT_COPY_C # define BN_MP_SUB_D_C |
| ︙ | ︙ | |||
684 685 686 687 688 689 690 | # define BN_MP_CMP_D_C # define BN_MP_SET_C # define BN_MP_SUB_D_C # define BN_MP_ISEVEN_C # define BN_MP_MOD_D_C # define BN_MP_INIT_C # define BN_MP_ADD_D_C | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > | 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 | # define BN_MP_CMP_D_C # define BN_MP_SET_C # define BN_MP_SUB_D_C # define BN_MP_ISEVEN_C # define BN_MP_MOD_D_C # define BN_MP_INIT_C # define BN_MP_ADD_D_C # define BN_MP_PRIME_IS_PRIME_C # define BN_MP_CLEAR_C #endif #if defined(BN_MP_PRIME_RABIN_MILLER_TRIALS_C) #endif #if defined(BN_MP_PRIME_RANDOM_EX_C) # define BN_MP_READ_UNSIGNED_BIN_C # define BN_MP_PRIME_IS_PRIME_C # define BN_MP_SUB_D_C # define BN_MP_DIV_2_C # define BN_MP_MUL_2_C # define BN_MP_ADD_D_C #endif #if defined(BN_MP_PRIME_STRONG_LUCAS_SELFRIDGE_C) # define BN_MP_PRIME_IS_PRIME_C # define BN_MP_MUL_D_C # define BN_S_MP_MUL_SI_C # define BN_MP_INIT_C # define BN_MP_SET_LONG_C # define BN_MP_MUL_C # define BN_MP_CLEAR_C # define BN_MP_INIT_MULTI_C # define BN_MP_GCD_C # define BN_MP_CMP_D_C # define BN_MP_CMP_C # define BN_MP_KRONECKER_C # define BN_MP_ADD_D_C # define BN_MP_CNT_LSB_C # define BN_MP_DIV_2D_C # define BN_MP_SET_C # define BN_MP_MUL_2_C # define BN_MP_COUNT_BITS_C # define BN_MP_MOD_C # define BN_MP_SQR_C # define BN_MP_SUB_C # define BN_S_MP_GET_BIT_C # define BN_MP_ADD_C # define BN_MP_ISODD_C # define BN_MP_DIV_2_C # define BN_MP_SUB_D_C # define BN_MP_ISZERO_C # define BN_MP_CLEAR_MULTI_C #endif #if defined(BN_MP_RADIX_SIZE_C) # define BN_MP_ISZERO_C # define BN_MP_COUNT_BITS_C # define BN_MP_INIT_COPY_C # define BN_MP_DIV_D_C # define BN_MP_CLEAR_C #endif #if defined(BN_MP_RADIX_SMAP_C) # define BN_MP_S_RMAP_C # define BN_MP_S_RMAP_REVERSE_C # define BN_MP_S_RMAP_REVERSE_SZ_C #endif #if defined(BN_MP_RAND_C) # define BN_MP_RAND_DIGIT_C # define BN_MP_ZERO_C # define BN_MP_ADD_D_C # define BN_MP_LSHD_C #endif #if defined(BN_MP_READ_RADIX_C) # define BN_MP_ZERO_C # define BN_MP_S_RMAP_REVERSE_SZ_C # define BN_MP_S_RMAP_REVERSE_C # define BN_MP_MUL_D_C # define BN_MP_ADD_D_C # define BN_MP_ISZERO_C #endif #if defined(BN_MP_READ_SIGNED_BIN_C) # define BN_MP_READ_UNSIGNED_BIN_C |
| ︙ | ︙ | |||
814 815 816 817 818 819 820 821 822 823 824 825 826 827 | #if defined(BN_MP_RSHD_C) # define BN_MP_ZERO_C #endif #if defined(BN_MP_SET_C) # define BN_MP_ZERO_C #endif #if defined(BN_MP_SET_INT_C) # define BN_MP_ZERO_C # define BN_MP_MUL_2D_C # define BN_MP_CLAMP_C #endif | > > > > > > > | 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 | #if defined(BN_MP_RSHD_C) # define BN_MP_ZERO_C #endif #if defined(BN_MP_SET_C) # define BN_MP_ZERO_C #endif #if defined(BN_MP_SET_DOUBLE_C) # define BN_MP_SET_LONG_LONG_C # define BN_MP_DIV_2D_C # define BN_MP_MUL_2D_C # define BN_MP_ISZERO_C #endif #if defined(BN_MP_SET_INT_C) # define BN_MP_ZERO_C # define BN_MP_MUL_2D_C # define BN_MP_CLAMP_C #endif |
| ︙ | ︙ | |||
899 900 901 902 903 904 905 906 907 908 909 910 911 912 | #if defined(BN_MP_SUBMOD_C) # define BN_MP_INIT_C # define BN_MP_SUB_C # define BN_MP_CLEAR_C # define BN_MP_MOD_C #endif #if defined(BN_MP_TO_SIGNED_BIN_C) # define BN_MP_TO_UNSIGNED_BIN_C #endif #if defined(BN_MP_TO_SIGNED_BIN_N_C) # define BN_MP_SIGNED_BIN_SIZE_C | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 | #if defined(BN_MP_SUBMOD_C) # define BN_MP_INIT_C # define BN_MP_SUB_C # define BN_MP_CLEAR_C # define BN_MP_MOD_C #endif #if defined(BN_MP_TC_AND_C) # define BN_MP_ISNEG_C # define BN_MP_COUNT_BITS_C # define BN_MP_INIT_SET_INT_C # define BN_MP_MUL_2D_C # define BN_MP_INIT_C # define BN_MP_ADD_C # define BN_MP_CLEAR_C # define BN_MP_AND_C # define BN_MP_SUB_C #endif #if defined(BN_MP_SIGNED_RSH_C) # define BN_MP_ISNEG_C # define BN_MP_DIV_2D_C # define BN_MP_ADD_D_C # define BN_MP_SUB_D_C #endif #if defined(BN_MP_TC_OR_C) # define BN_MP_ISNEG_C # define BN_MP_COUNT_BITS_C # define BN_MP_INIT_SET_INT_C # define BN_MP_MUL_2D_C # define BN_MP_INIT_C # define BN_MP_ADD_C # define BN_MP_CLEAR_C # define BN_MP_OR_C # define BN_MP_SUB_C #endif #if defined(BN_MP_TC_XOR_C) # define BN_MP_ISNEG_C # define BN_MP_COUNT_BITS_C # define BN_MP_INIT_SET_INT_C # define BN_MP_MUL_2D_C # define BN_MP_INIT_C # define BN_MP_ADD_C # define BN_MP_CLEAR_C # define BN_MP_XOR_C # define BN_MP_SUB_C #endif #if defined(BN_MP_TO_SIGNED_BIN_C) # define BN_MP_TO_UNSIGNED_BIN_C #endif #if defined(BN_MP_TO_SIGNED_BIN_N_C) # define BN_MP_SIGNED_BIN_SIZE_C |
| ︙ | ︙ | |||
1052 1053 1054 1055 1056 1057 1058 | #endif #include <tommath_superclass.h> #include <tommath_class.h> #else # define LTM_LAST #endif | > > > > | 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 | #endif #include <tommath_superclass.h> #include <tommath_class.h> #else # define LTM_LAST #endif /* ref: $Format:%D$ */ /* git commit: $Format:%H$ */ /* commit time: $Format:%ai$ */ |
Changes to libtommath/tommath_private.h.
1 2 3 4 5 6 7 8 9 | /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * | | < < < < < < < < < < < < < | | | < | | < | > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 |
/* LibTomMath, multiple-precision integer library -- Tom St Denis
*
* LibTomMath is a library that provides multiple-precision
* integer arithmetic as well as number theoretic functionality.
*
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
#ifndef TOMMATH_PRIV_H_
#define TOMMATH_PRIV_H_
#include <tommath.h>
#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" {
#endif
/* define heap macros */
#ifndef XMALLOC
/* default to libc stuff */
# define XMALLOC(size) malloc(size)
# define XFREE(mem, size) free(mem)
# define XREALLOC(mem, oldsize, newsize) realloc(mem, newsize)
#elif 0
/* prototypes for our heap functions */
extern void *XMALLOC(size_t size);
extern void *XREALLOC(void *mem, size_t oldsize, size_t newsize);
extern void XFREE(void *mem, size_t size);
#endif
/* you'll have to tune these... */
#define KARATSUBA_MUL_CUTOFF 80 /* Min. number of digits before Karatsuba multiplication is used. */
#define KARATSUBA_SQR_CUTOFF 120 /* Min. number of digits before Karatsuba squaring is used. */
#define TOOM_MUL_CUTOFF 350 /* no optimal values of these are known yet so set em high */
#define TOOM_SQR_CUTOFF 400
/* size of comba arrays, should be at least 2 * 2**(BITS_PER_WORD - BITS_PER_DIGIT*2) */
#define MP_WARRAY (1u << (((sizeof(mp_word) * CHAR_BIT) - (2 * DIGIT_BIT)) + 1))
/* ---> Basic Manipulations <--- */
#define IS_ZERO(a) ((a)->used == 0)
#define IS_EVEN(a) (((a)->used == 0) || (((a)->dp[0] & 1u) == 0u))
#define IS_ODD(a) (((a)->used > 0) && (((a)->dp[0] & 1u) == 1u))
/* lowlevel functions, do not call! */
int s_mp_add(const mp_int *a, const mp_int *b, mp_int *c);
int s_mp_sub(const mp_int *a, const 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(const mp_int *a, const mp_int *b, mp_int *c, int digs);
int s_mp_mul_digs(const mp_int *a, const mp_int *b, mp_int *c, int digs);
int fast_s_mp_mul_high_digs(const mp_int *a, const mp_int *b, mp_int *c, int digs);
|
| ︙ | ︙ | |||
71 72 73 74 75 76 77 | int fast_mp_invmod(const mp_int *a, const mp_int *b, mp_int *c); int mp_invmod_slow(const mp_int *a, const mp_int *b, mp_int *c); int fast_mp_montgomery_reduce(mp_int *x, const mp_int *n, mp_digit rho); int mp_exptmod_fast(const mp_int *G, const mp_int *X, const mp_int *P, mp_int *Y, int redmode); int s_mp_exptmod(const mp_int *G, const mp_int *X, const mp_int *P, mp_int *Y, int redmode); void bn_reverse(unsigned char *s, int len); | | | | | < | < < < < | | | < < | < < > > | < < | | | < | 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 |
int fast_mp_invmod(const mp_int *a, const mp_int *b, mp_int *c);
int mp_invmod_slow(const mp_int *a, const mp_int *b, mp_int *c);
int fast_mp_montgomery_reduce(mp_int *x, const mp_int *n, mp_digit rho);
int mp_exptmod_fast(const mp_int *G, const mp_int *X, const mp_int *P, mp_int *Y, int redmode);
int s_mp_exptmod(const mp_int *G, const mp_int *X, const mp_int *P, mp_int *Y, int redmode);
void bn_reverse(unsigned char *s, int len);
extern const char *const mp_s_rmap;
extern const unsigned char mp_s_rmap_reverse[];
extern const size_t mp_s_rmap_reverse_sz;
/* Fancy macro to set an MPI from another type.
* There are several things assumed:
* x is the counter
* a is the pointer to the MPI
* b is the original value that should be set in the MPI.
*/
#define MP_SET_XLONG(func_name, type) \
int func_name (mp_int * a, type b) \
{ \
int x = 0; \
int new_size = (((CHAR_BIT * sizeof(type)) + DIGIT_BIT) - 1) / DIGIT_BIT; \
int res = mp_grow(a, new_size); \
if (res == MP_OKAY) { \
mp_zero(a); \
while (b != 0u) { \
a->dp[x++] = ((mp_digit)b & MP_MASK); \
if ((CHAR_BIT * sizeof (b)) <= DIGIT_BIT) { break; } \
b >>= ((CHAR_BIT * sizeof (b)) <= DIGIT_BIT ? 0 : DIGIT_BIT); \
} \
a->used = x; \
} \
return res; \
}
#ifdef __cplusplus
}
#endif
#endif
/* ref: $Format:%D$ */
/* git commit: $Format:%H$ */
/* commit time: $Format:%ai$ */
|
Changes to libtommath/tommath_superclass.h.
1 2 3 4 5 6 7 | /* super class file for PK algos */ /* default ... include all MPI */ #define LTM_ALL /* RSA only (does not support DH/DSA/ECC) */ /* #define SC_RSA_1 */ | > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * SPDX-License-Identifier: Unlicense */ /* super class file for PK algos */ /* default ... include all MPI */ #define LTM_ALL /* RSA only (does not support DH/DSA/ECC) */ /* #define SC_RSA_1 */ |
| ︙ | ︙ |
Changes to macosx/GNUmakefile.
| ︙ | ︙ | |||
128 129 130 131 132 133 134 |
${MAKE} install-${PROJECT} INSTALL_ROOT="${OBJ_DIR}/"
${objdir}/Makefile: ${UNIX_DIR}/Makefile.in ${UNIX_DIR}/configure \
${UNIX_DIR}/tclConfig.sh.in Tcl-Info.plist.in
mkdir -p "${OBJ_DIR}" && cd "${OBJ_DIR}" && \
if [ ${UNIX_DIR}/configure -nt config.status ]; then ${UNIX_DIR}/configure -C \
--prefix="${PREFIX}" --bindir="${BINDIR}" --libdir="${LIBDIR}" \
| | | | | | < < < < < < < < < < < > | | > | 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 |
${MAKE} install-${PROJECT} INSTALL_ROOT="${OBJ_DIR}/"
${objdir}/Makefile: ${UNIX_DIR}/Makefile.in ${UNIX_DIR}/configure \
${UNIX_DIR}/tclConfig.sh.in Tcl-Info.plist.in
mkdir -p "${OBJ_DIR}" && cd "${OBJ_DIR}" && \
if [ ${UNIX_DIR}/configure -nt config.status ]; then ${UNIX_DIR}/configure -C \
--prefix="${PREFIX}" --bindir="${BINDIR}" --libdir="${LIBDIR}" \
--mandir="${MANDIR}" --enable-framework --enable-dtrace \
${CONFIGURE_ARGS} ${EXTRA_CONFIGURE_ARGS}; else ./config.status; fi
build-${PROJECT}: ${objdir}/Makefile
${DO_MAKE}
ifeq (${INSTALL_BUILD},)
# symolic link hackery to trick
# 'make install INSTALL_ROOT=${OBJ_DIR}'
# into building Tcl.framework and tclsh in ${SYMROOT}
@cd "${OBJ_DIR}" && mkdir -p $(dir $(subst ${space},\ ,.${LIBDIR})) $(dir $(subst ${space},\ ,.${BINDIR})) "${SYMROOT}" && \
rm -f ".${LIBDIR}" ".${BINDIR}" && ln -fs "${SYMROOT}" ".${LIBDIR}" && \
ln -fs "${SYMROOT}" ".${BINDIR}" && ln -fs "${OBJ_DIR}/tcltest" "${SYMROOT}"
endif
install-${PROJECT}: build-${PROJECT}
ifeq (${EMBEDDED_BUILD}_${INSTALL_ROOT},1_)
@echo "Cannot install-embedded with empty INSTALL_ROOT !" && false
endif
ifeq (${EMBEDDED_BUILD},1)
@rm -rf "${INSTALL_ROOT}${LIBDIR}/Tcl.framework"
endif
${DO_MAKE}
ifeq (${INSTALL_BUILD},1)
ifeq (${EMBEDDED_BUILD},1)
# if we are embedding frameworks, don't install tclsh
@rm -f "${INSTALL_ROOT}${BINDIR}/${TCLSH}" && \
rmdir -p "${INSTALL_ROOT}${BINDIR}" 2>&- || true
else
# install tclsh symbolic link
@ln -fs ${TCLSH} "${INSTALL_ROOT}${BINDIR}/tclsh"
endif
endif
ifeq (${BUILD_STYLE}_${EMBEDDED_BUILD},Development_)
# keep copy of debug library around, so that
# Deployment build can be installed on top
# of Development build without overwriting
# the debug library
@if [ -d "${INSTALL_ROOT}${LIBDIR}/${PRODUCT_NAME}.framework/Versions/${VERSION}" ]; then \
cd "${INSTALL_ROOT}${LIBDIR}/${PRODUCT_NAME}.framework/Versions/${VERSION}"; \
ln -f "${PRODUCT_NAME}" "${PRODUCT_NAME}_debug"; \
fi
endif
clean-${PROJECT}: %-${PROJECT}:
${DO_MAKE}
rm -rf "${SYMROOT}"/{${PRODUCT_NAME}.framework,${TCLSH},tcltest}
rm -f "${OBJ_DIR}"{"${LIBDIR}","${BINDIR}"} && \
rmdir -p "${OBJ_DIR}"$(dir $(subst ${space},\ ,${LIBDIR})) 2>&- || true && \
|
| ︙ | ︙ |
Changes to macosx/README.
| ︙ | ︙ | |||
124 125 126 127 128 129 130 | Tiger you need to add "-isysroot /Developer/SDKs/MacOSX10.4u.sdk"). Note that configure requires CFLAGS to contain a least one architecture that can be run on the build machine (i.e. ppc on G3/G4, ppc or ppc64 on G5, ppc or i386 on Core and ppc, i386 or x86_64 on Core2/Xeon). Universal builds of Tcl TEA extensions are also possible with CFLAGS set as above, they will be [load]able by universal as well as thin binaries of Tcl. | < < < < < < < | 124 125 126 127 128 129 130 131 132 133 134 135 136 137 |
Tiger you need to add "-isysroot /Developer/SDKs/MacOSX10.4u.sdk").
Note that configure requires CFLAGS to contain a least one architecture that can
be run on the build machine (i.e. ppc on G3/G4, ppc or ppc64 on G5, ppc or i386
on Core and ppc, i386 or x86_64 on Core2/Xeon).
Universal builds of Tcl TEA extensions are also possible with CFLAGS set as
above, they will be [load]able by universal as well as thin binaries of Tcl.
Detailed Instructions for building with macosx/GNUmakefile
----------------------------------------------------------
- Unpack the Tcl source release archive.
- The following instructions assume the Tcl source tree is named "tcl${ver}",
(where ${ver} is a shell variable containing the Tcl version number e.g. '9.0').
|
| ︙ | ︙ |
Changes to macosx/Tcl-Common.xcconfig.
| ︙ | ︙ | |||
26 27 28 29 30 31 32 | FRAMEWORK_INSTALL_PATH = /Library/Frameworks INCLUDEDIR = $(PREFIX)/include LIBDIR = $(PREFIX)/lib MANDIR = $(PREFIX)/man PER_ARCH_CFLAGS_ppc = -mcpu=G3 -mtune=G4 $(PER_ARCH_CFLAGS_ppc) PER_ARCH_CFLAGS_ppc64 = -mcpu=G5 -mpowerpc64 $(PER_ARCH_CFLAGS_ppc64) PREFIX = /usr/local | | | 26 27 28 29 30 31 32 33 34 35 36 37 | FRAMEWORK_INSTALL_PATH = /Library/Frameworks INCLUDEDIR = $(PREFIX)/include LIBDIR = $(PREFIX)/lib MANDIR = $(PREFIX)/man PER_ARCH_CFLAGS_ppc = -mcpu=G3 -mtune=G4 $(PER_ARCH_CFLAGS_ppc) PER_ARCH_CFLAGS_ppc64 = -mcpu=G5 -mpowerpc64 $(PER_ARCH_CFLAGS_ppc64) PREFIX = /usr/local TCL_CONFIGURE_ARGS = --enable-dtrace TCL_LIBRARY = $(LIBDIR)/tcl$(VERSION) TCL_PACKAGE_PATH = "$(LIBDIR)" TCL_DEFS = HAVE_TCL_CONFIG_H VERSION = 9.0 |
Changes to macosx/Tcl.xcode/project.pbxproj.
| ︙ | ︙ | |||
140 141 142 143 144 145 146 |
F96D494908F272C3004A47F5 /* bn_mp_toradix_n.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42CB08F272B3004A47F5 /* bn_mp_toradix_n.c */; };
F96D494C08F272C3004A47F5 /* bn_mp_zero.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42CE08F272B3004A47F5 /* bn_mp_zero.c */; };
F96D494E08F272C3004A47F5 /* bn_reverse.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42D008F272B3004A47F5 /* bn_reverse.c */; };
F96D494F08F272C3004A47F5 /* bn_s_mp_add.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42D108F272B3004A47F5 /* bn_s_mp_add.c */; };
F96D495108F272C3004A47F5 /* bn_s_mp_mul_digs.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42D308F272B3004A47F5 /* bn_s_mp_mul_digs.c */; };
F96D495308F272C3004A47F5 /* bn_s_mp_sqr.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42D508F272B3004A47F5 /* bn_s_mp_sqr.c */; };
F96D495408F272C3004A47F5 /* bn_s_mp_sub.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42D608F272B3004A47F5 /* bn_s_mp_sub.c */; };
| < | 140 141 142 143 144 145 146 147 148 149 150 151 152 153 |
F96D494908F272C3004A47F5 /* bn_mp_toradix_n.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42CB08F272B3004A47F5 /* bn_mp_toradix_n.c */; };
F96D494C08F272C3004A47F5 /* bn_mp_zero.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42CE08F272B3004A47F5 /* bn_mp_zero.c */; };
F96D494E08F272C3004A47F5 /* bn_reverse.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42D008F272B3004A47F5 /* bn_reverse.c */; };
F96D494F08F272C3004A47F5 /* bn_s_mp_add.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42D108F272B3004A47F5 /* bn_s_mp_add.c */; };
F96D495108F272C3004A47F5 /* bn_s_mp_mul_digs.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42D308F272B3004A47F5 /* bn_s_mp_mul_digs.c */; };
F96D495308F272C3004A47F5 /* bn_s_mp_sqr.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42D508F272B3004A47F5 /* bn_s_mp_sqr.c */; };
F96D495408F272C3004A47F5 /* bn_s_mp_sub.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42D608F272B3004A47F5 /* bn_s_mp_sub.c */; };
F96D49A908F272C4004A47F5 /* tclMacOSXBundle.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D433908F272B5004A47F5 /* tclMacOSXBundle.c */; };
F96D49AD08F272C4004A47F5 /* tclMacOSXFCmd.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D433D08F272B5004A47F5 /* tclMacOSXFCmd.c */; };
F96D49AE08F272C4004A47F5 /* tclMacOSXNotify.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D433E08F272B5004A47F5 /* tclMacOSXNotify.c */; };
F96D4AC608F272C9004A47F5 /* tclLoadDyld.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D445B08F272B9004A47F5 /* tclLoadDyld.c */; settings = {COMPILER_FLAGS = "-Wno-deprecated-declarations"; }; };
F96D4ACA08F272C9004A47F5 /* tclUnixChan.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D445F08F272B9004A47F5 /* tclUnixChan.c */; };
F96D4ACB08F272C9004A47F5 /* tclUnixEvent.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D446008F272B9004A47F5 /* tclUnixEvent.c */; };
F96D4ACC08F272C9004A47F5 /* tclUnixFCmd.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D446108F272B9004A47F5 /* tclUnixFCmd.c */; };
|
| ︙ | ︙ | |||
614 615 616 617 618 619 620 |
F96D42CD08F272B3004A47F5 /* bn_mp_xor.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_xor.c; sourceTree = "<group>"; };
F96D42CE08F272B3004A47F5 /* bn_mp_zero.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_zero.c; sourceTree = "<group>"; };
F96D42D008F272B3004A47F5 /* bn_reverse.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_reverse.c; sourceTree = "<group>"; };
F96D42D108F272B3004A47F5 /* bn_s_mp_add.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_s_mp_add.c; sourceTree = "<group>"; };
F96D42D308F272B3004A47F5 /* bn_s_mp_mul_digs.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_s_mp_mul_digs.c; sourceTree = "<group>"; };
F96D42D508F272B3004A47F5 /* bn_s_mp_sqr.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_s_mp_sqr.c; sourceTree = "<group>"; };
F96D42D608F272B3004A47F5 /* bn_s_mp_sub.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_s_mp_sub.c; sourceTree = "<group>"; };
| < | 613 614 615 616 617 618 619 620 621 622 623 624 625 626 |
F96D42CD08F272B3004A47F5 /* bn_mp_xor.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_xor.c; sourceTree = "<group>"; };
F96D42CE08F272B3004A47F5 /* bn_mp_zero.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_zero.c; sourceTree = "<group>"; };
F96D42D008F272B3004A47F5 /* bn_reverse.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_reverse.c; sourceTree = "<group>"; };
F96D42D108F272B3004A47F5 /* bn_s_mp_add.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_s_mp_add.c; sourceTree = "<group>"; };
F96D42D308F272B3004A47F5 /* bn_s_mp_mul_digs.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_s_mp_mul_digs.c; sourceTree = "<group>"; };
F96D42D508F272B3004A47F5 /* bn_s_mp_sqr.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_s_mp_sqr.c; sourceTree = "<group>"; };
F96D42D608F272B3004A47F5 /* bn_s_mp_sub.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_s_mp_sub.c; sourceTree = "<group>"; };
F96D432908F272B4004A47F5 /* tommath_class.h */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.h; path = tommath_class.h; sourceTree = "<group>"; };
F96D432A08F272B4004A47F5 /* tommath_superclass.h */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.h; path = tommath_superclass.h; sourceTree = "<group>"; };
F96D432B08F272B4004A47F5 /* license.terms */ = {isa = PBXFileReference; explicitFileType = text; fileEncoding = 4; path = license.terms; sourceTree = "<group>"; };
F96D432E08F272B5004A47F5 /* configure.ac */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text.script.sh; path = configure.ac; sourceTree = "<group>"; };
F96D432F08F272B5004A47F5 /* GNUmakefile */ = {isa = PBXFileReference; explicitFileType = sourcecode.make; fileEncoding = 4; path = GNUmakefile; sourceTree = "<group>"; };
F96D433108F272B5004A47F5 /* README */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text; path = README; sourceTree = "<group>"; };
F96D433208F272B5004A47F5 /* Tcl-Info.plist.in */ = {isa = PBXFileReference; explicitFileType = text.plist; fileEncoding = 4; path = "Tcl-Info.plist.in"; sourceTree = "<group>"; };
|
| ︙ | ︙ | |||
863 864 865 866 867 868 869 |
F96D449208F272BA004A47F5 /* tclWinPipe.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclWinPipe.c; sourceTree = "<group>"; };
F96D449308F272BA004A47F5 /* tclWinPort.h */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.h; path = tclWinPort.h; sourceTree = "<group>"; };
F96D449408F272BA004A47F5 /* tclWinReg.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclWinReg.c; sourceTree = "<group>"; };
F96D449508F272BA004A47F5 /* tclWinSerial.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclWinSerial.c; sourceTree = "<group>"; };
F96D449608F272BA004A47F5 /* tclWinSock.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclWinSock.c; sourceTree = "<group>"; };
F96D449708F272BA004A47F5 /* tclWinTest.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclWinTest.c; sourceTree = "<group>"; };
F96D449808F272BA004A47F5 /* tclWinThrd.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclWinThrd.c; sourceTree = "<group>"; };
| < | 861 862 863 864 865 866 867 868 869 870 871 872 873 874 |
F96D449208F272BA004A47F5 /* tclWinPipe.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclWinPipe.c; sourceTree = "<group>"; };
F96D449308F272BA004A47F5 /* tclWinPort.h */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.h; path = tclWinPort.h; sourceTree = "<group>"; };
F96D449408F272BA004A47F5 /* tclWinReg.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclWinReg.c; sourceTree = "<group>"; };
F96D449508F272BA004A47F5 /* tclWinSerial.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclWinSerial.c; sourceTree = "<group>"; };
F96D449608F272BA004A47F5 /* tclWinSock.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclWinSock.c; sourceTree = "<group>"; };
F96D449708F272BA004A47F5 /* tclWinTest.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclWinTest.c; sourceTree = "<group>"; };
F96D449808F272BA004A47F5 /* tclWinThrd.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclWinThrd.c; sourceTree = "<group>"; };
F96D449A08F272BA004A47F5 /* tclWinTime.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclWinTime.c; sourceTree = "<group>"; };
F974D56C0FBE7D6300BF728B /* http11.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = http11.test; sourceTree = "<group>"; };
F974D56D0FBE7D6300BF728B /* httpd11.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = httpd11.tcl; sourceTree = "<group>"; };
F974D5720FBE7DC600BF728B /* coroutine.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = coroutine.n; sourceTree = "<group>"; };
F974D5760FBE7E1900BF728B /* tailcall.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = tailcall.n; sourceTree = "<group>"; };
F974D5770FBE7E6100BF728B /* coroutine.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = coroutine.test; sourceTree = "<group>"; };
F974D5780FBE7E6100BF728B /* tailcall.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = tailcall.test; sourceTree = "<group>"; };
|
| ︙ | ︙ | |||
1333 1334 1335 1336 1337 1338 1339 | isa = PBXGroup; children = ( F96D3F3908F272A8004A47F5 /* auto.tcl */, F96D3F3A08F272A8004A47F5 /* clock.tcl */, F96D3F3B08F272A8004A47F5 /* dde */, F96D3F8C08F272A8004A47F5 /* history.tcl */, F96D3F8D08F272A8004A47F5 /* http */, | < | 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 | isa = PBXGroup; children = ( F96D3F3908F272A8004A47F5 /* auto.tcl */, F96D3F3A08F272A8004A47F5 /* clock.tcl */, F96D3F3B08F272A8004A47F5 /* dde */, F96D3F8C08F272A8004A47F5 /* history.tcl */, F96D3F8D08F272A8004A47F5 /* http */, F96D3F9308F272A8004A47F5 /* init.tcl */, F96D3F9408F272A8004A47F5 /* msgcat */, F96D401708F272AA004A47F5 /* opt */, F96D401A08F272AA004A47F5 /* package.tcl */, F96D401B08F272AA004A47F5 /* parray.tcl */, F9ECB1110B26521500A28025 /* platform */, F96D401C08F272AA004A47F5 /* reg */, |
| ︙ | ︙ | |||
1365 1366 1367 1368 1369 1370 1371 |
F96D3F8D08F272A8004A47F5 /* http */ = {
isa = PBXGroup;
children = (
F96D3F8E08F272A8004A47F5 /* http.tcl */,
F96D3F8F08F272A8004A47F5 /* pkgIndex.tcl */,
);
path = http;
| < < < < < < < < < | 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 |
F96D3F8D08F272A8004A47F5 /* http */ = {
isa = PBXGroup;
children = (
F96D3F8E08F272A8004A47F5 /* http.tcl */,
F96D3F8F08F272A8004A47F5 /* pkgIndex.tcl */,
);
path = http;
sourceTree = "<group>";
};
F96D3F9408F272A8004A47F5 /* msgcat */ = {
isa = PBXGroup;
children = (
F96D3F9508F272A8004A47F5 /* msgcat.tcl */,
F96D3F9608F272A8004A47F5 /* pkgIndex.tcl */,
|
| ︙ | ︙ | |||
1475 1476 1477 1478 1479 1480 1481 | F96D42CD08F272B3004A47F5 /* bn_mp_xor.c */, F96D42CE08F272B3004A47F5 /* bn_mp_zero.c */, F96D42D008F272B3004A47F5 /* bn_reverse.c */, F96D42D108F272B3004A47F5 /* bn_s_mp_add.c */, F96D42D308F272B3004A47F5 /* bn_s_mp_mul_digs.c */, F96D42D508F272B3004A47F5 /* bn_s_mp_sqr.c */, F96D42D608F272B3004A47F5 /* bn_s_mp_sub.c */, | < | 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 |
F96D42CD08F272B3004A47F5 /* bn_mp_xor.c */,
F96D42CE08F272B3004A47F5 /* bn_mp_zero.c */,
F96D42D008F272B3004A47F5 /* bn_reverse.c */,
F96D42D108F272B3004A47F5 /* bn_s_mp_add.c */,
F96D42D308F272B3004A47F5 /* bn_s_mp_mul_digs.c */,
F96D42D508F272B3004A47F5 /* bn_s_mp_sqr.c */,
F96D42D608F272B3004A47F5 /* bn_s_mp_sub.c */,
F96D432908F272B4004A47F5 /* tommath_class.h */,
F96D432A08F272B4004A47F5 /* tommath_superclass.h */,
);
path = libtommath;
sourceTree = "<group>";
};
F96D432C08F272B4004A47F5 /* macosx */ = {
|
| ︙ | ︙ | |||
1783 1784 1785 1786 1787 1788 1789 | F96D449208F272BA004A47F5 /* tclWinPipe.c */, F96D449308F272BA004A47F5 /* tclWinPort.h */, F96D449408F272BA004A47F5 /* tclWinReg.c */, F96D449508F272BA004A47F5 /* tclWinSerial.c */, F96D449608F272BA004A47F5 /* tclWinSock.c */, F96D449708F272BA004A47F5 /* tclWinTest.c */, F96D449808F272BA004A47F5 /* tclWinThrd.c */, | < | 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 |
F96D449208F272BA004A47F5 /* tclWinPipe.c */,
F96D449308F272BA004A47F5 /* tclWinPort.h */,
F96D449408F272BA004A47F5 /* tclWinReg.c */,
F96D449508F272BA004A47F5 /* tclWinSerial.c */,
F96D449608F272BA004A47F5 /* tclWinSock.c */,
F96D449708F272BA004A47F5 /* tclWinTest.c */,
F96D449808F272BA004A47F5 /* tclWinThrd.c */,
F96D449A08F272BA004A47F5 /* tclWinTime.c */,
);
path = win;
sourceTree = "<group>";
};
F9ECB1110B26521500A28025 /* platform */ = {
isa = PBXGroup;
|
| ︙ | ︙ | |||
2106 2107 2108 2109 2110 2111 2112 | F9E61D2D090A48BB002B3151 /* bn_mp_xor.c in Sources */, F96D494C08F272C3004A47F5 /* bn_mp_zero.c in Sources */, F96D494E08F272C3004A47F5 /* bn_reverse.c in Sources */, F96D494F08F272C3004A47F5 /* bn_s_mp_add.c in Sources */, F96D495108F272C3004A47F5 /* bn_s_mp_mul_digs.c in Sources */, F96D495308F272C3004A47F5 /* bn_s_mp_sqr.c in Sources */, F96D495408F272C3004A47F5 /* bn_s_mp_sub.c in Sources */, | < | 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 | F9E61D2D090A48BB002B3151 /* bn_mp_xor.c in Sources */, F96D494C08F272C3004A47F5 /* bn_mp_zero.c in Sources */, F96D494E08F272C3004A47F5 /* bn_reverse.c in Sources */, F96D494F08F272C3004A47F5 /* bn_s_mp_add.c in Sources */, F96D495108F272C3004A47F5 /* bn_s_mp_mul_digs.c in Sources */, F96D495308F272C3004A47F5 /* bn_s_mp_sqr.c in Sources */, F96D495408F272C3004A47F5 /* bn_s_mp_sub.c in Sources */, F96D49A908F272C4004A47F5 /* tclMacOSXBundle.c in Sources */, F96D49AD08F272C4004A47F5 /* tclMacOSXFCmd.c in Sources */, F96D49AE08F272C4004A47F5 /* tclMacOSXNotify.c in Sources */, F90509300913A72400327603 /* tclAppInit.c in Sources */, F96D4AC608F272C9004A47F5 /* tclLoadDyld.c in Sources */, F96D4ACA08F272C9004A47F5 /* tclUnixChan.c in Sources */, F9FC77B80AB29E9100B7077D /* tclUnixCompat.c in Sources */, |
| ︙ | ︙ |
Changes to macosx/Tcl.xcodeproj/project.pbxproj.
| ︙ | ︙ | |||
140 141 142 143 144 145 146 |
F96D494908F272C3004A47F5 /* bn_mp_toradix_n.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42CB08F272B3004A47F5 /* bn_mp_toradix_n.c */; };
F96D494C08F272C3004A47F5 /* bn_mp_zero.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42CE08F272B3004A47F5 /* bn_mp_zero.c */; };
F96D494E08F272C3004A47F5 /* bn_reverse.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42D008F272B3004A47F5 /* bn_reverse.c */; };
F96D494F08F272C3004A47F5 /* bn_s_mp_add.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42D108F272B3004A47F5 /* bn_s_mp_add.c */; };
F96D495108F272C3004A47F5 /* bn_s_mp_mul_digs.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42D308F272B3004A47F5 /* bn_s_mp_mul_digs.c */; };
F96D495308F272C3004A47F5 /* bn_s_mp_sqr.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42D508F272B3004A47F5 /* bn_s_mp_sqr.c */; };
F96D495408F272C3004A47F5 /* bn_s_mp_sub.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42D608F272B3004A47F5 /* bn_s_mp_sub.c */; };
| < | 140 141 142 143 144 145 146 147 148 149 150 151 152 153 |
F96D494908F272C3004A47F5 /* bn_mp_toradix_n.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42CB08F272B3004A47F5 /* bn_mp_toradix_n.c */; };
F96D494C08F272C3004A47F5 /* bn_mp_zero.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42CE08F272B3004A47F5 /* bn_mp_zero.c */; };
F96D494E08F272C3004A47F5 /* bn_reverse.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42D008F272B3004A47F5 /* bn_reverse.c */; };
F96D494F08F272C3004A47F5 /* bn_s_mp_add.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42D108F272B3004A47F5 /* bn_s_mp_add.c */; };
F96D495108F272C3004A47F5 /* bn_s_mp_mul_digs.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42D308F272B3004A47F5 /* bn_s_mp_mul_digs.c */; };
F96D495308F272C3004A47F5 /* bn_s_mp_sqr.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42D508F272B3004A47F5 /* bn_s_mp_sqr.c */; };
F96D495408F272C3004A47F5 /* bn_s_mp_sub.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42D608F272B3004A47F5 /* bn_s_mp_sub.c */; };
F96D49A908F272C4004A47F5 /* tclMacOSXBundle.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D433908F272B5004A47F5 /* tclMacOSXBundle.c */; };
F96D49AD08F272C4004A47F5 /* tclMacOSXFCmd.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D433D08F272B5004A47F5 /* tclMacOSXFCmd.c */; };
F96D49AE08F272C4004A47F5 /* tclMacOSXNotify.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D433E08F272B5004A47F5 /* tclMacOSXNotify.c */; };
F96D4AC608F272C9004A47F5 /* tclLoadDyld.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D445B08F272B9004A47F5 /* tclLoadDyld.c */; settings = {COMPILER_FLAGS = "-Wno-deprecated-declarations"; }; };
F96D4ACA08F272C9004A47F5 /* tclUnixChan.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D445F08F272B9004A47F5 /* tclUnixChan.c */; };
F96D4ACB08F272C9004A47F5 /* tclUnixEvent.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D446008F272B9004A47F5 /* tclUnixEvent.c */; };
F96D4ACC08F272C9004A47F5 /* tclUnixFCmd.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D446108F272B9004A47F5 /* tclUnixFCmd.c */; };
|
| ︙ | ︙ | |||
615 616 617 618 619 620 621 |
F96D42CD08F272B3004A47F5 /* bn_mp_xor.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_xor.c; sourceTree = "<group>"; };
F96D42CE08F272B3004A47F5 /* bn_mp_zero.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_zero.c; sourceTree = "<group>"; };
F96D42D008F272B3004A47F5 /* bn_reverse.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_reverse.c; sourceTree = "<group>"; };
F96D42D108F272B3004A47F5 /* bn_s_mp_add.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_s_mp_add.c; sourceTree = "<group>"; };
F96D42D308F272B3004A47F5 /* bn_s_mp_mul_digs.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_s_mp_mul_digs.c; sourceTree = "<group>"; };
F96D42D508F272B3004A47F5 /* bn_s_mp_sqr.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_s_mp_sqr.c; sourceTree = "<group>"; };
F96D42D608F272B3004A47F5 /* bn_s_mp_sub.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_s_mp_sub.c; sourceTree = "<group>"; };
| < | 614 615 616 617 618 619 620 621 622 623 624 625 626 627 |
F96D42CD08F272B3004A47F5 /* bn_mp_xor.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_xor.c; sourceTree = "<group>"; };
F96D42CE08F272B3004A47F5 /* bn_mp_zero.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_zero.c; sourceTree = "<group>"; };
F96D42D008F272B3004A47F5 /* bn_reverse.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_reverse.c; sourceTree = "<group>"; };
F96D42D108F272B3004A47F5 /* bn_s_mp_add.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_s_mp_add.c; sourceTree = "<group>"; };
F96D42D308F272B3004A47F5 /* bn_s_mp_mul_digs.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_s_mp_mul_digs.c; sourceTree = "<group>"; };
F96D42D508F272B3004A47F5 /* bn_s_mp_sqr.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_s_mp_sqr.c; sourceTree = "<group>"; };
F96D42D608F272B3004A47F5 /* bn_s_mp_sub.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_s_mp_sub.c; sourceTree = "<group>"; };
F96D432908F272B4004A47F5 /* tommath_class.h */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.h; path = tommath_class.h; sourceTree = "<group>"; };
F96D432A08F272B4004A47F5 /* tommath_superclass.h */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.h; path = tommath_superclass.h; sourceTree = "<group>"; };
F96D432B08F272B4004A47F5 /* license.terms */ = {isa = PBXFileReference; explicitFileType = text; fileEncoding = 4; path = license.terms; sourceTree = "<group>"; };
F96D432E08F272B5004A47F5 /* configure.ac */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text.script.sh; path = configure.ac; sourceTree = "<group>"; };
F96D432F08F272B5004A47F5 /* GNUmakefile */ = {isa = PBXFileReference; explicitFileType = sourcecode.make; fileEncoding = 4; path = GNUmakefile; sourceTree = "<group>"; };
F96D433108F272B5004A47F5 /* README */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text; path = README; sourceTree = "<group>"; };
F96D433208F272B5004A47F5 /* Tcl-Info.plist.in */ = {isa = PBXFileReference; explicitFileType = text.plist; fileEncoding = 4; path = "Tcl-Info.plist.in"; sourceTree = "<group>"; };
|
| ︙ | ︙ | |||
864 865 866 867 868 869 870 |
F96D449208F272BA004A47F5 /* tclWinPipe.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclWinPipe.c; sourceTree = "<group>"; };
F96D449308F272BA004A47F5 /* tclWinPort.h */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.h; path = tclWinPort.h; sourceTree = "<group>"; };
F96D449408F272BA004A47F5 /* tclWinReg.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclWinReg.c; sourceTree = "<group>"; };
F96D449508F272BA004A47F5 /* tclWinSerial.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclWinSerial.c; sourceTree = "<group>"; };
F96D449608F272BA004A47F5 /* tclWinSock.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclWinSock.c; sourceTree = "<group>"; };
F96D449708F272BA004A47F5 /* tclWinTest.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclWinTest.c; sourceTree = "<group>"; };
F96D449808F272BA004A47F5 /* tclWinThrd.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclWinThrd.c; sourceTree = "<group>"; };
| < | 862 863 864 865 866 867 868 869 870 871 872 873 874 875 |
F96D449208F272BA004A47F5 /* tclWinPipe.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclWinPipe.c; sourceTree = "<group>"; };
F96D449308F272BA004A47F5 /* tclWinPort.h */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.h; path = tclWinPort.h; sourceTree = "<group>"; };
F96D449408F272BA004A47F5 /* tclWinReg.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclWinReg.c; sourceTree = "<group>"; };
F96D449508F272BA004A47F5 /* tclWinSerial.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclWinSerial.c; sourceTree = "<group>"; };
F96D449608F272BA004A47F5 /* tclWinSock.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclWinSock.c; sourceTree = "<group>"; };
F96D449708F272BA004A47F5 /* tclWinTest.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclWinTest.c; sourceTree = "<group>"; };
F96D449808F272BA004A47F5 /* tclWinThrd.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclWinThrd.c; sourceTree = "<group>"; };
F96D449A08F272BA004A47F5 /* tclWinTime.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclWinTime.c; sourceTree = "<group>"; };
F974D56C0FBE7D6300BF728B /* http11.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = http11.test; sourceTree = "<group>"; };
F974D56D0FBE7D6300BF728B /* httpd11.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = httpd11.tcl; sourceTree = "<group>"; };
F974D5720FBE7DC600BF728B /* coroutine.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = coroutine.n; sourceTree = "<group>"; };
F974D5760FBE7E1900BF728B /* tailcall.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = tailcall.n; sourceTree = "<group>"; };
F974D5770FBE7E6100BF728B /* coroutine.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = coroutine.test; sourceTree = "<group>"; };
F974D5780FBE7E6100BF728B /* tailcall.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = tailcall.test; sourceTree = "<group>"; };
|
| ︙ | ︙ | |||
1334 1335 1336 1337 1338 1339 1340 | isa = PBXGroup; children = ( F96D3F3908F272A8004A47F5 /* auto.tcl */, F96D3F3A08F272A8004A47F5 /* clock.tcl */, F96D3F3B08F272A8004A47F5 /* dde */, F96D3F8C08F272A8004A47F5 /* history.tcl */, F96D3F8D08F272A8004A47F5 /* http */, | < | 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 | isa = PBXGroup; children = ( F96D3F3908F272A8004A47F5 /* auto.tcl */, F96D3F3A08F272A8004A47F5 /* clock.tcl */, F96D3F3B08F272A8004A47F5 /* dde */, F96D3F8C08F272A8004A47F5 /* history.tcl */, F96D3F8D08F272A8004A47F5 /* http */, F96D3F9308F272A8004A47F5 /* init.tcl */, F96D3F9408F272A8004A47F5 /* msgcat */, F96D401708F272AA004A47F5 /* opt */, F96D401A08F272AA004A47F5 /* package.tcl */, F96D401B08F272AA004A47F5 /* parray.tcl */, F9ECB1110B26521500A28025 /* platform */, F96D401C08F272AA004A47F5 /* reg */, |
| ︙ | ︙ | |||
1366 1367 1368 1369 1370 1371 1372 |
F96D3F8D08F272A8004A47F5 /* http */ = {
isa = PBXGroup;
children = (
F96D3F8E08F272A8004A47F5 /* http.tcl */,
F96D3F8F08F272A8004A47F5 /* pkgIndex.tcl */,
);
path = http;
| < < < < < < < < < | 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 |
F96D3F8D08F272A8004A47F5 /* http */ = {
isa = PBXGroup;
children = (
F96D3F8E08F272A8004A47F5 /* http.tcl */,
F96D3F8F08F272A8004A47F5 /* pkgIndex.tcl */,
);
path = http;
sourceTree = "<group>";
};
F96D3F9408F272A8004A47F5 /* msgcat */ = {
isa = PBXGroup;
children = (
F96D3F9508F272A8004A47F5 /* msgcat.tcl */,
F96D3F9608F272A8004A47F5 /* pkgIndex.tcl */,
|
| ︙ | ︙ | |||
1476 1477 1478 1479 1480 1481 1482 | F96D42CD08F272B3004A47F5 /* bn_mp_xor.c */, F96D42CE08F272B3004A47F5 /* bn_mp_zero.c */, F96D42D008F272B3004A47F5 /* bn_reverse.c */, F96D42D108F272B3004A47F5 /* bn_s_mp_add.c */, F96D42D308F272B3004A47F5 /* bn_s_mp_mul_digs.c */, F96D42D508F272B3004A47F5 /* bn_s_mp_sqr.c */, F96D42D608F272B3004A47F5 /* bn_s_mp_sub.c */, | < | 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 |
F96D42CD08F272B3004A47F5 /* bn_mp_xor.c */,
F96D42CE08F272B3004A47F5 /* bn_mp_zero.c */,
F96D42D008F272B3004A47F5 /* bn_reverse.c */,
F96D42D108F272B3004A47F5 /* bn_s_mp_add.c */,
F96D42D308F272B3004A47F5 /* bn_s_mp_mul_digs.c */,
F96D42D508F272B3004A47F5 /* bn_s_mp_sqr.c */,
F96D42D608F272B3004A47F5 /* bn_s_mp_sub.c */,
F96D432908F272B4004A47F5 /* tommath_class.h */,
F96D432A08F272B4004A47F5 /* tommath_superclass.h */,
);
path = libtommath;
sourceTree = "<group>";
};
F96D432C08F272B4004A47F5 /* macosx */ = {
|
| ︙ | ︙ | |||
1784 1785 1786 1787 1788 1789 1790 | F96D449208F272BA004A47F5 /* tclWinPipe.c */, F96D449308F272BA004A47F5 /* tclWinPort.h */, F96D449408F272BA004A47F5 /* tclWinReg.c */, F96D449508F272BA004A47F5 /* tclWinSerial.c */, F96D449608F272BA004A47F5 /* tclWinSock.c */, F96D449708F272BA004A47F5 /* tclWinTest.c */, F96D449808F272BA004A47F5 /* tclWinThrd.c */, | < | 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 |
F96D449208F272BA004A47F5 /* tclWinPipe.c */,
F96D449308F272BA004A47F5 /* tclWinPort.h */,
F96D449408F272BA004A47F5 /* tclWinReg.c */,
F96D449508F272BA004A47F5 /* tclWinSerial.c */,
F96D449608F272BA004A47F5 /* tclWinSock.c */,
F96D449708F272BA004A47F5 /* tclWinTest.c */,
F96D449808F272BA004A47F5 /* tclWinThrd.c */,
F96D449A08F272BA004A47F5 /* tclWinTime.c */,
);
path = win;
sourceTree = "<group>";
};
F9ECB1110B26521500A28025 /* platform */ = {
isa = PBXGroup;
|
| ︙ | ︙ | |||
2107 2108 2109 2110 2111 2112 2113 | F9E61D2D090A48BB002B3151 /* bn_mp_xor.c in Sources */, F96D494C08F272C3004A47F5 /* bn_mp_zero.c in Sources */, F96D494E08F272C3004A47F5 /* bn_reverse.c in Sources */, F96D494F08F272C3004A47F5 /* bn_s_mp_add.c in Sources */, F96D495108F272C3004A47F5 /* bn_s_mp_mul_digs.c in Sources */, F96D495308F272C3004A47F5 /* bn_s_mp_sqr.c in Sources */, F96D495408F272C3004A47F5 /* bn_s_mp_sub.c in Sources */, | < | 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 | F9E61D2D090A48BB002B3151 /* bn_mp_xor.c in Sources */, F96D494C08F272C3004A47F5 /* bn_mp_zero.c in Sources */, F96D494E08F272C3004A47F5 /* bn_reverse.c in Sources */, F96D494F08F272C3004A47F5 /* bn_s_mp_add.c in Sources */, F96D495108F272C3004A47F5 /* bn_s_mp_mul_digs.c in Sources */, F96D495308F272C3004A47F5 /* bn_s_mp_sqr.c in Sources */, F96D495408F272C3004A47F5 /* bn_s_mp_sub.c in Sources */, F96D49A908F272C4004A47F5 /* tclMacOSXBundle.c in Sources */, F96D49AD08F272C4004A47F5 /* tclMacOSXFCmd.c in Sources */, F96D49AE08F272C4004A47F5 /* tclMacOSXNotify.c in Sources */, F90509300913A72400327603 /* tclAppInit.c in Sources */, F96D4AC608F272C9004A47F5 /* tclLoadDyld.c in Sources */, F96D4ACA08F272C9004A47F5 /* tclUnixChan.c in Sources */, F9FC77B80AB29E9100B7077D /* tclUnixCompat.c in Sources */, |
| ︙ | ︙ |
Changes to macosx/tclMacOSXBundle.c.
| ︙ | ︙ | |||
163 164 165 166 167 168 169 |
*/
int
Tcl_MacOSXOpenBundleResources(
Tcl_Interp *interp,
const char *bundleName,
int hasResourceFile,
| | | 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 |
*/
int
Tcl_MacOSXOpenBundleResources(
Tcl_Interp *interp,
const char *bundleName,
int hasResourceFile,
size_t maxPathLen,
char *libraryPath)
{
return Tcl_MacOSXOpenVersionedBundleResources(interp, bundleName, NULL,
hasResourceFile, maxPathLen, libraryPath);
}
/*
|
| ︙ | ︙ | |||
197 198 199 200 201 202 203 |
int
Tcl_MacOSXOpenVersionedBundleResources(
Tcl_Interp *interp,
const char *bundleName,
const char *bundleVersion,
int hasResourceFile,
| | | 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 |
int
Tcl_MacOSXOpenVersionedBundleResources(
Tcl_Interp *interp,
const char *bundleName,
const char *bundleVersion,
int hasResourceFile,
size_t maxPathLen,
char *libraryPath)
{
#ifdef HAVE_COREFOUNDATION
CFBundleRef bundleRef, versionedBundleRef = NULL;
CFStringRef bundleNameRef;
CFURLRef libURL;
|
| ︙ | ︙ |
Changes to macosx/tclMacOSXFCmd.c.
| ︙ | ︙ | |||
188 189 190 191 192 193 194 |
OSSwapBigToHostInt32(finder->creator));
break;
case MACOSX_TYPE_ATTRIBUTE:
*attributePtrPtr = NewOSTypeObj(
OSSwapBigToHostInt32(finder->type));
break;
case MACOSX_HIDDEN_ATTRIBUTE:
| | | 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 |
OSSwapBigToHostInt32(finder->creator));
break;
case MACOSX_TYPE_ATTRIBUTE:
*attributePtrPtr = NewOSTypeObj(
OSSwapBigToHostInt32(finder->type));
break;
case MACOSX_HIDDEN_ATTRIBUTE:
*attributePtrPtr = Tcl_NewWideIntObj(
(finder->fdFlags & kFinfoIsInvisible) != 0);
break;
case MACOSX_RSRCLENGTH_ATTRIBUTE:
*attributePtrPtr = Tcl_NewWideIntObj(*rsrcForkSize);
break;
}
return TCL_OK;
|
| ︙ | ︙ | |||
573 574 575 576 577 578 579 |
GetOSTypeFromObj(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr, /* The object from which to get an OSType. */
OSType *osTypePtr) /* Place to store resulting OSType. */
{
int result = TCL_OK;
| | | | 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 |
GetOSTypeFromObj(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr, /* The object from which to get an OSType. */
OSType *osTypePtr) /* Place to store resulting OSType. */
{
int result = TCL_OK;
if (!TclHasIntRep(objPtr, &tclOSTypeType)) {
result = SetOSTypeFromAny(interp, objPtr);
}
*osTypePtr = (OSType) objPtr->internalRep.wideValue;
return result;
}
/*
*----------------------------------------------------------------------
*
* NewOSTypeObj --
|
| ︙ | ︙ | |||
605 606 607 608 609 610 611 |
const OSType osType) /* OSType used to initialize the new
* object. */
{
Tcl_Obj *objPtr;
TclNewObj(objPtr);
TclInvalidateStringRep(objPtr);
| | | 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 |
const OSType osType) /* OSType used to initialize the new
* object. */
{
Tcl_Obj *objPtr;
TclNewObj(objPtr);
TclInvalidateStringRep(objPtr);
objPtr->internalRep.wideValue = (Tcl_WideInt) osType;
objPtr->typePtr = &tclOSTypeType;
return objPtr;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
635 636 637 638 639 640 641 642 |
Tcl_Interp *interp, /* Tcl interpreter */
Tcl_Obj *objPtr) /* Pointer to the object to convert */
{
const char *string;
int result = TCL_OK;
Tcl_DString ds;
Tcl_Encoding encoding = Tcl_GetEncoding(NULL, "macRoman");
| > | | | | | 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 |
Tcl_Interp *interp, /* Tcl interpreter */
Tcl_Obj *objPtr) /* Pointer to the object to convert */
{
const char *string;
int result = TCL_OK;
Tcl_DString ds;
Tcl_Encoding encoding = Tcl_GetEncoding(NULL, "macRoman");
size_t length;
string = TclGetStringFromObj(objPtr, &length);
Tcl_UtfToExternalDString(encoding, string, length, &ds);
if (Tcl_DStringLength(&ds) > 4) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"expected Macintosh OS type but got \"%s\": ", string));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "MAC_OSTYPE", NULL);
}
result = TCL_ERROR;
} else {
OSType osType;
char bytes[4] = {'\0','\0','\0','\0'};
memcpy(bytes, Tcl_DStringValue(&ds), Tcl_DStringLength(&ds));
osType = (OSType) bytes[0] << 24 |
(OSType) bytes[1] << 16 |
(OSType) bytes[2] << 8 |
(OSType) bytes[3];
TclFreeIntRep(objPtr);
objPtr->internalRep.wideValue = (Tcl_WideInt) osType;
objPtr->typePtr = &tclOSTypeType;
}
Tcl_DStringFree(&ds);
Tcl_FreeEncoding(encoding);
return result;
}
|
| ︙ | ︙ | |||
688 689 690 691 692 693 694 |
*/
static void
UpdateStringOfOSType(
register Tcl_Obj *objPtr) /* OSType object whose string rep to
* update. */
{
| > | | | | > | > | | | | | | < < < | | > > > > | 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 |
*/
static void
UpdateStringOfOSType(
register Tcl_Obj *objPtr) /* OSType object whose string rep to
* update. */
{
const int size = TCL_UTF_MAX * 4;
char *dst = Tcl_InitStringRep(objPtr, NULL, size);
OSType osType = (OSType) objPtr->internalRep.wideValue;
int written = 0;
Tcl_Encoding encoding;
char src[5];
TclOOM(dst, size);
src[0] = (char) (osType >> 24);
src[1] = (char) (osType >> 16);
src[2] = (char) (osType >> 8);
src[3] = (char) (osType);
src[4] = '\0';
encoding = Tcl_GetEncoding(NULL, "macRoman");
Tcl_ExternalToUtf(NULL, encoding, src, -1, /* flags */ 0,
/* statePtr */ NULL, dst, size, /* srcReadPtr */ NULL,
/* dstWrotePtr */ &written, /* dstCharsPtr */ NULL);
Tcl_FreeEncoding(encoding);
(void)Tcl_InitStringRep(objPtr, NULL, written);
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to macosx/tclMacOSXNotify.c.
| ︙ | ︙ | |||
27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 |
* overhead. Note that these are not pure spinlocks, they employ various
* strategies to back off and relinquish the processor, making them immune to
* most priority-inversion livelocks (c.f. 'man 3 OSSpinLockLock' and Darwin
* sources: xnu/osfmk/{ppc,i386}/commpage/spinlocks.s).
*/
#if defined(HAVE_LIBKERN_OSATOMIC_H) && defined(HAVE_OSSPINLOCKLOCK)
/*
* Use OSSpinLock API where available (Tiger or later).
*/
#include <libkern/OSAtomic.h>
#if defined(HAVE_WEAK_IMPORT) && MAC_OS_X_VERSION_MIN_REQUIRED < 1040
/*
* Support for weakly importing spinlock API.
*/
#define WEAK_IMPORT_SPINLOCKLOCK
#if MAC_OS_X_VERSION_MAX_ALLOWED >= 1050
#define VOLATILE volatile
#else
#define VOLATILE
#endif /* MAC_OS_X_VERSION_MAX_ALLOWED >= 1050 */
#ifndef bool
#define bool int
#endif
extern void OSSpinLockLock(VOLATILE OSSpinLock *lock)
WEAK_IMPORT_ATTRIBUTE;
extern void OSSpinLockUnlock(VOLATILE OSSpinLock *lock)
WEAK_IMPORT_ATTRIBUTE;
extern bool OSSpinLockTry(VOLATILE OSSpinLock *lock)
WEAK_IMPORT_ATTRIBUTE;
extern void _spin_lock(VOLATILE OSSpinLock *lock)
| > > > > > > | 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 |
* overhead. Note that these are not pure spinlocks, they employ various
* strategies to back off and relinquish the processor, making them immune to
* most priority-inversion livelocks (c.f. 'man 3 OSSpinLockLock' and Darwin
* sources: xnu/osfmk/{ppc,i386}/commpage/spinlocks.s).
*/
#if defined(HAVE_LIBKERN_OSATOMIC_H) && defined(HAVE_OSSPINLOCKLOCK)
#pragma GCC diagnostic push
#pragma GCC diagnostic ignored "-Wdeprecated-declarations"
#pragma GCC diagnostic ignored "-Wunused-function"
/*
* Use OSSpinLock API where available (Tiger or later).
*/
#include <libkern/OSAtomic.h>
#if defined(HAVE_WEAK_IMPORT) && MAC_OS_X_VERSION_MIN_REQUIRED < 1040
/*
* Support for weakly importing spinlock API.
*/
#define WEAK_IMPORT_SPINLOCKLOCK
#if MAC_OS_X_VERSION_MAX_ALLOWED >= 1050
#define VOLATILE volatile
#else
#define VOLATILE
#endif /* MAC_OS_X_VERSION_MAX_ALLOWED >= 1050 */
#ifndef bool
#define bool int
#endif
extern void OSSpinLockLock(VOLATILE OSSpinLock *lock)
WEAK_IMPORT_ATTRIBUTE;
extern void OSSpinLockUnlock(VOLATILE OSSpinLock *lock)
WEAK_IMPORT_ATTRIBUTE;
extern bool OSSpinLockTry(VOLATILE OSSpinLock *lock)
WEAK_IMPORT_ATTRIBUTE;
extern void _spin_lock(VOLATILE OSSpinLock *lock)
|
| ︙ | ︙ | |||
73 74 75 76 77 78 79 |
lockLock = OSSpinLockLock != NULL ? OSSpinLockLock : _spin_lock;
lockUnlock = OSSpinLockUnlock != NULL ? OSSpinLockUnlock : _spin_unlock;
lockTry = OSSpinLockTry != NULL ? OSSpinLockTry : _spin_lock_try;
if (lockLock == NULL || lockUnlock == NULL) {
Tcl_Panic("SpinLockLockInit: no spinlock API available");
}
}
| > > > > > > | > > > > > | > > > > > | > > > > | > > > > > > > | > > > > > | > > > > > | > > > > > > > > > | > > > > > > > > | > > > > > > > > | | | > | > | 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 |
lockLock = OSSpinLockLock != NULL ? OSSpinLockLock : _spin_lock;
lockUnlock = OSSpinLockUnlock != NULL ? OSSpinLockUnlock : _spin_unlock;
lockTry = OSSpinLockTry != NULL ? OSSpinLockTry : _spin_lock_try;
if (lockLock == NULL || lockUnlock == NULL) {
Tcl_Panic("SpinLockLockInit: no spinlock API available");
}
}
/*
* Wrappers so that we get warnings in just one small part of this file.
*/
static inline void
SpinLockLock(
VOLATILE OSSpinLock *lock)
{
lockLock(lock);
}
static inline void
SpinLockUnlock(
VOLATILE OSSpinLock *lock)
{
lockUnlock(lock);
}
static inline bool
SpinLockTry(
VOLATILE OSSpinLock *lock)
{
return lockTry(lock);
}
#else /* !HAVE_WEAK_IMPORT */
/*
* Wrappers so that we get warnings in just one small part of this file.
*/
static inline void
SpinLockLock(
OSSpinLock *lock)
{
OSSpinLockLock(lock);
}
static inline void
SpinLockUnlock(
OSSpinLock *lock)
{
OSSpinLockUnlock(lock);
}
static inline bool
SpinLockTry(
OSSpinLock *lock)
{
return OSSpinLockTry(lock);
}
#endif /* HAVE_WEAK_IMPORT */
#define SPINLOCK_INIT OS_SPINLOCK_INIT
#else
/*
* Otherwise, use commpage spinlock SPI directly.
*/
typedef uint32_t OSSpinLock;
static inline void
SpinLockLock(
OSSpinLock *lock)
{
extern void _spin_lock(OSSpinLock *lock);
_spin_lock(lock);
}
static inline void
SpinLockUnlock(
OSSpinLock *lock)
{
extern void _spin_unlock(OSSpinLock *lock);
_spin_unlock(lock);
}
static inline int
SpinLockTry(
OSSpinLock *lock)
{
extern int _spin_lock_try(OSSpinLock *lock);
return _spin_lock_try(lock);
}
#define SPINLOCK_INIT 0
#pragma GCC diagnostic pop
#endif /* HAVE_LIBKERN_OSATOMIC_H && HAVE_OSSPINLOCKLOCK */
/*
* These spinlocks lock access to the global notifier state.
*/
static OSSpinLock notifierInitLock = SPINLOCK_INIT;
|
| ︙ | ︙ | |||
962 963 964 965 966 967 968 |
for (filePtr = tsdPtr->firstFileHandlerPtr; filePtr != NULL;
filePtr = filePtr->nextPtr) {
if (filePtr->fd == fd) {
break;
}
}
if (filePtr == NULL) {
| | | 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 |
for (filePtr = tsdPtr->firstFileHandlerPtr; filePtr != NULL;
filePtr = filePtr->nextPtr) {
if (filePtr->fd == fd) {
break;
}
}
if (filePtr == NULL) {
filePtr = Tcl_Alloc(sizeof(FileHandler));
filePtr->fd = fd;
filePtr->readyMask = 0;
filePtr->nextPtr = tsdPtr->firstFileHandlerPtr;
tsdPtr->firstFileHandlerPtr = filePtr;
}
filePtr->proc = proc;
filePtr->clientData = clientData;
|
| ︙ | ︙ | |||
1090 1091 1092 1093 1094 1095 1096 |
*/
if (prevPtr == NULL) {
tsdPtr->firstFileHandlerPtr = filePtr->nextPtr;
} else {
prevPtr->nextPtr = filePtr->nextPtr;
}
| | | 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 |
*/
if (prevPtr == NULL) {
tsdPtr->firstFileHandlerPtr = filePtr->nextPtr;
} else {
prevPtr->nextPtr = filePtr->nextPtr;
}
Tcl_Free(filePtr);
}
/*
*----------------------------------------------------------------------
*
* FileHandlerEventProc --
*
|
| ︙ | ︙ | |||
1345 1346 1347 1348 1349 1350 1351 |
/*
* Don't bother to queue an event if the mask was previously non-zero
* since an event must still be on the queue.
*/
if (filePtr->readyMask == 0) {
| | | 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 |
/*
* Don't bother to queue an event if the mask was previously non-zero
* since an event must still be on the queue.
*/
if (filePtr->readyMask == 0) {
FileHandlerEvent *fileEvPtr = Tcl_Alloc(sizeof(FileHandlerEvent));
fileEvPtr->header.proc = FileHandlerEventProc;
fileEvPtr->fd = filePtr->fd;
Tcl_QueueEvent((Tcl_Event *) fileEvPtr, TCL_QUEUE_TAIL);
}
filePtr->readyMask = mask;
}
|
| ︙ | ︙ | |||
1407 1408 1409 1410 1411 1412 1413 |
tsdPtr->runLoopNestingLevel--;
break;
case kCFRunLoopBeforeWaiting:
if (tsdPtr->runLoopTimer && !tsdPtr->runLoopServicingEvents &&
(tsdPtr->runLoopNestingLevel > 1
|| !tsdPtr->runLoopRunning)) {
tsdPtr->runLoopServicingEvents = 1;
| > | > > | 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 |
tsdPtr->runLoopNestingLevel--;
break;
case kCFRunLoopBeforeWaiting:
if (tsdPtr->runLoopTimer && !tsdPtr->runLoopServicingEvents &&
(tsdPtr->runLoopNestingLevel > 1
|| !tsdPtr->runLoopRunning)) {
tsdPtr->runLoopServicingEvents = 1;
/*
* This call seems to simply force event processing through and
* prevents hangups that have long been observed with Tk-Cocoa.
*/
Tcl_ServiceAll();
tsdPtr->runLoopServicingEvents = 0;
}
break;
default:
break;
}
|
| ︙ | ︙ |
Added tests-perf/clock.perf.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 |
#!/usr/bin/tclsh
# ------------------------------------------------------------------------
#
# test-performance.tcl --
#
# This file provides common performance tests for comparison of tcl-speed
# degradation by switching between branches.
# (currently for clock ensemble only)
#
# ------------------------------------------------------------------------
#
# Copyright (c) 2014 Serg G. Brester (aka sebres)
#
# See the file "license.terms" for information on usage and redistribution
# of this file.
#
array set in {-time 500}
if {[info exists ::argv0] && [file tail $::argv0] eq [file tail [info script]]} {
array set in $argv
}
## common test performance framework:
if {![namespace exists ::tclTestPerf]} {
source [file join [file dirname [info script]] test-performance.tcl]
}
namespace eval ::tclTestPerf-TclClock {
namespace path {::tclTestPerf}
## set testing defaults:
set ::env(TCL_TZ) :CET
# warm-up interpeter compiler env, clock platform-related features:
## warm-up test-related features (load clock.tcl, system zones, locales, etc.):
clock scan "" -gmt 1
clock scan ""
clock scan "" -timezone :CET
clock scan "" -format "" -locale en
clock scan "" -format "" -locale de
## ------------------------------------------
proc test-format {{reptime 1000}} {
_test_run $reptime {
# Format : short, week only (in gmt)
{clock format 1482525936 -format "%u" -gmt 1}
# Format : short, week only (system zone)
{clock format 1482525936 -format "%u"}
# Format : short, week only (CEST)
{clock format 1482525936 -format "%u" -timezone :CET}
# Format : date only (in gmt)
{clock format 1482525936 -format "%Y-%m-%d" -gmt 1}
# Format : date only (system zone)
{clock format 1482525936 -format "%Y-%m-%d"}
# Format : date only (CEST)
{clock format 1482525936 -format "%Y-%m-%d" -timezone :CET}
# Format : time only (in gmt)
{clock format 1482525936 -format "%H:%M" -gmt 1}
# Format : time only (system zone)
{clock format 1482525936 -format "%H:%M"}
# Format : time only (CEST)
{clock format 1482525936 -format "%H:%M" -timezone :CET}
# Format : time only (in gmt)
{clock format 1482525936 -format "%H:%M:%S" -gmt 1}
# Format : time only (system zone)
{clock format 1482525936 -format "%H:%M:%S"}
# Format : time only (CEST)
{clock format 1482525936 -format "%H:%M:%S" -timezone :CET}
# Format : default (in gmt)
{clock format 1482525936 -gmt 1 -locale en}
# Format : default (system zone)
{clock format 1482525936 -locale en}
# Format : default (CEST)
{clock format 1482525936 -timezone :CET -locale en}
# Format : ISO date-time (in gmt, numeric zone)
{clock format 1246379400 -format "%Y-%m-%dT%H:%M:%S %z" -gmt 1}
# Format : ISO date-time (system zone, CEST, numeric zone)
{clock format 1246379400 -format "%Y-%m-%dT%H:%M:%S %z"}
# Format : ISO date-time (CEST, numeric zone)
{clock format 1246379400 -format "%Y-%m-%dT%H:%M:%S %z" -timezone :CET}
# Format : ISO date-time (system zone, CEST)
{clock format 1246379400 -format "%Y-%m-%dT%H:%M:%S %Z"}
# Format : julian day with time (in gmt):
{clock format 1246379415 -format "%J %H:%M:%S" -gmt 1}
# Format : julian day with time (system zone):
{clock format 1246379415 -format "%J %H:%M:%S"}
# Format : locale date-time (en):
{clock format 1246379415 -format "%x %X" -locale en}
# Format : locale date-time (de):
{clock format 1246379415 -format "%x %X" -locale de}
# Format : locale lookup table month:
{clock format 1246379400 -format "%b" -locale en -gmt 1}
# Format : locale lookup 2 tables - month and day:
{clock format 1246379400 -format "%b %Od" -locale en -gmt 1}
# Format : locale lookup 3 tables - week, month and day:
{clock format 1246379400 -format "%a %b %Od" -locale en -gmt 1}
# Format : locale lookup 4 tables - week, month, day and year:
{clock format 1246379400 -format "%a %b %Od %Oy" -locale en -gmt 1}
# Format : dynamic clock value (without converter caches):
setup {set i 0}
{clock format [incr i] -format "%Y-%m-%dT%H:%M:%S" -locale en -timezone :CET}
cleanup {puts [clock format $i -format "%Y-%m-%dT%H:%M:%S" -locale en -timezone :CET]}
# Format : dynamic clock value (without any converter caches, zone range overflow):
setup {set i 0}
{clock format [incr i 86400] -format "%Y-%m-%dT%H:%M:%S" -locale en -timezone :CET}
cleanup {puts [clock format $i -format "%Y-%m-%dT%H:%M:%S" -locale en -timezone :CET]}
# Format : dynamic format (cacheable)
{clock format 1246379415 -format [string trim "%d.%m.%Y %H:%M:%S "] -gmt 1}
# Format : all (in gmt, locale en)
{clock format 1482525936 -format "%%a = %a | %%A = %A | %%b = %b | %%h = %h | %%B = %B | %%C = %C | %%d = %d | %%e = %e | %%g = %g | %%G = %G | %%H = %H | %%I = %I | %%j = %j | %%J = %J | %%k = %k | %%l = %l | %%m = %m | %%M = %M | %%N = %N | %%p = %p | %%P = %P | %%Q = %Q | %%s = %s | %%S = %S | %%t = %t | %%u = %u | %%U = %U | %%V = %V | %%w = %w | %%W = %W | %%y = %y | %%Y = %Y | %%z = %z | %%Z = %Z | %%n = %n | %%EE = %EE | %%EC = %EC | %%Ey = %Ey | %%n = %n | %%Od = %Od | %%Oe = %Oe | %%OH = %OH | %%Ok = %Ok | %%OI = %OI | %%Ol = %Ol | %%Om = %Om | %%OM = %OM | %%OS = %OS | %%Ou = %Ou | %%Ow = %Ow | %%Oy = %Oy" -gmt 1 -locale en}
# Format : all (in CET, locale de)
{clock format 1482525936 -format "%%a = %a | %%A = %A | %%b = %b | %%h = %h | %%B = %B | %%C = %C | %%d = %d | %%e = %e | %%g = %g | %%G = %G | %%H = %H | %%I = %I | %%j = %j | %%J = %J | %%k = %k | %%l = %l | %%m = %m | %%M = %M | %%N = %N | %%p = %p | %%P = %P | %%Q = %Q | %%s = %s | %%S = %S | %%t = %t | %%u = %u | %%U = %U | %%V = %V | %%w = %w | %%W = %W | %%y = %y | %%Y = %Y | %%z = %z | %%Z = %Z | %%n = %n | %%EE = %EE | %%EC = %EC | %%Ey = %Ey | %%n = %n | %%Od = %Od | %%Oe = %Oe | %%OH = %OH | %%Ok = %Ok | %%OI = %OI | %%Ol = %Ol | %%Om = %Om | %%OM = %OM | %%OS = %OS | %%Ou = %Ou | %%Ow = %Ow | %%Oy = %Oy" -timezone :CET -locale de}
}
}
proc test-scan {{reptime 1000}} {
_test_run $reptime {
# Scan : date (in gmt)
{clock scan "25.11.2015" -format "%d.%m.%Y" -base 0 -gmt 1}
# Scan : date (system time zone, with base)
{clock scan "25.11.2015" -format "%d.%m.%Y" -base 0}
# Scan : date (system time zone, without base)
{clock scan "25.11.2015" -format "%d.%m.%Y"}
# Scan : greedy match
{clock scan "111" -format "%d%m%y" -base 0 -gmt 1}
{clock scan "1111" -format "%d%m%y" -base 0 -gmt 1}
{clock scan "11111" -format "%d%m%y" -base 0 -gmt 1}
{clock scan "111111" -format "%d%m%y" -base 0 -gmt 1}
# Scan : greedy match (space separated)
{clock scan "1 1 1" -format "%d%m%y" -base 0 -gmt 1}
{clock scan "111 1" -format "%d%m%y" -base 0 -gmt 1}
{clock scan "1 111" -format "%d%m%y" -base 0 -gmt 1}
{clock scan "1 11 1" -format "%d%m%y" -base 0 -gmt 1}
{clock scan "1 11 11" -format "%d%m%y" -base 0 -gmt 1}
{clock scan "11 11 11" -format "%d%m%y" -base 0 -gmt 1}
# Scan : time (in gmt)
{clock scan "10:35:55" -format "%H:%M:%S" -base 1000000000 -gmt 1}
# Scan : time (system time zone, with base)
{clock scan "10:35:55" -format "%H:%M:%S" -base 1000000000}
# Scan : time (gmt, without base)
{clock scan "10:35:55" -format "%H:%M:%S" -gmt 1}
# Scan : time (system time zone, without base)
{clock scan "10:35:55" -format "%H:%M:%S"}
# Scan : date-time (in gmt)
{clock scan "25.11.2015 10:35:55" -format "%d.%m.%Y %H:%M:%S" -base 0 -gmt 1}
# Scan : date-time (system time zone with base)
{clock scan "25.11.2015 10:35:55" -format "%d.%m.%Y %H:%M:%S" -base 0}
# Scan : date-time (system time zone without base)
{clock scan "25.11.2015 10:35:55" -format "%d.%m.%Y %H:%M:%S"}
# Scan : julian day in gmt
{clock scan 2451545 -format %J -gmt 1}
# Scan : julian day in system TZ
{clock scan 2451545 -format %J}
# Scan : julian day in other TZ
{clock scan 2451545 -format %J -timezone +0200}
# Scan : julian day with time:
{clock scan "2451545 10:20:30" -format "%J %H:%M:%S"}
# Scan : julian day with time (greedy match):
{clock scan "2451545 102030" -format "%J%H%M%S"}
# Scan : century, lookup table month
{clock scan {1970 Jan 2} -format {%C%y %b %d} -locale en -gmt 1}
# Scan : century, lookup table month and day (both entries are first)
{clock scan {1970 Jan 01} -format {%C%y %b %Od} -locale en -gmt 1}
# Scan : century, lookup table month and day (list scan: entries with position 12 / 31)
{clock scan {2016 Dec 31} -format {%C%y %b %Od} -locale en -gmt 1}
# Scan : ISO date-time (CEST)
{clock scan "2009-06-30T18:30:00+02:00" -format "%Y-%m-%dT%H:%M:%S%z"}
{clock scan "2009-06-30T18:30:00 CEST" -format "%Y-%m-%dT%H:%M:%S %z"}
# Scan : ISO date-time (UTC)
{clock scan "2009-06-30T18:30:00Z" -format "%Y-%m-%dT%H:%M:%S%z"}
{clock scan "2009-06-30T18:30:00 UTC" -format "%Y-%m-%dT%H:%M:%S %z"}
# Scan : locale date-time (en):
{clock scan "06/30/2009 18:30:15" -format "%x %X" -gmt 1 -locale en}
# Scan : locale date-time (de):
{clock scan "30.06.2009 18:30:15" -format "%x %X" -gmt 1 -locale de}
# Scan : dynamic format (cacheable)
{clock scan "25.11.2015 10:35:55" -format [string trim "%d.%m.%Y %H:%M:%S "] -base 0 -gmt 1}
break
# # Scan : long format test (allock chain)
# {clock scan "25.11.2015" -format "%d.%m.%Y %d.%m.%Y %d.%m.%Y %d.%m.%Y %d.%m.%Y %d.%m.%Y %d.%m.%Y %d.%m.%Y" -base 0 -gmt 1}
# # Scan : dynamic, very long format test (create obj representation, allock chain, GC, etc):
# {clock scan "25.11.2015" -format [string repeat "[incr i] %d.%m.%Y %d.%m.%Y" 10] -base 0 -gmt 1}
# # Scan : again:
# {clock scan "25.11.2015" -format [string repeat "[incr i -1] %d.%m.%Y %d.%m.%Y" 10] -base 0 -gmt 1}
} {puts [clock format $_(r) -locale en]}
}
proc test-freescan {{reptime 1000}} {
_test_run $reptime {
# FreeScan : relative date
{clock scan "5 years 18 months 385 days" -base 0 -gmt 1}
# FreeScan : relative date with relative weekday
{clock scan "5 years 18 months 385 days Fri" -base 0 -gmt 1}
# FreeScan : relative date with ordinal month
{clock scan "5 years 18 months 385 days next 1 January" -base 0 -gmt 1}
# FreeScan : relative date with ordinal month and relative weekday
{clock scan "5 years 18 months 385 days next January Fri" -base 0 -gmt 1}
# FreeScan : ordinal month
{clock scan "next January" -base 0 -gmt 1}
# FreeScan : relative week
{clock scan "next Fri" -base 0 -gmt 1}
# FreeScan : relative weekday and week offset
{clock scan "next January + 2 week" -base 0 -gmt 1}
# FreeScan : time only with base
{clock scan "19:18:30" -base 148863600 -gmt 1}
# FreeScan : time only without base, gmt
{clock scan "19:18:30" -gmt 1}
# FreeScan : time only without base, system
{clock scan "19:18:30"}
# FreeScan : date, system time zone
{clock scan "05/08/2016 20:18:30"}
# FreeScan : date, supplied time zone
{clock scan "05/08/2016 20:18:30" -timezone :CET}
# FreeScan : date, supplied gmt (equivalent -timezone :GMT)
{clock scan "05/08/2016 20:18:30" -gmt 1}
# FreeScan : date, supplied time zone gmt
{clock scan "05/08/2016 20:18:30" -timezone :GMT}
# FreeScan : time only, numeric zone in string, base time gmt (exchange zones between gmt / -0500)
{clock scan "20:18:30 -0500" -base 148863600 -gmt 1}
# FreeScan : time only, zone in string (exchange zones between system / gmt)
{clock scan "19:18:30 GMT" -base 148863600}
# FreeScan : fast switch of zones in cycle - GMT, MST, CET (system) and EST
{clock scan "19:18:30 MST" -base 148863600 -gmt 1
clock scan "19:18:30 EST" -base 148863600
}
} {puts [clock format $_(r) -locale en]}
}
proc test-add {{reptime 1000}} {
set tests {
# Add : years
{clock add 1246379415 5 years -gmt 1}
# Add : months
{clock add 1246379415 18 months -gmt 1}
# Add : weeks
{clock add 1246379415 20 weeks -gmt 1}
# Add : days
{clock add 1246379415 385 days -gmt 1}
# Add : weekdays
{clock add 1246379415 3 weekdays -gmt 1}
# Add : hours
{clock add 1246379415 5 hours -gmt 1}
# Add : minutes
{clock add 1246379415 55 minutes -gmt 1}
# Add : seconds
{clock add 1246379415 100 seconds -gmt 1}
# Add : +/- in gmt
{clock add 1246379415 -5 years +21 months -20 weeks +386 days -19 hours +30 minutes -10 seconds -gmt 1}
# Add : +/- in system timezone
{clock add 1246379415 -5 years +21 months -20 weeks +386 days -19 hours +30 minutes -10 seconds -timezone :CET}
# Add : gmt
{clock add 1246379415 -5 years 18 months 366 days 5 hours 30 minutes 10 seconds -gmt 1}
# Add : system timezone
{clock add 1246379415 -5 years 18 months 366 days 5 hours 30 minutes 10 seconds -timezone :CET}
# Add : all in gmt
{clock add 1246379415 4 years 18 months 50 weeks 378 days 3 weekdays 5 hours 30 minutes 10 seconds -gmt 1}
# Add : all in system timezone
{clock add 1246379415 4 years 18 months 50 weeks 378 days 3 weekdays 5 hours 30 minutes 10 seconds -timezone :CET}
}
# if does not support add of weekdays:
if {[catch {clock add 0 3 weekdays -gmt 1}]} {
regsub -all {\mweekdays\M} $tests "days" tests
}
_test_run $reptime $tests {puts [clock format $_(r) -locale en]}
}
proc test-convert {{reptime 1000}} {
_test_run $reptime {
# Convert locale (en -> de):
{clock format [clock scan "Tue May 30 2017" -format "%a %b %d %Y" -gmt 1 -locale en] -format "%a %b %d %Y" -gmt 1 -locale de}
# Convert locale (de -> en):
{clock format [clock scan "Di Mai 30 2017" -format "%a %b %d %Y" -gmt 1 -locale de] -format "%a %b %d %Y" -gmt 1 -locale en}
# Convert TZ: direct
{clock format [clock scan "19:18:30" -base 148863600 -timezone EST] -timezone MST}
{clock format [clock scan "19:18:30" -base 148863600 -timezone MST] -timezone EST}
# Convert TZ: included in scan string & format
{clock format [clock scan "19:18:30 EST" -base 148863600] -format "%H:%M:%S %z" -timezone MST}
{clock format [clock scan "19:18:30 EST" -base 148863600] -format "%H:%M:%S %z" -timezone EST}
# Format locale 1x: comparison values
{clock format 0 -gmt 1 -locale en}
{clock format 0 -gmt 1 -locale de}
{clock format 0 -gmt 1 -locale fr}
# Format locale 2x: without switching locale (en, en)
{clock format 0 -gmt 1 -locale en; clock format 0 -gmt 1 -locale en}
# Format locale 2x: with switching locale (en, de)
{clock format 0 -gmt 1 -locale en; clock format 0 -gmt 1 -locale de}
# Format locale 3x: without switching locale (en, en, en)
{clock format 0 -gmt 1 -locale en; clock format 0 -gmt 1 -locale en; clock format 0 -gmt 1 -locale en}
# Format locale 3x: with switching locale (en, de, fr)
{clock format 0 -gmt 1 -locale en; clock format 0 -gmt 1 -locale de; clock format 0 -gmt 1 -locale fr}
# Scan locale 2x: without switching locale (en, en) + (de, de)
{clock scan "Tue May 30 2017" -format "%a %b %d %Y" -gmt 1 -locale en; clock scan "Tue May 30 2017" -format "%a %b %d %Y" -gmt 1 -locale en}
{clock scan "Di Mai 30 2017" -format "%a %b %d %Y" -gmt 1 -locale de; clock scan "Di Mai 30 2017" -format "%a %b %d %Y" -gmt 1 -locale de}
# Scan locale 2x: with switching locale (en, de)
{clock scan "Tue May 30 2017" -format "%a %b %d %Y" -gmt 1 -locale en; clock scan "Di Mai 30 2017" -format "%a %b %d %Y" -gmt 1 -locale de}
# Scan locale 3x: with switching locale (en, de, fr)
{clock scan "Tue May 30 2017" -format "%a %b %d %Y" -gmt 1 -locale en; clock scan "Di Mai 30 2017" -format "%a %b %d %Y" -gmt 1 -locale de; clock scan "mar. mai 30 2017" -format "%a %b %d %Y" -gmt 1 -locale fr}
# Format TZ 2x: comparison values
{clock format 0 -timezone CET -format "%Y-%m-%d %H:%M:%S %z"}
{clock format 0 -timezone EST -format "%Y-%m-%d %H:%M:%S %z"}
# Format TZ 2x: without switching
{clock format 0 -timezone CET -format "%Y-%m-%d %H:%M:%S %z"; clock format 0 -timezone CET -format "%Y-%m-%d %H:%M:%S %z"}
{clock format 0 -timezone EST -format "%Y-%m-%d %H:%M:%S %z"; clock format 0 -timezone EST -format "%Y-%m-%d %H:%M:%S %z"}
# Format TZ 2x: with switching
{clock format 0 -timezone CET -format "%Y-%m-%d %H:%M:%S %z"; clock format 0 -timezone EST -format "%Y-%m-%d %H:%M:%S %z"}
# Format TZ 3x: with switching (CET, EST, MST)
{clock format 0 -timezone CET -format "%Y-%m-%d %H:%M:%S %z"; clock format 0 -timezone EST -format "%Y-%m-%d %H:%M:%S %z"; clock format 0 -timezone MST -format "%Y-%m-%d %H:%M:%S %z"}
# Format TZ 3x: with switching (GMT, EST, MST)
{clock format 0 -gmt 1 -format "%Y-%m-%d %H:%M:%S %z"; clock format 0 -timezone EST -format "%Y-%m-%d %H:%M:%S %z"; clock format 0 -timezone MST -format "%Y-%m-%d %H:%M:%S %z"}
# FreeScan TZ 2x (+1 system-default): without switching TZ
{clock scan "19:18:30 MST" -base 148863600; clock scan "19:18:30 MST" -base 148863600}
{clock scan "19:18:30 EST" -base 148863600; clock scan "19:18:30 EST" -base 148863600}
# FreeScan TZ 2x (+1 system-default): with switching TZ
{clock scan "19:18:30 MST" -base 148863600; clock scan "19:18:30 EST" -base 148863600}
# FreeScan TZ 2x (+1 gmt, +1 system-default)
{clock scan "19:18:30 MST" -base 148863600 -gmt 1; clock scan "19:18:30 EST" -base 148863600}
# Scan TZ: comparison included in scan string vs. given
{clock scan "2009-06-30T18:30:00 CEST" -format "%Y-%m-%dT%H:%M:%S %z"}
{clock scan "2009-06-30T18:30:00 CET" -format "%Y-%m-%dT%H:%M:%S %z"}
{clock scan "2009-06-30T18:30:00" -timezone CET -format "%Y-%m-%dT%H:%M:%S"}
}
}
proc test-other {{reptime 1000}} {
_test_run $reptime {
# Bad zone
{catch {clock scan "1 day" -timezone BAD_ZONE -locale en}}
# Scan : julian day (overflow)
{catch {clock scan 5373485 -format %J}}
# Scan : test rotate of GC objects (format is dynamic, so tcl-obj removed with last reference)
{set i 0; time { clock scan "[incr i] - 25.11.2015" -format "$i - %d.%m.%Y" -base 0 -gmt 1 } 50}
# Scan : test reusability of GC objects (format is dynamic, so tcl-obj removed with last reference)
{set i 50; time { clock scan "[incr i -1] - 25.11.2015" -format "$i - %d.%m.%Y" -base 0 -gmt 1 } 50}
}
}
proc test-ensemble-perf {{reptime 1000}} {
_test_run $reptime {
# Clock clicks (ensemble)
{clock clicks}
# Clock clicks (direct)
{::tcl::clock::clicks}
# Clock seconds (ensemble)
{clock seconds}
# Clock seconds (direct)
{::tcl::clock::seconds}
# Clock microseconds (ensemble)
{clock microseconds}
# Clock microseconds (direct)
{::tcl::clock::microseconds}
# Clock scan (ensemble)
{clock scan ""}
# Clock scan (direct)
{::tcl::clock::scan ""}
# Clock format (ensemble)
{clock format 0 -f %s}
# Clock format (direct)
{::tcl::clock::format 0 -f %s}
}
}
proc test {{reptime 1000}} {
puts ""
test-ensemble-perf [expr {$reptime / 2}]; #fast enough
test-format $reptime
test-scan $reptime
test-freescan $reptime
test-add $reptime
test-convert [expr {$reptime / 2}]; #fast enough
test-other $reptime
puts \n**OK**
}
}; # end of ::tclTestPerf-TclClock
# ------------------------------------------------------------------------
# if calling direct:
if {[info exists ::argv0] && [file tail $::argv0] eq [file tail [info script]]} {
::tclTestPerf-TclClock::test $in(-time)
}
|
Added tests-perf/test-performance.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 |
# ------------------------------------------------------------------------
#
# test-performance.tcl --
#
# This file provides common performance tests for comparison of tcl-speed
# degradation or regression by switching between branches.
#
# To execute test case evaluate direct corresponding file "tests-perf\*.perf.tcl".
#
# ------------------------------------------------------------------------
#
# Copyright (c) 2014 Serg G. Brester (aka sebres)
#
# See the file "license.terms" for information on usage and redistribution
# of this file.
#
namespace eval ::tclTestPerf {
# warm-up interpeter compiler env, calibrate timerate measurement functionality:
# if no timerate here - import from unsupported:
if {[namespace which -command timerate] eq {}} {
namespace inscope ::tcl::unsupported {namespace export timerate}
namespace import ::tcl::unsupported::timerate
}
# if not yet calibrated:
if {[lindex [timerate {} 10] 6] >= (10-1)} {
puts -nonewline "Calibration ... "; flush stdout
puts "done: [lrange \
[timerate -calibrate {}] \
0 1]"
}
proc {**STOP**} {args} {
return -code error -level 4 "**STOP** in [info level [expr {[info level]-2}]] [join $args { }]"
}
proc _test_get_commands {lst} {
regsub -all {(?:^|\n)[ \t]*(\#[^\n]*|\msetup\M[^\n]*|\mcleanup\M[^\n]*)(?=\n\s*(?:[\{\#]|setup|cleanup|$))} $lst "\n{\\1}"
}
proc _test_out_total {} {
upvar _ _
set tcnt [llength $_(itm)]
if {!$tcnt} {
puts ""
return
}
set mintm 0x7fffffff
set maxtm 0
set nettm 0
set wtm 0
set wcnt 0
set i 0
foreach tm $_(itm) {
if {[llength $tm] > 6} {
set nettm [expr {$nettm + [lindex $tm 6]}]
}
set wtm [expr {$wtm + [lindex $tm 0]}]
set wcnt [expr {$wcnt + [lindex $tm 2]}]
set tm [lindex $tm 0]
if {$tm > $maxtm} {set maxtm $tm; set maxi $i}
if {$tm < $mintm} {set mintm $tm; set mini $i}
incr i
}
puts [string repeat ** 40]
set s [format "%d cases in %.2f sec." $tcnt [expr {([clock milliseconds] - $_(starttime)) / 1000.0}]]
if {$nettm > 0} {
append s [format " (%.2f net-sec.)" [expr {$nettm / 1000.0}]]
}
puts "Total $s:"
lset _(m) 0 [format %.6f $wtm]
lset _(m) 2 $wcnt
lset _(m) 4 [format %.3f [expr {$wcnt / (($nettm ? $nettm : ($tcnt * [lindex $_(reptime) 0])) / 1000.0)}]]
if {[llength $_(m)] > 6} {
lset _(m) 6 [format %.3f $nettm]
}
puts $_(m)
puts "Average:"
lset _(m) 0 [format %.6f [expr {[lindex $_(m) 0] / $tcnt}]]
lset _(m) 2 [expr {[lindex $_(m) 2] / $tcnt}]
if {[llength $_(m)] > 6} {
lset _(m) 6 [format %.3f [expr {[lindex $_(m) 6] / $tcnt}]]
lset _(m) 4 [format %.0f [expr {[lindex $_(m) 2] / [lindex $_(m) 6] * 1000}]]
}
puts $_(m)
puts "Min:"
puts [lindex $_(itm) $mini]
puts "Max:"
puts [lindex $_(itm) $maxi]
puts [string repeat ** 40]
puts ""
unset -nocomplain _(itm) _(starttime)
}
proc _test_start {reptime} {
upvar _ _
array set _ [list itm {} reptime $reptime starttime [clock milliseconds] -from-run 0]
}
proc _test_iter {args} {
if {[llength $args] > 2} {
return -code error "wrong # args: should be \"[lindex [info level [info level]] 0] ?level? measure-result\""
}
set lvl 1
if {[llength $args] > 1} {
set args [lassign $args lvl]
}
upvar $lvl _ _
puts [set _(m) {*}$args]
lappend _(itm) $_(m)
puts ""
}
proc _adjust_maxcount {reptime maxcount} {
if {[llength $reptime] > 1} {
lreplace $reptime 1 1 [expr {min($maxcount,[lindex $reptime 1])}]
} else {
lappend reptime $maxcount
}
}
proc _test_run {args} {
upvar _ _
# parse args:
array set _ [set _opts {-no-result 0 -uplevel 0}]
while {[llength $args] > 2} {
if {[set o [lindex $args 0]] ni $_opts || $_($o)} {
break
}
set _($o) 1
set args [lrange $args 1 end]
}
unset -nocomplain _opts o
if {[llength $args] < 2 || [llength $args] > 3} {
return -code error "wrong # args: should be \"[lindex [info level [info level]] 0] ?-no-result? reptime lst ?outcmd?\""
}
set _(outcmd) {puts}
set args [lassign $args reptime lst]
if {[llength $args]} {
set _(outcmd) [lindex $args 0]
}
# avoid output if only once:
if {[lindex $reptime 0] <= 1 || ([llength $reptime] > 1 && [lindex $reptime 1] == 1)} {
set _(-no-result) 1
}
if {![info exists _(itm)]} {
array set _ [list itm {} reptime $reptime starttime [clock milliseconds] -from-run 1]
} else {
array set _ [list reptime $reptime]
}
# process measurement:
foreach _(c) [_test_get_commands $lst] {
{*}$_(outcmd) "% [regsub -all {\n[ \t]*} $_(c) {; }]"
if {[regexp {^\s*\#} $_(c)]} continue
if {[regexp {^\s*(?:setup|cleanup)\s+} $_(c)]} {
set _(c) [lindex $_(c) 1]
if {$_(-uplevel)} {
set _(c) [list uplevel 1 $_(c)]
}
{*}$_(outcmd) [if 1 $_(c)]
continue
}
if {$_(-uplevel)} {
set _(c) [list uplevel 1 $_(c)]
}
set _(ittime) $_(reptime)
# if output result (and not once):
if {!$_(-no-result)} {
set _(r) [if 1 $_(c)]
if {$_(outcmd) ne {}} {{*}$_(outcmd) $_(r)}
if {[llength $_(ittime)] > 1} { # decrement max-count
lset _(ittime) 1 [expr {[lindex $_(ittime) 1] - 1}]
}
}
{*}$_(outcmd) [set _(m) [timerate $_(c) {*}$_(ittime)]]
lappend _(itm) $_(m)
{*}$_(outcmd) ""
}
if {$_(-from-run)} {
_test_out_total
}
}
}; # end of namespace ::tclTestPerf
|
Added tests-perf/timer-event.perf.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 |
#!/usr/bin/tclsh
# ------------------------------------------------------------------------
#
# timer-event.perf.tcl --
#
# This file provides performance tests for comparison of tcl-speed
# of timer events (event-driven tcl-handling).
#
# ------------------------------------------------------------------------
#
# Copyright (c) 2014 Serg G. Brester (aka sebres)
#
# See the file "license.terms" for information on usage and redistribution
# of this file.
#
if {![namespace exists ::tclTestPerf]} {
source [file join [file dirname [info script]] test-performance.tcl]
}
namespace eval ::tclTestPerf-Timer-Event {
namespace path {::tclTestPerf}
proc test-queue {{reptime {1000 10000}}} {
set howmuch [lindex $reptime 1]
# because of extremely short measurement times by tests below, wait a little bit (warming-up),
# to minimize influence of the time-gradation (just for better dispersion resp. result-comparison)
timerate {after 0} 156
puts "*** up to $howmuch events ***"
# single iteration by update, so using -no-result (measure only):
_test_run -no-result $reptime [string map [list \{*\}\$reptime $reptime \$howmuch $howmuch \\# \#] {
# generate up to $howmuch idle-events:
{after idle {set foo bar}}
# update / after idle:
{update; if {![llength [after info]]} break}
# generate up to $howmuch idle-events:
{after idle {set foo bar}}
# update idletasks / after idle:
{update idletasks; if {![llength [after info]]} break}
# generate up to $howmuch immediate events:
{after 0 {set foo bar}}
# update / after 0:
{update; if {![llength [after info]]} break}
# generate up to $howmuch 1-ms events:
{after 1 {set foo bar}}
setup {after 1}
# update / after 1:
{update; if {![llength [after info]]} break}
# generate up to $howmuch immediate events (+ 1 event of the second generation):
{after 0 {after 0 {}}}
# update / after 0 (double generation):
{update; if {![llength [after info]]} break}
# cancel forwards "after idle" / $howmuch idle-events in queue:
setup {set i 0; timerate {set ev([incr i]) [after idle {set foo bar}]} {*}$reptime}
setup {set le $i; set i 0; list 1 .. $le; # cancel up to $howmuch events}
{after cancel $ev([incr i]); if {$i >= $le} break}
cleanup {update; unset -nocomplain ev}
# cancel backwards "after idle" / $howmuch idle-events in queue:
setup {set i 0; timerate {set ev([incr i]) [after idle {set foo bar}]} {*}$reptime}
setup {set le $i; incr i; list $le .. 1; # cancel up to $howmuch events}
{after cancel $ev([incr i -1]); if {$i <= 1} break}
cleanup {update; unset -nocomplain ev}
# cancel forwards "after 0" / $howmuch timer-events in queue:
setup {set i 0; timerate {set ev([incr i]) [after 0 {set foo bar}]} {*}$reptime}
setup {set le $i; set i 0; list 1 .. $le; # cancel up to $howmuch events}
{after cancel $ev([incr i]); if {$i >= $le} break}
cleanup {update; unset -nocomplain ev}
# cancel backwards "after 0" / $howmuch timer-events in queue:
setup {set i 0; timerate {set ev([incr i]) [after 0 {set foo bar}]} {*}$reptime}
setup {set le $i; incr i; list $le .. 1; # cancel up to $howmuch events}
{after cancel $ev([incr i -1]); if {$i <= 1} break}
cleanup {update; unset -nocomplain ev}
# end $howmuch events.
cleanup {if [llength [after info]] {error "unexpected: [llength [after info]] events are still there."}}
}]
}
proc test-access {{reptime {1000 5000}}} {
set howmuch [lindex $reptime 1]
_test_run $reptime [string map [list \{*\}\$reptime $reptime \$howmuch $howmuch] {
# event random access: after idle + after info (by $howmuch events)
setup {set i -1; timerate {set ev([incr i]) [after idle {}]} {*}$reptime}
{after info $ev([expr {int(rand()*$i)}])}
cleanup {update; unset -nocomplain ev}
# event random access: after 0 + after info (by $howmuch events)
setup {set i -1; timerate {set ev([incr i]) [after 0 {}]} {*}$reptime}
{after info $ev([expr {int(rand()*$i)}])}
cleanup {update; unset -nocomplain ev}
# end $howmuch events.
cleanup {if [llength [after info]] {error "unexpected: [llength [after info]] events are still there."}}
}]
}
proc test-exec {{reptime 1000}} {
_test_run $reptime {
# after idle + after cancel
{after cancel [after idle {set foo bar}]}
# after 0 + after cancel
{after cancel [after 0 {set foo bar}]}
# after idle + update idletasks
{after idle {set foo bar}; update idletasks}
# after idle + update
{after idle {set foo bar}; update}
# immediate: after 0 + update
{after 0 {set foo bar}; update}
# delayed: after 1 + update
{after 1 {set foo bar}; update}
# empty update:
{update}
# empty update idle tasks:
{update idletasks}
# simple shortest sleep:
{after 0}
}
}
proc test-nrt-capability {{reptime 1000}} {
_test_run $reptime {
# comparison values:
{after 0 {set a 5}; update}
{after 0 {set a 5}; vwait a}
# conditional vwait with very brief wait-time:
{after 1 {set a timeout}; vwait a; expr {$::a ne "timeout" ? 1 : "0[unset ::a]"}}
{after 0 {set a timeout}; vwait a; expr {$::a ne "timeout" ? 1 : "0[unset ::a]"}}
}
}
proc test-long {{reptime 1000}} {
_test_run $reptime {
# in-between important event by amount of idle events:
{time {after idle {after 30}} 10; after 1 {set important 1}; vwait important;}
cleanup {foreach i [after info] {after cancel $i}}
# in-between important event (of new generation) by amount of idle events:
{time {after idle {after 30}} 10; after 1 {after 0 {set important 1}}; vwait important;}
cleanup {foreach i [after info] {after cancel $i}}
}
}
proc test {{reptime 1000}} {
test-exec $reptime
foreach howmuch {5000 50000} {
test-access [list $reptime $howmuch]
}
test-nrt-capability $reptime
test-long $reptime
puts ""
foreach howmuch { 10000 20000 40000 60000 } {
test-queue [list $reptime $howmuch]
}
puts \n**OK**
}
}; # end of ::tclTestPerf-Timer-Event
# ------------------------------------------------------------------------
# if calling direct:
if {[info exists ::argv0] && [file tail $::argv0] eq [file tail [info script]]} {
array set in {-time 500}
array set in $argv
::tclTestPerf-Timer-Event::test $in(-time)
}
|
Changes to tests/all.tcl.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 | # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. package prefer latest package require Tcl 8.5- package require tcltest 2.2 | | > | > > > > > | | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 |
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
package prefer latest
package require Tcl 8.5-
package require tcltest 2.2
namespace import ::tcltest::*
configure {*}$argv -testdir [file dirname [file dirname [file normalize [
info script]/...]]]
if {[singleProcess]} {
interp debug {} -frame 1
}
set ErrorOnFailures [info exists env(ERROR_ON_FAILURES)]
unset -nocomplain env(ERROR_ON_FAILURES)
if {[runAllTests] && $ErrorOnFailures} {exit 1}
proc exit args {}
|
Changes to tests/assemble.test.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 |
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
#-----------------------------------------------------------------------------
# Commands covered: assemble
if {"::tcltest" ni [namespace children]} {
| | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
#-----------------------------------------------------------------------------
# Commands covered: assemble
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
namespace eval tcl::unsupported {namespace export assemble}
namespace import tcl::unsupported::assemble
# Procedure to make code that fills the literal and local variable tables, to
# force instructions to spill to four bytes.
|
| ︙ | ︙ | |||
836 837 838 839 840 841 842 |
-result {1 {cannot use this instruction to create a variable in a non-proc context} {TCL ASSEM LVT}}
-cleanup {unset result}
}
test assemble-8.5 {bad context} {
-body {
namespace eval assem {
set x 1
| | | > | 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 |
-result {1 {cannot use this instruction to create a variable in a non-proc context} {TCL ASSEM LVT}}
-cleanup {unset result}
}
test assemble-8.5 {bad context} {
-body {
namespace eval assem {
set x 1
assemble {load x}
}
}
-result {cannot use this instruction to create a variable in a non-proc context}
-errorCode {TCL ASSEM LVT}
-cleanup {namespace delete assem}
}
test assemble-8.6 {load1} {
-body {
proc x {a} {
assemble {
load a
|
| ︙ | ︙ | |||
1094 1095 1096 1097 1098 1099 1100 |
-body {
assemble {push h; push e; push l; push l; push o; concat 5}
}
-result hello
}
test assemble-9.7 {concat} {
-body {
| | | | | 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 |
-body {
assemble {push h; push e; push l; push l; push o; concat 5}
}
-result hello
}
test assemble-9.7 {concat} {
-body {
assemble {concat 0}
}
-result {operand must be positive}
-errorCode {TCL ASSEM POSITIVE}
}
# assemble-10 -- eval and expr
test assemble-10.1 {eval - wrong # args} {
-body {
assemble {eval}
|
| ︙ | ︙ |
Changes to tests/async.test.
| ︙ | ︙ | |||
16 17 18 19 20 21 22 |
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testasync [llength [info commands testasync]]
| < | 16 17 18 19 20 21 22 23 24 25 26 27 28 29 |
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testasync [llength [info commands testasync]]
proc async1 {result code} {
global aresult acode
set aresult $result
set acode $code
return "new result"
}
|
| ︙ | ︙ | |||
145 146 147 148 149 150 151 |
test async-3.1 {deleting handlers} testasync {
set x {}
list [catch {testasync mark $hm2 "foobar" 5} msg] $msg $x
} {3 del2 {0 0 0 del1 del2}}
test async-4.1 {async interrupting bytecode sequence} -constraints {
| | | | | > | > | | > > | | > > > | > | > | | > > > > > > | > > > | 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 |
test async-3.1 {deleting handlers} testasync {
set x {}
list [catch {testasync mark $hm2 "foobar" 5} msg] $msg $x
} {3 del2 {0 0 0 del1 del2}}
test async-4.1 {async interrupting bytecode sequence} -constraints {
testasync
} -setup {
set hm [testasync create async3]
proc nothing {} {
# empty proc
}
} -body {
apply {{handle} {
global aresult
set aresult {Async event not delivered}
testasync marklater $handle
# allow plenty of time to pass in case valgrind is running
set start [clock seconds]
while {
[clock seconds] - $start < 180 && $aresult eq "Async event not delivered"
} {
# be less busy
after 100
nothing
}
return $aresult
}} $hm
} -result {test pattern} -cleanup {
# give other threads some time to go way so that valgrind doesn't pick up
# "still reachable" cases from early thread termination
after 100
testasync delete $hm
}
test async-4.2 {async interrupting straight bytecode sequence} -constraints {
testasync
} -setup {
set hm [testasync create async3]
} -body {
apply {{handle} {
global aresult
set aresult {Async event not delivered}
testasync marklater $handle
# allow plenty of time to pass in case valgrind is running
set start [clock seconds]
while {
[clock seconds] - $start < 180 && $aresult eq "Async event not delivered"
} {
# be less busy
after 100
}
return $aresult
}} $hm
} -result {test pattern} -cleanup {
# give other threads some time to go way so that valgrind doesn't pick up
# "still reachable" cases from early thread termination
after 100
testasync delete $hm
}
test async-4.3 {async interrupting loop-less bytecode sequence} -constraints {
testasync
} -setup {
set hm [testasync create async3]
} -body {
apply [list {handle} [concat {
global aresult
set aresult {Async event not delivered}
testasync marklater $handle
set i 0
} "[string repeat {;incr i;} 1500000]after 10;" {
return $aresult
}]] $hm
} -result {test pattern} -cleanup {
# give other threads some time to go way so that valgrind doesn't pick up
# "still reachable" cases from early thread termination
after 100
testasync delete $hm
}
# cleanup
if {[testConstraint testasync]} {
testasync delete
}
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Changes to tests/basic.test.
| ︙ | ︙ | |||
666 667 668 669 670 671 672 |
set l1 [list a {b b} c d]
set l2 [list e f {g g} h]
proc l3 {} {
list i j k {l l}
}
# Do all tests once byte compiled and once with direct string evaluation
| | | 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 |
set l1 [list a {b b} c d]
set l2 [list e f {g g} h]
proc l3 {} {
list i j k {l l}
}
# Do all tests once byte compiled and once with direct string evaluation
foreach noComp {0 1} {
if $noComp {
interp alias {} run {} testevalex
set constraints testevalex
} else {
interp alias {} run {} if 1
set constraints {}
|
| ︙ | ︙ | |||
953 954 955 956 957 958 959 960 961 962 963 964 965 966 |
lappend res $t
lappend res [catch { run { {*}{error Hejsan} } } err]
lappend res $err
} -cleanup {
unset res t
} -result {0 10 1 Hejsan}
} ;# End of noComp loop
test basic-49.1 {Tcl_EvalEx: verify TCL_EVAL_GLOBAL operation} testevalex {
set ::x global
namespace eval ns {
variable x namespace
| > > > > > > > > > > > > > > > > > > | 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 |
lappend res $t
lappend res [catch { run { {*}{error Hejsan} } } err]
lappend res $err
} -cleanup {
unset res t
} -result {0 10 1 Hejsan}
test basic-48.24.$noComp {expansion: empty not canonical list, regression test, bug [cc1e91552c]} -constraints $constraints -setup {
unset -nocomplain a
} -body {
run {list [list {*}{ }] [list {*}[format %c 32]] [list {*}[set a { }]]}
} -result [lrepeat 3 {}] -cleanup {unset -nocomplain a}
test basic-48.25.$noComp {Bug cc191552c: expansion: empty non-canonical list} -setup {
unset -nocomplain ::CRLF
set ::CRLF "\r\n"
} -body {
# Force variant that turned up in Bug 2c154a40be as that's externally
# noticeable in an important downstream project.
run {scan [list {*}$::CRLF]x %c%c%c}
} -cleanup {
unset -nocomplain ::CRLF
} -result {120 {} {}}
} ;# End of noComp loop
test basic-49.1 {Tcl_EvalEx: verify TCL_EVAL_GLOBAL operation} testevalex {
set ::x global
namespace eval ns {
variable x namespace
|
| ︙ | ︙ |
Changes to tests/binary.test.
| ︙ | ︙ | |||
1643 1644 1645 1646 1647 1648 1649 |
test binary-43.1 {Tcl_BinaryObjCmd: format wide int} {} {
binary format w 7810179016327718216
} HelloTcl
test binary-43.2 {Tcl_BinaryObjCmd: format wide int} {} {
binary format W 7810179016327718216
} lcTolleH
| < < < < < < < < < < < < < < < < > > > > > > > > > > > > > > > > > > > > > > > > > | 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 |
test binary-43.1 {Tcl_BinaryObjCmd: format wide int} {} {
binary format w 7810179016327718216
} HelloTcl
test binary-43.2 {Tcl_BinaryObjCmd: format wide int} {} {
binary format W 7810179016327718216
} lcTolleH
test binary-43.5 {Tcl_BinaryObjCmd: scan wide int} {} {
unset -nocomplain arg1
list [binary scan \x80[string repeat \x00 7] W arg1] $arg1
} {1 -9223372036854775808}
test binary-43.6 {Tcl_BinaryObjCmd: scan unsigned wide int} {} {
unset -nocomplain arg1
list [binary scan \x80[string repeat \x00 7] Wu arg1] $arg1
} {1 9223372036854775808}
test binary-43.7 {Tcl_BinaryObjCmd: scan unsigned wide int} {} {
unset -nocomplain arg1
list [binary scan [string repeat \x00 7]\x80 wu arg1] $arg1
} {1 9223372036854775808}
test binary-43.8 {Tcl_BinaryObjCmd: scan unsigned wide int} {} {
unset -nocomplain arg1 arg2
list [binary scan \x80[string repeat \x00 7]\x80[string repeat \x00 7] WuW arg1 arg2] $arg1 $arg2
} {2 9223372036854775808 -9223372036854775808}
test binary-43.9 {Tcl_BinaryObjCmd: scan unsigned wide int} {} {
unset -nocomplain arg1 arg2
list [binary scan [string repeat \x00 7]\x80[string repeat \x00 7]\x80 wuw arg1 arg2] $arg1 $arg2
} {2 9223372036854775808 -9223372036854775808}
test binary-44.1 {Tcl_BinaryObjCmd: scan wide int} {} {
binary scan HelloTcl W x
set x
} 5216694956358656876
test binary-44.2 {Tcl_BinaryObjCmd: scan wide int} {} {
binary scan lcTolleH w x
set x
} 5216694956358656876
test binary-44.3 {Tcl_BinaryObjCmd: scan wide int with bit 31 set} {} {
binary scan [binary format w [expr {wide(3) << 31}]] w x
set x
} 6442450944
test binary-44.4 {Tcl_BinaryObjCmd: scan wide int with bit 31 set} {} {
binary scan [binary format W [expr {wide(3) << 31}]] W x
set x
} 6442450944
test binary-44.5 {Tcl_BinaryObjCmd: scan wide int with bit 31 and 64 set} {} {
binary scan [binary format w [expr {(wide(3) << 31) + (wide(3) << 64)}]] w x
set x
} 6442450944
test binary-44.6 {Tcl_BinaryObjCmd: scan wide int with bit 31 and 64 set} {} {
binary scan [binary format W [expr {(wide(3) << 31) + (wide(3) << 64)}]] W x
set x
} 6442450944
test binary-45.1 {Tcl_BinaryObjCmd: combined wide int handling} {
binary scan [binary format sws 16450 -1 19521] c* x
set x
} {66 64 -1 -1 -1 -1 -1 -1 -1 -1 65 76}
test binary-45.2 {Tcl_BinaryObjCmd: combined wide int handling} {
binary scan [binary format sWs 16450 0x7fffffff 19521] c* x
|
| ︙ | ︙ | |||
2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 |
} -returnCodes error -match glob -result {invalid base64 character *}
test binary-73.30 {binary decode base64} -body {
list [string length [set r [binary decode base64 -strict WFla\n]]] $r
} -returnCodes error -match glob -result {invalid base64 character *}
test binary-73.31 {binary decode base64} -body {
list [string length [set r [binary decode base64 WA==WFla]]] $r
} -returnCodes error -match glob -result {invalid base64 character *}
test binary-74.1 {binary encode uuencode} -body {
binary encode uuencode
} -returnCodes error -match glob -result "wrong # args: *"
test binary-74.2 {binary encode uuencode} -body {
binary encode uuencode abc
} -result {#86)C
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 |
} -returnCodes error -match glob -result {invalid base64 character *}
test binary-73.30 {binary decode base64} -body {
list [string length [set r [binary decode base64 -strict WFla\n]]] $r
} -returnCodes error -match glob -result {invalid base64 character *}
test binary-73.31 {binary decode base64} -body {
list [string length [set r [binary decode base64 WA==WFla]]] $r
} -returnCodes error -match glob -result {invalid base64 character *}
test binary-73.32 {binary decode base64, bug [00d04c4f12]} -body {
list \
[string length [binary decode base64 =]] \
[string length [binary decode base64 " ="]] \
[string length [binary decode base64 " ="]] \
[string length [binary decode base64 "\r\n\t="]] \
} -result [lrepeat 4 0]
test binary-73.33 {binary decode base64, bug [00d04c4f12]} -body {
list \
[string length [binary decode base64 ==]] \
[string length [binary decode base64 " =="]] \
[string length [binary decode base64 " =="]] \
[string length [binary decode base64 " =="]] \
} -result [lrepeat 4 0]
test binary-73.34 {binary decode base64, (compatibility) unfulfilled base64 (single char) in non-strict mode} -body {
list \
[expr {[binary decode base64 a] eq [binary decode base64 ""]}] \
[expr {[binary decode base64 abcda] eq [binary decode base64 "abcd"]}]
} -result [lrepeat 2 1]
test binary-73.35 {binary decode base64, bad base64 in strict mode} -body {
set r {}
foreach c {a " a" " a" " a" " a" abcda abcdabcda a= a== abcda= abcda==} {
lappend r \
[catch {binary decode base64 $c}] \
[catch {binary decode base64 -strict $c}]
}
set r
} -result [lrepeat 11 0 1]
test binary-73.36 {binary decode base64: check encoded & decoded equals original} -body {
set r {}
for {set i 0} {$i < 255 && [llength $r] < 20} {incr i} {
foreach c {1 2 3 4 5 6 7 8} {
set c [string repeat [format %c $i] $c]
if {[set a [binary decode base64 [set x [binary encode base64 $c]]]] ne $c} {
lappend r "encode & decode is wrong on string `$c` (encoded: $x): `$a` != `$c`"
}
}
}
join $r \n
} -result {}
test binary-74.1 {binary encode uuencode} -body {
binary encode uuencode
} -returnCodes error -match glob -result "wrong # args: *"
test binary-74.2 {binary encode uuencode} -body {
binary encode uuencode abc
} -result {#86)C
|
| ︙ | ︙ | |||
2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 |
test binary-77.2 {string cat ops on all bytearrays} {
apply {{a b} {
set one [binary format H* $a]
return $one[binary format H* $b]
}} ab cd
} [binary format H* abcd]
# ----------------------------------------------------------------------
# cleanup
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
| > > > > > > | 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 |
test binary-77.2 {string cat ops on all bytearrays} {
apply {{a b} {
set one [binary format H* $a]
return $one[binary format H* $b]
}} ab cd
} [binary format H* abcd]
test binary-78.1 {unicode (out of BMP) to byte-array conversion, bug-[bd94500678]} -body {
# just test for BO-segfault (high surrogate w/o advance source pointer for out of BMP char if TCL_UTF_MAX <= 4):
binary encode hex \U0001f415
binary scan \U0001f415 a* v; set v
set str {}
} -result {}
# ----------------------------------------------------------------------
# cleanup
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Changes to tests/chanio.test.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 16 17 |
# Copyright (c) 1991-1994 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
| > < < < < < < > | | > | > > > < < < < | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 |
# Copyright (c) 1991-1994 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
# TODO: This test is likely worthless. Confirm and remove
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
}
namespace eval ::tcl::test::io {
namespace import ::tcltest::*
variable umaskValue
variable path
variable f
variable i
variable n
variable v
variable msg
variable expected
catch {
::tcltest::loadTestedCommands
package require -exact Tcltest [info patchlevel]
set ::tcltestlib [lindex [package ifneeded Tcltest [info patchlevel]] 1]
}
package require tcltests
testConstraint testbytestring [llength [info commands testbytestring]]
testConstraint testchannel [llength [info commands testchannel]]
testConstraint openpipe 1
testConstraint testfevent [llength [info commands testfevent]]
testConstraint testchannelevent [llength [info commands testchannelevent]]
testConstraint testmainthread [llength [info commands testmainthread]]
# You need a *very* special environment to do some tests. In particular,
# many file systems do not support large-files...
testConstraint largefileSupport [expr {$::tcl_platform(os) ne "Darwin"}]
# some tests can only be run is umask is 2 if "umask" cannot be run, the
# tests will be skipped.
|
| ︙ | ︙ | |||
5960 5961 5962 5963 5964 5965 5966 |
chan puts $f {exit}
vwait [namespace which -variable x]
list $x $l
} -cleanup {
chan close $f
} -result {done {0 1 0 1 0 1 0 1 0 1 0 1 0 0}}
unset path(bar)
| | | 5956 5957 5958 5959 5960 5961 5962 5963 5964 5965 5966 5967 5968 5969 5970 |
chan puts $f {exit}
vwait [namespace which -variable x]
list $x $l
} -cleanup {
chan close $f
} -result {done {0 1 0 1 0 1 0 1 0 1 0 1 0 0}}
unset path(bar)
removeFile bar
test chan-io-48.4 {lf write, testing readability, ^Z termination, auto read mode} -setup {
file delete $path(test1)
set c 0
set l ""
} -constraints {fileevent} -body {
set f [open $path(test1) w]
|
| ︙ | ︙ | |||
7449 7450 7451 7452 7453 7454 7455 7456 7457 7458 7459 7460 7461 7462 |
chan close $f
string equal $result [testmainthread]
} {1}
test chan-io-60.1 {writing illegal utf sequences} {openpipe fileevent testbytestring} {
# This test will hang in older revisions of the core.
set out [open $path(script) w]
chan puts $out {
chan puts [testbytestring \xe2]
exit 1
}
proc readit {pipe} {
variable x
variable result
| > | 7445 7446 7447 7448 7449 7450 7451 7452 7453 7454 7455 7456 7457 7458 7459 |
chan close $f
string equal $result [testmainthread]
} {1}
test chan-io-60.1 {writing illegal utf sequences} {openpipe fileevent testbytestring} {
# This test will hang in older revisions of the core.
set out [open $path(script) w]
chan puts $out "catch {load $::tcltestlib Tcltest}"
chan puts $out {
chan puts [testbytestring \xe2]
exit 1
}
proc readit {pipe} {
variable x
variable result
|
| ︙ | ︙ |
Changes to tests/clock.test.
| ︙ | ︙ | |||
245 246 247 248 249 250 251 252 253 254 255 256 257 258 |
return -code error "test case attempts to write/query the registry"
}
if { ![dict exists $reg $path $key] } {
return -code error "test case attempts to read unknown registry entry $path $key"
}
return [dict get $reg $path $key]
}
# Test some of the basics of [clock format]
test clock-1.0 "clock format - wrong # args" {
list [catch {clock format} msg] $msg $::errorCode
} {1 {wrong # args: should be "clock format clockval ?-format string? ?-gmt boolean? ?-locale LOCALE? ?-timezone ZONE?"} {CLOCK wrongNumArgs}}
| > > > > > > > > > > > > | 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 |
return -code error "test case attempts to write/query the registry"
}
if { ![dict exists $reg $path $key] } {
return -code error "test case attempts to read unknown registry entry $path $key"
}
return [dict get $reg $path $key]
}
proc timeWithinDuration {duration start end} {
regexp {([\d.]+)(s|ms|us)} $duration -> duration unit
if {[llength $start] > 1} { set start [expr "([join $start +])/[llength $start]"] }
if {[llength $end] > 1} { set end [expr "([join $end +])/[llength $end]"] }
set delta [expr {$end - $start}]
expr {
($delta > 0) && ($delta <= $duration) ?
"ok" :
"test should have taken 0-$duration $unit, actually took $delta"}
}
# Test some of the basics of [clock format]
test clock-1.0 "clock format - wrong # args" {
list [catch {clock format} msg] $msg $::errorCode
} {1 {wrong # args: should be "clock format clockval ?-format string? ?-gmt boolean? ?-locale LOCALE? ?-timezone ZONE?"} {CLOCK wrongNumArgs}}
|
| ︙ | ︙ | |||
35421 35422 35423 35424 35425 35426 35427 |
expr [clock clicks]+1
concat {}
} {}
test clock-33.2 {clock clicks tests} {
set start [clock clicks]
after 10
set end [clock clicks]
| | | | | < | < | < | | < < > > | < | < | < | | | | | < | > > | | < | > | | | > | | | 35433 35434 35435 35436 35437 35438 35439 35440 35441 35442 35443 35444 35445 35446 35447 35448 35449 35450 35451 35452 35453 35454 35455 35456 35457 35458 35459 35460 35461 35462 35463 35464 35465 35466 35467 35468 35469 35470 35471 35472 35473 35474 35475 35476 35477 35478 35479 35480 35481 35482 35483 35484 35485 35486 35487 35488 35489 35490 35491 35492 35493 35494 35495 35496 35497 35498 35499 35500 35501 35502 |
expr [clock clicks]+1
concat {}
} {}
test clock-33.2 {clock clicks tests} {
set start [clock clicks]
after 10
set end [clock clicks]
expr {$end > $start}
} {1}
test clock-33.3 {clock clicks tests} {
list [catch {clock clicks foo} msg] $msg
} {1 {bad option "foo": must be -milliseconds or -microseconds}}
test clock-33.4 {clock clicks tests} {
expr [clock clicks -milliseconds]+1
concat {}
} {}
test clock-33.4a {clock milliseconds} {
expr { [clock milliseconds] + 1 }
concat {}
} {}
test clock-33.5 {clock clicks tests, millisecond timing test} {
set start [set end {}]
lassign [time {
lappend start [clock clicks -milli]
after 1 {lappend end [clock clicks -milli]}
vwait end
} 5] tm
timeWithinDuration [expr {int($tm/1000 + 1)}]ms $start $end
} {ok}
test clock-33.5a {clock tests, millisecond timing test} {
set start [set end {}]
lassign [time {
lappend start [clock milliseconds]
after 1 {lappend end [clock milliseconds]}
vwait end
} 5] tm
timeWithinDuration [expr {int($tm/1000 + 1)}]ms $start $end
} {ok}
test clock-33.6 {clock clicks, milli with too much abbreviation} {
list [catch { clock clicks ? } msg] $msg
} {1 {bad option "?": must be -milliseconds or -microseconds}}
test clock-33.7 {clock clicks, milli with too much abbreviation} {
list [catch { clock clicks - } msg] $msg
} {1 {ambiguous option "-": must be -milliseconds or -microseconds}}
test clock-33.8 {clock clicks test, microsecond timing test} {
set start [set end {}]
lassign [time {
lappend start [clock clicks -micro]
after 1 {lappend end [clock clicks -micro]}
vwait end
} 5] tm
timeWithinDuration [expr {int($tm + 10)}]us $start $end
} {ok}
test clock-33.8a {clock test, microsecond timing test} {
set start [set end {}]
lassign [time {
lappend start [clock microseconds]
after 1 {lappend end [clock microseconds]}
vwait end
} 5] tm
timeWithinDuration [expr {int($tm + 10)}]us $start $end
} {ok}
test clock-33.9 {clock clicks test, millis align with seconds} {
set t1 [clock seconds]
while { 1 } {
set t2 [clock clicks -millis]
set t3 [clock seconds]
if { $t3 == $t1 } break
|
| ︙ | ︙ | |||
35822 35823 35824 35825 35826 35827 35828 |
test clock-35.2 {clock seconds tests} {
list [catch {clock seconds foo} msg] $msg
} {1 {wrong # args: should be "clock seconds"}}
test clock-35.3 {clock seconds tests} {
set start [clock seconds]
after 2000
set end [clock seconds]
| | | 35830 35831 35832 35833 35834 35835 35836 35837 35838 35839 35840 35841 35842 35843 35844 |
test clock-35.2 {clock seconds tests} {
list [catch {clock seconds foo} msg] $msg
} {1 {wrong # args: should be "clock seconds"}}
test clock-35.3 {clock seconds tests} {
set start [clock seconds]
after 2000
set end [clock seconds]
expr {$end > $start}
} {1}
test clock-36.1 {clock scan next monthname} {
clock format [clock scan "next june" -base [clock scan "june 1, 2000"]] \
-format %m.%Y
} "06.2001"
|
| ︙ | ︙ | |||
36695 36696 36697 36698 36699 36700 36701 |
}
}
return $retval
}
}
-body {
set trouble {}
| | | | | | | | | | > > | | 36703 36704 36705 36706 36707 36708 36709 36710 36711 36712 36713 36714 36715 36716 36717 36718 36719 36720 36721 36722 36723 36724 36725 36726 36727 36728 |
}
}
return $retval
}
}
-body {
set trouble {}
foreach {date jdate} {
1872-12-31 \u897f\u66a61872\u5e7412\u670831\u65e5
1873-01-01 \u660e\u6cbb06\u5e7401\u670801\u65e5
1912-07-29 \u660e\u6cbb45\u5e7407\u670829\u65e5
1912-07-30 \u5927\u6b6301\u5e7407\u670830\u65e5
1926-12-24 \u5927\u6b6315\u5e7412\u670824\u65e5
1926-12-25 \u662d\u548c01\u5e7412\u670825\u65e5
1989-01-07 \u662d\u548c64\u5e7401\u670807\u65e5
1989-01-08 \u5e73\u621001\u5e7401\u670808\u65e5
2019-04-30 \u5e73\u621031\u5e7404\u670830\u65e5
2019-05-01 \u4ee4\u548c01\u5e7405\u670801\u65e5
} {
set status [catch {
set secs [clock scan $date \
-timezone +0900 \
-locale ja_JP \
-format %Y-%m-%d]
set jda [clock format $secs \
-timezone +0900 \
|
| ︙ | ︙ |
Changes to tests/cmdAH.test.
| ︙ | ︙ | |||
19 20 21 22 23 24 25 |
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testchmod [llength [info commands testchmod]]
testConstraint testsetplatform [llength [info commands testsetplatform]]
testConstraint testvolumetype [llength [info commands testvolumetype]]
testConstraint linkDirectory [expr {
![testConstraint win] ||
| | | 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 |
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testchmod [llength [info commands testchmod]]
testConstraint testsetplatform [llength [info commands testsetplatform]]
testConstraint testvolumetype [llength [info commands testvolumetype]]
testConstraint linkDirectory [expr {
![testConstraint win] ||
($::tcl_platform(osVersion) >= 5.0
&& [lindex [file system [temporaryDirectory]] 1] eq "NTFS")
}]
global env
set cmdAHwd [pwd]
catch {set platform [testgetplatform]}
|
| ︙ | ︙ | |||
229 230 231 232 233 234 235 |
} -result iso8859-1
test cmdAH-5.1 {Tcl_FileObjCmd} -returnCodes error -body {
file
} -result {wrong # args: should be "file subcommand ?arg ...?"}
test cmdAH-5.2 {Tcl_FileObjCmd} -returnCodes error -body {
file x
| | | 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 |
} -result iso8859-1
test cmdAH-5.1 {Tcl_FileObjCmd} -returnCodes error -body {
file
} -result {wrong # args: should be "file subcommand ?arg ...?"}
test cmdAH-5.2 {Tcl_FileObjCmd} -returnCodes error -body {
file x
} -result {unknown or ambiguous subcommand "x": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mkdir, mtime, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, tempdir, tempfile, type, volumes, or writable}
test cmdAH-5.3 {Tcl_FileObjCmd} -returnCodes error -body {
file exists
} -result {wrong # args: should be "file exists name"}
test cmdAH-5.4 {Tcl_FileObjCmd} {
file exists ""
} 0
|
| ︙ | ︙ | |||
560 561 562 563 564 565 566 567 568 569 570 571 572 573 |
testsetplatform windows
file tail {c:/foo\bar}
} bar
test cmdAH-9.51 {Tcl_FileObjCmd: tail} testsetplatform {
testsetplatform windows
file tail {foo\bar}
} bar
# rootname
test cmdAH-10.1 {Tcl_FileObjCmd: rootname} -returnCodes error -body {
file rootname a b
} -result {wrong # args: should be "file rootname name"}
test cmdAH-10.2 {Tcl_FileObjCmd: rootname} testsetplatform {
testsetplatform unix
| > > > > > > > | 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 |
testsetplatform windows
file tail {c:/foo\bar}
} bar
test cmdAH-9.51 {Tcl_FileObjCmd: tail} testsetplatform {
testsetplatform windows
file tail {foo\bar}
} bar
test cmdAH-9.52 {Tcl_FileObjCmd: tail / normalize, bug 7a9dc52b29} {
list \
[file tail {~/~foo}] \
[file tail {~/test/~foo}] \
[file tail [file normalize {~/~foo}]] \
[file tail [file normalize {~/test/~foo}]]
} [lrepeat 4 ./~foo]
# rootname
test cmdAH-10.1 {Tcl_FileObjCmd: rootname} -returnCodes error -body {
file rootname a b
} -result {wrong # args: should be "file rootname name"}
test cmdAH-10.2 {Tcl_FileObjCmd: rootname} testsetplatform {
testsetplatform unix
|
| ︙ | ︙ | |||
1034 1035 1036 1037 1038 1039 1040 |
} -constraints {win} -body {
file atime con
} -result "could not get access time for file \"con\"" -returnCodes error
test cmdAH-20.7.1 {
Tcl_FileObjCmd: atime (built-in Windows names with dir path and extension)
} -constraints {win} -body {
file atime [file join [temporaryDirectory] CON.txt]
| | | 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 |
} -constraints {win} -body {
file atime con
} -result "could not get access time for file \"con\"" -returnCodes error
test cmdAH-20.7.1 {
Tcl_FileObjCmd: atime (built-in Windows names with dir path and extension)
} -constraints {win} -body {
file atime [file join [temporaryDirectory] CON.txt]
} -match regexp -result {could not (?:get access time|read)} -returnCodes error
if {[testConstraint unix] && [file exists /tmp]} {
removeFile touch.me /tmp
} else {
removeFile touch.me
}
|
| ︙ | ︙ | |||
1275 1276 1277 1278 1279 1280 1281 |
} -constraints {win} -body {
file mtime con
} -result "could not get modification time for file \"con\"" -returnCodes error
test cmdAH-24.14.1 {
Tcl_FileObjCmd: mtime (built-in Windows names with dir path and extension)
} -constraints {win} -body {
file mtime [file join [temporaryDirectory] CON.txt]
| | | 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 |
} -constraints {win} -body {
file mtime con
} -result "could not get modification time for file \"con\"" -returnCodes error
test cmdAH-24.14.1 {
Tcl_FileObjCmd: mtime (built-in Windows names with dir path and extension)
} -constraints {win} -body {
file mtime [file join [temporaryDirectory] CON.txt]
} -match regexp -result {could not (?:get modification time|read)} -returnCodes error
# owned
test cmdAH-25.1 {Tcl_FileObjCmd: owned} -returnCodes error -body {
file owned a b
} -result {wrong # args: should be "file owned name"}
test cmdAH-25.2 {Tcl_FileObjCmd: owned} -constraints win -body {
file owned $gorpfile
|
| ︙ | ︙ | |||
1339 1340 1341 1342 1343 1344 1345 |
Tcl_FileObjCmd: size (built-in Windows names)
} -constraints {win} -body {
file size con
} -result 0
test cmdAH-27.4.1 {
Tcl_FileObjCmd: size (built-in Windows names with dir path and extension)
} -constraints {win} -body {
| > | > > > > | 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 |
Tcl_FileObjCmd: size (built-in Windows names)
} -constraints {win} -body {
file size con
} -result 0
test cmdAH-27.4.1 {
Tcl_FileObjCmd: size (built-in Windows names with dir path and extension)
} -constraints {win} -body {
try {
set res [file size [file join [temporaryDirectory] con.txt]]
} trap {POSIX ENOENT} {} {
set res 0
}
set res
} -result 0
catch {testsetplatform $platform}
removeFile $gorpfile
set gorpfile [makeFile "Test string" gorp.file]
catch {file attributes $gorpfile -permissions 0765}
|
| ︙ | ︙ | |||
1441 1442 1443 1444 1445 1446 1447 |
} -body {
file stat con stat
lmap elem {atime ctime dev gid ino mode mtime nlink size type uid} {set stat($elem)}
} -result {0 0 -1 0 0 8630 0 0 0 characterSpecial 0}
test cmdAH-28.13.1 {Tcl_FileObjCmd: stat (built-in Windows names)} -constraints {win} -setup {
unset -nocomplain stat
} -body {
| > | | > > > > | 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 |
} -body {
file stat con stat
lmap elem {atime ctime dev gid ino mode mtime nlink size type uid} {set stat($elem)}
} -result {0 0 -1 0 0 8630 0 0 0 characterSpecial 0}
test cmdAH-28.13.1 {Tcl_FileObjCmd: stat (built-in Windows names)} -constraints {win} -setup {
unset -nocomplain stat
} -body {
try {
file stat [file join [temporaryDirectory] CON.txt] stat
set res [lmap elem {atime ctime dev gid ino mode mtime nlink size type uid} {set stat($elem)}]
} trap {POSIX ENOENT} {} {
set res {0 0 -1 0 0 8630 0 0 0 characterSpecial 0}
}
set res
} -result {0 0 -1 0 0 8630 0 0 0 characterSpecial 0}
unset -nocomplain stat
# type
test cmdAH-29.1 {Tcl_FileObjCmd: type} -returnCodes error -body {
file type a b
} -result {wrong # args: should be "file type name"}
|
| ︙ | ︙ | |||
1492 1493 1494 1495 1496 1497 1498 |
Tcl_FileObjCmd: type (built-in Windows names)
} -constraints {win} -body {
file type con
} -result "characterSpecial"
test cmdAH-29.6.1 {
Tcl_FileObjCmd: type (built-in Windows names, with dir path and extension)
} -constraints {win} -body {
| > | > > > > | | 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 |
Tcl_FileObjCmd: type (built-in Windows names)
} -constraints {win} -body {
file type con
} -result "characterSpecial"
test cmdAH-29.6.1 {
Tcl_FileObjCmd: type (built-in Windows names, with dir path and extension)
} -constraints {win} -body {
try {
set res [file type [file join [temporaryDirectory] CON.txt]]
} trap {POSIX ENOENT} {} {
set res {characterSpecial}
}
set res
} -result "characterSpecial"
# Error conditions
test cmdAH-30.1 {Tcl_FileObjCmd: error conditions} -returnCodes error -body {
file gorp x
} -result {unknown or ambiguous subcommand "gorp": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mkdir, mtime, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, tempdir, tempfile, type, volumes, or writable}
test cmdAH-30.2 {Tcl_FileObjCmd: error conditions} -returnCodes error -body {
file ex x
} -match glob -result {unknown or ambiguous subcommand "ex": must be *}
test cmdAH-30.3 {Tcl_FileObjCmd: error conditions} -returnCodes error -body {
file is x
} -match glob -result {unknown or ambiguous subcommand "is": must be *}
test cmdAH-30.4 {Tcl_FileObjCmd: error conditions} -returnCodes error -body {
|
| ︙ | ︙ | |||
1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 |
set template [file join $dirfile foo]
close [file tempfile name $template.bar]
expr {[string match $template*.bar $name] ? "ok" :
"$template.bar produced $name"}
} -constraints {unix nonPortable} -cleanup {
catch {file delete $name}
} -result ok
# This shouldn't work, but just in case a test above failed...
catch {close $newFileId}
interp delete safeInterp
interp delete simpleInterp
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 |
set template [file join $dirfile foo]
close [file tempfile name $template.bar]
expr {[string match $template*.bar $name] ? "ok" :
"$template.bar produced $name"}
} -constraints {unix nonPortable} -cleanup {
catch {file delete $name}
} -result ok
test cmdAH-33.1 {file tempdir} -body {
file tempdir a b
} -returnCodes error -result {wrong # args: should be "file tempdir ?template?"}
test cmdAH-33.2 {file tempdir} -body {
set d [file tempdir]
list [file tail $d] [file exists $d] [file type $d] \
[glob -nocomplain -directory $d *]
} -match glob -result {tcl_* 1 directory {}} -cleanup {
catch {file delete $d}
}
test cmdAH-33.3 {file tempdir} -body {
set d [file tempdir gorp]
list [file tail $d] [file exists $d] [file type $d] \
[glob -nocomplain -directory $d *]
} -match glob -result {gorp_* 1 directory {}} -cleanup {
catch {file delete $d}
}
test cmdAH-33.4 {file tempdir} -setup {
set base [file join [temporaryDirectory] gorp]
file mkdir $base
} -body {
set pre [glob -nocomplain -directory $base *]
set d [file normalize [file tempdir $base/]]
list [string map [list $base GORP:] $d] [file exists $d] [file type $d] \
$pre [glob -nocomplain -directory $d *]
} -match glob -result {GORP:/tcl_* 1 directory {} {}} -cleanup {
catch {file delete -force $base}
}
test cmdAH-33.5 {file tempdir} -setup {
set base [file join [temporaryDirectory] gorp]
file mkdir $base
} -body {
set pre [glob -nocomplain -directory $base *]
set d [file normalize [file tempdir $base/gorp]]
list [string map [list $base GORP:] $d] [file exists $d] [file type $d] \
$pre [glob -nocomplain -directory $d *]
} -match glob -result {GORP:/gorp_* 1 directory {} {}} -cleanup {
catch {file delete -force $base}
}
test cmdAH-33.6 {file tempdir: missing parent dir} -setup {
set base [file join [temporaryDirectory] gorp]
file mkdir $base
} -returnCodes error -body {
file tempdir $base/quux/
} -cleanup {
catch {file delete -force $base}
} -result {can't create temporary directory: no such file or directory}
test cmdAH-33.7 {file tempdir: missing parent dir} -setup {
set base [file join [temporaryDirectory] gorp]
file mkdir $base
} -returnCodes error -body {
file tempdir $base/quux/foobar
} -cleanup {
catch {file delete -force $base}
} -result {can't create temporary directory: no such file or directory}
# This shouldn't work, but just in case a test above failed...
catch {close $newFileId}
interp delete safeInterp
interp delete simpleInterp
|
| ︙ | ︙ |
Changes to tests/cmdIL.test.
| ︙ | ︙ | |||
15 16 17 18 19 20 21 | ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] # Used for constraining memory leak tests testConstraint memory [llength [info commands memory]] testConstraint testobj [llength [info commands testobj]] | < | | 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 |
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
# Used for constraining memory leak tests
testConstraint memory [llength [info commands memory]]
testConstraint testobj [llength [info commands testobj]]
test cmdIL-1.1 {Tcl_LsortObjCmd procedure} -returnCodes error -body {
lsort
} -result {wrong # args: should be "lsort ?-option value ...? list"}
test cmdIL-1.2 {Tcl_LsortObjCmd procedure} -returnCodes error -body {
lsort -foo {1 3 2 5}
} -result {bad option "-foo": must be -ascii, -command, -decreasing, -dictionary, -increasing, -index, -indices, -integer, -nocase, -real, -stride, or -unique}
test cmdIL-1.3 {Tcl_LsortObjCmd procedure, default options} {
|
| ︙ | ︙ | |||
150 151 152 153 154 155 156 |
} {{{b i g} 12345} {{d e m o} 34512} {{c o d e} 54321} {{b l a h} 94729}}
test cmdIL-1.37 {Tcl_LsortObjCmd procedure, Bug 8e1e31eac0fd6b6c} {
lsort -ascii [list \0 \x7f \x80 \uffff]
} [list \0 \x7f \x80 \uffff]
test cmdIL-1.38 {Tcl_LsortObjCmd procedure, Bug 8e1e31eac0fd6b6c} {
lsort -ascii -nocase [list \0 \x7f \x80 \uffff]
} [list \0 \x7f \x80 \uffff]
| | | | 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 |
} {{{b i g} 12345} {{d e m o} 34512} {{c o d e} 54321} {{b l a h} 94729}}
test cmdIL-1.37 {Tcl_LsortObjCmd procedure, Bug 8e1e31eac0fd6b6c} {
lsort -ascii [list \0 \x7f \x80 \uffff]
} [list \0 \x7f \x80 \uffff]
test cmdIL-1.38 {Tcl_LsortObjCmd procedure, Bug 8e1e31eac0fd6b6c} {
lsort -ascii -nocase [list \0 \x7f \x80 \uffff]
} [list \0 \x7f \x80 \uffff]
test cmdIL-1.39 {Tcl_LsortObjCmd procedure, Bug 8e1e31eac0fd6b6c} {
lsort -ascii [list \0 \x7f \x80 \U01ffff \uffff]
} [list \0 \x7f \x80 \uffff \U01ffff]
test cmdIL-1.40 {Tcl_LsortObjCmd procedure, Bug 8e1e31eac0fd6b6c} {
lsort -ascii -nocase [list \0 \x7f \x80 \U01ffff \uffff]
} [list \0 \x7f \x80 \uffff \U01ffff]
test cmdIL-1.41 {lsort -stride and -index} -body {
lsort -stride 2 -index -2 {a 2 b 1}
} -returnCodes error -result {index "-2" cannot select an element from any list}
test cmdIL-1.42 {lsort -stride and-index} -body {
lsort -stride 2 -index -1-1 {a 2 b 1}
|
| ︙ | ︙ | |||
229 230 231 232 233 234 235 |
lsort -index -1-1 {{1 . c} {2 . b} {3 . a}}
} -returnCodes error -result {index "-1-1" cannot select an element from any list}
test cmdIL-3.5.3 {SortCompare procedure, -index option (out of range, calculated index)} -body {
lsort -index -2 {{1 . c} {2 . b} {3 . a}}
} -returnCodes error -result {index "-2" cannot select an element from any list}
test cmdIL-3.5.4 {SortCompare procedure, -index option (out of range, calculated index)} -body {
lsort -index end-4 {{1 . c} {2 . b} {3 . a}}
| | > > > | 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 |
lsort -index -1-1 {{1 . c} {2 . b} {3 . a}}
} -returnCodes error -result {index "-1-1" cannot select an element from any list}
test cmdIL-3.5.3 {SortCompare procedure, -index option (out of range, calculated index)} -body {
lsort -index -2 {{1 . c} {2 . b} {3 . a}}
} -returnCodes error -result {index "-2" cannot select an element from any list}
test cmdIL-3.5.4 {SortCompare procedure, -index option (out of range, calculated index)} -body {
lsort -index end-4 {{1 . c} {2 . b} {3 . a}}
} -returnCodes error -result {element end-4 missing from sublist "1 . c"}
test cmdIL-3.5.5 {SortCompare procedure, -index option} {
lsort -index {} {a b}
} {a b}
test cmdIL-3.5.6 {SortCompare procedure, -index option} {
lsort -index {} [list a \{]
} {a \{}
test cmdIL-3.5.7 {SortCompare procedure, -index option (out of range, calculated index)} -body {
lsort -index end--1 {{1 . c} {2 . b} {3 . a}}
} -returnCodes error -result {index "end--1" cannot select an element from any list}
test cmdIL-3.5.8 {SortCompare procedure, -index option (out of range, calculated index)} -body {
lsort -index end+1 {{1 . c} {2 . b} {3 . a}}
} -returnCodes error -result {index "end+1" cannot select an element from any list}
test cmdIL-3.5.9 {SortCompare procedure, -index option (out of range, calculated index)} -body {
lsort -index end+2 {{1 . c} {2 . b} {3 . a}}
} -returnCodes error -result {index "end+2" cannot select an element from any list}
test cmdIL-3.5.10 {SortCompare procedure, -index option (out of range, calculated index)} -body {
lsort -index 0 {{}}
} -returnCodes error -result {element 0 missing from sublist ""}
test cmdIL-3.6 {SortCompare procedure, -index option} {
lsort -integer -index 2 {{1 15 30} {2 5 25} {3 25 20}}
} {{3 25 20} {2 5 25} {1 15 30}}
test cmdIL-3.7 {SortCompare procedure, -ascii option} {
lsort -ascii {d e c b a d35 d300 100 20}
} {100 20 a b c d d300 d35 e}
test cmdIL-3.8 {SortCompare procedure, -dictionary option} {
|
| ︙ | ︙ | |||
767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 |
} -constraints testobj -body {
lreverse [K $y [unset y]]
lindex $x 0
} -cleanup {
unset -nocomplain x y
rename K {}
} -result 1
# This belongs in info test, but adding tests there breaks tests
# that compute source file line numbers.
test info-20.6 {Bug 3587651} -setup {
namespace eval my {namespace eval tcl {namespace eval mathfunc {
proc demo x {return 42}
}}}} -body { namespace eval my {expr {"demo" in [info functions]}}} -cleanup {
namespace delete my
} -result 1
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | < | 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 |
} -constraints testobj -body {
lreverse [K $y [unset y]]
lindex $x 0
} -cleanup {
unset -nocomplain x y
rename K {}
} -result 1
test cmdIL-8.1 {lremove command: error path} -returnCodes error -body {
lremove
} -result {wrong # args: should be "lremove list ?index ...?"}
test cmdIL-8.2 {lremove command: error path} -returnCodes error -body {
lremove {{}{}}
} -result {list element in braces followed by "{}" instead of space}
test cmdIL-8.3 {lremove command: error path} -returnCodes error -body {
lremove {a b c} gorp
} -result {bad index "gorp": must be integer?[+-]integer? or end?[+-]integer?}
test cmdIL-8.4 {lremove command: no indices} -body {
lremove {a b c}
} -result {a b c}
test cmdIL-8.5 {lremove command: before start} -body {
lremove {a b c} -1
} -result {a b c}
test cmdIL-8.6 {lremove command: after end} -body {
lremove {a b c} 3
} -result {a b c}
test cmdIL-8.7 {lremove command} -body {
lremove {a b c} 0
} -result {b c}
test cmdIL-8.8 {lremove command} -body {
lremove {a b c} 1
} -result {a c}
test cmdIL-8.9 {lremove command} -body {
lremove {a b c} end
} -result {a b}
test cmdIL-8.10 {lremove command} -body {
lremove {a b c} end-1
} -result {a c}
test cmdIL-8.11 {lremove command} -body {
lremove {a b c d e} 1 3
} -result {a c e}
test cmdIL-8.12 {lremove command} -body {
lremove {a b c d e} 3 1
} -result {a c e}
test cmdIL-8.13 {lremove command: same index twice} -body {
lremove {a b c d e} 2 2
} -result {a b d e}
test cmdIL-8.14 {lremove command: same index twice} -body {
lremove {a b c d e} 3 end-1
} -result {a b c e}
test cmdIL-8.15 {lremove command: many indices} -body {
lremove {a b c d e} 1 3 1 4 0
} -result {c}
# This belongs in info test, but adding tests there breaks tests
# that compute source file line numbers.
test info-20.6 {Bug 3587651} -setup {
namespace eval my {namespace eval tcl {namespace eval mathfunc {
proc demo x {return 42}
}}}} -body { namespace eval my {expr {"demo" in [info functions]}}} -cleanup {
namespace delete my
} -result 1
# cleanup
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Changes to tests/cmdMZ.test.
| ︙ | ︙ | |||
311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 |
# if not UTF-8 aware, result is "a {} {} b qw\xe5 {} N wq"
split "a\u4e4eb qw\u5e4e\x4e wq" " \u4e4e"
} "a b qw\u5e4eN wq"
# The tests for Tcl_StringObjCmd are in string.test
# The tests for Tcl_SubstObjCmd are in subst.test
# The tests for Tcl_SwitchObjCmd are in switch.test
test cmdMZ-5.1 {Tcl_TimeObjCmd: basic format of command} -body {
time
} -returnCodes error -result {wrong # args: should be "time command ?count?"}
test cmdMZ-5.2 {Tcl_TimeObjCmd: basic format of command} -body {
time a b c
} -returnCodes error -result {wrong # args: should be "time command ?count?"}
test cmdMZ-5.3 {Tcl_TimeObjCmd: basic format of command} -body {
time a b
} -returnCodes error -result {expected integer but got "b"}
test cmdMZ-5.4 {Tcl_TimeObjCmd: nothing happens with negative iteration counts} {
time bogusCmd -12456
} {0 microseconds per iteration}
test cmdMZ-5.5 {Tcl_TimeObjCmd: result format} -body {
time {format 1}
} -match regexp -result {^\d+ microseconds per iteration}
test cmdMZ-5.6 {Tcl_TimeObjCmd: slower commands take longer} {
| > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 |
# if not UTF-8 aware, result is "a {} {} b qw\xe5 {} N wq"
split "a\u4e4eb qw\u5e4e\x4e wq" " \u4e4e"
} "a b qw\u5e4eN wq"
# The tests for Tcl_StringObjCmd are in string.test
# The tests for Tcl_SubstObjCmd are in subst.test
# The tests for Tcl_SwitchObjCmd are in switch.test
# todo: rewrite this if monotonic clock is provided resp. command "after"
# gets microsecond accuracy (RFE [fdfbd5e10] gets merged):
proc _nrt_sleep {msec} {
set usec [expr {$msec * 1000}]
set stime [clock microseconds]
while {abs([clock microseconds] - $stime) < $usec} {after 0}
}
test cmdMZ-5.1 {Tcl_TimeObjCmd: basic format of command} -body {
time
} -returnCodes error -result {wrong # args: should be "time command ?count?"}
test cmdMZ-5.2 {Tcl_TimeObjCmd: basic format of command} -body {
time a b c
} -returnCodes error -result {wrong # args: should be "time command ?count?"}
test cmdMZ-5.3 {Tcl_TimeObjCmd: basic format of command} -body {
time a b
} -returnCodes error -result {expected integer but got "b"}
test cmdMZ-5.4 {Tcl_TimeObjCmd: nothing happens with negative iteration counts} {
time bogusCmd -12456
} {0 microseconds per iteration}
test cmdMZ-5.5 {Tcl_TimeObjCmd: result format} -body {
time {format 1}
} -match regexp -result {^\d+ microseconds per iteration}
test cmdMZ-5.6 {Tcl_TimeObjCmd: slower commands take longer} {
expr {[lindex [time {_nrt_sleep 1}] 0] < [lindex [time {_nrt_sleep 20}] 0]}
} 1
test cmdMZ-5.7 {Tcl_TimeObjCmd: errors generate right trace} {
list [catch {time {error foo}} msg] $msg $::errorInfo
} {1 foo {foo
while executing
"error foo"
invoked from within
"time {error foo}"}}
test cmdMZ-6.1 {Tcl_TimeRateObjCmd: basic format of command} {
list [catch {timerate} msg] $msg
} {1 {wrong # args: should be "timerate ?-direct? ?-calibrate? ?-overhead double? command ?time ?max-count??"}}
test cmdMZ-6.2.1 {Tcl_TimeRateObjCmd: basic format of command} {
list [catch {timerate a b c d} msg] $msg
} {1 {wrong # args: should be "timerate ?-direct? ?-calibrate? ?-overhead double? command ?time ?max-count??"}}
test cmdMZ-6.2.2 {Tcl_TimeRateObjCmd: basic format of command} {
list [catch {timerate a b c} msg] $msg
} {1 {expected integer but got "b"}}
test cmdMZ-6.2.3 {Tcl_TimeRateObjCmd: basic format of command} {
list [catch {timerate a b} msg] $msg
} {1 {expected integer but got "b"}}
test cmdMZ-6.3 {Tcl_TimeRateObjCmd: basic format of command} {
list [catch {timerate -overhead b {} a b} msg] $msg
} {1 {expected floating-point number but got "b"}}
test cmdMZ-6.4 {Tcl_TimeRateObjCmd: compile of script happens even with negative iteration counts} {
list [catch {timerate "foreach a {c d e} \{" -12456} msg] $msg
} {1 {missing close-brace}}
test cmdMZ-6.5a {Tcl_TimeRateObjCmd: result format and one iteration} {
regexp {^\d+(?:\.\d+)? \ws/# 1 # \d+(?:\.\d+)? #/sec \d+(?:\.\d+)? net-ms$} [timerate {} 0]
} 1
test cmdMZ-6.5b {Tcl_TimeRateObjCmd: result format without iterations} {
regexp {^0 \ws/# 0 # 0 #/sec 0 net-ms$} [timerate {} 0 0]
} 1
test cmdMZ-6.6 {Tcl_TimeRateObjCmd: slower commands take longer, but it remains almost the same time of measument} {
set m1 [timerate {_nrt_sleep 0} 20]
set m2 [timerate {_nrt_sleep 0.2} 20]
list \
[expr {[lindex $m1 0] < [lindex $m2 0]}] \
[expr {[lindex $m1 0] < 100}] \
[expr {[lindex $m2 0] > 100}] \
[expr {[lindex $m1 2] > 1000}] \
[expr {[lindex $m2 2] < 1000}] \
[expr {[lindex $m1 4] > 50000}] \
[expr {[lindex $m2 4] < 50000}] \
[expr {[lindex $m1 6] > 10 && [lindex $m1 6] < 100}] \
[expr {[lindex $m2 6] > 10 && [lindex $m2 6] < 100}]
} [lrepeat 9 1]
test cmdMZ-6.7 {Tcl_TimeRateObjCmd: errors generate right trace} {
list [catch {timerate {error foo} 1} msg] $msg $::errorInfo
} {1 foo {foo
while executing
"error foo"
invoked from within
"timerate {error foo} 1"}}
test cmdMZ-6.8 {Tcl_TimeRateObjCmd: allow (conditional) break from timerate} {
set m1 [timerate {break}]
list \
[expr {[lindex $m1 0] < 1000}] \
[expr {[lindex $m1 2] == 1}] \
[expr {[lindex $m1 4] > 1000}] \
[expr {[lindex $m1 6] < 10}]
} {1 1 1 1}
test cmdMZ-6.8.1 {Tcl_TimeRateObjCmd: allow (conditional) continue in timerate} {
set m1 [timerate {continue; return -code error "unexpected"} 1000 10]
list \
[expr {[lindex $m1 0] < 1000}] \
[expr {[lindex $m1 2] == 10}] \
[expr {[lindex $m1 4] > 1000}] \
[expr {[lindex $m1 6] < 100}]
} {1 1 1 1}
test cmdMZ-6.9 {Tcl_TimeRateObjCmd: max count of iterations} {
set m1 [timerate {} 1000 5]; # max-count wins
set m2 [timerate {_nrt_sleep 20} 1 5]; # max-time wins
list [lindex $m1 2] [lindex $m2 2]
} {5 1}
test cmdMZ-6.10 {Tcl_TimeRateObjCmd: huge overhead cause 0us result} {
set m1 [timerate -overhead 1e6 {_nrt_sleep 10} 100 1]
list \
[expr {[lindex $m1 0] == 0.0}] \
[expr {[lindex $m1 2] == 1}] \
[expr {[lindex $m1 4] == 1000000}] \
[expr {[lindex $m1 6] <= 0.001}]
} {1 1 1 1}
test cmdMZ-6.11 {Tcl_TimeRateObjCmd: done/continue optimization rollback} {
set m1 {set m2 ok}
if 1 $m1
timerate $m1 1000 10
if 1 $m1; # if rollback is missing throws an error: invoked "continue" outside of a loop
} ok
test cmdMZ-try-1.0 {
fix for issue 45b9faf103f2
[try] interaction with local variable names produces segmentation violation
} -body {
::apply {{} {
set cmd try
$cmd {
lindex 5
} on ok res {}
set res
}}
} -result 5
# The tests for Tcl_WhileObjCmd are in while.test
# cleanup
cleanupTests
}
namespace delete ::tcl::test::cmdMZ
return
# Local Variables:
# mode: tcl
# End:
|
Changes to tests/compExpr-old.test.
| ︙ | ︙ | |||
73 74 75 76 77 78 79 |
default {
return 0
}
}
}
testConstraint ieeeFloatingPoint [testIEEE]
| | | | 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 |
default {
return 0
}
}
}
testConstraint ieeeFloatingPoint [testIEEE]
testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}]
testConstraint longIs64bit [expr {$tcl_platform(wordSize) == 8}]
# procedures used below
proc put_hello_char {c} {
global a
append a [format %c $c]
return $c
|
| ︙ | ︙ | |||
326 327 328 329 330 331 332 |
} -returnCodes error -match glob -result *
test compExpr-old-9.1 {CompileRelationalExpr: just shift expr} {expr 3<<2} 12
test compExpr-old-9.2 {CompileRelationalExpr: just shift expr} {expr 0xff>>2} 63
test compExpr-old-9.3 {CompileRelationalExpr: just shift expr} {expr -1>>2} -1
test compExpr-old-9.4 {CompileRelationalExpr: just shift expr} {expr {1<<3}} 8
| | < < < < | < < < | 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 |
} -returnCodes error -match glob -result *
test compExpr-old-9.1 {CompileRelationalExpr: just shift expr} {expr 3<<2} 12
test compExpr-old-9.2 {CompileRelationalExpr: just shift expr} {expr 0xff>>2} 63
test compExpr-old-9.3 {CompileRelationalExpr: just shift expr} {expr -1>>2} -1
test compExpr-old-9.4 {CompileRelationalExpr: just shift expr} {expr {1<<3}} 8
test compExpr-old-9.5 {CompileRelationalExpr: large shift expr} {
expr {int(1<<63)}
} 9223372036854775808
test compExpr-old-9.6 {CompileRelationalExpr: error in shift expr} -body {
expr x>>3
} -returnCodes error -match glob -result *
test compExpr-old-9.7 {CompileRelationalExpr: simple relational exprs} {expr 0xff>=+0x3} 1
test compExpr-old-9.8 {CompileRelationalExpr: simple relational exprs} {expr -0xf2<0x3} 1
test compExpr-old-9.9 {CompileRelationalExpr: error compiling relational arm} -body {
|
| ︙ | ︙ |
Changes to tests/compile.test.
| ︙ | ︙ | |||
495 496 497 498 499 500 501 |
test compile-15.4 {proper TCL_RETURN code from [return]} {
apply {{} {catch {return [info library]}}}
} 2
test compile-15.5 {proper TCL_RETURN code from [return]} {
apply {{} {catch {set a 1}; return}}
} ""
| > | | 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 |
test compile-15.4 {proper TCL_RETURN code from [return]} {
apply {{} {catch {return [info library]}}}
} 2
test compile-15.5 {proper TCL_RETURN code from [return]} {
apply {{} {catch {set a 1}; return}}
} ""
# Do all tests once byte compiled and once with direct string evaluation
foreach noComp {0 1} {
if $noComp {
interp alias {} run {} testevalex
set constraints testevalex
} else {
interp alias {} run {} if 1
set constraints {}
|
| ︙ | ︙ |
Changes to tests/config.test.
| ︙ | ︙ | |||
15 16 17 18 19 20 21 |
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
test pkgconfig-1.1 {query keys} {
lsort [::tcl::pkgconfig list]
| | | 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 |
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
test pkgconfig-1.1 {query keys} {
lsort [::tcl::pkgconfig list]
} {64bit bindir,install bindir,runtime compile_debug compile_stats debug dllfile,runtime docdir,install docdir,runtime includedir,install includedir,runtime libdir,install libdir,runtime mem_debug optimized profiled scriptdir,install scriptdir,runtime threaded zipfile,runtime}
test pkgconfig-1.2 {query keys multiple times} {
string compare [::tcl::pkgconfig list] [::tcl::pkgconfig list]
} 0
test pkgconfig-1.3 {query value multiple times} {
string compare \
[::tcl::pkgconfig get bindir,install] \
[::tcl::pkgconfig get bindir,install]
|
| ︙ | ︙ |
Changes to tests/coroutine.test.
| ︙ | ︙ | |||
622 623 624 625 626 627 628 |
test coroutine-7.5 {return codes} {
set result {}
foreach code {0 1 2 3 4 5} {
lappend result [catch {coroutine demo return -level 0 -code $code}]
}
set result
} {0 1 2 3 4 5}
| | > > > > | | | | > > | > > > | > > | > | | | 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 |
test coroutine-7.5 {return codes} {
set result {}
foreach code {0 1 2 3 4 5} {
lappend result [catch {coroutine demo return -level 0 -code $code}]
}
set result
} {0 1 2 3 4 5}
test coroutine-7.6 {Early yield crashes} -setup {
set i [interp create]
} -body {
# Force into a child interpreter [bug 60559fd4a6]
$i eval {
proc foo args {}
trace add execution foo enter {catch yield}
coroutine demo foo
rename foo {}
return ok
}
} -cleanup {
interp delete $i
} -result ok
test coroutine-7.7 {Bug 2486550} -setup {
set i [interp create]
$i hide yield
} -body {
# Force into a child interpreter [bug 60559fd4a6]
$i eval {
coroutine demo interp invokehidden {} yield ok
}
} -cleanup {
$i eval demo
interp delete $i
} -result ok
test coroutine-7.8 {yieldto context nuke: Bug a90d9331bc} -setup {
namespace eval cotest {}
set ::result ""
} -body {
proc cotest::body {} {
lappend ::result a
|
| ︙ | ︙ | |||
777 778 779 780 781 782 783 |
slave eval demo
set result [slave eval {set ::result}]
interp delete slave
set result
} -result {inject-executed}
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 |
slave eval demo
set result [slave eval {set ::result}]
interp delete slave
set result
} -result {inject-executed}
test coroutine-9.1 {coroprobe with yield} -body {
coroutine demo apply {{} { foreach i {1 2} yield }}
list [coroprobe demo set i] [demo] [coroprobe demo set i] [demo]
} -cleanup {
catch {rename demo {}}
} -result {1 {} 2 {}}
test coroutine-9.2 {coroprobe with yieldto} -body {
coroutine demo apply {{} { lmap i {1 2} {yieldto string cat} }}
list [coroprobe demo set i] [demo a b] [coroprobe demo set i] [demo c d]
} -cleanup {
catch {rename demo {}}
} -result {1 {} 2 {{a b} {c d}}}
test coroutine-9.3 {coroprobe errors} -setup {
catch {rename demo {}}
} -body {
coroprobe demo set i
} -returnCodes error -result {can only inject a probe command into a coroutine}
test coroutine-9.4 {coroprobe errors} -body {
proc demo {} { foreach i {1 2} yield }
coroprobe demo set i
} -returnCodes error -cleanup {
catch {rename demo {}}
} -result {can only inject a probe command into a coroutine}
test coroutine-9.5 {coroprobe errors} -body {
coroutine demo apply {{} { foreach i {1 2} yield }}
coroprobe
} -returnCodes error -cleanup {
catch {rename demo {}}
} -result {wrong # args: should be "coroprobe coroName cmd ?arg1 arg2 ...?"}
test coroutine-9.6 {coroprobe errors} -body {
coroutine demo apply {{} { foreach i {1 2} yield }}
coroprobe demo
} -returnCodes error -cleanup {
catch {rename demo {}}
} -result {wrong # args: should be "coroprobe coroName cmd ?arg1 arg2 ...?"}
test coroutine-9.7 {coroprobe errors in probe command} -body {
coroutine demo apply {{} { foreach i {1 2} yield }}
coroprobe demo set
} -returnCodes error -cleanup {
catch {rename demo {}}
} -result {wrong # args: should be "set varName ?newValue?"}
test coroutine-9.8 {coroprobe errors in probe command} -body {
coroutine demo apply {{} { foreach i {1 2} yield }}
list [catch {coroprobe demo set}] [demo] [coroprobe demo set i]
} -cleanup {
catch {rename demo {}}
} -result {1 {} 2}
test coroutine-9.9 {coroprobe: advanced features} -setup {
set i [interp create]
} -body {
$i eval {
coroutine demo apply {{} {
set f [info level],[info frame]
foreach i {1 2} yield
}}
coroprobe demo apply {{} {
upvar 1 f f
list [info coroutine] [info level] [info frame] $f
}}
}
} -cleanup {
interp delete $i
} -result {::demo 2 3 1,2}
test coroutine-10.1 {coroinject with yield} -setup {
set result {}
} -body {
coroutine demo apply {{} { lmap i {1 2} yield }}
coroinject demo apply {{op val} {lappend ::result $op $val}}
list $result [demo x] [demo y] $result
} -cleanup {
catch {rename demo {}}
} -result {{} {} {{yield x} y} {yield x}}
test coroutine-10.2 {coroinject stacking} -setup {
set result {}
} -body {
coroutine demo apply {{} { lmap i {1 2} yield }}
coroinject demo apply {{op val} {lappend ::result $op $val A;return $val}}
coroinject demo apply {{op val} {lappend ::result $op $val B;return $val}}
list $result [demo x] [demo y] $result
} -cleanup {
catch {rename demo {}}
} -result {{} {} {x y} {yield x B yield x A}}
test coroutine-10.3 {coroinject with yieldto} -setup {
set result {}
} -body {
coroutine demo apply {{} { lmap i {1 2} {yieldto string cat} }}
coroinject demo apply {{op val} {lappend ::result $op $val;return $val}}
list $result [demo x mp] [demo y le] $result
} -cleanup {
catch {rename demo {}}
} -result {{} {} {{x mp} {y le}} {yieldto {x mp}}}
test coroutine-10.4 {coroinject errors} -setup {
catch {rename demo {}}
} -body {
coroinject demo set i
} -returnCodes error -result {can only inject a command into a coroutine}
test coroutine-10.5 {coroinject errors} -body {
proc demo {} { foreach i {1 2} yield }
coroinject demo set i
} -returnCodes error -cleanup {
catch {rename demo {}}
} -result {can only inject a command into a coroutine}
test coroutine-10.6 {coroinject errors} -body {
coroutine demo apply {{} { foreach i {1 2} yield }}
coroinject
} -returnCodes error -cleanup {
catch {rename demo {}}
} -result {wrong # args: should be "coroinject coroName cmd ?arg1 arg2 ...?"}
test coroutine-10.7 {coroinject errors} -body {
coroutine demo apply {{} { foreach i {1 2} yield }}
coroinject demo
} -returnCodes error -cleanup {
catch {rename demo {}}
} -result {wrong # args: should be "coroinject coroName cmd ?arg1 arg2 ...?"}
test coroutine-10.8 {coroinject errors in injected command} -body {
coroutine demo apply {{} { foreach i {1 2} yield }}
coroinject demo apply {args {error "ERR: $args"}}
list [catch demo msg] $msg [catch demo msg] $msg
} -cleanup {
catch {rename demo {}}
} -result {1 {ERR: yield {}} 1 {invalid command name "demo"}}
test coroutine-10.9 {coroinject: advanced features} -setup {
set i [interp create]
} -body {
$i eval {
coroutine demo apply {{} {
set l [info level]
set f [info frame]
lmap i {1 2} yield
}}
coroinject demo apply {{arg op val} {
global result
upvar 1 f f l l
lappend result [info coroutine] $arg $op $val
lappend result [info level] $l [info frame] $f
lappend result [yield $arg]
return [string toupper $val]
}} grill
list [demo ABC] [demo pqr] [demo def] $result
}
} -cleanup {
interp delete $i
} -result {grill {} {ABC def} {::demo grill yield ABC 2 1 3 2 pqr}}
test coroutine-11.1 {coro type} {
coroutine demo eval {
yield
yield "PHASE 1"
yieldto string cat "PHASE 2"
::tcl::unsupported::corotype [info coroutine]
}
list [demo] [::tcl::unsupported::corotype demo] \
[demo] [::tcl::unsupported::corotype demo] [demo]
} {{PHASE 1} yield {PHASE 2} yieldto active}
test coroutine-11.2 {coro type} -setup {
catch {rename nosuchcommand ""}
} -returnCodes error -body {
::tcl::unsupported::corotype nosuchcommand
} -result {can only get coroutine type of a coroutine}
test coroutine-11.3 {coro type} -returnCodes error -body {
proc notacoroutine {} {}
::tcl::unsupported::corotype notacoroutine
} -returnCodes error -cleanup {
rename notacoroutine {}
} -result {can only get coroutine type of a coroutine}
test coroutine-12.1 {coroutine general introspection} -setup {
set i [interp create]
} -body {
$i eval {
# Make the introspection code
namespace path tcl::unsupported
proc probe {type var} {
upvar 1 $var v
set f [info frame]
incr f -1
set result [list $v [dict get [info frame $f] proc]]
if {$type eq "yield"} {
tailcall yield $result
} else {
tailcall yieldto string cat $result
}
}
proc pokecoro {c var} {
inject $c probe [corotype $c] $var
$c
}
# Coroutine implementations
proc cbody1 {} {
set val [info coroutine]
set accum {}
while {[set val [yield $val]] ne ""} {
lappend accum $val
set val ok
}
return $accum
}
proc cbody2 {} {
set val [info coroutine]
set accum {}
while {[llength [set val [yieldto string cat $val]]]} {
lappend accum {*}$val
set val ok
}
return $accum
}
# Make the coroutines
coroutine c1 cbody1
coroutine c2 cbody2
list [c1 abc] [c2 1 2 3] [pokecoro c1 accum] [pokecoro c2 accum] \
[c1 def] [c2 4 5 6] [pokecoro c1 accum] [pokecoro c2 accum] \
[c1] [c2]
}
} -cleanup {
interp delete $i
} -result {ok ok {abc ::cbody1} {{1 2 3} ::cbody2} ok ok {{abc def} ::cbody1} {{1 2 3 4 5 6} ::cbody2} {abc def} {1 2 3 4 5 6}}
# cleanup
unset lambda
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Changes to tests/dict.test.
1 2 3 4 5 6 7 8 9 10 11 12 |
# This test file covers the dictionary object type and the dict command used
# to work with values of that type.
#
# This file contains a collection of tests for one or more of the Tcl built-in
# commands. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
#
# Copyright (c) 2003-2009 Donal K. Fellows
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
| | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 |
# This test file covers the dictionary object type and the dict command used
# to work with values of that type.
#
# This file contains a collection of tests for one or more of the Tcl built-in
# commands. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
#
# Copyright (c) 2003-2009 Donal K. Fellows
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
# Used for constraining memory leak tests
testConstraint memory [llength [info commands memory]]
if {[testConstraint memory]} {
proc memtest script {
|
| ︙ | ︙ | |||
171 172 173 174 175 176 177 |
dict replace { a b c d }
} {a b c d}
test dict-4.12 {dict replace command: canonicality is forced} {
dict replace {a b c d a e}
} {a e c d}
test dict-4.13 {dict replace command: type check is mandatory} -body {
dict replace { a b c d e }
| | < < < < | 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 |
dict replace { a b c d }
} {a b c d}
test dict-4.12 {dict replace command: canonicality is forced} {
dict replace {a b c d a e}
} {a e c d}
test dict-4.13 {dict replace command: type check is mandatory} -body {
dict replace { a b c d e }
} -errorCode {TCL VALUE DICTIONARY} -result {missing value to go with key}
test dict-4.14 {dict replace command: type check is mandatory} -body {
dict replace { a b {}c d }
} -returnCodes error -result {dict element in braces followed by "c" instead of space}
test dict-4.14a {dict replace command: type check is mandatory} {
catch {dict replace { a b {}c d }} -> opt
dict get $opt -errorcode
} {TCL VALUE DICTIONARY JUNK}
|
| ︙ | ︙ | |||
199 200 201 202 203 204 205 |
} -returnCodes error -result {unmatched open quote in dict}
test dict-4.16a {dict replace command: type check is mandatory} {
catch {dict replace " a b \"c d "} -> opt
dict get $opt -errorcode
} {TCL VALUE DICTIONARY QUOTE}
test dict-4.17 {dict replace command: type check is mandatory} -body {
dict replace " a b \{c d "
| | < < < < | 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 |
} -returnCodes error -result {unmatched open quote in dict}
test dict-4.16a {dict replace command: type check is mandatory} {
catch {dict replace " a b \"c d "} -> opt
dict get $opt -errorcode
} {TCL VALUE DICTIONARY QUOTE}
test dict-4.17 {dict replace command: type check is mandatory} -body {
dict replace " a b \{c d "
} -errorCode {TCL VALUE DICTIONARY BRACE} -result {unmatched open brace in dict}
test dict-4.18 {dict replace command: canonicality forcing doesn't leak} {
set example { a b c d }
list $example [dict replace $example]
} {{ a b c d } {a b c d}}
test dict-5.1 {dict remove command} {dict remove {a b c d} a} {c d}
test dict-5.2 {dict remove command} {dict remove {a b c d} c} {a b}
|
| ︙ | ︙ | |||
2051 2052 2053 2054 2055 2056 2057 |
test dict-25.1 {compiled dict update with low-refcount values [Bug d553228d9f]} {
# Test crashes on failure
apply {{} {
lassign {} item
dict update item item item two two {}
}}
} {}
| | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 |
test dict-25.1 {compiled dict update with low-refcount values [Bug d553228d9f]} {
# Test crashes on failure
apply {{} {
lassign {} item
dict update item item item two two {}
}}
} {}
set dict dict; # Used to force interpretation, not compilation
test dict-26.1 {dict getdef command} -body {
dict getdef {a b} a c
} -result b
test dict-26.2 {dict getdef command} -body {
dict getdef {a b} b c
} -result c
test dict-26.3 {dict getdef command} -body {
dict getdef {a {b c}} a b d
} -result c
test dict-26.4 {dict getdef command} -body {
dict getdef {a {b c}} a c d
} -result d
test dict-26.5 {dict getdef command} -body {
dict getdef {a {b c}} b c d
} -result d
test dict-26.6 {dict getdef command} -returnCodes error -body {
dict getdef {a {b c d}} a b d
} -result {missing value to go with key}
test dict-26.7 {dict getdef command} -returnCodes error -body {
dict getdef
} -result {wrong # args: should be "dict getdef dictionary ?key ...? key default"}
test dict-26.8 {dict getdef command} -returnCodes error -body {
dict getdef {}
} -result {wrong # args: should be "dict getdef dictionary ?key ...? key default"}
test dict-26.9 {dict getdef command} -returnCodes error -body {
dict getdef {} {}
} -result {wrong # args: should be "dict getdef dictionary ?key ...? key default"}
test dict-26.10 {dict getdef command} -returnCodes error -body {
dict getdef {a b c} d e
} -result {missing value to go with key}
test dict-26.11 {dict getdef command} -body {
$dict getdef {a b} a c
} -result b
test dict-26.12 {dict getdef command} -body {
$dict getdef {a b} b c
} -result c
test dict-26.13 {dict getdef command} -body {
$dict getdef {a {b c}} a b d
} -result c
test dict-26.14 {dict getdef command} -body {
$dict getdef {a {b c}} a c d
} -result d
test dict-26.15 {dict getdef command} -body {
$dict getdef {a {b c}} b c d
} -result d
test dict-26.16 {dict getdef command} -returnCodes error -body {
$dict getdef {a {b c d}} a b d
} -result {missing value to go with key}
test dict-26.17 {dict getdef command} -returnCodes error -body {
$dict getdef {a b c} d e
} -result {missing value to go with key}
test dict-27.1 {dict getwithdefault command} -body {
dict getwithdefault {a b} a c
} -result b
test dict-27.2 {dict getwithdefault command} -body {
dict getwithdefault {a b} b c
} -result c
test dict-27.3 {dict getwithdefault command} -body {
dict getwithdefault {a {b c}} a b d
} -result c
test dict-27.4 {dict getwithdefault command} -body {
dict getwithdefault {a {b c}} a c d
} -result d
test dict-27.5 {dict getwithdefault command} -body {
dict getwithdefault {a {b c}} b c d
} -result d
test dict-27.6 {dict getwithdefault command} -returnCodes error -body {
dict getwithdefault {a {b c d}} a b d
} -result {missing value to go with key}
test dict-27.7 {dict getwithdefault command} -returnCodes error -body {
dict getwithdefault
} -result {wrong # args: should be "dict getwithdefault dictionary ?key ...? key default"}
test dict-27.8 {dict getwithdefault command} -returnCodes error -body {
dict getwithdefault {}
} -result {wrong # args: should be "dict getwithdefault dictionary ?key ...? key default"}
test dict-27.9 {dict getwithdefault command} -returnCodes error -body {
dict getwithdefault {} {}
} -result {wrong # args: should be "dict getwithdefault dictionary ?key ...? key default"}
test dict-27.10 {dict getdef command} -returnCodes error -body {
dict getwithdefault {a b c} d e
} -result {missing value to go with key}
test dict-27.11 {dict getwithdefault command} -body {
$dict getwithdefault {a b} a c
} -result b
test dict-27.12 {dict getwithdefault command} -body {
$dict getwithdefault {a b} b c
} -result c
test dict-27.13 {dict getwithdefault command} -body {
$dict getwithdefault {a {b c}} a b d
} -result c
test dict-27.14 {dict getwithdefault command} -body {
$dict getwithdefault {a {b c}} a c d
} -result d
test dict-27.15 {dict getwithdefault command} -body {
$dict getwithdefault {a {b c}} b c d
} -result d
test dict-27.16 {dict getwithdefault command} -returnCodes error -body {
$dict getwithdefault {a {b c d}} a b d
} -result {missing value to go with key}
test dict-27.17 {dict getdef command} -returnCodes error -body {
$dict getwithdefault {a b c} d e
} -result {missing value to go with key}
# cleanup
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Changes to tests/encoding.test.
| ︙ | ︙ | |||
32 33 34 35 36 37 38 |
proc runtests {} {
variable x
# Some tests require the testencoding command
testConstraint testencoding [llength [info commands testencoding]]
testConstraint testbytestring [llength [info commands testbytestring]]
testConstraint teststringbytes [llength [info commands teststringbytes]]
| < | 32 33 34 35 36 37 38 39 40 41 42 43 44 45 |
proc runtests {} {
variable x
# Some tests require the testencoding command
testConstraint testencoding [llength [info commands testencoding]]
testConstraint testbytestring [llength [info commands testbytestring]]
testConstraint teststringbytes [llength [info commands teststringbytes]]
testConstraint exec [llength [info commands exec]]
testConstraint testgetencpath [llength [info commands testgetencpath]]
# TclInitEncodingSubsystem is tested by the rest of this file
# TclFinalizeEncodingSubsystem is not currently tested
test encoding-1.1 {Tcl_GetEncoding: system encoding} -setup {
|
| ︙ | ︙ | |||
319 320 321 322 323 324 325 |
} 00
test encoding-15.3 {UtfToUtfProc null character input} teststringbytes {
set y [encoding convertfrom utf-8 [encoding convertto utf-8 \u0000]]
binary scan [teststringbytes $y] H* z
set z
} c080
| | | | | | 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 |
} 00
test encoding-15.3 {UtfToUtfProc null character input} teststringbytes {
set y [encoding convertfrom utf-8 [encoding convertto utf-8 \u0000]]
binary scan [teststringbytes $y] H* z
set z
} c080
test encoding-16.1 {UnicodeToUtfProc} -body {
set val [encoding convertfrom unicode NN]
list $val [format %x [scan $val %c]]
} -result "\u4e4e 4e4e"
test encoding-16.2 {UnicodeToUtfProc} -body {
set val [encoding convertfrom unicode "\xd8\xd8\xdc\xdc"]
list $val [format %x [scan $val %c]]
} -result "\U460dc 460dc"
test encoding-17.1 {UtfToUnicodeProc} -body {
encoding convertto unicode "\U460dc"
} -result "\xd8\xd8\xdc\xdc"
test encoding-18.1 {TableToUtfProc} {
} {}
test encoding-19.1 {TableFromUtfProc} {
|
| ︙ | ︙ |
Changes to tests/env.test.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
| > > | | > > > > | > > | > > | | | > > > | < | | > > > > | | > > | > | | | > > > > | > > | > | < < | > > > > > | | > > > > > > > | | > | | > | > > | > | | > | | < | | | > | > > > > > > | > | | | < < < < < < | | | | | | > | > | > > | > | | > > > > > > > > < > > | > > > | < < < < < < < < | > | | | < < | | < | | | | | | | | > | < | < > | < < | > > | | > > | | < | < | | < | | | | | | > < < | | < < | | < | < < < | < | | | | > | < | | | | > | < > > < < < | > | > | | | > | < | | | | > > > | > > > > | > > > > | > | | | > | > | > | > | | | | > | > > | | > > > > > > | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
package require tcltests
# [exec] is required here to see the actual environment received by child
# processes.
proc getenv {} {
global printenvScript
catch {exec [interpreter] $printenvScript} out
if {$out eq "child process exited abnormally"} {
set out {}
}
return $out
}
proc envrestore {} {
# Restore the environment variables at the end of the test.
global env
variable env2
foreach name [array names env] {
unset env($name)
}
array set env $env2
return
}
proc envprep {} {
# Save the current environment variables at the start of the test.
global env
variable keep
variable env2
set env2 [array get env]
foreach name [array names env] {
# Keep some environment variables that support operation of the tcltest
# package.
if {[string toupper $name] ni [string toupper $keep]} {
unset env($name)
}
}
return
}
proc encodingrestore {} {
variable sysenc
encoding system $sysenc
return
}
proc encodingswitch encoding {
variable sysenc
# Need to run [getenv] in known encoding, so save the current one here...
set sysenc [encoding system]
encoding system $encoding
return
}
proc setup1 {} {
global env
envprep
encodingswitch iso8859-1
}
proc setup2 {} {
global env
setup1
set env(NAME1) {test string}
set env(NAME2) {new value}
set env(XYZZY) {garbage}
}
proc cleanup1 {} {
encodingrestore
envrestore
}
variable keep {
TCL_LIBRARY PATH LD_LIBRARY_PATH LIBPATH PURE_PROG_NAME DISPLAY
SHLIB_PATH SYSTEMDRIVE SYSTEMROOT DYLD_LIBRARY_PATH DYLD_FRAMEWORK_PATH
DYLD_NEW_LOCAL_SHARED_REGIONS DYLD_NO_FIX_PREBINDING
__CF_USER_TEXT_ENCODING SECURITYSESSIONID LANG WINDIR TERM
CommonProgramFiles ProgramFiles CommonProgramW6432 ProgramW6432
}
variable printenvScript [makeFile [string map [list @keep@ [list $keep]] {
encoding system iso8859-1
proc lrem {listname name} {
upvar $listname list
set i [lsearch -nocase $list $name]
if {$i >= 0} {
set list [lreplace $list $i $i]
}
return $list
}
proc mangle s {
regsub -all {\[|\\|\]} $s {\\&} s
regsub -all "\[\u0000-\u001f\u007f-\uffff\]" $s {[manglechar {&}]} s
return [subst -novariables $s]
}
proc manglechar c {
return [format {\u%04x} [scan $c %c]]
}
set names [lsort [array names env]]
if {$tcl_platform(platform) eq "windows"} {
lrem names HOME
lrem names COMSPEC
lrem names ComSpec
lrem names ""
}
foreach name @keep@ {
lrem names $name
}
foreach p $names {
puts [mangle $p]=[mangle $env($p)]
}
exit
}] printenv]
test env-1.1 {propagation of env values to child interpreters} -setup {
catch {interp delete child}
catch {unset env(test)}
} -body {
interp create child
set env(test) garbage
child eval {set env(test)}
} -cleanup {
interp delete child
unset env(test)
} -result {garbage}
# This one crashed on Solaris under Tcl8.0, so we only want to make sure it
# runs.
test env-1.2 {lappend to env value} -setup {
catch {unset env(test)}
} -body {
set env(test) aaaaaaaaaaaaaaaa
append env(test) bbbbbbbbbbbbbb
unset env(test)
}
test env-1.3 {reflection of env by "array names"} -setup {
catch {interp delete child}
catch {unset env(test)}
} -body {
interp create child
child eval {set env(test) garbage}
expr {"test" in [array names env]}
} -cleanup {
interp delete child
catch {unset env(test)}
} -result 1
test env-2.1 {
adding environment variables
} -constraints exec -setup setup1 -body {
getenv
} -cleanup cleanup1 -result {}
test env-2.2 {
adding environment variables
} -constraints exec -setup setup1 -body {
set env(NAME1) "test string"
getenv
} -cleanup cleanup1 -result {NAME1=test string}
test env-2.3 {adding environment variables} -constraints exec -setup {
setup1
set env(NAME1) "test string"
} -body {
set env(NAME2) "more"
getenv
} -cleanup cleanup1 -result {NAME1=test string
NAME2=more}
test env-2.4 {
adding environment variables
} -constraints exec -setup {
setup1
set env(NAME1) "test string"
set env(NAME2) "more"
} -body {
set env(XYZZY) "garbage"
getenv
} -cleanup { cleanup1
} -result {NAME1=test string
NAME2=more
XYZZY=garbage}
test env-3.1 {
changing environment variables
} -constraints exec -setup setup2 -body {
set result [getenv]
unset env(NAME2)
set result
} -cleanup {
cleanup1
} -result {NAME1=test string
NAME2=new value
XYZZY=garbage}
test env-4.1 {
unsetting environment variables
} -constraints exec -setup setup2 -body {
unset -nocomplain env(NAME2)
getenv
} -cleanup cleanup1 -result {NAME1=test string
XYZZY=garbage}
# env-4.2 is deleted
test env-4.3 {
setting international environment variables
} -constraints exec -setup setup1 -body {
set env(\ua7) \ub6
getenv
} -cleanup cleanup1 -result {\u00a7=\u00b6}
test env-4.4 {
changing international environment variables
} -constraints exec -setup setup1 -body {
set env(\ua7) \ua7
getenv
} -cleanup cleanup1 -result {\u00a7=\u00a7}
test env-4.5 {
unsetting international environment variables
} -constraints exec -setup {
setup1
set env(\ua7) \ua7
} -body {
set env(\ub6) \ua7
unset env(\ua7)
getenv
} -cleanup cleanup1 -result {\u00b6=\u00a7}
test env-5.0 {
corner cases - set a value, it should exist
} -setup setup1 -body {
set env(temp) a
set env(temp)
} -cleanup cleanup1 -result a
test env-5.1 {
corner cases - remove one elem at a time
} -setup setup1 -body {
# When no environment variables exist, the env var will contain no
# entries. The "array names" call synchs up the C-level environ array with
# the Tcl level env array. Make sure an empty Tcl array is created.
foreach e [array names env] {
unset env($e)
}
array size env
} -cleanup cleanup1 -result 0
test env-5.2 {corner cases - unset the env array} -setup {
interp create i
} -body {
# Unsetting a variable in an interp detaches the C-level traces from the
# Tcl "env" variable.
i eval {
unset env
set env(THIS_SHOULDNT_EXIST) a
}
info exists env(THIS_SHOULDNT_EXIST)
} -cleanup {
interp delete i
} -result {0}
test env-5.3 {corner cases: unset the env in master should unset child} -setup {
setup1
interp create i
} -body {
# Variables deleted in a master interp should be deleted in child interp
# too.
i eval {set env(THIS_SHOULD_EXIST) a}
set result [set env(THIS_SHOULD_EXIST)]
unset env(THIS_SHOULD_EXIST)
lappend result [i eval {catch {set env(THIS_SHOULD_EXIST)}}]
} -cleanup {
cleanup1
interp delete i
} -result {a 1}
test env-5.4 {corner cases - unset the env array} -setup {
setup1
interp create i
} -body {
# The info exists command should be in synch with the env array.
# Know Bug: 1737
i eval {set env(THIS_SHOULD_EXIST) a}
set result [info exists env(THIS_SHOULD_EXIST)]
lappend result [set env(THIS_SHOULD_EXIST)]
lappend result [info exists env(THIS_SHOULD_EXIST)]
} -cleanup {
cleanup1
interp delete i
} -result {1 a 1}
test env-5.5 {
corner cases - cannot have null entries on Windows
} -constraints win -body {
set env() a
catch {set env()}
} -cleanup cleanup1 -result 1
test env-6.1 {corner cases - add lots of env variables} -setup setup1 -body {
set size [array size env]
for {set i 0} {$i < 100} {incr i} {
set env(BOGUS$i) $i
}
expr {[array size env] - $size}
} -cleanup cleanup1 -result 100
test env-7.1 {[219226]: whole env array should not be unset by read} -body {
set n [array size env]
set s [array startsearch env]
while {[array anymore env $s]} {
array nextelement env $s
incr n -1
}
array donesearch env $s
return $n
} -result 0
test env-7.2 {
[219226]: links to env elements should not be removed by read
} -setup setup1 -body {
apply {{} {
set ::env(test7_2) ok
upvar env(test7_2) elem
set ::env(PATH)
return $elem
}}
} -cleanup cleanup1 -result ok
test env-7.3 {
[9b4702]: testing existence of env(some_thing) should not destroy trace
} -setup setup1 -body {
apply {{} {
catch {unset ::env(test7_3)}
proc foo args {
set ::env(test7_3) ok
}
trace add variable ::env(not_yet_existent) write foo
info exists ::env(not_yet_existent)
set ::env(not_yet_existent) "Now I'm here";
return [info exists ::env(test7_3)]
}}
} -cleanup cleanup1 -result 1
test env-8.0 {
memory usage - valgrind does not report reachable memory
} -body {
set res [set env(__DUMMY__) {i'm with dummy}]
unset env(__DUMMY__)
return $res
} -result {i'm with dummy}
# cleanup
rename getenv {}
rename envrestore {}
rename envprep {}
rename encodingrestore {}
rename encodingswitch {}
removeFile $printenvScript
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Changes to tests/event.test.
| ︙ | ︙ | |||
523 524 525 526 527 528 529 |
foreach i [after info] {
after cancel $i
}
after 10; update; # On Mac make sure update won't take long
} -body {
after 100 {set x x-done}
after 200 {set y y-done}
| | | 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 |
foreach i [after info] {
after cancel $i
}
after 10; update; # On Mac make sure update won't take long
} -body {
after 100 {set x x-done}
after 200 {set y y-done}
after 400 {set z z-done}
after idle {set q q-done}
set x before
set y before
set z before
set q before
list [vwait y] $x $y $z $q
} -cleanup {
|
| ︙ | ︙ |
Changes to tests/exec.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 |
# Commands covered: exec
#
# This file contains a collection of tests for one or more of the Tcl built-in
# commands. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
#
# Copyright (c) 1991-1994 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
package require tcltest 2
namespace import -force ::tcltest::*
# All tests require the "exec" command.
# Skip them if exec is not defined.
testConstraint exec [llength [info commands exec]]
unset -nocomplain path
# Utilities that are like bourne shell stalwarts, but cross-platform.
set path(echo) [makeFile {
| > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 |
# Commands covered: exec
#
# This file contains a collection of tests for one or more of the Tcl built-in
# commands. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
#
# Copyright (c) 1991-1994 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
# There is no point in running Valgrind on cases where [exec] forks but then
# fails and the child process doesn't go through full cleanup.
package require tcltest 2
namespace import -force ::tcltest::*
loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
package require tcltests
# All tests require the "exec" command.
# Skip them if exec is not defined.
testConstraint exec [llength [info commands exec]]
unset -nocomplain path
# Utilities that are like bourne shell stalwarts, but cross-platform.
set path(echo) [makeFile {
|
| ︙ | ︙ | |||
321 322 323 324 325 326 327 |
# More than 20 arguments to exec.
test exec-8.2 {long input and output} {exec} {
exec [interpreter] $path(echo) 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23
} {1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23}
# Commands that return errors.
| | | | | 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 |
# More than 20 arguments to exec.
test exec-8.2 {long input and output} {exec} {
exec [interpreter] $path(echo) 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23
} {1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23}
# Commands that return errors.
test exec-9.1 {commands returning errors} {exec notValgrind} {
set x [catch {exec gorp456} msg]
list $x [string tolower $msg] [string tolower $errorCode]
} {1 {couldn't execute "gorp456": no such file or directory} {posix enoent {no such file or directory}}}
test exec-9.2 {commands returning errors} {exec notValgrind} {
string tolower [list [catch {exec [interpreter] echo foo | foo123} msg] $msg $errorCode]
} {1 {couldn't execute "foo123": no such file or directory} {posix enoent {no such file or directory}}}
test exec-9.3 {commands returning errors} -constraints {exec stdio} -body {
exec [interpreter] $path(sleep) 1 | [interpreter] $path(exit) 43 | [interpreter] $path(sleep) 1
} -returnCodes error -result {child process exited abnormally}
test exec-9.4 {commands returning errors} -constraints {exec stdio} -body {
exec [interpreter] $path(exit) 43 | [interpreter] $path(echo) "foo bar"
} -returnCodes error -result {foo bar
child process exited abnormally}
test exec-9.5 {commands returning errors} -constraints {exec stdio notValgrind} -body {
exec gorp456 | [interpreter] echo a b c
} -returnCodes error -result {couldn't execute "gorp456": no such file or directory}
test exec-9.6 {commands returning errors} -constraints {exec} -body {
exec [interpreter] $path(sh) -c "\"$path(echo)\" error msg 1>&2"
} -returnCodes error -result {error msg}
test exec-9.7 {commands returning errors} -constraints {exec stdio nonPortable} -body {
# This test can fail easily on multiprocessor machines
|
| ︙ | ︙ | |||
424 425 426 427 428 429 430 |
} -returnCodes error -result "channel \"$f\" wasn't opened for reading"
close $f
set f [open $path(gorp.file) r]
test exec-10.19 {errors in exec invocation} -constraints {exec} -body {
exec cat >@ $f
} -returnCodes error -result "channel \"$f\" wasn't opened for writing"
close $f
| | | | | 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 |
} -returnCodes error -result "channel \"$f\" wasn't opened for reading"
close $f
set f [open $path(gorp.file) r]
test exec-10.19 {errors in exec invocation} -constraints {exec} -body {
exec cat >@ $f
} -returnCodes error -result "channel \"$f\" wasn't opened for writing"
close $f
test exec-10.20 {errors in exec invocation} -constraints {exec notValgrind} -body {
exec ~non_existent_user/foo/bar
} -returnCodes error -result {user "non_existent_user" doesn't exist}
test exec-10.21 {errors in exec invocation} -constraints {exec notValgrind} -body {
exec [interpreter] true | ~xyzzy_bad_user/x | false
} -returnCodes error -result {user "xyzzy_bad_user" doesn't exist}
test exec-10.22 {errors in exec invocation} -constraints {exec notValgrind} -body {
exec echo test > ~non_existent_user/foo/bar
} -returnCodes error -result {user "non_existent_user" doesn't exist}
# Commands in background.
test exec-11.1 {commands in background} {exec} {
set time [time {exec [interpreter] $path(sleep) 2 &}]
expr {[lindex $time 0] < 1000000}
|
| ︙ | ︙ | |||
506 507 508 509 510 511 512 |
test exec-13.1 {setting errorCode variable} {exec} {
list [catch {exec [interpreter] $path(cat) < a/b/c} msg] [string tolower $errorCode]
} {1 {posix enoent {no such file or directory}}}
test exec-13.2 {setting errorCode variable} {exec} {
list [catch {exec [interpreter] $path(cat) > a/b/c} msg] [string tolower $errorCode]
} {1 {posix enoent {no such file or directory}}}
| | | 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 |
test exec-13.1 {setting errorCode variable} {exec} {
list [catch {exec [interpreter] $path(cat) < a/b/c} msg] [string tolower $errorCode]
} {1 {posix enoent {no such file or directory}}}
test exec-13.2 {setting errorCode variable} {exec} {
list [catch {exec [interpreter] $path(cat) > a/b/c} msg] [string tolower $errorCode]
} {1 {posix enoent {no such file or directory}}}
test exec-13.3 {setting errorCode variable} {exec notValgrind} {
set x [catch {exec _weird_cmd_} msg]
list $x [string tolower $msg] [lindex $errorCode 0] \
[string tolower [lrange $errorCode 2 end]]
} {1 {couldn't execute "_weird_cmd_": no such file or directory} POSIX {{no such file or directory}}}
test exec-13.4 {extended exit result codes} -setup {
set tmp [makeFile {exit 0x00000101} tmpfile.exec-13.4]
} -constraints {win} -body {
|
| ︙ | ︙ | |||
544 545 546 547 548 549 550 |
} "foo\n"
test exec-14.2 {-keepnewline switch} -constraints {exec} -body {
exec -keepnewline
} -returnCodes error -result {wrong # args: should be "exec ?-option ...? arg ?arg ...?"}
test exec-14.3 {unknown switch} -constraints {exec} -body {
exec -gorp
} -returnCodes error -result {bad option "-gorp": must be -ignorestderr, -keepnewline, or --}
| | | 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 |
} "foo\n"
test exec-14.2 {-keepnewline switch} -constraints {exec} -body {
exec -keepnewline
} -returnCodes error -result {wrong # args: should be "exec ?-option ...? arg ?arg ...?"}
test exec-14.3 {unknown switch} -constraints {exec} -body {
exec -gorp
} -returnCodes error -result {bad option "-gorp": must be -ignorestderr, -keepnewline, or --}
test exec-14.4 {-- switch} -constraints {exec notValgrind} -body {
exec -- -gorp
} -returnCodes error -result {couldn't execute "-gorp": no such file or directory}
test exec-14.5 {-ignorestderr switch} {exec} {
# Alas, the use of -ignorestderr is buried here :-(
exec [interpreter] $path(sh2) -c [list $path(echo2) foo bar] 2>@1
} "foo bar\nbar"
|
| ︙ | ︙ | |||
658 659 660 661 662 663 664 |
} -constraints {exec tempNotWin} -cleanup {
removeFile $path(fooblah)
} -result contents
# Note that this test cannot be adapted to work on Windows; that platform has
# no kernel support for an analog of O_APPEND. OTOH, that means we can assume
# that there is a POSIX shell...
| | | | 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 |
} -constraints {exec tempNotWin} -cleanup {
removeFile $path(fooblah)
} -result contents
# Note that this test cannot be adapted to work on Windows; that platform has
# no kernel support for an analog of O_APPEND. OTOH, that means we can assume
# that there is a POSIX shell...
test exec-19.1 {exec >> uses O_APPEND} -constraints {exec unix notValgrind} -setup {
set tmpfile [makeFile {0} tmpfile.exec-19.1]
} -body {
# Note that we have to allow for the current contents of the temporary
# file, which is why the result is 14 and not 12
exec /bin/sh -c \
{for a in 1 2 3; do sleep 1; echo $a; done} >>$tmpfile &
exec /bin/sh -c \
{for a in 4 5 6; do sleep 1; echo $a >&2; done} 2>>$tmpfile &
exec /bin/sh -c \
{for a in a b c; do sleep 1; echo $a; done} >>$tmpfile &
exec /bin/sh -c \
{for a in d e f; do sleep 1; echo $a >&2; done} 2>>$tmpfile &
# The above four shell invocations take about 3 seconds to finish, so allow
# 5s (in case the machine is busy)
after 5000
# Check that no bytes have got lost through mixups with overlapping
# appends, which is only guaranteed to work when we set O_APPEND on the
# file descriptor in the [exec >>...]
file size $tmpfile
} -cleanup {
|
| ︙ | ︙ |
Changes to tests/execute.test.
| ︙ | ︙ | |||
30 31 32 33 34 35 36 |
testConstraint testobj [expr {
[llength [info commands testobj]]
&& [llength [info commands testdoubleobj]]
&& [llength [info commands teststringobj]]
}]
| | | 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 |
testConstraint testobj [expr {
[llength [info commands testobj]]
&& [llength [info commands testdoubleobj]]
&& [llength [info commands teststringobj]]
}]
testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}]
testConstraint testexprlongobj [llength [info commands testexprlongobj]]
# Tests for the omnibus TclExecuteByteCode function:
# INST_DONE not tested
# INST_PUSH1 not tested
# INST_PUSH4 not tested
|
| ︙ | ︙ | |||
797 798 799 800 801 802 803 |
} 1
# wide ints have more bits of precision than doubles, but we convert anyway
test execute-7.7 {Wide int handling in INST_EQ and [incr]} {
set x [expr {wide(1)<<62}]
set y [expr {$x+1}]
expr {double($x) == double($y)}
} 1
| | | | | 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 |
} 1
# wide ints have more bits of precision than doubles, but we convert anyway
test execute-7.7 {Wide int handling in INST_EQ and [incr]} {
set x [expr {wide(1)<<62}]
set y [expr {$x+1}]
expr {double($x) == double($y)}
} 1
test execute-7.8 {Wide int conversions can change sign} {
set x 0x8000000000000000
expr {wide($x) < 0}
} 1
test execute-7.9 {Wide int handling in INST_MOD} {
expr {(wide(1)<<60) % ((wide(47)<<45)-1)}
} 316659348800185
test execute-7.10 {Wide int handling in INST_MOD} {
expr {((wide(1)<<60)-1) % 0x400000000}
} 17179869183
|
| ︙ | ︙ | |||
879 880 881 882 883 884 885 |
} 1
test execute-7.31 {Wide int handling in abs()} {
set x 0xa23456871234568
incr x
set y 0x123456871234568
concat [expr {abs($x)}] [expr {abs($y)}]
} {730503879441204585 81985533099853160}
| | | | | | 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 |
} 1
test execute-7.31 {Wide int handling in abs()} {
set x 0xa23456871234568
incr x
set y 0x123456871234568
concat [expr {abs($x)}] [expr {abs($y)}]
} {730503879441204585 81985533099853160}
test execute-7.32 {Wide int handling} {
expr {int(1024 * 1024 * 1024 * 1024)}
} 1099511627776
test execute-7.33 {Wide int handling} {
expr {int(0x1 * 1024 * 1024 * 1024 * 1024)}
} 1099511627776
test execute-7.34 {Wide int handling} {
expr {wide(0x1) * 1024 * 1024 * 1024 * 1024}
} 1099511627776
test execute-8.1 {Stack protection} -setup {
# If [Bug #804681] has not been properly taken care of, this should
# segfault
|
| ︙ | ︙ |
Changes to tests/expr-old.test.
| ︙ | ︙ | |||
18 19 20 21 22 23 24 | ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] testConstraint testexprlong [llength [info commands testexprlong]] testConstraint testexprdouble [llength [info commands testexprdouble]] testConstraint testexprstring [llength [info commands testexprstring]] | | > | 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 |
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testexprlong [llength [info commands testexprlong]]
testConstraint testexprdouble [llength [info commands testexprdouble]]
testConstraint testexprstring [llength [info commands testexprstring]]
testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}]
testConstraint longIs64bit [expr {$tcl_platform(wordSize) == 8}]
# Big test for correct ordering of data in [expr]
proc testIEEE {} {
variable ieeeValues
binary scan [binary format dd -1.0 1.0] c* c
switch -exact -- $c {
|
| ︙ | ︙ | |||
809 810 811 812 813 814 815 |
expr int(-1.4)
} {-1}
test expr-old-32.32 {math functions in expressions} {
expr int(-1.6)
} {-1}
test expr-old-32.33 {math functions in expressions} {
expr int(1e60)
| | | | 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 |
expr int(-1.4)
} {-1}
test expr-old-32.32 {math functions in expressions} {
expr int(-1.6)
} {-1}
test expr-old-32.33 {math functions in expressions} {
expr int(1e60)
} 999999999999999949387135297074018866963645011013410073083904
test expr-old-32.34 {math functions in expressions} {
expr int(-1e60)
} -999999999999999949387135297074018866963645011013410073083904
test expr-old-32.35 {math functions in expressions} {
expr round(1.49)
} {1}
test expr-old-32.36 {math functions in expressions} {
expr round(1.51)
} {2}
test expr-old-32.37 {math functions in expressions} {
|
| ︙ | ︙ | |||
1032 1033 1034 1035 1036 1037 1038 |
list [catch {testexprlong 0x100000000} result] $result
} \
-result {1 {integer value too large to represent*}}
test expr-old-37.8 {Tcl_ExprLong handles overflows} testexprlong {
testexprlong -0x80000000
} {This is a result: -2147483648}
test expr-old-37.9 {Tcl_ExprLong handles overflows} {testexprlong longIs32bit} {
| | | | 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 |
list [catch {testexprlong 0x100000000} result] $result
} \
-result {1 {integer value too large to represent*}}
test expr-old-37.8 {Tcl_ExprLong handles overflows} testexprlong {
testexprlong -0x80000000
} {This is a result: -2147483648}
test expr-old-37.9 {Tcl_ExprLong handles overflows} {testexprlong longIs32bit} {
testexprlong -0x7fffffff
} {This is a result: -2147483647}
test expr-old-37.10 {Tcl_ExprLong handles overflows} \
-constraints {testexprlong longIs32bit} \
-match glob \
-body {
list [catch {testexprlong -0x100000000} result] $result
} \
-result {1 {integer value too large to represent*}}
|
| ︙ | ︙ | |||
1057 1058 1059 1060 1061 1062 1063 |
-body {
list [catch {testexprlong 4294967296.} result] $result
} \
-result {1 {integer value too large to represent*}}
test expr-old-37.14 {Tcl_ExprLong handles overflows} testexprlong {
testexprlong -2147483648.
} {This is a result: -2147483648}
| | | > > > > | | 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 |
-body {
list [catch {testexprlong 4294967296.} result] $result
} \
-result {1 {integer value too large to represent*}}
test expr-old-37.14 {Tcl_ExprLong handles overflows} testexprlong {
testexprlong -2147483648.
} {This is a result: -2147483648}
test expr-old-37.15 {Tcl_ExprLong handles overflows} \
-constraints {testexprlong longIs32bit} \
-match glob \
-body {
list [catch {testexprlong -2147483649.} result] $result
} \
-result {1 {integer value too large to represent*}}
test expr-old-37.16 {Tcl_ExprLong handles overflows} \
-constraints {testexprlong longIs32bit} \
-match glob \
-body {
list [catch {testexprlong 4294967296.} result] $result
} \
-result {1 {integer value too large to represent*}}
|
| ︙ | ︙ |
Changes to tests/expr.test.
| ︙ | ︙ | |||
16 17 18 19 20 21 22 | } ::tcltest::loadTestedCommands # Determine if "long int" type is a 32 bit number and if the wide # type is a 64 bit number on this machine. | | | | < | 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 |
}
::tcltest::loadTestedCommands
# Determine if "long int" type is a 32 bit number and if the wide
# type is a 64 bit number on this machine.
testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}]
testConstraint longIs64bit [expr {$tcl_platform(wordSize) == 8}]
testConstraint wideIs64bit [expr {wide(0x8000000000000000) < 0}]
# Big test for correct ordering of data in [expr]
proc testIEEE {} {
variable ieeeValues
binary scan [binary format dd -1.0 1.0] c* c
switch -exact -- $c {
|
| ︙ | ︙ | |||
412 413 414 415 416 417 418 |
expr {1ea}
} -returnCodes error -match glob -result *
test expr-9.1 {CompileRelationalExpr: just shift expr} {expr 3<<2} 12
test expr-9.2 {CompileRelationalExpr: just shift expr} {expr 0xff>>2} 63
test expr-9.3 {CompileRelationalExpr: just shift expr} {expr -1>>2} -1
test expr-9.4 {CompileRelationalExpr: just shift expr} {expr {1<<3}} 8
| | | < < < | 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 |
expr {1ea}
} -returnCodes error -match glob -result *
test expr-9.1 {CompileRelationalExpr: just shift expr} {expr 3<<2} 12
test expr-9.2 {CompileRelationalExpr: just shift expr} {expr 0xff>>2} 63
test expr-9.3 {CompileRelationalExpr: just shift expr} {expr -1>>2} -1
test expr-9.4 {CompileRelationalExpr: just shift expr} {expr {1<<3}} 8
test expr-9.5 {CompileRelationalExpr: shift expr producing LONG_MIN} {
expr {int(1<<63)}
} 9223372036854775808
test expr-9.6 {CompileRelationalExpr: error in shift expr} -body {
expr x>>3
} -returnCodes error -match glob -result *
test expr-9.7 {CompileRelationalExpr: simple relational exprs} {expr 0xff>=+0x3} 1
test expr-9.8 {CompileRelationalExpr: simple relational exprs} {expr -0xf2<0x3} 1
test expr-9.9 {CompileRelationalExpr: error compiling relational arm} -body {
expr 2***3>6
|
| ︙ | ︙ | |||
1106 1107 1108 1109 1110 1111 1112 |
test expr-23.54.10 {INST_EXPON: Bug 2798543} {
expr {3**19 == 3**65555}
} 0
test expr-23.54.11 {INST_EXPON: Bug 2798543} {
expr {3**9 == 3**131081}
} 0
test expr-23.54.12 {INST_EXPON: Bug 2798543} -body {
| | | | | | | | | | | | | | | | | | | | | | | | | 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 |
test expr-23.54.10 {INST_EXPON: Bug 2798543} {
expr {3**19 == 3**65555}
} 0
test expr-23.54.11 {INST_EXPON: Bug 2798543} {
expr {3**9 == 3**131081}
} 0
test expr-23.54.12 {INST_EXPON: Bug 2798543} -body {
expr {3**268435456}
} -returnCodes error -result {exponent too large}
test expr-23.54.13 {INST_EXPON: Bug 2798543} {
expr {(-3)**9 == (-3)**65545}
} 0
test expr-23.55.0 {INST_EXPON: Bug 2798543} {
expr {4**9 == 4**65545}
} 0
test expr-23.55.1 {INST_EXPON: Bug 2798543} {
expr {4**15 == 4**65551}
} 0
test expr-23.55.2 {INST_EXPON: Bug 2798543} {
expr {4**9 == 4**131081}
} 0
test expr-23.55.3 {INST_EXPON: Bug 2798543} -body {
expr {4**268435456}
} -returnCodes error -result {exponent too large}
test expr-23.55.4 {INST_EXPON: Bug 2798543} {
expr {(-4)**9 == (-4)**65545}
} 0
test expr-23.56.0 {INST_EXPON: Bug 2798543} {
expr {5**9 == 5**65545}
} 0
test expr-23.56.1 {INST_EXPON: Bug 2798543} {
expr {5**13 == 5**65549}
} 0
test expr-23.56.2 {INST_EXPON: Bug 2798543} {
expr {5**9 == 5**131081}
} 0
test expr-23.56.3 {INST_EXPON: Bug 2798543} -body {
expr {5**268435456}
} -returnCodes error -result {exponent too large}
test expr-23.56.4 {INST_EXPON: Bug 2798543} {
expr {(-5)**9 == (-5)**65545}
} 0
test expr-23.57.0 {INST_EXPON: Bug 2798543} {
expr {6**9 == 6**65545}
} 0
test expr-23.57.1 {INST_EXPON: Bug 2798543} {
expr {6**11 == 6**65547}
} 0
test expr-23.57.2 {INST_EXPON: Bug 2798543} {
expr {6**9 == 6**131081}
} 0
test expr-23.57.3 {INST_EXPON: Bug 2798543} -body {
expr {6**268435456}
} -returnCodes error -result {exponent too large}
test expr-23.57.4 {INST_EXPON: Bug 2798543} {
expr {(-6)**9 == (-6)**65545}
} 0
test expr-23.58.0 {INST_EXPON: Bug 2798543} {
expr {7**9 == 7**65545}
} 0
test expr-23.58.1 {INST_EXPON: Bug 2798543} {
expr {7**11 == 7**65547}
} 0
test expr-23.58.2 {INST_EXPON: Bug 2798543} {
expr {7**9 == 7**131081}
} 0
test expr-23.58.3 {INST_EXPON: Bug 2798543} -body {
expr {7**268435456}
} -returnCodes error -result {exponent too large}
test expr-23.58.4 {INST_EXPON: Bug 2798543} {
expr {(-7)**9 == (-7)**65545}
} 0
test expr-23.59.0 {INST_EXPON: Bug 2798543} {
expr {8**9 == 8**65545}
} 0
test expr-23.59.1 {INST_EXPON: Bug 2798543} {
expr {8**10 == 8**65546}
} 0
test expr-23.59.2 {INST_EXPON: Bug 2798543} {
expr {8**9 == 8**131081}
} 0
test expr-23.59.3 {INST_EXPON: Bug 2798543} -body {
expr {8**268435456}
} -returnCodes error -result {exponent too large}
test expr-23.59.4 {INST_EXPON: Bug 2798543} {
expr {(-8)**9 == (-8)**65545}
} 0
test expr-23.60.0 {INST_EXPON: Bug 2798543} {
expr {9**9 == 9**65545}
} 0
test expr-23.60.1 {INST_EXPON: Bug 2798543} {
expr {9**9 == 9**131081}
} 0
test expr-23.60.2 {INST_EXPON: Bug 2798543} -body {
expr {9**268435456}
} -returnCodes error -result {exponent too large}
test expr-23.60.3 {INST_EXPON: Bug 2798543} {
expr {(-9)**9 == (-9)**65545}
} 0
test expr-23.61.0 {INST_EXPON: Bug 2798543} {
expr {10**9 == 10**65545}
} 0
test expr-23.61.1 {INST_EXPON: Bug 2798543} {
expr {10**9 == 10**131081}
} 0
test expr-23.61.2 {INST_EXPON: Bug 2798543} -body {
expr {10**268435456}
} -returnCodes error -result {exponent too large}
test expr-23.61.3 {INST_EXPON: Bug 2798543} {
expr {(-10)**9 == (-10)**65545}
} 0
test expr-23.62.0 {INST_EXPON: Bug 2798543} {
expr {11**9 == 11**65545}
} 0
test expr-23.62.1 {INST_EXPON: Bug 2798543} {
expr {11**9 == 11**131081}
} 0
test expr-23.62.2 {INST_EXPON: Bug 2798543} -body {
expr {11**268435456}
} -returnCodes error -result {exponent too large}
test expr-23.62.3 {INST_EXPON: Bug 2798543} {
expr {(-11)**9 == (-11)**65545}
} 0
test expr-23.63.0 {INST_EXPON: Bug 2798543} {
expr {3**20 == 3**65556}
} 0
test expr-23.63.1 {INST_EXPON: Bug 2798543} {
expr {3**39 == 3**65575}
} 0
test expr-23.63.2 {INST_EXPON: Bug 2798543} {
expr {3**20 == 3**131092}
} 0
test expr-23.63.3 {INST_EXPON: Bug 2798543} -body {
expr {3**268435456}
} -returnCodes error -result {exponent too large}
test expr-23.63.4 {INST_EXPON: Bug 2798543} {
expr {(-3)**20 == (-3)**65556}
} 0
test expr-23.64.0 {INST_EXPON: Bug 2798543} {
expr {4**17 == 4**65553}
} 0
test expr-23.64.1 {INST_EXPON: Bug 2798543} {
expr {4**31 == 4**65567}
} 0
test expr-23.64.2 {INST_EXPON: Bug 2798543} {
expr {4**17 == 4**131089}
} 0
test expr-23.64.3 {INST_EXPON: Bug 2798543} -body {
expr {4**268435456}
} -returnCodes error -result {exponent too large}
test expr-23.64.4 {INST_EXPON: Bug 2798543} {
expr {(-4)**17 == (-4)**65553}
} 0
test expr-23.65.0 {INST_EXPON: Bug 2798543} {
expr {5**17 == 5**65553}
} 0
test expr-23.65.1 {INST_EXPON: Bug 2798543} {
expr {5**27 == 5**65563}
} 0
test expr-23.65.2 {INST_EXPON: Bug 2798543} {
expr {5**17 == 5**131089}
} 0
test expr-23.65.3 {INST_EXPON: Bug 2798543} -body {
expr {5**268435456}
} -returnCodes error -result {exponent too large}
test expr-23.65.4 {INST_EXPON: Bug 2798543} {
expr {(-5)**17 == (-5)**65553}
} 0
test expr-23.66.0 {INST_EXPON: Bug 2798543} {
expr {6**17 == 6**65553}
} 0
test expr-23.66.1 {INST_EXPON: Bug 2798543} {
expr {6**24 == 6**65560}
} 0
test expr-23.66.2 {INST_EXPON: Bug 2798543} {
expr {6**17 == 6**131089}
} 0
test expr-23.66.3 {INST_EXPON: Bug 2798543} -body {
expr {6**268435456}
} -returnCodes error -result {exponent too large}
test expr-23.66.4 {INST_EXPON: Bug 2798543} {
expr {(-6)**17 == (-6)**65553}
} 0
test expr-23.67.0 {INST_EXPON: Bug 2798543} {
expr {7**17 == 7**65553}
} 0
test expr-23.67.1 {INST_EXPON: Bug 2798543} {
expr {7**22 == 7**65558}
} 0
test expr-23.67.2 {INST_EXPON: Bug 2798543} {
expr {7**17 == 7**131089}
} 0
test expr-23.67.3 {INST_EXPON: Bug 2798543} -body {
expr {7**268435456}
} -returnCodes error -result {exponent too large}
test expr-23.67.4 {INST_EXPON: Bug 2798543} {
expr {(-7)**17 == (-7)**65553}
} 0
test expr-23.68.0 {INST_EXPON: Bug 2798543} {
expr {8**17 == 8**65553}
} 0
test expr-23.68.1 {INST_EXPON: Bug 2798543} {
expr {8**20 == 8**65556}
} 0
test expr-23.68.2 {INST_EXPON: Bug 2798543} {
expr {8**17 == 8**131089}
} 0
test expr-23.68.3 {INST_EXPON: Bug 2798543} -body {
expr {8**268435456}
} -returnCodes error -result {exponent too large}
test expr-23.68.4 {INST_EXPON: Bug 2798543} {
expr {(-8)**17 == (-8)**65553}
} 0
test expr-23.69.0 {INST_EXPON: Bug 2798543} {
expr {9**17 == 9**65553}
} 0
test expr-23.69.1 {INST_EXPON: Bug 2798543} {
expr {9**19 == 9**65555}
} 0
test expr-23.69.2 {INST_EXPON: Bug 2798543} {
expr {9**17 == 9**131089}
} 0
test expr-23.69.3 {INST_EXPON: Bug 2798543} -body {
expr {9**268435456}
} -returnCodes error -result {exponent too large}
test expr-23.69.4 {INST_EXPON: Bug 2798543} {
expr {(-9)**17 == (-9)**65553}
} 0
test expr-23.70.0 {INST_EXPON: Bug 2798543} {
expr {10**17 == 10**65553}
} 0
test expr-23.70.1 {INST_EXPON: Bug 2798543} {
expr {10**18 == 10**65554}
} 0
test expr-23.70.2 {INST_EXPON: Bug 2798543} {
expr {10**17 == 10**131089}
} 0
test expr-23.70.3 {INST_EXPON: Bug 2798543} -body {
expr {10**268435456}
} -returnCodes error -result {exponent too large}
test expr-23.70.4 {INST_EXPON: Bug 2798543} {
expr {(-10)**17 == (-10)**65553}
} 0
test expr-23.71.0 {INST_EXPON: Bug 2798543} {
expr {11**17 == 11**65553}
} 0
test expr-23.71.1 {INST_EXPON: Bug 2798543} {
expr {11**18 == 11**65554}
} 0
test expr-23.71.2 {INST_EXPON: Bug 2798543} {
expr {11**17 == 11**131089}
} 0
test expr-23.71.3 {INST_EXPON: Bug 2798543} -body {
expr {11**268435456}
} -returnCodes error -result {exponent too large}
test expr-23.71.4 {INST_EXPON: Bug 2798543} {
expr {(-11)**17 == (-11)**65553}
} 0
test expr-23.72.0 {INST_EXPON: Bug 2798543} {
expr {12**17 == 12**65553}
} 0
test expr-23.72.1 {INST_EXPON: Bug 2798543} {
expr {12**17 == 12**131089}
} 0
test expr-23.72.2 {INST_EXPON: Bug 2798543} -body {
expr {12**268435456}
} -returnCodes error -result {exponent too large}
test expr-23.72.3 {INST_EXPON: Bug 2798543} {
expr {(-12)**17 == (-12)**65553}
} 0
test expr-23.73.0 {INST_EXPON: Bug 2798543} {
expr {13**17 == 13**65553}
} 0
test expr-23.73.1 {INST_EXPON: Bug 2798543} {
expr {13**17 == 13**131089}
} 0
test expr-23.73.2 {INST_EXPON: Bug 2798543} -body {
expr {13**268435456}
} -returnCodes error -result {exponent too large}
test expr-23.73.3 {INST_EXPON: Bug 2798543} {
expr {(-13)**17 == (-13)**65553}
} 0
test expr-23.74.0 {INST_EXPON: Bug 2798543} {
expr {14**17 == 14**65553}
} 0
test expr-23.74.1 {INST_EXPON: Bug 2798543} {
expr {14**17 == 14**131089}
} 0
test expr-23.74.2 {INST_EXPON: Bug 2798543} -body {
expr {14**268435456}
} -returnCodes error -result {exponent too large}
test expr-23.74.3 {INST_EXPON: Bug 2798543} {
expr {(-14)**17 == (-14)**65553}
} 0
# Some compilers get this wrong; ensure that we work around it correctly
test expr-24.1 {expr edge cases; shifting} {expr int(5)>>32} 0
test expr-24.2 {expr edge cases; shifting} {expr int(5)>>63} 0
test expr-24.3 {expr edge cases; shifting} {expr wide(5)>>32} 0
test expr-24.4 {expr edge cases; shifting} {expr wide(5)>>63} 0
test expr-24.5 {expr edge cases; shifting} {expr int(5<<32)} 21474836480
test expr-24.6 {expr edge cases; shifting} {expr int(5<<63)} 46116860184273879040
test expr-24.7 {expr edge cases; shifting} {expr wide(5)<<32} 21474836480
test expr-24.8 {expr edge cases; shifting} {expr wide(10<<63)} 0
test expr-24.9 {expr edge cases; shifting} {expr 5>>32} 0
test expr-24.10 {INST_LSHIFT: Bug 1567222} {expr 500000000000000<<28} 134217728000000000000000
# List membership tests
|
| ︙ | ︙ | |||
5804 5805 5806 5807 5808 5809 5810 |
test expr-32.8 {bignum regression} {
expr {0%-(1<<63)}
} 0
test expr-32.9 {bignum regression} {
expr {0%-(1+(1<<63))}
} 0
| | | | | 5800 5801 5802 5803 5804 5805 5806 5807 5808 5809 5810 5811 5812 5813 5814 5815 5816 5817 5818 5819 5820 5821 5822 5823 5824 5825 5826 5827 5828 5829 5830 5831 5832 5833 5834 5835 5836 5837 5838 5839 5840 5841 5842 5843 5844 5845 5846 5847 5848 |
test expr-32.8 {bignum regression} {
expr {0%-(1<<63)}
} 0
test expr-32.9 {bignum regression} {
expr {0%-(1+(1<<63))}
} 0
test expr-33.1 {parse largest long value} {
set max_long_str 2147483647
set max_long_hex "0x7FFFFFFF "
# Convert to integer (long, not wide) internal rep
set max_long 2147483647
string is integer $max_long
list \
[expr {" $max_long_str "}] \
[expr {$max_long_str + 0}] \
[expr {$max_long + 0}] \
[expr {2147483647 + 0}] \
[expr {$max_long == $max_long_hex}] \
[expr {int(2147483647 + 1) > 0}] \
} {2147483647 2147483647 2147483647 2147483647 1 1}
test expr-33.2 {parse smallest long value} longIs32bit {
set min_long_str -2147483648
set min_long_hex "-0x80000000 "
set min_long -2147483648
# This will convert to integer (not wide) internal rep
string is integer $min_long
# Note: If the final expression returns 0 then the
# expression literal is being promoted to a wide type
# when it should be parsed as a long type.
list \
[expr {" $min_long_str "}] \
[expr {$min_long_str + 0}] \
[expr {$min_long + 0}] \
[expr {-2147483648 + 0}] \
[expr {$min_long == $min_long_hex}] \
[expr {int(-2147483648 - 1) == -0x80000001}] \
} {-2147483648 -2147483648 -2147483648 -2147483648 1 1}
test expr-33.3 {parse largest wide value} wideIs64bit {
set max_wide_str 9223372036854775807
set max_wide_hex "0x7FFFFFFFFFFFFFFF "
# Convert to wide integer
|
| ︙ | ︙ | |||
5918 5919 5920 5921 5922 5923 5924 |
} {-2}
test expr-34.11 {expr edge cases} {
expr {$min / -2}
} {1073741824}
test expr-34.12 {expr edge cases} {
expr {$min % -2}
} {0}
| | | | | | | | 5914 5915 5916 5917 5918 5919 5920 5921 5922 5923 5924 5925 5926 5927 5928 5929 5930 5931 5932 5933 5934 5935 5936 5937 5938 |
} {-2}
test expr-34.11 {expr edge cases} {
expr {$min / -2}
} {1073741824}
test expr-34.12 {expr edge cases} {
expr {$min % -2}
} {0}
test expr-34.13 {expr edge cases} {
expr {int($min / -1)}
} {2147483648}
test expr-34.14 {expr edge cases} {
expr {$min % -1}
} {0}
test expr-34.15 {expr edge cases} {
expr {-int($min * -1)}
} $min
test expr-34.16 {expr edge cases} {
expr {-int(-$min)}
} $min
test expr-34.17 {expr edge cases} {
expr {$min / 1}
} $min
test expr-34.18 {expr edge cases} {
expr {$min % 1}
} {0}
|
| ︙ | ︙ | |||
6715 6716 6717 6718 6719 6720 6721 |
list [catch {testexprlongobj 0x100000000} result] $result
} \
-result {1 {integer value too large to represent*}}
test expr-39.8 {Tcl_ExprLongObj handles overflows} testexprlongobj {
testexprlongobj -0x80000000
} {This is a result: -2147483648}
test expr-39.9 {Tcl_ExprLongObj handles overflows} {testexprlongobj longIs32bit} {
| | | | 6711 6712 6713 6714 6715 6716 6717 6718 6719 6720 6721 6722 6723 6724 6725 6726 |
list [catch {testexprlongobj 0x100000000} result] $result
} \
-result {1 {integer value too large to represent*}}
test expr-39.8 {Tcl_ExprLongObj handles overflows} testexprlongobj {
testexprlongobj -0x80000000
} {This is a result: -2147483648}
test expr-39.9 {Tcl_ExprLongObj handles overflows} {testexprlongobj longIs32bit} {
testexprlongobj -0x7fffffff
} {This is a result: -2147483647}
test expr-39.10 {Tcl_ExprLongObj handles overflows} \
-constraints {testexprlongobj longIs32bit} \
-match glob \
-body {
list [catch {testexprlongobj -0x100000000} result] $result
} \
-result {1 {integer value too large to represent*}}
|
| ︙ | ︙ | |||
6741 6742 6743 6744 6745 6746 6747 |
list [catch {testexprlongobj 4294967296.} result] $result
} \
-result {1 {integer value too large to represent*}}
test expr-39.14 {Tcl_ExprLongObj handles overflows} testexprlongobj {
testexprlongobj -2147483648.
} {This is a result: -2147483648}
test expr-39.15 {Tcl_ExprLongObj handles overflows} {testexprlongobj longIs32bit} {
| | | | 6737 6738 6739 6740 6741 6742 6743 6744 6745 6746 6747 6748 6749 6750 6751 6752 |
list [catch {testexprlongobj 4294967296.} result] $result
} \
-result {1 {integer value too large to represent*}}
test expr-39.14 {Tcl_ExprLongObj handles overflows} testexprlongobj {
testexprlongobj -2147483648.
} {This is a result: -2147483648}
test expr-39.15 {Tcl_ExprLongObj handles overflows} {testexprlongobj longIs32bit} {
testexprlongobj -2147483648.
} {This is a result: -2147483648}
test expr-39.16 {Tcl_ExprLongObj handles overflows} \
-constraints {testexprlongobj longIs32bit} \
-match glob \
-body {
list [catch {testexprlongobj 4294967296.} result] $result
} \
-result {1 {integer value too large to represent*}}
|
| ︙ | ︙ | |||
7151 7152 7153 7154 7155 7156 7157 7158 7159 7160 7161 7162 7163 7164 |
test expr-50.1 {test sqrt() of bignums with non-Inf answer} {
expr {sqrt("1[string repeat 0 616]") == 1e308}
} 1
test expr-51.1 {test round-to-even on input} {
expr 6.9294956446009195e15
} 6929495644600920.0
# cleanup
if {[info exists a]} {
unset a
}
| > > > > > > > > > | 7147 7148 7149 7150 7151 7152 7153 7154 7155 7156 7157 7158 7159 7160 7161 7162 7163 7164 7165 7166 7167 7168 7169 |
test expr-50.1 {test sqrt() of bignums with non-Inf answer} {
expr {sqrt("1[string repeat 0 616]") == 1e308}
} 1
test expr-51.1 {test round-to-even on input} {
expr 6.9294956446009195e15
} 6929495644600920.0
test expr-52.1 {
comparison with empty string does not generate string representation
} {
set a [list one two three]
list [expr {$a eq {}}] [expr {$a < {}}] [expr {$a > {}}] [
string match {*no string representation*} [
::tcl::unsupported::representation $a]]
} {0 0 1 1}
# cleanup
if {[info exists a]} {
unset a
}
|
| ︙ | ︙ |
Changes to tests/fCmd.test.
| ︙ | ︙ | |||
61 62 63 64 65 66 67 |
if {[catch {makeDirectory tcl[pid] /tmp} tmpspace] == 0} {
testConstraint xdev [expr {([dev .] != [dev $tmpspace])}]
}
}
# Also used in winFCmd...
if {[testConstraint win]} {
| | < | | 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 |
if {[catch {makeDirectory tcl[pid] /tmp} tmpspace] == 0} {
testConstraint xdev [expr {([dev .] != [dev $tmpspace])}]
}
}
# Also used in winFCmd...
if {[testConstraint win]} {
if {$::tcl_platform(osVersion) >= 5.0} {
testConstraint winVista 1
} else {
testConstraint winXP 1
}
}
testConstraint darwin9 [expr {
[testConstraint unix]
&& $tcl_platform(os) eq "Darwin"
&& [package vsatisfies 1.$::tcl_platform(osVersion) 1.9]
}]
testConstraint notDarwin9 [expr {![testConstraint darwin9]}]
testConstraint fileSharing 0
testConstraint notFileSharing 1
testConstraint linkFile 1
testConstraint linkDirectory 1
|
| ︙ | ︙ | |||
786 787 788 789 790 791 792 |
testchmod 0o444 tf2
file rename tf1 tf3
file rename tf2 tf4
list [lsort [glob tf*]] [file writable tf3] [file writable tf4]
} -result {{tf3 tf4} 1 0}
test fCmd-9.4.a {file rename: comprehensive: dir to new name} -setup {
cleanup
| | | 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 |
testchmod 0o444 tf2
file rename tf1 tf3
file rename tf2 tf4
list [lsort [glob tf*]] [file writable tf3] [file writable tf4]
} -result {{tf3 tf4} 1 0}
test fCmd-9.4.a {file rename: comprehensive: dir to new name} -setup {
cleanup
} -constraints {win winXP testchmod} -body {
file mkdir td1 td2
testchmod 0o555 td2
file rename td1 td3
file rename td2 td4
list [lsort [glob td*]] [file writable td3] [file writable td4]
} -cleanup {
cleanup
|
| ︙ | ︙ | |||
2303 2304 2305 2306 2307 2308 2309 |
file attributes foo.tmp {*}[lrange $attrs 0 3]
} -cleanup {
file delete -force -- foo.tmp
} -result {}
if {
[testConstraint win] &&
| | | 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 |
file attributes foo.tmp {*}[lrange $attrs 0 3]
} -cleanup {
file delete -force -- foo.tmp
} -result {}
if {
[testConstraint win] &&
($::tcl_platform(osVersion) < 5.0
|| [lindex [file system [temporaryDirectory]] 1] ne "NTFS")
} then {
testConstraint linkDirectory 0
testConstraint linkFile 0
}
test fCmd-28.1 {file link} -returnCodes error -body {
|
| ︙ | ︙ |
Changes to tests/fileName.test.
| ︙ | ︙ | |||
19 20 21 22 23 24 25 |
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testsetplatform [llength [info commands testsetplatform]]
testConstraint testtranslatefilename [llength [info commands testtranslatefilename]]
testConstraint linkDirectory 1
testConstraint symbolicLinkFile 1
if {[testConstraint win]} {
| | | 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 |
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testsetplatform [llength [info commands testsetplatform]]
testConstraint testtranslatefilename [llength [info commands testtranslatefilename]]
testConstraint linkDirectory 1
testConstraint symbolicLinkFile 1
if {[testConstraint win]} {
if {$::tcl_platform(osVersion) < 5.0 \
|| [lindex [file system [temporaryDirectory]] 1] ne "NTFS"} {
testConstraint linkDirectory 0
}
testConstraint symbolicLinkFile 0
testConstraint sharedCdrive [expr {![catch {cd //[info hostname]/c}]}]
}
# This match compares the first two words of the result. If the wanted result
|
| ︙ | ︙ | |||
774 775 776 777 778 779 780 781 782 783 784 785 786 787 |
glob ~\\/globTest
} [list [file join $env(HOME) globTest]]
test filename-11.16 {Tcl_GlobCmd} {
glob globTest
} {globTest}
set globname "globTest"
set horribleglobname "glob\[\{Test"
test filename-11.17 {Tcl_GlobCmd} {unix} {
lsort [glob -directory $globname *]
} [lsort [list [file join $globname a1] [file join $globname a2]\
[file join $globname a3]\
[file join $globname "weird name.c"]\
[file join $globname x,z1.c]\
[file join $globname x1.c]\
| > > | 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 |
glob ~\\/globTest
} [list [file join $env(HOME) globTest]]
test filename-11.16 {Tcl_GlobCmd} {
glob globTest
} {globTest}
set globname "globTest"
set horribleglobname "glob\[\{Test"
set tildeglobname "./~test.txt"
test filename-11.17 {Tcl_GlobCmd} {unix} {
lsort [glob -directory $globname *]
} [lsort [list [file join $globname a1] [file join $globname a2]\
[file join $globname a3]\
[file join $globname "weird name.c"]\
[file join $globname x,z1.c]\
[file join $globname x1.c]\
|
| ︙ | ︙ | |||
913 914 915 916 917 918 919 |
touch {[tcl].testremains}
lsort [glob -path {[tcl]} *]
} -cleanup {
file delete -force {[tcl].testremains}
} -result {{[tcl].testremains}}
# Get rid of file/dir if it exists, since it will have been left behind by a
# previous failed run.
| < | < > > > | 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 |
touch {[tcl].testremains}
lsort [glob -path {[tcl]} *]
} -cleanup {
file delete -force {[tcl].testremains}
} -result {{[tcl].testremains}}
# Get rid of file/dir if it exists, since it will have been left behind by a
# previous failed run.
file delete -force $horribleglobname
file rename globTest $horribleglobname
set globname $horribleglobname
file delete -force $tildeglobname
close [open $tildeglobname w]
test filename-11.22 {Tcl_GlobCmd} {unix} {
lsort [glob -dir $globname *]
} [lsort [list [file join $globname a1] [file join $globname a2]\
[file join $globname a3]\
[file join $globname "weird name.c"]\
[file join $globname x,z1.c]\
[file join $globname x1.c]\
|
| ︙ | ︙ | |||
1036 1037 1038 1039 1040 1041 1042 |
} -match compareWords -result equal
test filename-11.41 {Tcl_GlobCmd} -body {
list [glob -dir [pwd] -tails *] [glob -dir [pwd] *]
} -match compareWords -result "not equal"
test filename-11.42 {Tcl_GlobCmd} -body {
set res [list]
foreach f [glob -dir [pwd] *] {
| > > | | 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 |
} -match compareWords -result equal
test filename-11.41 {Tcl_GlobCmd} -body {
list [glob -dir [pwd] -tails *] [glob -dir [pwd] *]
} -match compareWords -result "not equal"
test filename-11.42 {Tcl_GlobCmd} -body {
set res [list]
foreach f [glob -dir [pwd] *] {
set f [file tail $f]
regsub {^./} $f {} f; # until glob bug [2511011fff] don't fixed (tilde expansion prevention).
lappend res $f
}
list $res [glob *]
} -match compareWords -result equal
test filename-11.43 {Tcl_GlobCmd} -returnCodes error -body {
glob -t *
} -result {ambiguous option "-t": must be -directory, -join, -nocomplain, -path, -tails, -types, or --}
test filename-11.44 {Tcl_GlobCmd} -returnCodes error -body {
|
| ︙ | ︙ | |||
1076 1077 1078 1079 1080 1081 1082 1083 |
glob -types abcde -dir foo -join * *
} -result {bad argument to "-types": abcde}
test filename-11.49 {Tcl_GlobCmd} -returnCodes error -body {
glob -types abcde -path foo -join * *
} -result {bad argument to "-types": abcde}
file rename $horribleglobname globTest
set globname globTest
| > | | 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 |
glob -types abcde -dir foo -join * *
} -result {bad argument to "-types": abcde}
test filename-11.49 {Tcl_GlobCmd} -returnCodes error -body {
glob -types abcde -path foo -join * *
} -result {bad argument to "-types": abcde}
file rename $horribleglobname globTest
file delete -force $tildeglobname
set globname globTest
unset horribleglobname tildeglobname
test filename-12.1 {simple globbing} {unixOrPc} {
glob {}
} {.}
test filename-12.1.1 {simple globbing} -constraints {unixOrPc} -body {
glob -types f {}
} -result {}
|
| ︙ | ︙ |
Changes to tests/fileSystem.test.
| ︙ | ︙ | |||
260 261 262 263 264 265 266 267 268 269 270 271 272 273 |
file delete -force [file join dir.dir dirinside.link]
removeFile [file join dir.dir inside.file]
removeDirectory [file join dir.dir dirinside.dir]
removeDirectory dir.dir
test filesystem-1.30 {normalisation of nonexistent user} -body {
file normalize ~noonewiththisname
} -returnCodes error -result {user "noonewiththisname" doesn't exist}
test filesystem-1.31 {link normalisation: link near filesystem root} {testsetplatform} {
testsetplatform unix
file normalize /foo/../bar
} {/bar}
test filesystem-1.32 {link normalisation: link near filesystem root} {testsetplatform} {
testsetplatform unix
file normalize /../bar
| > > > > > > | 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 |
file delete -force [file join dir.dir dirinside.link]
removeFile [file join dir.dir inside.file]
removeDirectory [file join dir.dir dirinside.dir]
removeDirectory dir.dir
test filesystem-1.30 {normalisation of nonexistent user} -body {
file normalize ~noonewiththisname
} -returnCodes error -result {user "noonewiththisname" doesn't exist}
test filesystem-1.30.1 {normalisation of existing user} -body {
catch {file normalize ~$::tcl_platform(user)}
} -result {0}
test filesystem-1.30.2 {normalisation of nonexistent user specified as user@domain} -body {
file normalize ~nonexistentuser@nonexistentdomain
} -returnCodes error -result {user "nonexistentuser@nonexistentdomain" doesn't exist}
test filesystem-1.31 {link normalisation: link near filesystem root} {testsetplatform} {
testsetplatform unix
file normalize /foo/../bar
} {/bar}
test filesystem-1.32 {link normalisation: link near filesystem root} {testsetplatform} {
testsetplatform unix
file normalize /../bar
|
| ︙ | ︙ |
Changes to tests/format.test.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 |
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
# %u output depends on word length, so this test is not portable.
| | | | < < | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 |
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
# %u output depends on word length, so this test is not portable.
testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}]
testConstraint longIs64bit [expr {$tcl_platform(wordSize) == 8}]
testConstraint wideIs64bit [expr {wide(0x8000000000000000) < 0}]
testConstraint pointerIs64bit [expr {$tcl_platform(pointerSize) >= 8}]
test format-1.1 {integer formatting} {
format "%*d %d %d %d" 6 34 16923 -12 -1
} { 34 16923 -12 -1}
test format-1.2 {integer formatting} {
format "%4d %4d %4d %4d %d %#x %#X" 6 34 16923 -12 -1 14 12
|
| ︙ | ︙ | |||
543 544 545 546 547 548 549 |
for {set i 290} {$i < 400} {incr i} {
test format-16.[expr $i -289] {testing MAX_FLOAT_SIZE} {
format {%s} $b
} $b
append b "x"
}
| | | 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 |
for {set i 290} {$i < 400} {incr i} {
test format-16.[expr $i -289] {testing MAX_FLOAT_SIZE} {
format {%s} $b
} $b
append b "x"
}
test format-17.1 {testing %d with wide} {longIs32bit wideIs64bit} {
format %d 7810179016327718216
} 1819043144
test format-17.2 {testing %ld with wide} {wideIs64bit} {
format %ld 7810179016327718216
} 7810179016327718216
test format-17.3 {testing %ld with non-wide} {wideIs64bit} {
format %ld 42
|
| ︙ | ︙ | |||
576 577 578 579 580 581 582 |
lappend result [expr {$a == $b}]
set b 0xaaaa
append b aaaa
lappend result [expr {$a == $b}]
format %08x $b
lappend result [expr {$a == $b}]
} {1 1 1 1}
| | > > > > > > > > > > > > > > | 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 |
lappend result [expr {$a == $b}]
set b 0xaaaa
append b aaaa
lappend result [expr {$a == $b}]
format %08x $b
lappend result [expr {$a == $b}]
} {1 1 1 1}
test format-18.2 {do not demote existing numeric values} {longIs32bit wideIs64bit} {
set a [expr {0xaaaaaaaaaa + 1}]
set b 0xaaaaaaaaab
list [format %08x $a] [expr {$a == $b}]
} {aaaaaaab 1}
test format-19.1 {regression test - tcl-core message by Brian Griffin on 26 0ctober 2004} -body {
set x 0x8fedc654
list [expr { ~ $x }] [format %08x [expr { ~$x }]]
} -match regexp -result {-2414724693 f*701239ab}
test format-19.2 {Bug 1867855} {
format %llx 0
} 0
test format-19.3 {Bug 2830354} {
string length [format %340f 0]
} 340
test format-19.4.1 {Bug d498578df4: width overflow should cause limit exceeded} \
-constraints {longIs32bit} -body {
# in case of overflow into negative, it produces width -2 (and limit exceeded),
# in case of width will be unsigned, it will be outside limit (2GB for 32bit)...
# and it don't throw an error in case the bug is not fixed (and probably no segfault).
format %[expr {0xffffffff - 1}]g 0
} -returnCodes error -result "max size for a Tcl value exceeded"
test format-19.4.2 {Bug d498578df4: width overflow should cause limit exceeded} -body {
# limit should exceeds in any case,
# and it don't throw an error in case the bug is not fixed (and probably no segfault).
format %[expr {0xffffffffffffffff - 1}]g 0
} -returnCodes error -result "max size for a Tcl value exceeded"
# Note that this test may fail in future versions
test format-20.1 {Bug 2932421: plain %s caused intrep change of args} -body {
set x [dict create a b c d]
format %s $x
# After this, obj in $x should be a dict
# We are testing to make sure it has not been shimmered to a
|
| ︙ | ︙ |
Changes to tests/get.test.
| ︙ | ︙ | |||
16 17 18 19 20 21 22 | } ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] testConstraint testgetint [llength [info commands testgetint]] testConstraint testdoubleobj [llength [info commands testdoubleobj]] | | | | 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 |
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testgetint [llength [info commands testgetint]]
testConstraint testdoubleobj [llength [info commands testdoubleobj]]
testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}]
testConstraint longIs64bit [expr {$tcl_platform(wordSize) == 8}]
test get-1.1 {Tcl_GetInt procedure} testgetint {
testgetint 44 { 22}
} {66}
test get-1.2 {Tcl_GetInt procedure} testgetint {
testgetint 44 -3
} {41}
|
| ︙ | ︙ | |||
41 42 43 44 45 46 47 |
test get-1.6 {Tcl_GetInt procedure} testgetint {
list [catch {testgetint 44 {16 x}} msg] $msg
} {1 {expected integer but got "16 x"}}
test get-1.7 {Tcl_GetInt procedure} {testgetint longIs64bit} {
list [catch {testgetint 44 18446744073709551616} msg] $msg $errorCode
} {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}}
test get-1.8 {Tcl_GetInt procedure} {testgetint longIs64bit} {
| | | | | | | | | 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 |
test get-1.6 {Tcl_GetInt procedure} testgetint {
list [catch {testgetint 44 {16 x}} msg] $msg
} {1 {expected integer but got "16 x"}}
test get-1.7 {Tcl_GetInt procedure} {testgetint longIs64bit} {
list [catch {testgetint 44 18446744073709551616} msg] $msg $errorCode
} {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}}
test get-1.8 {Tcl_GetInt procedure} {testgetint longIs64bit} {
testgetint 18446744073709551614
} {-2}
test get-1.9 {Tcl_GetInt procedure} {testgetint longIs64bit} {
testgetint +18446744073709551614
} {-2}
test get-1.10 {Tcl_GetInt procedure} {testgetint longIs64bit} {
list [catch {testgetint -18446744073709551614} msg] $msg $errorCode
} {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}}
test get-1.11 {Tcl_GetInt procedure} {testgetint longIs32bit} {
list [catch {testgetint 44 4294967296} msg] $msg $errorCode
} {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}}
test get-1.12 {Tcl_GetInt procedure} {testgetint longIs32bit} {
list [catch {testgetint 4294967294} msg] $msg
} {0 -2}
test get-1.13 {Tcl_GetInt procedure} {testgetint longIs32bit} {
list [catch {testgetint +4294967294} msg] $msg
} {0 -2}
test get-1.14 {Tcl_GetInt procedure} {testgetint longIs32bit} {
list [catch {testgetint -4294967294} msg] $msg
} {1 {integer value too large to represent}}
test get-2.1 {Tcl_GetInt procedure} {
format %g 1.23
} {1.23}
test get-2.2 {Tcl_GetInt procedure} {
format %g { 1.23 }
} {1.23}
|
| ︙ | ︙ |
Changes to tests/http.test.
| ︙ | ︙ | |||
78 79 80 81 82 83 84 |
return
}
}
test http-1.1 {http::config} {
http::config -useragent UserAgent
http::config
| | | | | 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 |
return
}
}
test http-1.1 {http::config} {
http::config -useragent UserAgent
http::config
} [list -accept */* -cookiejar {} -pipeline 1 -postfresh 0 -proxyfilter http::ProxyRequired -proxyhost {} -proxyport {} -repost 0 -urlencoding utf-8 -useragent UserAgent -zip 1]
test http-1.2 {http::config} {
http::config -proxyfilter
} http::ProxyRequired
test http-1.3 {http::config} {
catch {http::config -junk}
} 1
test http-1.4 {http::config} {
set savedconf [http::config]
http::config -proxyhost nowhere.come -proxyport 8080 \
-proxyfilter myFilter -useragent "Tcl Test Suite" \
-urlencoding iso8859-1
set x [http::config]
http::config {*}$savedconf
set x
} {-accept */* -cookiejar {} -pipeline 1 -postfresh 0 -proxyfilter myFilter -proxyhost nowhere.come -proxyport 8080 -repost 0 -urlencoding iso8859-1 -useragent {Tcl Test Suite} -zip 1}
test http-1.5 {http::config} -returnCodes error -body {
http::config -proxyhost {} -junk 8080
} -result {Unknown option -junk, must be: -accept, -cookiejar, -pipeline, -postfresh, -proxyfilter, -proxyhost, -proxyport, -repost, -urlencoding, -useragent, -zip}
test http-1.6 {http::config} -setup {
set oldenc [http::config -urlencoding]
} -body {
set enc [list [http::config -urlencoding]]
http::config -urlencoding iso8859-1
lappend enc [http::config -urlencoding]
} -cleanup {
|
| ︙ | ︙ | |||
596 597 598 599 600 601 602 |
catch {http::cleanup $token}
} -returnCodes 1 -match glob -result "couldn't open socket*"
test http-4.16 {Leak with Close vs Keepalive (bug [6ca52aec14]} -setup {
proc list-difference {l1 l2} {
lmap item $l2 {if {$item in $l1} continue; set item}
}
} -body {
| | | 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 |
catch {http::cleanup $token}
} -returnCodes 1 -match glob -result "couldn't open socket*"
test http-4.16 {Leak with Close vs Keepalive (bug [6ca52aec14]} -setup {
proc list-difference {l1 l2} {
lmap item $l2 {if {$item in $l1} continue; set item}
}
} -body {
set before [chan names]
set token [http::geturl $url -headers {X-Connection keep-alive}]
http::cleanup $token
update
# Compute what channels have been unexpectedly leaked past cleanup
list-difference $before [chan names]
} -cleanup {
rename list-difference {}
|
| ︙ | ︙ | |||
665 666 667 668 669 670 671 672 673 674 675 676 677 678 |
# this would be reverting to http <=2.4 behavior w/o errors
# (unknown chars become '?')
http::config -urlencoding "iso8859-1"
http::mapReply "\u2208"
} -cleanup {
http::config -urlencoding $enc
} -result {%3F}
# cleanup
catch {unset url}
catch {unset badurl}
catch {unset port}
catch {unset data}
if {[info exists httpthread]} {
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 |
# this would be reverting to http <=2.4 behavior w/o errors
# (unknown chars become '?')
http::config -urlencoding "iso8859-1"
http::mapReply "\u2208"
} -cleanup {
http::config -urlencoding $enc
} -result {%3F}
package require -exact tcl::idna 1.0
test http-idna-1.1 {IDNA package: basics} -returnCodes error -body {
::tcl::idna
} -result {wrong # args: should be "::tcl::idna subcommand ?arg ...?"}
test http-idna-1.2 {IDNA package: basics} -returnCodes error -body {
::tcl::idna ?
} -result {unknown or ambiguous subcommand "?": must be decode, encode, puny, or version}
test http-idna-1.3 {IDNA package: basics} -body {
::tcl::idna version
} -result 1.0
test http-idna-1.4 {IDNA package: basics} -returnCodes error -body {
::tcl::idna version what
} -result {wrong # args: should be "::tcl::idna version"}
test http-idna-1.5 {IDNA package: basics} -returnCodes error -body {
::tcl::idna puny
} -result {wrong # args: should be "::tcl::idna puny subcommand ?arg ...?"}
test http-idna-1.6 {IDNA package: basics} -returnCodes error -body {
::tcl::idna puny ?
} -result {unknown or ambiguous subcommand "?": must be decode, or encode}
test http-idna-1.7 {IDNA package: basics} -returnCodes error -body {
::tcl::idna puny encode
} -result {wrong # args: should be "::tcl::idna puny encode string ?case?"}
test http-idna-1.8 {IDNA package: basics} -returnCodes error -body {
::tcl::idna puny encode a b c
} -result {wrong # args: should be "::tcl::idna puny encode string ?case?"}
test http-idna-1.9 {IDNA package: basics} -returnCodes error -body {
::tcl::idna puny decode
} -result {wrong # args: should be "::tcl::idna puny decode string ?case?"}
test http-idna-1.10 {IDNA package: basics} -returnCodes error -body {
::tcl::idna puny decode a b c
} -result {wrong # args: should be "::tcl::idna puny decode string ?case?"}
test http-idna-1.11 {IDNA package: basics} -returnCodes error -body {
::tcl::idna decode
} -result {wrong # args: should be "::tcl::idna decode hostname"}
test http-idna-1.12 {IDNA package: basics} -returnCodes error -body {
::tcl::idna encode
} -result {wrong # args: should be "::tcl::idna encode hostname"}
test http-idna-2.1 {puny encode: functional test} {
::tcl::idna puny encode abc
} abc-
test http-idna-2.2 {puny encode: functional test} {
::tcl::idna puny encode a\u20acb\u20acc
} abc-k50ab
test http-idna-2.3 {puny encode: functional test} {
::tcl::idna puny encode ABC
} ABC-
test http-idna-2.4 {puny encode: functional test} {
::tcl::idna puny encode A\u20ACB\u20ACC
} ABC-k50ab
test http-idna-2.5 {puny encode: functional test} {
::tcl::idna puny encode ABC 0
} abc-
test http-idna-2.6 {puny encode: functional test} {
::tcl::idna puny encode A\u20ACB\u20ACC 0
} abc-k50ab
test http-idna-2.7 {puny encode: functional test} {
::tcl::idna puny encode ABC 1
} ABC-
test http-idna-2.8 {puny encode: functional test} {
::tcl::idna puny encode A\u20ACB\u20ACC 1
} ABC-k50ab
test http-idna-2.9 {puny encode: functional test} {
::tcl::idna puny encode abc 0
} abc-
test http-idna-2.10 {puny encode: functional test} {
::tcl::idna puny encode a\u20ACb\u20ACc 0
} abc-k50ab
test http-idna-2.11 {puny encode: functional test} {
::tcl::idna puny encode abc 1
} ABC-
test http-idna-2.12 {puny encode: functional test} {
::tcl::idna puny encode a\u20ACb\u20ACc 1
} ABC-k50ab
test http-idna-2.13 {puny encode: edge cases} {
::tcl::idna puny encode ""
} ""
test http-idna-2.14-A {puny encode: examples from RFC 3492} {
::tcl::idna puny encode [join [subst [string map {u+ \\u} {
u+0644 u+064A u+0647 u+0645 u+0627 u+0628 u+062A u+0643 u+0644
u+0645 u+0648 u+0634 u+0639 u+0631 u+0628 u+064A u+061F
}]] ""]
} egbpdaj6bu4bxfgehfvwxn
test http-idna-2.14-B {puny encode: examples from RFC 3492} {
::tcl::idna puny encode [join [subst [string map {u+ \\u} {
u+4ED6 u+4EEC u+4E3A u+4EC0 u+4E48 u+4E0D u+8BF4 u+4E2D u+6587
}]] ""]
} ihqwcrb4cv8a8dqg056pqjye
test http-idna-2.14-C {puny encode: examples from RFC 3492} {
::tcl::idna puny encode [join [subst [string map {u+ \\u} {
u+4ED6 u+5011 u+7232 u+4EC0 u+9EBD u+4E0D u+8AAA u+4E2D u+6587
}]] ""]
} ihqwctvzc91f659drss3x8bo0yb
test http-idna-2.14-D {puny encode: examples from RFC 3492} {
::tcl::idna puny encode [join [subst [string map {u+ \\u} {
u+0050 u+0072 u+006F u+010D u+0070 u+0072 u+006F u+0073 u+0074
u+011B u+006E u+0065 u+006D u+006C u+0075 u+0076 u+00ED u+010D
u+0065 u+0073 u+006B u+0079
}]] ""]
} Proprostnemluvesky-uyb24dma41a
test http-idna-2.14-E {puny encode: examples from RFC 3492} {
::tcl::idna puny encode [join [subst [string map {u+ \\u} {
u+05DC u+05DE u+05D4 u+05D4 u+05DD u+05E4 u+05E9 u+05D5 u+05D8
u+05DC u+05D0 u+05DE u+05D3 u+05D1 u+05E8 u+05D9 u+05DD u+05E2
u+05D1 u+05E8 u+05D9 u+05EA
}]] ""]
} 4dbcagdahymbxekheh6e0a7fei0b
test http-idna-2.14-F {puny encode: examples from RFC 3492} {
::tcl::idna puny encode [join [subst [string map {u+ \\u} {
u+092F u+0939 u+0932 u+094B u+0917 u+0939 u+093F u+0928 u+094D
u+0926 u+0940 u+0915 u+094D u+092F u+094B u+0902 u+0928 u+0939
u+0940 u+0902 u+092C u+094B u+0932 u+0938 u+0915 u+0924 u+0947
u+0939 u+0948 u+0902
}]] ""]
} i1baa7eci9glrd9b2ae1bj0hfcgg6iyaf8o0a1dig0cd
test http-idna-2.14-G {puny encode: examples from RFC 3492} {
::tcl::idna puny encode [join [subst [string map {u+ \\u} {
u+306A u+305C u+307F u+3093 u+306A u+65E5 u+672C u+8A9E u+3092
u+8A71 u+3057 u+3066 u+304F u+308C u+306A u+3044 u+306E u+304B
}]] ""]
} n8jok5ay5dzabd5bym9f0cm5685rrjetr6pdxa
test http-idna-2.14-H {puny encode: examples from RFC 3492} {
::tcl::idna puny encode [join [subst [string map {u+ \\u} {
u+C138 u+ACC4 u+C758 u+BAA8 u+B4E0 u+C0AC u+B78C u+B4E4 u+C774
u+D55C u+AD6D u+C5B4 u+B97C u+C774 u+D574 u+D55C u+B2E4 u+BA74
u+C5BC u+B9C8 u+B098 u+C88B u+C744 u+AE4C
}]] ""]
} 989aomsvi5e83db1d2a355cv1e0vak1dwrv93d5xbh15a0dt30a5jpsd879ccm6fea98c
test http-idna-2.14-I {puny encode: examples from RFC 3492} {
::tcl::idna puny encode [join [subst [string map {u+ \\u} {
u+043F u+043E u+0447 u+0435 u+043C u+0443 u+0436 u+0435 u+043E
u+043D u+0438 u+043D u+0435 u+0433 u+043E u+0432 u+043E u+0440
u+044F u+0442 u+043F u+043E u+0440 u+0443 u+0441 u+0441 u+043A
u+0438
}]] ""]
} b1abfaaepdrnnbgefbadotcwatmq2g4l
test http-idna-2.14-J {puny encode: examples from RFC 3492} {
::tcl::idna puny encode [join [subst [string map {u+ \\u} {
u+0050 u+006F u+0072 u+0071 u+0075 u+00E9 u+006E u+006F u+0070
u+0075 u+0065 u+0064 u+0065 u+006E u+0073 u+0069 u+006D u+0070
u+006C u+0065 u+006D u+0065 u+006E u+0074 u+0065 u+0068 u+0061
u+0062 u+006C u+0061 u+0072 u+0065 u+006E u+0045 u+0073 u+0070
u+0061 u+00F1 u+006F u+006C
}]] ""]
} PorqunopuedensimplementehablarenEspaol-fmd56a
test http-idna-2.14-K {puny encode: examples from RFC 3492} {
::tcl::idna puny encode [join [subst [string map {u+ \\u} {
u+0054 u+1EA1 u+0069 u+0073 u+0061 u+006F u+0068 u+1ECD u+006B
u+0068 u+00F4 u+006E u+0067 u+0074 u+0068 u+1EC3 u+0063 u+0068
u+1EC9 u+006E u+00F3 u+0069 u+0074 u+0069 u+1EBF u+006E u+0067
u+0056 u+0069 u+1EC7 u+0074
}]] ""]
} TisaohkhngthchnitingVit-kjcr8268qyxafd2f1b9g
test http-idna-2.14-L {puny encode: examples from RFC 3492} {
::tcl::idna puny encode [join [subst [string map {u+ \\u} {
u+0033 u+5E74 u+0042 u+7D44 u+91D1 u+516B u+5148 u+751F
}]] ""]
} 3B-ww4c5e180e575a65lsy2b
test http-idna-2.14-M {puny encode: examples from RFC 3492} {
::tcl::idna puny encode [join [subst [string map {u+ \\u} {
u+5B89 u+5BA4 u+5948 u+7F8E u+6075 u+002D u+0077 u+0069 u+0074
u+0068 u+002D u+0053 u+0055 u+0050 u+0045 u+0052 u+002D u+004D
u+004F u+004E u+004B u+0045 u+0059 u+0053
}]] ""]
} -with-SUPER-MONKEYS-pc58ag80a8qai00g7n9n
test http-idna-2.14-N {puny encode: examples from RFC 3492} {
::tcl::idna puny encode [join [subst [string map {u+ \\u} {
u+0048 u+0065 u+006C u+006C u+006F u+002D u+0041 u+006E u+006F
u+0074 u+0068 u+0065 u+0072 u+002D u+0057 u+0061 u+0079 u+002D
u+305D u+308C u+305E u+308C u+306E u+5834 u+6240
}]] ""]
} Hello-Another-Way--fc4qua05auwb3674vfr0b
test http-idna-2.14-O {puny encode: examples from RFC 3492} {
::tcl::idna puny encode [join [subst [string map {u+ \\u} {
u+3072 u+3068 u+3064 u+5C4B u+6839 u+306E u+4E0B u+0032
}]] ""]
} 2-u9tlzr9756bt3uc0v
test http-idna-2.14-P {puny encode: examples from RFC 3492} {
::tcl::idna puny encode [join [subst [string map {u+ \\u} {
u+004D u+0061 u+006A u+0069 u+3067 u+004B u+006F u+0069 u+3059
u+308B u+0035 u+79D2 u+524D
}]] ""]
} MajiKoi5-783gue6qz075azm5e
test http-idna-2.14-Q {puny encode: examples from RFC 3492} {
::tcl::idna puny encode [join [subst [string map {u+ \\u} {
u+30D1 u+30D5 u+30A3 u+30FC u+0064 u+0065 u+30EB u+30F3 u+30D0
}]] ""]
} de-jg4avhby1noc0d
test http-idna-2.14-R {puny encode: examples from RFC 3492} {
::tcl::idna puny encode [join [subst [string map {u+ \\u} {
u+305D u+306E u+30B9 u+30D4 u+30FC u+30C9 u+3067
}]] ""]
} d9juau41awczczp
test http-idna-2.14-S {puny encode: examples from RFC 3492} {
::tcl::idna puny encode {-> $1.00 <-}
} {-> $1.00 <--}
test http-idna-3.1 {puny decode: functional test} {
::tcl::idna puny decode abc-
} abc
test http-idna-3.2 {puny decode: functional test} {
::tcl::idna puny decode abc-k50ab
} a\u20acb\u20acc
test http-idna-3.3 {puny decode: functional test} {
::tcl::idna puny decode ABC-
} ABC
test http-idna-3.4 {puny decode: functional test} {
::tcl::idna puny decode ABC-k50ab
} A\u20ACB\u20ACC
test http-idna-3.5 {puny decode: functional test} {
::tcl::idna puny decode ABC-K50AB
} A\u20ACB\u20ACC
test http-idna-3.6 {puny decode: functional test} {
::tcl::idna puny decode abc-K50AB
} a\u20ACb\u20ACc
test http-idna-3.7 {puny decode: functional test} {
::tcl::idna puny decode ABC- 0
} abc
test http-idna-3.8 {puny decode: functional test} {
::tcl::idna puny decode ABC-K50AB 0
} a\u20ACb\u20ACc
test http-idna-3.9 {puny decode: functional test} {
::tcl::idna puny decode ABC- 1
} ABC
test http-idna-3.10 {puny decode: functional test} {
::tcl::idna puny decode ABC-K50AB 1
} A\u20ACB\u20ACC
test http-idna-3.11 {puny decode: functional test} {
::tcl::idna puny decode abc- 0
} abc
test http-idna-3.12 {puny decode: functional test} {
::tcl::idna puny decode abc-k50ab 0
} a\u20ACb\u20ACc
test http-idna-3.13 {puny decode: functional test} {
::tcl::idna puny decode abc- 1
} ABC
test http-idna-3.14 {puny decode: functional test} {
::tcl::idna puny decode abc-k50ab 1
} A\u20ACB\u20ACC
test http-idna-3.15 {puny decode: edge cases and errors} {
# Is this case actually correct?
binary encode hex [encoding convertto utf-8 [::tcl::idna puny decode abc]]
} c282c281c280
test http-idna-3.16 {puny decode: edge cases and errors} -returnCodes error -body {
::tcl::idna puny decode abc!
} -result {bad decode character "!"}
test http-idna-3.17 {puny decode: edge cases and errors} {
catch {::tcl::idna puny decode abc!} -> opt
dict get $opt -errorcode
} {PUNYCODE BAD_INPUT CHAR}
test http-idna-3.18 {puny decode: edge cases and errors} {
::tcl::idna puny decode ""
} {}
# A helper so we don't get lots of crap in failures
proc hexify s {lmap c [split $s ""] {format u+%04X [scan $c %c]}}
test http-idna-3.19-A {puny decode: examples from RFC 3492} {
hexify [::tcl::idna puny decode egbpdaj6bu4bxfgehfvwxn]
} [list {*}{
u+0644 u+064A u+0647 u+0645 u+0627 u+0628 u+062A u+0643 u+0644
u+0645 u+0648 u+0634 u+0639 u+0631 u+0628 u+064A u+061F
}]
test http-idna-3.19-B {puny decode: examples from RFC 3492} {
hexify [::tcl::idna puny decode ihqwcrb4cv8a8dqg056pqjye]
} {u+4ED6 u+4EEC u+4E3A u+4EC0 u+4E48 u+4E0D u+8BF4 u+4E2D u+6587}
test http-idna-3.19-C {puny decode: examples from RFC 3492} {
hexify [::tcl::idna puny decode ihqwctvzc91f659drss3x8bo0yb]
} {u+4ED6 u+5011 u+7232 u+4EC0 u+9EBD u+4E0D u+8AAA u+4E2D u+6587}
test http-idna-3.19-D {puny decode: examples from RFC 3492} {
hexify [::tcl::idna puny decode Proprostnemluvesky-uyb24dma41a]
} [list {*}{
u+0050 u+0072 u+006F u+010D u+0070 u+0072 u+006F u+0073 u+0074
u+011B u+006E u+0065 u+006D u+006C u+0075 u+0076 u+00ED u+010D
u+0065 u+0073 u+006B u+0079
}]
test http-idna-3.19-E {puny decode: examples from RFC 3492} {
hexify [::tcl::idna puny decode 4dbcagdahymbxekheh6e0a7fei0b]
} [list {*}{
u+05DC u+05DE u+05D4 u+05D4 u+05DD u+05E4 u+05E9 u+05D5 u+05D8
u+05DC u+05D0 u+05DE u+05D3 u+05D1 u+05E8 u+05D9 u+05DD u+05E2
u+05D1 u+05E8 u+05D9 u+05EA
}]
test http-idna-3.19-F {puny decode: examples from RFC 3492} {
hexify [::tcl::idna puny decode \
i1baa7eci9glrd9b2ae1bj0hfcgg6iyaf8o0a1dig0cd]
} [list {*}{
u+092F u+0939 u+0932 u+094B u+0917 u+0939 u+093F u+0928 u+094D
u+0926 u+0940 u+0915 u+094D u+092F u+094B u+0902 u+0928 u+0939
u+0940 u+0902 u+092C u+094B u+0932 u+0938 u+0915 u+0924 u+0947
u+0939 u+0948 u+0902
}]
test http-idna-3.19-G {puny decode: examples from RFC 3492} {
hexify [::tcl::idna puny decode n8jok5ay5dzabd5bym9f0cm5685rrjetr6pdxa]
} [list {*}{
u+306A u+305C u+307F u+3093 u+306A u+65E5 u+672C u+8A9E u+3092
u+8A71 u+3057 u+3066 u+304F u+308C u+306A u+3044 u+306E u+304B
}]
test http-idna-3.19-H {puny decode: examples from RFC 3492} {
hexify [::tcl::idna puny decode \
989aomsvi5e83db1d2a355cv1e0vak1dwrv93d5xbh15a0dt30a5jpsd879ccm6fea98c]
} [list {*}{
u+C138 u+ACC4 u+C758 u+BAA8 u+B4E0 u+C0AC u+B78C u+B4E4 u+C774
u+D55C u+AD6D u+C5B4 u+B97C u+C774 u+D574 u+D55C u+B2E4 u+BA74
u+C5BC u+B9C8 u+B098 u+C88B u+C744 u+AE4C
}]
test http-idna-3.19-I {puny decode: examples from RFC 3492} {
hexify [::tcl::idna puny decode b1abfaaepdrnnbgefbadotcwatmq2g4l]
} [list {*}{
u+043F u+043E u+0447 u+0435 u+043C u+0443 u+0436 u+0435 u+043E
u+043D u+0438 u+043D u+0435 u+0433 u+043E u+0432 u+043E u+0440
u+044F u+0442 u+043F u+043E u+0440 u+0443 u+0441 u+0441 u+043A
u+0438
}]
test http-idna-3.19-J {puny decode: examples from RFC 3492} {
hexify [::tcl::idna puny decode \
PorqunopuedensimplementehablarenEspaol-fmd56a]
} [list {*}{
u+0050 u+006F u+0072 u+0071 u+0075 u+00E9 u+006E u+006F u+0070
u+0075 u+0065 u+0064 u+0065 u+006E u+0073 u+0069 u+006D u+0070
u+006C u+0065 u+006D u+0065 u+006E u+0074 u+0065 u+0068 u+0061
u+0062 u+006C u+0061 u+0072 u+0065 u+006E u+0045 u+0073 u+0070
u+0061 u+00F1 u+006F u+006C
}]
test http-idna-3.19-K {puny decode: examples from RFC 3492} {
hexify [::tcl::idna puny decode \
TisaohkhngthchnitingVit-kjcr8268qyxafd2f1b9g]
} [list {*}{
u+0054 u+1EA1 u+0069 u+0073 u+0061 u+006F u+0068 u+1ECD u+006B
u+0068 u+00F4 u+006E u+0067 u+0074 u+0068 u+1EC3 u+0063 u+0068
u+1EC9 u+006E u+00F3 u+0069 u+0074 u+0069 u+1EBF u+006E u+0067
u+0056 u+0069 u+1EC7 u+0074
}]
test http-idna-3.19-L {puny decode: examples from RFC 3492} {
hexify [::tcl::idna puny decode 3B-ww4c5e180e575a65lsy2b]
} {u+0033 u+5E74 u+0042 u+7D44 u+91D1 u+516B u+5148 u+751F}
test http-idna-3.19-M {puny decode: examples from RFC 3492} {
hexify [::tcl::idna puny decode -with-SUPER-MONKEYS-pc58ag80a8qai00g7n9n]
} [list {*}{
u+5B89 u+5BA4 u+5948 u+7F8E u+6075 u+002D u+0077 u+0069 u+0074
u+0068 u+002D u+0053 u+0055 u+0050 u+0045 u+0052 u+002D u+004D
u+004F u+004E u+004B u+0045 u+0059 u+0053
}]
test http-idna-3.19-N {puny decode: examples from RFC 3492} {
hexify [::tcl::idna puny decode Hello-Another-Way--fc4qua05auwb3674vfr0b]
} [list {*}{
u+0048 u+0065 u+006C u+006C u+006F u+002D u+0041 u+006E u+006F
u+0074 u+0068 u+0065 u+0072 u+002D u+0057 u+0061 u+0079 u+002D
u+305D u+308C u+305E u+308C u+306E u+5834 u+6240
}]
test http-idna-3.19-O {puny decode: examples from RFC 3492} {
hexify [::tcl::idna puny decode 2-u9tlzr9756bt3uc0v]
} {u+3072 u+3068 u+3064 u+5C4B u+6839 u+306E u+4E0B u+0032}
test http-idna-3.19-P {puny decode: examples from RFC 3492} {
hexify [::tcl::idna puny decode MajiKoi5-783gue6qz075azm5e]
} [list {*}{
u+004D u+0061 u+006A u+0069 u+3067 u+004B u+006F u+0069 u+3059
u+308B u+0035 u+79D2 u+524D
}]
test http-idna-3.19-Q {puny decode: examples from RFC 3492} {
hexify [::tcl::idna puny decode de-jg4avhby1noc0d]
} {u+30D1 u+30D5 u+30A3 u+30FC u+0064 u+0065 u+30EB u+30F3 u+30D0}
test http-idna-3.19-R {puny decode: examples from RFC 3492} {
hexify [::tcl::idna puny decode d9juau41awczczp]
} {u+305D u+306E u+30B9 u+30D4 u+30FC u+30C9 u+3067}
test http-idna-3.19-S {puny decode: examples from RFC 3492} {
::tcl::idna puny decode {-> $1.00 <--}
} {-> $1.00 <-}
rename hexify ""
test http-idna-4.1 {IDNA encoding} {
::tcl::idna encode abc.def
} abc.def
test http-idna-4.2 {IDNA encoding} {
::tcl::idna encode a\u20acb\u20acc.def
} xn--abc-k50ab.def
test http-idna-4.3 {IDNA encoding} {
::tcl::idna encode def.a\u20acb\u20acc
} def.xn--abc-k50ab
test http-idna-4.4 {IDNA encoding} {
::tcl::idna encode ABC.DEF
} ABC.DEF
test http-idna-4.5 {IDNA encoding} {
::tcl::idna encode A\u20acB\u20acC.def
} xn--ABC-k50ab.def
test http-idna-4.6 {IDNA encoding: invalid edge case} {
# Should this be an error?
::tcl::idna encode abc..def
} abc..def
test http-idna-4.7 {IDNA encoding: invalid char} -returnCodes error -body {
::tcl::idna encode abc.$.def
} -result {bad character "$" in DNS name}
test http-idna-4.7.1 {IDNA encoding: invalid char} {
catch {::tcl::idna encode abc.$.def} -> opt
dict get $opt -errorcode
} {IDNA INVALID_NAME_CHARACTER {$}}
test http-idna-4.8 {IDNA encoding: empty} {
::tcl::idna encode ""
} {}
set overlong www.[join [subst [string map {u+ \\u} {
u+C138 u+ACC4 u+C758 u+BAA8 u+B4E0 u+C0AC u+B78C u+B4E4 u+C774
u+D55C u+AD6D u+C5B4 u+B97C u+C774 u+D574 u+D55C u+B2E4 u+BA74
u+C5BC u+B9C8 u+B098 u+C88B u+C744 u+AE4C
}]] ""].com
test http-idna-4.9 {IDNA encoding: max lengths from RFC 5890} -body {
::tcl::idna encode $overlong
} -returnCodes error -result "hostname part too long"
test http-idna-4.9.1 {IDNA encoding: max lengths from RFC 5890} {
catch {::tcl::idna encode $overlong} -> opt
dict get $opt -errorcode
} {IDNA OVERLONG_PART xn--989aomsvi5e83db1d2a355cv1e0vak1dwrv93d5xbh15a0dt30a5jpsd879ccm6fea98c}
unset overlong
test http-idna-4.10 {IDNA encoding: edge cases} {
::tcl::idna encode pass\u00e9.example.com
} xn--pass-epa.example.com
test http-idna-5.1 {IDNA decoding} {
::tcl::idna decode abc.def
} abc.def
test http-idna-5.2 {IDNA decoding} {
# Invalid entry that's just a wrapper
::tcl::idna decode xn--abc-.def
} abc.def
test http-idna-5.3 {IDNA decoding} {
# Invalid entry that's just a wrapper
::tcl::idna decode xn--abc-.xn--def-
} abc.def
test http-idna-5.4 {IDNA decoding} {
# Invalid entry that's just a wrapper
::tcl::idna decode XN--abc-.XN--def-
} abc.def
test http-idna-5.5 {IDNA decoding: error cases} -returnCodes error -body {
::tcl::idna decode xn--$$$.example.com
} -result {bad decode character "$"}
test http-idna-5.5.1 {IDNA decoding: error cases} {
catch {::tcl::idna decode xn--$$$.example.com} -> opt
dict get $opt -errorcode
} {PUNYCODE BAD_INPUT CHAR}
test http-idna-5.6 {IDNA decoding: error cases} -returnCodes error -body {
::tcl::idna decode xn--a-zzzzzzzzzzzzzzzzzzzzzzzzzzzzzz.def
} -result {exceeded input data}
test http-idna-5.6.1 {IDNA decoding: error cases} {
catch {::tcl::idna decode xn--a-zzzzzzzzzzzzzzzzzzzzzzzzzzzzzz.def} -> opt
dict get $opt -errorcode
} {PUNYCODE BAD_INPUT LENGTH}
# cleanup
catch {unset url}
catch {unset badurl}
catch {unset port}
catch {unset data}
if {[info exists httpthread]} {
|
| ︙ | ︙ |
Changes to tests/http11.test.
| ︙ | ︙ | |||
511 512 513 514 515 516 517 |
# returns in 3.2 and 3.3 and HTTP/1.1 in all but test 3.1
proc handler {var sock token} {
upvar #0 $var data
set chunk [read $sock]
append data $chunk
#::http::Log "handler read [string length $chunk] ([chan configure $sock -buffersize])"
| | < < < | 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 |
# returns in 3.2 and 3.3 and HTTP/1.1 in all but test 3.1
proc handler {var sock token} {
upvar #0 $var data
set chunk [read $sock]
append data $chunk
#::http::Log "handler read [string length $chunk] ([chan configure $sock -buffersize])"
return [string length $chunk]
}
test http11-3.0 "-handler,close,identity" -setup {
variable httpd [create_httpd]
set testdata ""
} -body {
set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \
|
| ︙ | ︙ | |||
661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 |
http::cleanup $tok
close $chan
removeFile testfile.tmp
halt_httpd
} -result {status ok code {HTTP/1.1 200 OK} crc ok connection close query-length 122880}
# -------------------------------------------------------------------------
foreach p {create_httpd httpd_read halt_httpd meta check_crc} {
if {[llength [info proc $p]]} {rename $p {}}
}
removeFile testdoc.html
unset -nocomplain httpd_port httpd p
::tcltest::cleanupTests
| > > > > > > > | 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 |
http::cleanup $tok
close $chan
removeFile testfile.tmp
halt_httpd
} -result {status ok code {HTTP/1.1 200 OK} crc ok connection close query-length 122880}
# -------------------------------------------------------------------------
# Eliminate valgrind "still reachable" reports on outstanding "Detached"
# structures in the detached list which stem from PipeClose2Proc not waiting
# around for background processes to complete, meaning that previous calls to
# Tcl_ReapDetachedProcs might not have had a chance to reap all processes.
after 10
exec [info nameofexecutable] << {}
foreach p {create_httpd httpd_read halt_httpd meta check_crc} {
if {[llength [info proc $p]]} {rename $p {}}
}
removeFile testdoc.html
unset -nocomplain httpd_port httpd p
::tcltest::cleanupTests
|
Added tests/httpPipeline.test.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 |
# httpPipeline.test
#
# Test HTTP/1.1 concurrent requests including
# queueing, pipelining and retries.
#
# Copyright (C) 2018 Keith Nash <kjnash@users.sourceforge.net>
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
package require tcltest 2
namespace import -force ::tcltest::*
package require http 2.8
set sourcedir [file normalize [file dirname [info script]]]
source [file join $sourcedir httpTest.tcl]
source [file join $sourcedir httpTestScript.tcl]
# ------------------------------------------------------------------------------
# (1) Define the test scripts that will be used to generate logs for analysis -
# and also define the "correct" results.
# ------------------------------------------------------------------------------
proc ReturnTestScriptAndResult {ca cb delay te} {
switch -- $ca {
1 {set start {
START
KEEPALIVE 0
PIPELINE 0
}}
2 {set start {
START
KEEPALIVE 0
PIPELINE 1
}}
3 {set start {
START
KEEPALIVE 1
PIPELINE 0
}}
4 {set start {
START
KEEPALIVE 1
PIPELINE 1
}}
default {
return -code error {no matching script}
}
}
set middle "
[list DELAY $delay]
"
switch -- $cb {
1 {set end {
GET a
GET b
GET c
GET a
STOP
}
set resShort {1 ? ? ?}
set resLong {1 2 3 4}
}
2 {set end {
GET a
HEAD b
GET c
HEAD a
HEAD c
STOP
}
set resShort {1 ? ? ? ?}
set resLong {1 2 3 4 5}
}
3 {set end {
HEAD a
GET b
HEAD c
HEAD b
GET a
GET b
STOP
}
set resShort {1 ? ? ? ? ?}
set resLong {1 2 3 4 5 6}
}
4 {set end {
GET a
GET b
GET c
GET a
POST b address=home code=brief paid=yes
GET c
GET a
GET b
GET c
STOP
}
set resShort {1 ? ? ? 5 ? ? ? ?}
set resLong {1 2 3 4 5 6 7 8 9}
}
5 {set end {
POST a address=home code=brief paid=yes
POST b address=home code=brief paid=yes
POST c address=home code=brief paid=yes
POST a address=home code=brief paid=yes
POST b address=home code=brief paid=yes
POST c address=home code=brief paid=yes
POST a address=home code=brief paid=yes
POST b address=home code=brief paid=yes
POST c address=home code=brief paid=yes
STOP
}
set resShort {1 2 3 4 5 6 7 8 9}
set resLong {1 2 3 4 5 6 7 8 9}
}
6 {set end {
POST a address=home code=brief paid=yes
GET b address=home code=brief paid=yes
POST c address=home code=brief paid=yes
GET a address=home code=brief paid=yes
GET b address=home code=brief paid=yes
POST c address=home code=brief paid=yes
POST a address=home code=brief paid=yes
HEAD b address=home code=brief paid=yes
GET c address=home code=brief paid=yes
STOP
}
set resShort {1 ? 3 ? ? 6 7 ? ?}
set resLong {1 2 3 4 5 6 7 8 9}
}
7 {set end {
GET b address=home code=brief paid=yes
POST a address=home code=brief paid=yes
GET a address=home code=brief paid=yes
POST c address=home code=brief paid=yes
GET b address=home code=brief paid=yes
HEAD b address=home code=brief paid=yes
POST c address=home code=brief paid=yes
POST a address=home code=brief paid=yes
GET c address=home code=brief paid=yes
STOP
}
set resShort {1 2 ? 4 ? ? 7 8 ?}
set resLong {1 2 3 4 5 6 7 8 9}
}
8 {set end {
# Telling the server to close the connection.
GET a
GET b close=y
GET c
GET a
GET b
GET c
GET a
GET b
GET c
STOP
}
set resShort {1 ? 3 ? ? ? ? ? ?}
set resLong {1 2 3 4 5 6 7 8 9}
}
9 {set end {
# Telling the server to close the connection.
GET a
POST b close=y address=home code=brief paid=yes
GET c
GET a
GET b
GET c
GET a
GET b
GET c
STOP
}
set resShort {1 2 3 ? ? ? ? ? ?}
set resLong {1 2 3 4 5 6 7 8 9}
}
10 {set end {
# Telling the server to close the connection.
GET a
GET b close=y
POST c address=home code=brief paid=yes
GET a
GET b
GET c
GET a
GET b
GET c
STOP
}
set resShort {1 ? 3 ? ? ? ? ? ?}
set resLong {1 2 3 4 5 6 7 8 9}
}
11 {set end {
# Telling the server to close the connection twice.
GET a
GET b close=y
GET c
GET a
GET b close=y
GET c
GET a
GET b
GET c
STOP
}
set resShort {1 ? 3 ? ? 6 ? ? ?}
set resLong {1 2 3 4 5 6 7 8 9}
}
12 {set end {
# Telling the server to delay before sending the response.
GET a
GET b delay=1
GET c
GET a
GET b
STOP
}
set resShort {1 ? ? ? ?}
set resLong {1 2 3 4 5}
}
13 {set end {
# Making the server close the connection (time out).
GET a
WAIT 2000
GET b
GET c
GET a
GET b
STOP
}
set resShort {1 2 ? ? ?}
set resLong {1 2 3 4 5}
}
14 {set end {
# Making the server close the connection (time out) twice.
GET a
WAIT 2000
GET b
GET c
GET a
WAIT 2000
GET b
GET c
GET a
GET b
GET c
STOP
}
set resShort {1 2 ? ? 5 ? ? ? ?}
set resLong {1 2 3 4 5 6 7 8 9}
}
15 {set end {
POST a address=home code=brief paid=yes
POST b address=home code=brief paid=yes close=y delay=1
POST c address=home code=brief paid=yes delay=1
POST a address=home code=brief paid=yes close=y
WAIT 2000
POST b address=home code=brief paid=yes delay=1
POST c address=home code=brief paid=yes close=y
POST a address=home code=brief paid=yes
POST b address=home code=brief paid=yes close=y
POST c address=home code=brief paid=yes
STOP
}
set resShort {1 2 3 4 5 6 7 8 9}
set resLong {1 2 3 4 5 6 7 8 9}
}
16 {set end {
POST a address=home code=brief paid=yes
GET b address=home code=brief paid=yes
POST c address=home code=brief paid=yes close=y
GET a address=home code=brief paid=yes
GET b address=home code=brief paid=yes close=y
POST c address=home code=brief paid=yes
WAIT 2000
POST a address=home code=brief paid=yes
HEAD b address=home code=brief paid=yes close=y
GET c address=home code=brief paid=yes
STOP
}
set resShort {1 ? 3 4 ? 6 7 ? 9}
set resLong {1 2 3 4 5 6 7 8 9}
}
17 {set end {
GET b address=home code=brief paid=yes
POST a address=home code=brief paid=yes
GET a address=home code=brief paid=yes
POST c address=home code=brief paid=yes close=y
GET b address=home code=brief paid=yes
HEAD b address=home code=brief paid=yes close=y
POST c address=home code=brief paid=yes
WAIT 2000
POST a address=home code=brief paid=yes
WAIT 2000
GET c address=home code=brief paid=yes
STOP
}
set resShort {1 2 3 4 5 ? 7 8 9}
set resLong {1 2 3 4 5 6 7 8 9}
}
18 {set end {
REPOST 0
GET a
WAIT 2000
POST b address=home code=brief paid=yes
GET c
GET a
STOP
}
set resShort {1 2 ? ?}
set resLong {1 2 3 4}
# resShort is overwritten below for the case ($te == 1).
}
19 {set end {
REPOST 0
GET a
WAIT 2000
GET b address=home code=brief paid=yes
GET c
GET a
STOP
}
set resShort {1 2 ? ?}
set resLong {1 2 3 4}
}
20 {set end {
POSTFRESH 1
GET a
WAIT 2000
POST b address=home code=brief paid=yes
GET c
GET a
STOP
}
set resShort {1 3 ?}
set resLong {1 3 4}
}
21 {set end {
POSTFRESH 1
GET a
WAIT 2000
GET b address=home code=brief paid=yes
GET c
GET a
STOP
}
set resShort {1 2 ? ?}
set resLong {1 2 3 4}
}
22 {set end {
GET a
WAIT 2000
KEEPALIVE 0
POST b address=home code=brief paid=yes
KEEPALIVE 1
GET c
GET a
STOP
}
set resShort {1 3 ?}
set resLong {1 3 4}
}
23 {set end {
GET a
WAIT 2000
KEEPALIVE 0
GET b address=home code=brief paid=yes
KEEPALIVE 1
GET c
GET a
STOP
}
set resShort {1 3 ?}
set resLong {1 3 4}
}
24 {set end {
GET a
KEEPALIVE 0
POST b address=home code=brief paid=yes
KEEPALIVE 1
GET c
GET a
STOP
}
set resShort {1 ? ?}
set resLong {1 3 4}
}
25 {set end {
GET a
KEEPALIVE 0
GET b address=home code=brief paid=yes
KEEPALIVE 1
GET c
GET a
STOP
}
set resShort {1 ? ?}
set resLong {1 3 4}
}
default {
return -code error {no matching script}
}
}
if {$ca < 3} {
# Not Keep-Alive.
set result "Passed all sanity checks."
} elseif {$ca == 3} {
# Keep-Alive, not pipelined.
set result {}
append result "Passed all sanity checks.\n"
append result "Have overlaps including response body:\n"
} else {
# Keep-Alive, pipelined: ($ca == 4)
set result {}
append result "Passed all sanity checks.\n"
append result "Overlap-free without response body:\n"
append result "$resShort"
}
# - The special case of test *.18*-testEof needs test results to be
# individually written.
# - These test -repost 0 when there is a POST to apply it to, and the server
# timeout has not been detected.
if {($cb == 18) && ($te == 1)} {
if {$ca < 3} {
# Not Keep-Alive.
set result "Passed all sanity checks."
} elseif {$ca == 3 && $delay == 0} {
# Keep-Alive, not pipelined.
set result [MakeMessage {
|Problems with sanity checks:
|Wrong sequence for token ::http::2 - {A B C D X X X}
|- and error(s) X
|Wrong sequence for token ::http::3 - {A X X}
|- and error(s) X
|Wrong sequence for token ::http::4 - {A X X X}
|- and error(s) X
|
|Have overlaps including response body:
|
}]
} elseif {$ca == 3} {
# Keep-Alive, not pipelined.
set result [MakeMessage {
|Problems with sanity checks:
|Wrong sequence for token ::http::2 - {A B C D X X X}
|- and error(s) X
|
|Have overlaps including response body:
|
}]
} elseif {$delay == 0} {
# Keep-Alive, pipelined: ($ca == 4)
set result [MakeMessage {
|Problems with sanity checks:
|Wrong sequence for token ::http::2 - {A B C D X X X}
|- and error(s) X
|Wrong sequence for token ::http::3 - {A X X}
|- and error(s) X
|Wrong sequence for token ::http::4 - {A X X X}
|- and error(s) X
|
|Overlap-free without response body:
|
}]
} else {
set result [MakeMessage {
|Problems with sanity checks:
|Wrong sequence for token ::http::2 - {A B C D X X X}
|- and error(s) X
|
|Overlap-free without response body:
|
}]
}
}
return [list "$start$middle$end" $result]
}
# ------------------------------------------------------------------------------
# Proc MakeMessage
# ------------------------------------------------------------------------------
# WHD's one-line command to generate multi-line strings from readable code.
#
# Example:
# set blurb [MakeMessage {
# |This command allows multi-line strings to be created with readable
# |code, and without breaking the rules for indentation.
# |
# |The command shifts the entire block of text to the left, omitting
# |the pipe character and the spaces to its left.
# }]
# ------------------------------------------------------------------------------
proc MakeMessage {in} {
regsub -all -line {^\s*\|} [string trim $in] {}
# N.B. Implicit Return.
}
proc ReturnTestScript {ca cb delay te} {
lassign [ReturnTestScriptAndResult $ca $cb $delay $te] script result
return $script
}
proc ReturnTestResult {ca cb delay te} {
lassign [ReturnTestScriptAndResult $ca $cb $delay $te] script result
return $result
}
# ------------------------------------------------------------------------------
# (2) Command to run a test script and use httpTest to analyse the logs.
# ------------------------------------------------------------------------------
namespace import httpTestScript::runHttpTestScript
namespace import httpTestScript::cleanupHttpTestScript
namespace import httpTest::cleanupHttpTest
namespace import httpTest::logAnalyse
namespace import httpTest::setHttpTestOptions
proc RunTest {header footer delay te} {
set num [runHttpTestScript [ReturnTestScript $header $footer $delay $te]]
set skipOverlaps 0
set notPiped {}
set notIncluded {}
# --------------------------------------------------------------------------
# Custom code for specific tests
# --------------------------------------------------------------------------
if {$header < 3} {
set skipOverlaps 1
for {set i 1} {$i <= $num} {incr i} {
lappend notPiped $i
}
} elseif {$header > 2 && $footer == 18 && $te == 1} {
set skipOverlaps 1
if {$delay == 0} {
# Transaction 1 is conventional.
# Check that transactions 2,3,4 are cancelled.
set notPiped {1}
set notIncluded $notPiped
} else {
# Transaction 1 is conventional.
# Check that transaction 2 is cancelled.
# The timing of transactions 3 and 4 is uncertain.
set notPiped {1 3 4}
set notIncluded $notPiped
}
} elseif {$footer in {20 22 23 24 25}} {
# Transaction 2 uses its own socket.
set notPiped 2
set notIncluded $notPiped
} else {
}
# --------------------------------------------------------------------------
# End of custom code for specific tests
# --------------------------------------------------------------------------
set Results [logAnalyse $num $skipOverlaps $notIncluded $notPiped]
lassign $Results msg cleanE cleanF dirtyE dirtyF
if {$msg eq {}} {
set msg "Passed all sanity checks."
} else {
set msg "Problems with sanity checks:\n$msg"
}
if 0 {
puts $msg
puts "Overlap-free including response body:\n$cleanF"
puts "Have overlaps including response body:\n$dirtyF"
puts "Overlap-free without response body:\n$cleanE"
puts "Have overlaps without response body:\n$dirtyE"
}
if {$header < 3} {
# No ordering, just check that transactions all finish
set result $msg
} elseif {$header == 3} {
# Not pipelined - check overlaps with response body.
set result "$msg\nHave overlaps including response body:\n$dirtyF"
} else {
# Pipelined - check overlaps without response body. Check that the
# first request, the first requests after replay, and POSTs are clean.
set result "$msg\nOverlap-free without response body:\n$cleanE"
}
set ::nTokens $num
return $result
}
# ------------------------------------------------------------------------------
# (3) VERBOSITY CONTROL
# ------------------------------------------------------------------------------
# If tests fail, run an individual test with -verbose 1 or 2 for diagnosis.
# If still obscure, uncomment #Log and ##Log lines in the http package.
# ------------------------------------------------------------------------------
setHttpTestOptions -verbose 0
# ------------------------------------------------------------------------------
# (4) Define the base URLs used for testing. Each must have a query string.
# ------------------------------------------------------------------------------
# - A HTTP/1.1 server is required. It should be configured to provide
# persistent connections when requested to do so, and to close these
# connections if they are idle for one second.
# - The resource must be served with status 200 in response to a valid GET or
# POST.
# - The value of "page" is always specified in the query-string. Different
# resources for the three values of "page" allow testing of both chunked and
# unchunked transfer encoding.
# - The variables "close" and "delay" may be specified in the query-string (for
# a GET) or the request body (for a POST).
# - "delay" is a numerical value in seconds, and causes the server to delay
# the response, including headers.
# - "close", if it has the value "y", instructs the server to close the
# connection ater the current request.
# - Any other variables should be ignored.
# ------------------------------------------------------------------------------
namespace eval ::httpTestScript {
variable URL
array set URL {
a http://test-tcl-http.kerlin.org/index.html?page=privacy
b http://test-tcl-http.kerlin.org/index.html?page=conditions
c http://test-tcl-http.kerlin.org/index.html?page=welcome
}
}
# ------------------------------------------------------------------------------
# (5) Define the tests
# ------------------------------------------------------------------------------
# Constraints:
# - serverNeeded - the URLs defined at (4) must be available, and must have the
# properties specified there.
# - duplicate - the value of -pipeline does not matter if -keepalive 0
# - timeout1s - tests that work correctly only if the server closes
# persistent connections after one second.
#
# Server timeout of persistent connections should be 1s. Delays of 2s are
# intended to cause timeout.
# Servers are usually configured to use a longer timeout: this will cause the
# tests to fail. The "2000" could be replaced with a larger number, but the
# tests will then be inconveniently slow.
# ------------------------------------------------------------------------------
#testConstraint serverNeeded 1
#testConstraint timeout1s 1
#testConstraint duplicate 1
# ------------------------------------------------------------------------------
# Proc SetTestEof - to edit the command ::http::KeepSocket
# ------------------------------------------------------------------------------
# The usual line in command ::http::KeepSocket is " set TEST_EOF 0".
# Whether the value set in the file is 0 or 1, change it here to the value
# specified by the argument.
#
# It is worth doing all tests for both values of the argument.
#
# test 0 - ::http::KeepSocket is unchanged, detects server eof where possible
# and closes the connection.
# test 1 - ::http::KeepSocket is edited, does not detect server eof, so the
# reaction to finding server eof can be tested without the difficulty
# of testing in the few milliseconds of an asynchronous close event.
# ------------------------------------------------------------------------------
proc SetTestEof {test} {
set body [info body ::http::KeepSocket]
set subs " set TEST_EOF $test"
set count [regsub -line -all -- {^\s*set TEST_EOF .*$} $body $subs newBody]
if {$count != 1} {
return -code error {proc ::http::KeepSocket has unexpected form}
}
proc ::http::KeepSocket {token} $newBody
return
}
for {set header 1} {$header <= 4} {incr header} {
if {$header == 4} {
setHttpTestOptions -dotted 1
set match glob
} else {
setHttpTestOptions -dotted 0
set match exact
}
if {$header == 2} {
set cons0 {serverNeeded duplicate}
} else {
set cons0 serverNeeded
}
for {set footer 1} {$footer <= 25} {incr footer} {
foreach {delay label} {
0 a
1 b
2 c
3 d
5 e
8 f
12 g
100 h
500 i
2000 j
} {
foreach te {0 1} {
if {$te} {
set tag testEof
} else {
set tag normal
}
set suffix {}
set cons $cons0
# ------------------------------------------------------------------
# Custom code for individual tests
# ------------------------------------------------------------------
if {$footer in {18}} {
# Custom code:
if {($label eq "j") && ($te == 1)} {
continue
}
if {$te == 1} {
# The test (of REPOST 0) is useful if tag is "testEof"
# (server timeout without client reaction). The same test
# has a different result if tag is "normal".
set suffix " - extra test for -repost 0 - ::http::2 must be"
append suffix " cancelled"
if {($delay == 0)} {
append suffix ", along with ::http::3 ::http::4 if"
append suffix " the test creates these before ::http::2"
append suffix " is cancelled"
}
} else {
}
} elseif {$footer in {19}} {
set suffix " - extra test for -repost 0"
} elseif {$footer in {20 21}} {
set suffix " - extra test for -postfresh 1"
if {($footer == 20)} {
append suffix " - ::http::2 uses a separate socket"
append suffix ", other requests use a persistent connection"
}
} elseif {$footer in {22 23 24 25}} {
append suffix " - ::http::2 uses a separate socket"
append suffix ", other requests use a persistent connection"
} else {
}
if {($footer >= 13 && $footer <= 23)} {
# Test use WAIT and depend on server timeout before this time.
lappend cons timeout1s
}
# ------------------------------------------------------------------
# End of custom code.
# ------------------------------------------------------------------
set name "pipeline test header $header footer $footer delay $delay $tag$suffix"
# Here's the test:
test httpPipeline-${header}.${footer}${label}-${tag} $name \
-constraints $cons \
-setup [string map [list TE $te] {
# Restore default values for tests:
http::config -pipeline 1 -postfresh 0 -repost 1
http::init
set http::http(uid) 0
SetTestEof {TE}
}] -body [list RunTest $header $footer $delay $te] -cleanup {
# Restore default values for tests:
http::config -pipeline 1 -postfresh 0 -repost 1
cleanupHttpTestScript
SetTestEof 0
cleanupHttpTest
after 2000
# Wait for persistent sockets on the server to time out.
} -result [ReturnTestResult $header $footer $delay $te] -match $match
}
}
}
}
# ------------------------------------------------------------------------------
# (*) Notes on tests *.18*-testEof, *.19*-testEof - these test -repost 0
# ------------------------------------------------------------------------------
# These tests are a bit awkward because the main test kit analyses whether all
# requests are satisfied, with retries if necessary, and it has result analysis
# for processing retry logs.
# - *.18*-testEof tests that certain requests are NOT satisfied, so the analysis
# is a one-off.
# - Tests *.18a-testEof depend on client/server timing - the test needs to call
# http::geturl for all requests before the POST (request 2) is cancelled.
# We test that requests 2, 3, 4 are all cancelled.
# - Other tests *.18*-testEof may not request 3 and 4 in time for the to be
# added to the write queue before request 2 is completed. We simply check that
# request 2 is cancelled.
# - The behaviour is different if all connections are allowed to time out
# (label "j"). This case is not needed to test -repost 0, and is omitted.
# - Tests *.18*-normal and *.19* are conventional (-repost 0 should have no
# effect).
# ------------------------------------------------------------------------------
unset header footer delay label suffix match cons name te
namespace delete ::httpTest
namespace delete ::httpTestScript
::tcltest::cleanupTests
|
Added tests/httpTest.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 |
# httpTest.tcl
#
# Test HTTP/1.1 concurrent requests including
# queueing, pipelining and retries.
#
# Copyright (C) 2018 Keith Nash <kjnash@users.sourceforge.net>
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# ------------------------------------------------------------------------------
# "Package" httpTest for analysis of Log output of http requests.
# ------------------------------------------------------------------------------
# This is a specialised test kit for examining the presence, ordering, and
# overlap of multiple HTTP transactions over a persistent ("Keep-Alive")
# connection; and also for testing reconnection in accordance with RFC 7230 when
# the connection is lost.
#
# This kit is probably not useful for other purposes. It depends on the
# presence of specific Log commands in the http library, and it interprets the
# logs that these commands create.
# ------------------------------------------------------------------------------
package require http
namespace eval ::http {
variable TestStartTimeInMs [clock milliseconds]
# catch {puts stdout "Start time (zero ms) is $TestStartTimeInMs"}
}
namespace eval ::httpTest {
variable testResults {}
variable testOptions
array set testOptions {
-verbose 0
-dotted 1
}
# -verbose - 0 quiet 1 write to stdout 2 write more
# -dotted - (boolean) use dots for absences in lists of transactions
}
proc httpTest::Puts {txt} {
variable testOptions
if {$testOptions(-verbose) > 0} {
puts stdout $txt
flush stdout
}
return
}
# http::Log
#
# A special-purpose logger used for running tests.
# - Processes Log calls that have "^" in their arguments, and records them in
# variable ::httpTest::testResults.
# - Also writes them to stdout (using Puts) if ($testOptions(-verbose) > 0).
# - Also writes Log calls that do not have "^", if ($testOptions(-verbose) > 1).
proc http::Log {args} {
variable TestStartTimeInMs
set time [expr {[clock milliseconds] - $TestStartTimeInMs}]
set txt [list $time {*}$args]
if {[string first ^ $txt] != -1} {
::httpTest::LogRecord $txt
::httpTest::Puts $txt
} elseif {$::httpTest::testOptions(-verbose) > 1} {
::httpTest::Puts $txt
}
return
}
# The http::Log routine above needs the variable ::httpTest::testOptions
# Set up to destroy it when that variable goes away.
trace add variable ::httpTest::testOptions unset {apply {args {
proc ::http::Log args {}
}}}
# Called by http::Log (the "testing" version) to record logs for later analysis.
proc httpTest::LogRecord {txt} {
variable testResults
set pos [string first ^ $txt]
set len [string length $txt]
if {$pos > $len - 3} {
puts stdout "Logging Error: $txt"
puts stdout "Fix this call to Log in http-*.tm so it has ^ then\
a letter then a numeral."
flush stdout
} elseif {$pos == -1} {
# Called by mistake.
} else {
set letter [string index $txt [incr pos]]
set number [string index $txt [incr pos]]
# Max 9 requests!
lappend testResults [list $letter $number]
}
return
}
# ------------------------------------------------------------------------------
# Commands for analysing the logs recorded when calling http::geturl.
# ------------------------------------------------------------------------------
# httpTest::TestOverlaps --
#
# The main test for correct behaviour of pipelined and sequential
# (non-pipelined) transactions. Other tests should be run first to detect
# any inconsistencies in the data (e.g. absence of the elements that are
# examined here).
#
# Examine the sequence $someResults for each transaction from 1 to $n,
# ignoring any that are listed in $badTrans.
# Determine whether the elements "B" to $term for one transaction overlap
# elements "B" to $term for the previous and following transactions.
#
# Transactions in the list $badTrans are not included in "clean" or
# "dirty", but their possible overlap with other transactions is noted.
# Transactions in the list $notPiped are a subset of $badTrans, and
# their possible overlap with other transactions is NOT noted.
#
# Arguments:
# someResults - list of results, each of the form {letter numeral}
# n - number of HTTP transactions
# term - letter that indicated end of search range. "E" for testing
# overlaps from start of request to end of response headers.
# "F" to extend to the end of the response body.
# msg - the cumulative message from sanity checks. Append to it only
# to report a test failure.
# badTrans - list of transaction numbers not to be assessed as "clean" or
# "dirty"
# notPiped - subset of badTrans. List of transaction numbers that cannot
# taint another transaction by overlapping with it, because it
# used a different socket.
#
# Return value: [list $msg $clean $dirty]
# msg - warning messages: nothing will be appended to argument $msg if there
# is an error with the test.
# clean - list of transactions that have no overlap with other transactions
# dirty - list of transactions that have YES overlap with other transactions
proc httpTest::TestOverlaps {someResults n term msg badTrans notPiped} {
variable testOptions
# Check whether transactions overlap:
set clean {}
set dirty {}
for {set i 1} {$i <= $n} {incr i} {
if {$i in $badTrans} {
continue
}
set myStart [lsearch -exact $someResults [list B $i]]
set myEnd [lsearch -exact $someResults [list $term $i]]
if {($myStart == -1 || $myEnd == -1)} {
set res "Cannot find positions of transaction $i"
append msg $res \n
Puts $res
}
set overlaps {}
for {set j $myStart} {$j <= $myEnd} {incr j} {
lassign [lindex $someResults $j] letter number
if {$number != $i && $letter ne "A" && $number ni $notPiped} {
lappend overlaps $number
}
}
if {[llength $overlaps] == 0} {
set res "Transaction $i has no overlaps"
Puts $res
lappend clean $i
if {$testOptions(-dotted)} {
# N.B. results from different segments are concatenated.
lappend dirty .
} else {
}
} else {
set res "Transaction $i overlaps with [join $overlaps { }]"
Puts $res
lappend dirty $i
if {$testOptions(-dotted)} {
# N.B. results from different segments are concatenated.
lappend clean .
} else {
}
}
}
return [list $msg $clean $dirty]
}
# httpTest::PipelineNext --
#
# Test whether prevPair, pair are valid as consecutive elements of a pipelined
# sequence (Start 1), (End 1), (Start 2), (End 2) ...
# Numbers are integers increasing (by 1 if argument "any" is false), and need
# not begin with 1.
# The first element of the sequence has prevPair {} and is always passed as
# valid.
#
# Arguments;
# Start - string that labels the start of a segment
# End - string that labels the end of a segment
# prevPair - previous "pair" (list of string and number) element of a
# sequence, or {} if argument "pair" is the first in the
# sequence.
# pair - current "pair" (list of string and number) element of a
# sequence
# any - (boolean) iff true, accept any increasing sequence of integers.
# If false, integers must increase by 1.
#
# Return value - boolean, true iff the two pairs are valid consecutive elements.
proc httpTest::PipelineNext {Start End prevPair pair any} {
if {$prevPair eq {}} {
return 1
}
lassign $prevPair letter number
lassign $pair newLetter newNumber
if {$letter eq $Start} {
return [expr {($newLetter eq $End) && ($newNumber == $number)}]
} elseif {$any} {
set nxt [list $Start [expr {$number + 1}]]
return [expr {($newLetter eq $Start) && ($newNumber > $number)}]
} else {
set nxt [list $Start [expr {$number + 1}]]
return [expr {($newLetter eq $Start) && ($newNumber == $number + 1)}]
}
}
# httpTest::TestPipeline --
#
# Given a sequence of "pair" elements, check that the elements whose string is
# $Start or $End form a valid pipeline. Ignore other elements.
#
# Return value: {} if valid pipeline, otherwise a non-empty error message.
proc httpTest::TestPipeline {someResults n Start End msg desc badTrans} {
set sequence {}
set prevPair {}
set ok 1
set any [llength $badTrans]
foreach pair $someResults {
lassign $pair letter number
if {($letter in [list $Start $End]) && ($number ni $badTrans)} {
lappend sequence $pair
if {![PipelineNext $Start $End $prevPair $pair $any]} {
set ok 0
break
}
set prevPair $pair
}
}
if {!$ok} {
set res "$desc are not pipelined: {$sequence}"
append msg $res \n
Puts $res
}
return $msg
}
# httpTest::TestSequence --
#
# Examine each transaction from 1 to $n, ignoring any that are listed
# in $badTrans.
# Check that each transaction has elements A to F, in alphabetical order.
proc httpTest::TestSequence {someResults n msg badTrans} {
variable testOptions
for {set i 1} {$i <= $n} {incr i} {
if {$i in $badTrans} {
continue
}
set sequence {}
foreach pair $someResults {
lassign $pair letter number
if {$number == $i} {
lappend sequence $letter
}
}
if {$sequence eq {A B C D E F}} {
} else {
set res "Wrong sequence for token ::http::$i - {$sequence}"
append msg $res \n
Puts $res
if {"X" in $sequence} {
set res "- and error(s) X"
append msg $res \n
Puts $res
}
if {"Y" in $sequence} {
set res "- and warnings(s) Y"
append msg $res \n
Puts $res
}
}
}
return $msg
}
#
# Arguments:
# someResults - list of elements, each a list of a letter and a number
# n - (positive integer) the number of HTTP requests
# msg - accumulated warning messages
# skipOverlaps - (boolean) whether to skip testing of transaction overlaps
# badTrans - list of transaction numbers not to be assessed as "clean" or
# "dirty" by their overlaps
# for 1/2 includes all transactions
# for 3/4 includes an increasing (with recursion) set that will not be included in the list because they are already handled.
# notPiped - subset of badTrans. List of transaction numbers that cannot
# taint another transaction by overlapping with it, because it
# used a different socket.
#
# Return value: [list $msg $cleanE $cleanF $dirtyE $dirtyF]
# msg - warning messages: nothing will be appended to argument $msg if there
# is no error with the test.
# cleanE - list of transactions that have no overlap with other transactions
# (not considering response body)
# dirtyE - list of transactions that have YES overlap with other transactions
# (not considering response body)
# cleanF - list of transactions that have no overlap with other transactions
# (including response body)
# dirtyF - list of transactions that have YES overlap with other transactions
# (including response body)
proc httpTest::MostAnalysis {someResults n msg skipOverlaps badTrans notPiped} {
variable testOptions
# Check that stages for "good" transactions are all present and correct:
set msg [TestSequence $someResults $n $msg $badTrans]
# Check that requests are pipelined:
set msg [TestPipeline $someResults $n B C $msg Requests $notPiped]
# Check that responses are pipelined:
set msg [TestPipeline $someResults $n D F $msg Responses $notPiped]
if {$skipOverlaps} {
set cleanE {}
set dirtyE {}
set cleanF {}
set dirtyF {}
} else {
Puts "Overlaps including response body (test for non-pipelined case)"
lassign [TestOverlaps $someResults $n F $msg $badTrans $notPiped] msg cleanF dirtyF
Puts "Overlaps without response body (test for pipelined case)"
lassign [TestOverlaps $someResults $n E $msg $badTrans $notPiped] msg cleanE dirtyE
}
return [list $msg $cleanE $cleanF $dirtyE $dirtyF]
}
# httpTest::ProcessRetries --
#
# Command to examine results for socket-changing records [PQR],
# divide the results into segments for each connection, and analyse each segment
# individually.
# (Could add $sock to the logging to simplify this, but never mind.)
#
# In each segment, identify any transactions that are not included, and
# any that are aborted, to assist subsequent testing.
#
# Prepend A records (socket-independent) to each segment for transactions that
# were scheduled (by A) but not completed (by F). Pass each segment to
# MostAnalysis for processing.
proc httpTest::ProcessRetries {someResults n msg skipOverlaps notIncluded notPiped} {
variable testOptions
set nextRetry [lsearch -glob -index 0 $someResults {[PQR]}]
if {$nextRetry == -1} {
return [MostAnalysis $someResults $n $msg $skipOverlaps $notIncluded $notPiped]
}
set badTrans $notIncluded
set tryCount 0
set try $nextRetry
incr tryCount
lassign [lindex $someResults $try] letter number
Puts "Processing retry [lindex $someResults $try]"
set beforeTry [lrange $someResults 0 $try-1]
Puts [join $beforeTry \n]
set afterTry [lrange $someResults $try+1 end]
set dummyTry {}
for {set i 1} {$i <= $n} {incr i} {
set first [lsearch -exact $beforeTry [list A $i]]
set last [lsearch -exact $beforeTry [list F $i]]
if {$first == -1} {
set res "Transaction $i was not started in connection number $tryCount"
# So lappend it to badTrans and don't include it in the call below of MostAnalysis.
# append msg $res \n
Puts $res
if {$i ni $badTrans} {
lappend badTrans $i
} else {
}
} elseif {$last == -1} {
set res "Transaction $i was started but unfinished in connection number $tryCount"
# So lappend it to badTrans and don't include it in the call below of MostAnalysis.
# append msg $res \n
Puts $res
lappend badTrans $i
lappend dummyTry [list A $i]
} else {
set res "Transaction $i was started and finished in connection number $tryCount"
# So include it in the call below of MostAnalysis.
# So lappend it to notIncluded and don't include it in the recursive call of
# ProcessRetries which handles the later connections.
# append msg $res \n
Puts $res
lappend notIncluded $i
}
}
# Analyse the part of the results before the first replay:
set HeadResults [MostAnalysis $beforeTry $n $msg $skipOverlaps $badTrans $notPiped]
lassign $HeadResults msg cleanE1 cleanF1 dirtyE1 dirtyF1
# Pass the rest of the results to be processed recursively.
set afterTry [concat $dummyTry $afterTry]
set TailResults [ProcessRetries $afterTry $n $msg $skipOverlaps $notIncluded $notPiped]
lassign $TailResults msg cleanE2 cleanF2 dirtyE2 dirtyF2
set cleanE [concat $cleanE1 $cleanE2]
set cleanF [concat $cleanF1 $cleanF2]
set dirtyE [concat $dirtyE1 $dirtyE2]
set dirtyF [concat $dirtyF1 $dirtyF2]
return [list $msg $cleanE $cleanF $dirtyE $dirtyF]
}
# httpTest::logAnalyse --
#
# The main command called to analyse logs for a single test.
#
# Arguments:
# n - (positive integer) the number of HTTP requests
# skipOverlaps - (boolean) whether to skip testing of transaction overlaps
# notIncluded - list of transaction numbers not to be assessed as "clean" or
# "dirty" by their overlaps
# notPiped - subset of notIncluded. List of transaction numbers that cannot
# taint another transaction by overlapping with it, because it
# used a different socket.
#
# Return value: [list $msg $cleanE $cleanF $dirtyE $dirtyF]
# msg - warning messages: {} if there is no error with the test.
# cleanE - list of transactions that have no overlap with other transactions
# (not considering response body)
# dirtyE - list of transactions that have YES overlap with other transactions
# (not considering response body)
# cleanF - list of transactions that have no overlap with other transactions
# (including response body)
# dirtyF - list of transactions that have YES overlap with other transactions
# (including response body)
proc httpTest::logAnalyse {n skipOverlaps notIncluded notPiped} {
variable testResults
variable testOptions
# Check that each data item has the correct form {letter numeral}.
set ii 0
set ok 1
foreach pair $testResults {
lassign $pair letter number
if { [string match {[A-Z]} $letter]
&& [string match {[0-9]} $number]
} {
# OK
} else {
set ok 0
set res "Error: testResults has bad element {$pair} at position $ii"
append msg $res \n
Puts $res
}
incr ii
}
if {!$ok} {
return $msg
}
set msg {}
Puts [join $testResults \n]
ProcessRetries $testResults $n $msg $skipOverlaps $notIncluded $notPiped
# N.B. Implicit Return.
}
proc httpTest::cleanupHttpTest {} {
variable testResults
set testResults {}
return
}
proc httpTest::setHttpTestOptions {key args} {
variable testOptions
if {$key ni {-dotted -verbose}} {
return -code error {valid options are -dotted, -verbose}
}
set testOptions($key) {*}$args
}
namespace eval httpTest {
namespace export cleanupHttpTest logAnalyse setHttpTestOptions
}
|
Added tests/httpTestScript.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 |
# httpTestScript.tcl
#
# Test HTTP/1.1 concurrent requests including
# queueing, pipelining and retries.
#
# Copyright (C) 2018 Keith Nash <kjnash@users.sourceforge.net>
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# ------------------------------------------------------------------------------
# "Package" httpTestScript for executing test scripts written in a convenient
# shorthand.
# ------------------------------------------------------------------------------
# ------------------------------------------------------------------------------
# Documentation for "package" httpTestScript.
# ------------------------------------------------------------------------------
# To use the package:
# (a) define URLs as the values of elements in the array ::httpTestScript
# (b) define a script in terms of the commands
# START STOP DELAY KEEPALIVE WAIT PIPELINE GET HEAD POST
# referring to URLs by the name of the corresponding array element. The
# script can include any other Tcl commands, and evaluates in the
# httpTestScript namespace.
# (c) Use the command httpTestScript::runHttpTestScript to evaluate the script.
# (d) For tcltest tests, wrap the runHttpTestScript call in a suitable "test"
# command.
# ------------------------------------------------------------------------------
# START
# Must be the first command of the script.
#
# STOP
# Must be present in the script to avoid waiting for client timeout.
# Usually the last command, but can be elsewhere to end a script prematurely.
# Subsequent httpTestScript commands will have no effect.
#
# DELAY ms
# If there are no WAIT commands, this sets the delay in ms between subsequent
# calls to http::geturl. Default 500ms.
#
# KEEPALIVE
# Set the value passed to http::geturl for the -keepalive option. The command
# applies to subsequent requests in the script. Default 1.
#
# WAIT ms
# Pause for a time in ms before sending subsequent requests.
#
# PIPELINE boolean
# Set the value of -pipeline using http::config. The last PIPELINE command
# in the script applies to every request. Default 1.
#
# POSTFRESH boolean
# Set the value of -postfresh using http::config. The last POSTFRESH command
# in the script applies to every request. Default 0.
#
# REPOST boolean
# Set the value of -repost using http::config. The last REPOST command
# in the script applies to every request. Default 1 for httpTestScript.
# (Default value in http is 0).
#
# GET uriCode ?arg ...?
# Send a HTTP request using the GET method.
# Arguments:
# uriCode - the code for the base URI - the value must be stored in
# ::httpTestScript::URL($uriCode).
# args - strings that will be joined by "&" and appended to the query
# string with a preceding "&".
#
# HEAD uriCode ?arg ...?
# Send a HTTP request using the HEAD method.
# Arguments: as for GET
#
# POST uriCode ?arg ...?
# Send a HTTP request using the POST method.
# Arguments:
# uriCode - the code for the base URI - the value must be stored in
# ::httpTestScript::URL($uriCode).
# args - strings that will be joined by "&" and used as the request body.
# ------------------------------------------------------------------------------
namespace eval ::httpTestScript {
namespace export runHttpTestScript cleanupHttpTestScript
}
# httpTestScript::START --
# Initialise, and create a long-stop timeout.
proc httpTestScript::START {} {
variable CountRequestedSoFar
variable RequestsWhenStopped
variable KeepAlive
variable Delay
variable TimeOutCode
variable TimeOutDone
variable StartDone
variable StopDone
variable CountFinishedSoFar
variable RequestList
variable RequestsMade
variable ExtraTime
variable ActualKeepAlive
if {[info exists StartDone] && ($StartDone == 1)} {
set msg {START has been called twice without an intervening STOP}
return -code error $msg
}
set StartDone 1
set StopDone 0
set TimeOutDone 0
set CountFinishedSoFar 0
set CountRequestedSoFar 0
set RequestList {}
set RequestsMade {}
set ExtraTime 0
set ActualKeepAlive 1
# Undefined until a STOP command:
unset -nocomplain RequestsWhenStopped
# Default values:
set KeepAlive 1
set Delay 500
# Default values for tests:
KEEPALIVE 1
PIPELINE 1
POSTFRESH 0
REPOST 1
set TimeOutCode [after 30000 httpTestScript::TimeOutNow]
# set TimeOutCode [after 4000 httpTestScript::TimeOutNow]
return
}
# httpTestScript::STOP --
# Do not process any more commands. The commands will be executed but will
# silently do nothing.
proc httpTestScript::STOP {} {
variable CountRequestedSoFar
variable CountFinishedSoFar
variable RequestsWhenStopped
variable TimeOutCode
variable StartDone
variable StopDone
variable RequestsMade
if {$StopDone} {
# Don't do anything on a second call.
return
}
if {![info exists StartDone]} {
return -code error {initialise the script by calling command START}
}
set StopDone 1
set StartDone 0
set RequestsWhenStopped $CountRequestedSoFar
unset -nocomplain StartDone
if {$CountFinishedSoFar == $RequestsWhenStopped} {
if {[info exists TimeOutCode]} {
after cancel $TimeOutCode
}
set ::httpTestScript::FOREVER 0
}
return
}
# httpTestScript::DELAY --
# If there are no WAIT commands, this sets the delay in ms between subsequent
# calls to http::geturl. Default 500ms.
proc httpTestScript::DELAY {t} {
variable StartDone
variable StopDone
if {$StopDone} {
return
}
if {![info exists StartDone]} {
return -code error {initialise the script by calling command START}
}
variable Delay
set Delay $t
return
}
# httpTestScript::KEEPALIVE --
# Set the value passed to http::geturl for the -keepalive option. Default 1.
proc httpTestScript::KEEPALIVE {b} {
variable StartDone
variable StopDone
if {$StopDone} {
return
}
if {![info exists StartDone]} {
return -code error {initialise the script by calling command START}
}
variable KeepAlive
set KeepAlive $b
return
}
# httpTestScript::WAIT --
# Pause for a time in ms before processing any more commands.
proc httpTestScript::WAIT {t} {
variable StartDone
variable StopDone
variable ExtraTime
if {$StopDone} {
return
}
if {![info exists StartDone]} {
return -code error {initialise the script by calling command START}
}
if {(![string is integer -strict $t]) || $t < 0} {
return -code error {argument to WAIT must be a non-negative integer}
}
incr ExtraTime $t
return
}
# httpTestScript::PIPELINE --
# Pass a value to http::config -pipeline.
proc httpTestScript::PIPELINE {b} {
variable StartDone
variable StopDone
if {$StopDone} {
return
}
if {![info exists StartDone]} {
return -code error {initialise the script by calling command START}
}
::http::config -pipeline $b
##::http::Log http(-pipeline) is now [::http::config -pipeline]
return
}
# httpTestScript::POSTFRESH --
# Pass a value to http::config -postfresh.
proc httpTestScript::POSTFRESH {b} {
variable StartDone
variable StopDone
if {$StopDone} {
return
}
if {![info exists StartDone]} {
return -code error {initialise the script by calling command START}
}
::http::config -postfresh $b
##::http::Log http(-postfresh) is now [::http::config -postfresh]
return
}
# httpTestScript::REPOST --
# Pass a value to http::config -repost.
proc httpTestScript::REPOST {b} {
variable StartDone
variable StopDone
if {$StopDone} {
return
}
if {![info exists StartDone]} {
return -code error {initialise the script by calling command START}
}
::http::config -repost $b
##::http::Log http(-repost) is now [::http::config -repost]
return
}
# httpTestScript::GET --
# Send a HTTP request using the GET method.
# Arguments:
# uriCode - the code for the base URI - the value must be stored in
# ::httpTestScript::URL($uriCode).
# args - strings that will each be preceded by "&" and appended to the query
# string.
proc httpTestScript::GET {uriCode args} {
variable RequestList
lappend RequestList GET
RequestAfter $uriCode 0 {} {*}$args
return
}
# httpTestScript::HEAD --
# Send a HTTP request using the HEAD method.
# Arguments: as for GET
proc httpTestScript::HEAD {uriCode args} {
variable RequestList
lappend RequestList HEAD
RequestAfter $uriCode 1 {} {*}$args
return
}
# httpTestScript::POST --
# Send a HTTP request using the POST method.
# Arguments:
# uriCode - the code for the base URI - the value must be stored in
# ::httpTestScript::URL($uriCode).
# args - strings that will be joined by "&" and used as the request body.
proc httpTestScript::POST {uriCode args} {
variable RequestList
lappend RequestList POST
RequestAfter $uriCode 0 {use} {*}$args
return
}
proc httpTestScript::RequestAfter {uriCode validate query args} {
variable CountRequestedSoFar
variable Delay
variable ExtraTime
variable StartDone
variable StopDone
variable KeepAlive
if {$StopDone} {
return
}
if {![info exists StartDone]} {
return -code error {initialise the script by calling command START}
}
incr CountRequestedSoFar
set idelay [expr {($CountRequestedSoFar - 1) * $Delay + 10 + $ExtraTime}]
# Could pass values of -pipeline, -postfresh, -repost if it were
# useful to change these mid-script.
after $idelay [list httpTestScript::Requester $uriCode $KeepAlive $validate $query {*}$args]
return
}
proc httpTestScript::Requester {uriCode keepAlive validate query args} {
variable URL
::http::config -accept {*/*}
set absUrl $URL($uriCode)
if {$query eq {}} {
if {$args ne {}} {
append absUrl & [join $args &]
}
set queryArgs {}
} elseif {$validate} {
return -code error {cannot have both -validate (HEAD) and -query (POST)}
} else {
set queryArgs [list -query [join $args &]]
}
if {[catch {
::http::geturl $absUrl \
-validate $validate \
-timeout 10000 \
{*}$queryArgs \
-keepalive $keepAlive \
-command ::httpTestScript::WhenFinished
} token]} {
set msg $token
catch {puts stdout "Error: $msg"}
return
} else {
# Request will begin.
}
return
}
proc httpTestScript::TimeOutNow {} {
variable TimeOutDone
set TimeOutDone 1
set ::httpTestScript::FOREVER 0
return
}
proc httpTestScript::WhenFinished {hToken} {
variable CountFinishedSoFar
variable RequestsWhenStopped
variable TimeOutCode
variable StopDone
variable RequestList
variable RequestsMade
variable ActualKeepAlive
upvar #0 $hToken state
if {[catch {
if { [info exists state(transfer)]
&& ($state(transfer) eq "chunked")
} {
set Trans chunked
} else {
set Trans unchunked
}
if { [info exists ::httpTest::testOptions(-verbose)]
&& ($::httpTest::testOptions(-verbose) > 0)
} {
puts "Token $hToken
Response $state(http)
Status $state(status)
Method $state(method)
Transfer $Trans
Size $state(currentsize)
URL $state(url)
"
}
if {!$state(-keepalive)} {
set ActualKeepAlive 0
}
if {[info exists state(method)]} {
lappend RequestsMade $state(method)
} else {
lappend RequestsMade UNKNOWN
}
set tk [namespace tail $hToken]
if { ($state(http) != {HTTP/1.1 200 OK})
|| ($state(status) != {ok})
|| (($state(currentsize) == 0) && ($state(method) ne "HEAD"))
} {
::http::Log ^X$tk unexpected result Response $state(http) Status $state(status) Size $state(currentsize) - token $hToken
}
} err]} {
::http::Log ^X$tk httpTestScript::WhenFinished failed with error status: $err - token $hToken
}
incr CountFinishedSoFar
if {$StopDone && ($CountFinishedSoFar == $RequestsWhenStopped)} {
if {[info exists TimeOutCode]} {
after cancel $TimeOutCode
}
if {$RequestsMade ne $RequestList && $ActualKeepAlive} {
::http::Log ^X$tk unexpected result - Script asked for "{$RequestList}" but got "{$RequestsMade}" - token $hToken
}
set ::httpTestScript::FOREVER 0
}
return
}
proc httpTestScript::runHttpTestScript {scr} {
variable TimeOutDone
variable RequestsWhenStopped
after idle [list namespace eval ::httpTestScript $scr]
vwait ::httpTestScript::FOREVER
# N.B. does not automatically execute in this namespace, unlike some other events.
# Release when all requests have been served or have timed out.
if {$TimeOutDone} {
return -code error {test script timed out}
}
return $RequestsWhenStopped
}
proc httpTestScript::cleanupHttpTestScript {} {
variable TimeOutDone
variable RequestsWhenStopped
if {![info exists RequestsWhenStopped]} {
return -code error {Cleanup Failed: RequestsWhenStopped is undefined}
}
for {set i 1} {$i <= $RequestsWhenStopped} {incr i} {
http::cleanup ::http::$i
}
return
}
|
Added tests/httpcookie.test.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 |
# Commands covered: http::cookiejar
#
# This file contains a collection of tests for the cookiejar package.
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
# Copyright (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.
package require tcltest 2
namespace import -force ::tcltest::*
::tcltest::loadTestedCommands
testConstraint notOSXtravis [apply {{} {
upvar 1 env(TRAVIS_OSX_IMAGE) travis
return [expr {![info exists travis] || ![string match xcode* $travis]}]
}}]
testConstraint sqlite3 [expr {[testConstraint notOSXtravis] && ![catch {
package require sqlite3
}]}]
testConstraint cookiejar [expr {[testConstraint sqlite3] && ![catch {
package require cookiejar
}]}]
set COOKIEJAR_VERSION 0.1
test http-cookiejar-1.1 "cookie storage: packaging" {notOSXtravis sqlite3 cookiejar} {
package require cookiejar
} $COOKIEJAR_VERSION
test http-cookiejar-1.2 "cookie storage: packaging" {notOSXtravis sqlite3 cookiejar} {
package require cookiejar
package require cookiejar
} $COOKIEJAR_VERSION
test http-cookiejar-2.1 "cookie storage: basics" -constraints {
notOSXtravis sqlite3 cookiejar
} -returnCodes error -body {
http::cookiejar
} -result {wrong # args: should be "http::cookiejar method ?arg ...?"}
test http-cookiejar-2.2 "cookie storage: basics" -constraints {
notOSXtravis sqlite3 cookiejar
} -returnCodes error -body {
http::cookiejar ?
} -result {unknown method "?": must be configure, create, destroy or new}
test http-cookiejar-2.3 "cookie storage: basics" -constraints {
notOSXtravis sqlite3 cookiejar
} -body {
http::cookiejar configure
} -result {-domainfile -domainlist -domainrefresh -loglevel -offline -purgeold -retain -vacuumtrigger}
test http-cookiejar-2.4 "cookie storage: basics" -constraints {
notOSXtravis sqlite3 cookiejar
} -returnCodes error -body {
http::cookiejar configure a b c d e
} -result {wrong # args: should be "http::cookiejar configure ?optionName? ?optionValue?"}
test http-cookiejar-2.5 "cookie storage: basics" -constraints {
notOSXtravis sqlite3 cookiejar
} -returnCodes error -body {
http::cookiejar configure a
} -result {bad option "a": must be -domainfile, -domainlist, -domainrefresh, -loglevel, -offline, -purgeold, -retain, or -vacuumtrigger}
test http-cookiejar-2.6 "cookie storage: basics" -constraints {
notOSXtravis sqlite3 cookiejar
} -returnCodes error -body {
http::cookiejar configure -d
} -result {ambiguous option "-d": must be -domainfile, -domainlist, -domainrefresh, -loglevel, -offline, -purgeold, -retain, or -vacuumtrigger}
test http-cookiejar-2.7 "cookie storage: basics" -setup {
set old [http::cookiejar configure -loglevel]
} -constraints {notOSXtravis sqlite3 cookiejar} -body {
list [http::cookiejar configure -loglevel] \
[http::cookiejar configure -loglevel debug] \
[http::cookiejar configure -loglevel] \
[http::cookiejar configure -loglevel error] \
[http::cookiejar configure -loglevel]
} -cleanup {
http::cookiejar configure -loglevel $old
} -result {info debug debug error error}
test http-cookiejar-2.8 "cookie storage: basics" -setup {
set old [http::cookiejar configure -loglevel]
} -constraints {notOSXtravis sqlite3 cookiejar} -body {
list [http::cookiejar configure -loglevel] \
[http::cookiejar configure -loglevel d] \
[http::cookiejar configure -loglevel i] \
[http::cookiejar configure -loglevel w] \
[http::cookiejar configure -loglevel e]
} -cleanup {
http::cookiejar configure -loglevel $old
} -result {info debug info warn error}
test http-cookiejar-2.9 "cookie storage: basics" -body {
http::cookiejar configure -off
} -constraints {notOSXtravis sqlite3 cookiejar} -match glob -result *
test http-cookiejar-2.10 "cookie storage: basics" -setup {
set oldval [http::cookiejar configure -offline]
} -constraints {notOSXtravis sqlite3 cookiejar} -body {
http::cookiejar configure -offline true
} -cleanup {
catch {http::cookiejar configure -offline $oldval}
} -result 1
test http-cookiejar-2.11 "cookie storage: basics" -setup {
set oldval [http::cookiejar configure -offline]
} -constraints {notOSXtravis sqlite3 cookiejar} -body {
http::cookiejar configure -offline nonbool
} -cleanup {
catch {http::cookiejar configure -offline $oldval}
} -returnCodes error -result {expected boolean value but got "nonbool"}
test http-cookiejar-2.12 "cookie storage: basics" -setup {
set oldval [http::cookiejar configure -purgeold]
} -constraints {notOSXtravis sqlite3 cookiejar} -body {
http::cookiejar configure -purge nonint
} -cleanup {
catch {http::cookiejar configure -purgeold $oldval}
} -returnCodes error -result {expected positive integer but got "nonint"}
test http-cookiejar-2.13 "cookie storage: basics" -setup {
set oldval [http::cookiejar configure -domainrefresh]
} -constraints {notOSXtravis sqlite3 cookiejar} -body {
http::cookiejar configure -domainref nonint
} -cleanup {
catch {http::cookiejar configure -domainrefresh $oldval}
} -returnCodes error -result {expected positive integer but got "nonint"}
test http-cookiejar-2.14 "cookie storage: basics" -setup {
set oldval [http::cookiejar configure -domainrefresh]
} -constraints {notOSXtravis sqlite3 cookiejar} -body {
http::cookiejar configure -domainref -42
} -cleanup {
catch {http::cookiejar configure -domainrefresh $oldval}
} -returnCodes error -result {expected positive integer but got "-42"}
test http-cookiejar-2.15 "cookie storage: basics" -setup {
set oldval [http::cookiejar configure -domainrefresh]
set result unset
set tracer [http::cookiejar create tracer]
} -constraints {notOSXtravis sqlite3 cookiejar} -body {
oo::objdefine $tracer method PostponeRefresh {} {
set ::result set
next
}
http::cookiejar configure -domainref 12345
return $result
} -cleanup {
$tracer destroy
catch {http::cookiejar configure -domainrefresh $oldval}
} -result set
test http-cookiejar-3.1 "cookie storage: class" {notOSXtravis sqlite3 cookiejar} {
info object isa object http::cookiejar
} 1
test http-cookiejar-3.2 "cookie storage: class" {notOSXtravis sqlite3 cookiejar} {
info object isa class http::cookiejar
} 1
test http-cookiejar-3.3 "cookie storage: class" {notOSXtravis sqlite3 cookiejar} {
lsort [info object methods http::cookiejar]
} {configure}
test http-cookiejar-3.4 "cookie storage: class" {notOSXtravis sqlite3 cookiejar} {
lsort [info object methods http::cookiejar -all]
} {configure create destroy new}
test http-cookiejar-3.5 "cookie storage: class" -setup {
catch {rename ::cookiejar ""}
} -constraints {notOSXtravis sqlite3 cookiejar} -body {
namespace eval :: {http::cookiejar create cookiejar}
} -cleanup {
catch {rename ::cookiejar ""}
} -result ::cookiejar
test http-cookiejar-3.6 "cookie storage: class" -setup {
catch {rename ::cookiejar ""}
} -constraints {notOSXtravis sqlite3 cookiejar} -body {
list [http::cookiejar create ::cookiejar] [info commands ::cookiejar] \
[::cookiejar destroy] [info commands ::cookiejar]
} -cleanup {
catch {rename ::cookiejar ""}
} -result {::cookiejar ::cookiejar {} {}}
test http-cookiejar-3.7 "cookie storage: class" -setup {
catch {rename ::cookiejar ""}
} -constraints {notOSXtravis sqlite3 cookiejar} -body {
http::cookiejar create ::cookiejar foo bar
} -returnCodes error -cleanup {
catch {rename ::cookiejar ""}
} -result {wrong # args: should be "http::cookiejar create ::cookiejar ?path?"}
test http-cookiejar-3.8 "cookie storage: class" -setup {
catch {rename ::cookiejar ""}
set f [makeFile "" cookiejar]
file delete $f
} -constraints {notOSXtravis sqlite3 cookiejar} -body {
list [file exists $f] [http::cookiejar create ::cookiejar $f] \
[file exists $f]
} -cleanup {
catch {rename ::cookiejar ""}
removeFile $f
} -result {0 ::cookiejar 1}
test http-cookiejar-3.9 "cookie storage: class" -setup {
catch {rename ::cookiejar ""}
set f [makeFile "bogus content for a database" cookiejar]
} -constraints {notOSXtravis sqlite3 cookiejar} -body {
http::cookiejar create ::cookiejar $f
} -returnCodes error -cleanup {
catch {rename ::cookiejar ""}
removeFile $f
} -match glob -result *
test http-cookiejar-3.10 "cookie storage: class" -setup {
catch {rename ::cookiejar ""}
set dir [makeDirectory cookiejar]
} -constraints {notOSXtravis sqlite3 cookiejar} -body {
http::cookiejar create ::cookiejar $dir
} -returnCodes error -cleanup {
catch {rename ::cookiejar ""}
removeDirectory $dir
} -match glob -result *
test http-cookiejar-4.1 "cookie storage: instance" -setup {
http::cookiejar create ::cookiejar
} -constraints {notOSXtravis sqlite3 cookiejar} -body {
cookiejar
} -returnCodes error -cleanup {
::cookiejar destroy
} -result {wrong # args: should be "cookiejar method ?arg ...?"}
test http-cookiejar-4.2 "cookie storage: instance" -setup {
http::cookiejar create ::cookiejar
} -constraints {notOSXtravis sqlite3 cookiejar} -body {
cookiejar ?
} -returnCodes error -cleanup {
::cookiejar destroy
} -result {unknown method "?": must be destroy, forceLoadDomainData, getCookies, lookup, policyAllow or storeCookie}
test http-cookiejar-4.3 "cookie storage: instance" -setup {
http::cookiejar create ::cookiejar
} -constraints {notOSXtravis sqlite3 cookiejar} -body {
lsort [info object methods cookiejar -all]
} -cleanup {
::cookiejar destroy
} -result {destroy forceLoadDomainData getCookies lookup policyAllow storeCookie}
test http-cookiejar-4.4 "cookie storage: instance" -setup {
http::cookiejar create ::cookiejar
} -constraints {notOSXtravis sqlite3 cookiejar} -body {
cookiejar getCookies
} -returnCodes error -cleanup {
::cookiejar destroy
} -result {wrong # args: should be "cookiejar getCookies proto host path"}
test http-cookiejar-4.5 "cookie storage" -setup {
http::cookiejar create ::cookiejar
} -constraints {notOSXtravis sqlite3 cookiejar} -body {
cookiejar getCookies http www.example.com /
} -cleanup {
::cookiejar destroy
} -result {}
test http-cookiejar-4.6 "cookie storage: instance" -setup {
http::cookiejar create ::cookiejar
} -constraints {notOSXtravis sqlite3 cookiejar} -body {
cookiejar storeCookie
} -returnCodes error -cleanup {
::cookiejar destroy
} -result {wrong # args: should be "cookiejar storeCookie options"}
test http-cookiejar-4.7 "cookie storage: instance" -setup {
http::cookiejar create ::cookiejar
} -constraints {notOSXtravis sqlite3 cookiejar} -body {
cookiejar storeCookie {
key foo
value bar
secure 0
domain www.example.com
origin www.example.com
path /
hostonly 1
}
} -cleanup {
::cookiejar destroy
} -result {}
test http-cookiejar-4.8 "cookie storage: instance" -setup {
http::cookiejar create ::cookiejar
oo::objdefine ::cookiejar export Database
} -constraints {notOSXtravis sqlite3 cookiejar} -body {
cookiejar storeCookie {
key foo
value bar
secure 0
domain www.example.com
origin www.example.com
path /
hostonly 1
}
# Poke inside implementation!
cookiejar Database eval {SELECT count(*) FROM sessionCookies}
} -cleanup {
::cookiejar destroy
} -result 1
test http-cookiejar-4.9 "cookie storage: instance" -setup {
http::cookiejar create ::cookiejar
oo::objdefine ::cookiejar export Database
} -constraints {notOSXtravis sqlite3 cookiejar} -body {
cookiejar storeCookie {
key foo
value bar
secure 0
domain www.example.com
origin www.example.com
path /
hostonly 1
}
# Poke inside implementation!
cookiejar Database eval {SELECT count(*) FROM persistentCookies}
} -cleanup {
::cookiejar destroy
} -result 0
test http-cookiejar-4.10 "cookie storage: instance" -setup {
http::cookiejar create ::cookiejar
} -constraints {notOSXtravis sqlite3 cookiejar} -body {
cookiejar storeCookie [dict replace {
key foo
value bar
secure 0
domain www.example.com
origin www.example.com
path /
hostonly 1
} expires [expr {[clock seconds]+5}]]
} -cleanup {
::cookiejar destroy
} -result {}
test http-cookiejar-4.11 "cookie storage: instance" -setup {
http::cookiejar create ::cookiejar
oo::objdefine ::cookiejar export Database
} -constraints {notOSXtravis sqlite3 cookiejar} -body {
cookiejar storeCookie [dict replace {
key foo
value bar
secure 0
domain www.example.com
origin www.example.com
path /
hostonly 1
} expires [expr {[clock seconds]+5}]]
# Poke inside implementation!
cookiejar Database eval {SELECT count(*) FROM sessionCookies}
} -cleanup {
::cookiejar destroy
} -result 0
test http-cookiejar-4.12 "cookie storage: instance" -setup {
http::cookiejar create ::cookiejar
oo::objdefine ::cookiejar export Database
} -constraints {notOSXtravis sqlite3 cookiejar} -body {
cookiejar storeCookie [dict replace {
key foo
value bar
secure 0
domain www.example.com
origin www.example.com
path /
hostonly 1
} expires [expr {[clock seconds]+5}]]
# Poke inside implementation!
cookiejar Database eval {SELECT count(*) FROM persistentCookies}
} -cleanup {
::cookiejar destroy
} -result 1
test http-cookiejar-4.13 "cookie storage: instance" -setup {
http::cookiejar create ::cookiejar
set result {}
} -constraints {notOSXtravis sqlite3 cookiejar} -body {
lappend result [cookiejar getCookies http www.example.com /]
cookiejar storeCookie {
key foo
value bar
secure 0
domain www.example.com
origin www.example.com
path /
hostonly 1
}
lappend result [cookiejar getCookies http www.example.com /]
} -cleanup {
::cookiejar destroy
} -result {{} {foo bar}}
test http-cookiejar-4.14 "cookie storage: instance" -setup {
http::cookiejar create ::cookiejar
set result {}
} -constraints {notOSXtravis sqlite3 cookiejar} -body {
lappend result [cookiejar getCookies http www.example.com /]
cookiejar storeCookie [dict replace {
key foo
value bar
secure 0
domain www.example.com
origin www.example.com
path /
hostonly 1
} expires [expr {[clock seconds]+5}]]
lappend result [cookiejar getCookies http www.example.com /]
} -cleanup {
::cookiejar destroy
} -result {{} {foo bar}}
test http-cookiejar-4.15 "cookie storage: instance" -setup {
http::cookiejar create ::cookiejar
set result {}
} -constraints {notOSXtravis sqlite3 cookiejar} -body {
lappend result [cookiejar getCookies http www.example.com /]
cookiejar storeCookie {
key foo
value bar
secure 0
domain www.example.com
origin www.example.com
path /
hostonly 1
}
cookiejar storeCookie [dict replace {
key foo
value bar
secure 0
domain www.example.com
origin www.example.com
path /
hostonly 1
} expires [expr {[clock seconds]+5}]]
lappend result [cookiejar getCookies http www.example.com /]
} -cleanup {
::cookiejar destroy
} -result {{} {foo bar}}
test http-cookiejar-4.16 "cookie storage: instance" -setup {
http::cookiejar create ::cookiejar
set result {}
} -constraints {notOSXtravis sqlite3 cookiejar} -body {
lappend result [cookiejar getCookies http www.example.com /]
cookiejar storeCookie {
key foo1
value bar
secure 0
domain www.example.com
origin www.example.com
path /
hostonly 1
}
cookiejar storeCookie [dict replace {
key foo2
value bar
secure 0
domain www.example.com
origin www.example.com
path /
hostonly 1
} expires [expr {[clock seconds]+5}]]
lappend result [lsort -stride 2 [cookiejar getCookies http www.example.com /]]
} -cleanup {
::cookiejar destroy
} -result {{} {foo1 bar foo2 bar}}
test http-cookiejar-4.17 "cookie storage: instance" -setup {
http::cookiejar create ::cookiejar
} -constraints {notOSXtravis sqlite3 cookiejar} -body {
cookiejar lookup a b c d
} -returnCodes error -cleanup {
::cookiejar destroy
} -result {wrong # args: should be "cookiejar lookup ?host? ?key?"}
test http-cookiejar-4.18 "cookie storage: instance" -setup {
http::cookiejar create ::cookiejar
set result {}
} -constraints {notOSXtravis sqlite3 cookiejar} -body {
lappend result [cookiejar lookup]
lappend result [cookiejar lookup www.example.com]
lappend result [catch {cookiejar lookup www.example.com foo} value] $value
cookiejar storeCookie {
key foo
value bar
secure 0
domain www.example.com
origin www.example.com
path /
hostonly 1
}
lappend result [cookiejar lookup]
lappend result [cookiejar lookup www.example.com]
lappend result [cookiejar lookup www.example.com foo]
} -cleanup {
::cookiejar destroy
} -result {{} {} 1 {no such key for that host} www.example.com foo bar}
test http-cookiejar-4.19 "cookie storage: instance" -setup {
http::cookiejar create ::cookiejar
set result {}
} -constraints {notOSXtravis sqlite3 cookiejar} -body {
cookiejar storeCookie {
key foo
value bar
secure 0
domain www.example.com
origin www.example.com
path /
hostonly 1
}
cookiejar storeCookie {
key bar
value foo
secure 0
domain www.example.org
origin www.example.org
path /
hostonly 1
}
lappend result [lsort [cookiejar lookup]]
lappend result [cookiejar lookup www.example.com]
lappend result [cookiejar lookup www.example.com foo]
lappend result [cookiejar lookup www.example.org]
lappend result [cookiejar lookup www.example.org bar]
} -cleanup {
::cookiejar destroy
} -result {{www.example.com www.example.org} foo bar bar foo}
test http-cookiejar-4.20 "cookie storage: instance" -setup {
http::cookiejar create ::cookiejar
set result {}
} -constraints {notOSXtravis sqlite3 cookiejar} -body {
cookiejar storeCookie {
key foo1
value bar1
secure 0
domain www.example.com
origin www.example.com
path /
hostonly 1
}
cookiejar storeCookie [dict replace {
key foo2
value bar2
secure 0
domain www.example.com
origin www.example.com
path /
hostonly 1
} expires [expr {[clock seconds]+5}]]
lappend result [cookiejar lookup]
lappend result [lsort [cookiejar lookup www.example.com]]
lappend result [cookiejar lookup www.example.com foo1]
lappend result [cookiejar lookup www.example.com foo2]
} -cleanup {
::cookiejar destroy
} -result {www.example.com {foo1 foo2} bar1 bar2}
test http-cookiejar-4.21 "cookie storage: instance" -setup {
http::cookiejar create ::cookiejar
set result {}
} -constraints {notOSXtravis sqlite3 cookiejar} -body {
cookiejar storeCookie {
key foo1
value bar1
secure 0
domain www.example.com
origin www.example.com
path /
hostonly 1
}
cookiejar storeCookie {
key foo2
value bar2
secure 0
domain www.example.com
origin www.example.com
path /
hostonly 1
}
lappend result [cookiejar lookup]
lappend result [lsort [cookiejar lookup www.example.com]]
lappend result [cookiejar lookup www.example.com foo1]
lappend result [cookiejar lookup www.example.com foo2]
} -cleanup {
::cookiejar destroy
} -result {www.example.com {foo1 foo2} bar1 bar2}
test http-cookiejar-4.22 "cookie storage: instance" -setup {
http::cookiejar create ::cookiejar
set result {}
} -constraints {notOSXtravis sqlite3 cookiejar} -body {
cookiejar forceLoadDomainData x y z
} -returnCodes error -cleanup {
::cookiejar destroy
} -result {wrong # args: should be "cookiejar forceLoadDomainData"}
test http-cookiejar-4.23 "cookie storage: instance" -setup {
http::cookiejar create ::cookiejar
set result {}
} -constraints {notOSXtravis sqlite3 cookiejar} -body {
cookiejar forceLoadDomainData
} -cleanup {
::cookiejar destroy
} -result {}
test http-cookiejar-4.23.a {cookie storage: instance} -setup {
set off [http::cookiejar configure -offline]
} -constraints {notOSXtravis sqlite3 cookiejar} -body {
http::cookiejar configure -offline 1
[http::cookiejar create ::cookiejar] destroy
} -cleanup {
catch {::cookiejar destroy}
http::cookiejar configure -offline $off
} -result {}
test http-cookiejar-4.23.b {cookie storage: instance} -setup {
set off [http::cookiejar configure -offline]
} -constraints {notOSXtravis sqlite3 cookiejar} -body {
http::cookiejar configure -offline 0
[http::cookiejar create ::cookiejar] destroy
} -cleanup {
catch {::cookiejar destroy}
http::cookiejar configure -offline $off
} -result {}
test http-cookiejar-5.1 "cookie storage: constraints" -setup {
http::cookiejar create ::cookiejar
cookiejar forceLoadDomainData
} -constraints {notOSXtravis sqlite3 cookiejar} -body {
cookiejar storeCookie {
key foo
value bar
secure 0
domain com
origin com
path /
hostonly 1
}
cookiejar lookup
} -cleanup {
::cookiejar destroy
} -result {}
test http-cookiejar-5.2 "cookie storage: constraints" -setup {
http::cookiejar create ::cookiejar
cookiejar forceLoadDomainData
} -constraints {notOSXtravis sqlite3 cookiejar} -body {
cookiejar storeCookie {
key foo
value bar
secure 0
domain foo.example.com
origin bar.example.org
path /
hostonly 1
}
cookiejar lookup
} -cleanup {
::cookiejar destroy
} -result {}
test http-cookiejar-5.3 "cookie storage: constraints" -setup {
http::cookiejar create ::cookiejar
cookiejar forceLoadDomainData
} -constraints {notOSXtravis sqlite3 cookiejar} -body {
cookiejar storeCookie {
key foo1
value bar
secure 0
domain com
origin www.example.com
path /
hostonly 1
}
cookiejar storeCookie {
key foo2
value bar
secure 0
domain example.com
origin www.example.com
path /
hostonly 1
}
cookiejar lookup
} -cleanup {
::cookiejar destroy
} -result {example.com}
test http-cookiejar-5.4 "cookie storage: constraints" -setup {
http::cookiejar create ::cookiejar
cookiejar forceLoadDomainData
} -constraints {notOSXtravis sqlite3 cookiejar} -body {
cookiejar storeCookie {
key foo
value bar1
secure 0
domain www.example.com
origin www.example.com
path /
hostonly 1
}
cookiejar storeCookie {
key foo
value bar2
secure 0
domain example.com
origin www.example.com
path /
hostonly 1
}
lsort [cookiejar lookup]
} -cleanup {
::cookiejar destroy
} -result {example.com www.example.com}
test http-cookiejar-5.5 "cookie storage: constraints" -setup {
http::cookiejar create ::cookiejar
cookiejar forceLoadDomainData
} -constraints {notOSXtravis sqlite3 cookiejar} -body {
cookiejar storeCookie {
key foo1
value 1
secure 0
domain com
origin www.example.com
path /
hostonly 0
}
cookiejar storeCookie {
key foo2
value 2
secure 0
domain com
origin www.example.com
path /
hostonly 1
}
cookiejar storeCookie {
key foo3
value 3
secure 0
domain example.com
origin www.example.com
path /
hostonly 0
}
cookiejar storeCookie {
key foo4
value 4
secure 0
domain example.com
origin www.example.com
path /
hostonly 1
}
cookiejar storeCookie {
key foo5
value 5
secure 0
domain www.example.com
origin www.example.com
path /
hostonly 0
}
cookiejar storeCookie {
key foo6
value 6
secure 0
domain www.example.com
origin www.example.com
path /
hostonly 1
}
cookiejar storeCookie {
key foo7
value 7
secure 1
domain www.example.com
origin www.example.com
path /
hostonly 0
}
cookiejar storeCookie {
key foo8
value 8
secure 1
domain www.example.com
origin www.example.com
path /
hostonly 1
}
cookiejar storeCookie {
key foo9
value 9
secure 0
domain sub.www.example.com
origin www.example.com
path /
hostonly 1
}
list [cookiejar getCookies http www.example.com /] \
[cookiejar getCookies http www2.example.com /] \
[cookiejar getCookies https www.example.com /] \
[cookiejar getCookies http sub.www.example.com /]
} -cleanup {
::cookiejar destroy
} -result {{foo3 3 foo6 6} {foo3 3} {foo3 3 foo6 6 foo8 8} {foo3 3 foo5 5}}
test http-cookiejar-6.1 "cookie storage: expiry and lookup" -setup {
http::cookiejar create ::cookiejar
oo::objdefine cookiejar export PurgeCookies
set result {}
proc values cookies {
global result
lappend result [lsort [lmap {k v} $cookies {set v}]]
}
} -constraints {notOSXtravis sqlite3 cookiejar} -body {
values [cookiejar getCookies http www.example.com /]
cookiejar storeCookie {
key foo
value session
secure 0
domain www.example.com
origin www.example.com
path /
hostonly 1
}
values [cookiejar getCookies http www.example.com /]
cookiejar storeCookie [dict replace {
key foo
value cookie
secure 0
domain www.example.com
origin www.example.com
path /
hostonly 1
} expires [expr {[clock seconds]+1}]]
values [cookiejar getCookies http www.example.com /]
cookiejar storeCookie {
key foo
value session-global
secure 0
domain example.com
origin www.example.com
path /
hostonly 0
}
values [cookiejar getCookies http www.example.com /]
after 2500
update
values [cookiejar getCookies http www.example.com /]
cookiejar PurgeCookies
values [cookiejar getCookies http www.example.com /]
cookiejar storeCookie {
key foo
value go-away
secure 0
domain example.com
origin www.example.com
path /
hostonly 0
expires 0
}
values [cookiejar getCookies http www.example.com /]
} -cleanup {
::cookiejar destroy
} -result {{} session cookie {cookie session-global} {cookie session-global} session-global {}}
test http-cookiejar-7.1 "cookie storage: persistence of persistent cookies" -setup {
catch {rename ::cookiejar ""}
set f [makeFile "" cookiejar]
file delete $f
} -constraints {notOSXtravis sqlite3 cookiejar} -body {
http::cookiejar create ::cookiejar $f
::cookiejar destroy
http::cookiejar create ::cookiejar $f
} -cleanup {
catch {rename ::cookiejar ""}
removeFile $f
} -result ::cookiejar
test http-cookiejar-7.2 "cookie storage: persistence of persistent cookies" -setup {
catch {rename ::cookiejar ""}
set f [makeFile "" cookiejar]
file delete $f
set result {}
} -constraints {notOSXtravis sqlite3 cookiejar} -body {
http::cookiejar create ::cookiejar $f
cookiejar storeCookie [dict replace {
key foo
value cookie
secure 0
domain www.example.com
origin www.example.com
path /
hostonly 1
} expires [expr {[clock seconds]+1}]]
lappend result [::cookiejar getCookies http www.example.com /]
::cookiejar destroy
http::cookiejar create ::cookiejar
lappend result [::cookiejar getCookies http www.example.com /]
::cookiejar destroy
http::cookiejar create ::cookiejar $f
lappend result [::cookiejar getCookies http www.example.com /]
} -cleanup {
catch {rename ::cookiejar ""}
removeFile $f
} -result {{foo cookie} {} {foo cookie}}
::tcltest::cleanupTests
# Local variables:
# mode: tcl
# End:
|
Changes to tests/info.test.
| ︙ | ︙ | |||
15 16 17 18 19 20 21 |
#
# DO NOT DELETE THIS LINE
if {{::tcltest} ni [namespace children]} {
package require tcltest 2
namespace import -force ::tcltest::*
}
| < > | | 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 |
#
# DO NOT DELETE THIS LINE
if {{::tcltest} ni [namespace children]} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint zlib [llength [info commands zlib]]
# Set up namespaces needed to test operation of "info args", "info body",
# "info default", and "info procs" with imported procedures.
catch {namespace delete test_ns_info1 test_ns_info2}
namespace eval test_ns_info1 {
namespace export *
proc p {x} {return "x=$x"}
proc q {{y 27} {z {}}} {return "y=$y"}
}
test info-1.1 {info args option} {
proc t1 {a bbb c} {return foo}
info args t1
} {a bbb c}
test info-1.2 {info args option} {
proc t1 {{a default1} {bbb default2} {c default3} args} {return foo}
info a t1
|
| ︙ | ︙ | |||
106 107 108 109 110 111 112 |
list [string bytelength [info body foo]] \
[foo; string bytelength [info body foo]]
} {9 9}
proc testinfocmdcount {} {
set x [info cmdcount]
set y 12345
| | | | 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 |
list [string bytelength [info body foo]] \
[foo; string bytelength [info body foo]]
} {9 9}
proc testinfocmdcount {} {
set x [info cmdcount]
set y 12345
set z [info cmdc]
expr {$z-$x}
}
test info-3.1 {info cmdcount compiled} {
testinfocmdcount
} 4
test info-3.2 {info cmdcount evaled} -body {
set x [info cmdcount]
set y 12345
set z [info cmdc]
expr {$z-$x}
} -cleanup {unset x y z} -result 4
test info-3.3 {info cmdcount evaled} -body [info body testinfocmdcount] -cleanup {unset x y z} -result 4
test info-3.4 {info cmdcount option} -body {
info cmdcount 1
} -returnCodes error -result {wrong # args: should be "info cmdcount"}
|
| ︙ | ︙ | |||
674 675 676 677 678 679 680 |
unset functions msg
test info-21.1 {miscellaneous error conditions} -returnCodes error -body {
info
} -result {wrong # args: should be "info subcommand ?arg ...?"}
test info-21.2 {miscellaneous error conditions} -returnCodes error -body {
info gorp
| | | | | | 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 |
unset functions msg
test info-21.1 {miscellaneous error conditions} -returnCodes error -body {
info
} -result {wrong # args: should be "info subcommand ?arg ...?"}
test info-21.2 {miscellaneous error conditions} -returnCodes error -body {
info gorp
} -result {unknown or ambiguous subcommand "gorp": must be args, body, class, cmdcount, cmdtype, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars}
test info-21.3 {miscellaneous error conditions} -returnCodes error -body {
info c
} -result {unknown or ambiguous subcommand "c": must be args, body, class, cmdcount, cmdtype, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars}
test info-21.4 {miscellaneous error conditions} -returnCodes error -body {
info l
} -result {unknown or ambiguous subcommand "l": must be args, body, class, cmdcount, cmdtype, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars}
test info-21.5 {miscellaneous error conditions} -returnCodes error -body {
info s
} -result {unknown or ambiguous subcommand "s": must be args, body, class, cmdcount, cmdtype, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars}
##
# ### ### ### ######### ######### #########
## info frame
## Helper
# For the more complex results we cut the file name down to remove path
|
| ︙ | ︙ | |||
764 765 766 767 768 769 770 |
test info-22.8 {info frame, basic trace} -match glob -body {
join [lrange [etrace] 0 2] \n
} -result {* {type source line 730 file info.test cmd {info frame $level} proc ::etrace level 0}
* {type source line 765 file info.test cmd etrace proc ::tcltest::RunTest}
* {type source line * file tcltest* cmd {uplevel 1 $script} proc ::tcltest::RunTest}}
unset -nocomplain msg
| | | | | | | | | | > | | | | | < | | | | | | 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 |
test info-22.8 {info frame, basic trace} -match glob -body {
join [lrange [etrace] 0 2] \n
} -result {* {type source line 730 file info.test cmd {info frame $level} proc ::etrace level 0}
* {type source line 765 file info.test cmd etrace proc ::tcltest::RunTest}
* {type source line * file tcltest* cmd {uplevel 1 $script} proc ::tcltest::RunTest}}
unset -nocomplain msg
## The line 1967 is off by 5 from the true value of 1972. This is a knownBug, see testcase 30.0
test info-23.0 {eval'd info frame} -constraints {!singleTestInterp} -body {
list [i eval {info frame}] [i eval {eval {info frame}}]
} -setup {interp create i} -cleanup {interp delete i} -result {1 2}
test info-23.1 {eval'd info frame, semi-dynamic} -constraints {!singleTestInterp} -body {
i eval {eval info frame}
} -setup {interp create i} -cleanup {interp delete i} -result 2
test info-23.2 {eval'd info frame, dynamic} -constraints {!singleTestInterp} -body {
i eval { set script {info frame}
eval $script}
} -setup {interp create i} -cleanup {interp delete i} -result 2
test info-23.3 {eval'd info frame, literal} -match glob -body {
eval {
info frame 0
}
} -result {type source line 793 file * cmd {info frame 0} proc ::tcltest::RunTest}
test info-23.4 {eval'd info frame, semi-dynamic} {
eval info frame 0
|
| ︙ | ︙ | |||
2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 |
}
test info-33.35 {{*}, literal, simple, bytecompiled} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
} -result {type source line 2389 file info.test cmd {info frame 0} proc ::foo::bar level 0}
# -------------------------------------------------------------------------
unset -nocomplain res
test info-39.2 {Bug 4b61afd660} -setup {
proc probe {} {
return [dict get [info frame -1] line]
}
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 |
}
test info-33.35 {{*}, literal, simple, bytecompiled} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
} -result {type source line 2389 file info.test cmd {info frame 0} proc ::foo::bar level 0}
# -------------------------------------------------------------------------
namespace eval ::testinfocmdtype {
apply {cmds {
foreach c $cmds {rename $c {}}
} ::testinfocmdtype} [info commands ::testinfocmdtype::*]
}
test info-40.1 {info cmdtype: syntax} -body {
info cmdtype
} -returnCodes error -result {wrong # args: should be "info cmdtype commandName"}
test info-40.2 {info cmdtype: syntax} -body {
info cmdtype foo bar
} -returnCodes error -result {wrong # args: should be "info cmdtype commandName"}
test info-40.3 {info cmdtype: no such command} -body {
info cmdtype ::testinfocmdtype::foo
} -returnCodes error -result {unknown command "::testinfocmdtype::foo"}
test info-40.4 {info cmdtype: native commands} -body {
info cmdtype ::if
} -result native
test info-40.5 {info cmdtype: native commands} -body {
info cmdtype ::puts
} -result native
test info-40.6 {info cmdtype: native commands} -body {
info cmdtype ::yield
} -result native
test info-40.7 {info cmdtype: procedures} -setup {
proc ::testinfocmdtype::someproc {} {}
} -body {
info cmdtype ::testinfocmdtype::someproc
} -cleanup {
rename ::testinfocmdtype::someproc {}
} -result proc
test info-40.8 {info cmdtype: aliases} -setup {
interp alias {} ::testinfocmdtype::somealias {} ::puts
} -body {
info cmdtype ::testinfocmdtype::somealias
} -cleanup {
rename ::testinfocmdtype::somealias {}
} -result alias
test info-40.9 {info cmdtype: imports} -setup {
namespace eval ::testinfocmdtype {
namespace eval foo {
proc bar {} {}
namespace export bar
}
namespace import foo::bar
}
} -body {
info cmdtype ::testinfocmdtype::bar
} -cleanup {
rename ::testinfocmdtype::bar {}
namespace delete ::testinfocmdtype::foo
} -result import
test info-40.10 {info cmdtype: slaves} -setup {
apply {i {
rename $i ::testinfocmdtype::slave
variable ::testinfocmdtype::slave $i
}} [interp create]
} -body {
info cmdtype ::testinfocmdtype::slave
} -cleanup {
interp delete $::testinfocmdtype::slave
} -result slave
test info-40.11 {info cmdtype: objects} -setup {
apply {{} {
oo::object create obj
} ::testinfocmdtype}
} -body {
info cmdtype ::testinfocmdtype::obj
} -cleanup {
::testinfocmdtype::obj destroy
} -result object
test info-40.12 {info cmdtype: objects} -setup {
apply {{} {
oo::object create obj
} ::testinfocmdtype}
} -body {
info cmdtype [info object namespace ::testinfocmdtype::obj]::my
} -cleanup {
::testinfocmdtype::obj destroy
} -result privateObject
test info-40.13 {info cmdtype: ensembles} -setup {
namespace eval ::testinfocmdtype {
namespace eval ensmbl {
proc bar {} {}
namespace export *
namespace ensemble create
}
}
} -body {
info cmdtype ::testinfocmdtype::ensmbl
} -cleanup {
namespace delete ::testinfocmdtype::ensmbl
} -result ensemble
test info-40.14 {info cmdtype: zlib streams} -constraints zlib -setup {
namespace eval ::testinfocmdtype {
rename [zlib stream gzip] zstream
}
} -body {
info cmdtype ::testinfocmdtype::zstream
} -cleanup {
::testinfocmdtype::zstream close
} -result zlibStream
test info-40.15 {info cmdtype: coroutines} -setup {
coroutine ::testinfocmdtype::coro eval yield
} -body {
info cmdtype ::testinfocmdtype::coro
} -cleanup {
::testinfocmdtype::coro
} -result coroutine
test info-40.16 {info cmdtype: dynamic behavior} -setup {
proc ::testinfocmdtype::foo {} {}
} -body {
namespace eval ::testinfocmdtype {
list [catch {info cmdtype foo}] [catch {info cmdtype bar}] \
[namespace which foo] [rename foo bar] [namespace which bar] \
[catch {info cmdtype foo}] [catch {info cmdtype bar}]
}
} -cleanup {
namespace eval ::testinfocmdtype {
catch {rename foo {}}
catch {rename bar {}}
}
} -result {0 1 ::testinfocmdtype::foo {} ::testinfocmdtype::bar 1 0}
test info-40.17 {info cmdtype: aliases in slave interpreters} -setup {
set i [interp create]
} -body {
$i alias foo gorp
$i eval {
info cmdtype foo
}
} -cleanup {
interp delete $i
} -result alias
test info-40.18 {info cmdtype: aliases in slave interpreters} -setup {
set safe [interp create -safe]
} -body {
$safe alias foo gorp
$safe eval {
info cmdtype foo
}
} -returnCodes error -cleanup {
interp delete $safe
} -result {not allowed to invoke subcommand cmdtype of info}
test info-40.19 {info cmdtype: aliases in slave interpreters} -setup {
set safe [interp create -safe]
} -body {
set inner [interp create [list $safe bar]]
interp alias $inner foo $safe gorp
$safe eval {
bar eval {
info cmdtype foo
}
}
} -returnCodes error -cleanup {
interp delete $safe
} -result {not allowed to invoke subcommand cmdtype of info}
test info-40.20 {info cmdtype: aliases in slave interpreters} -setup {
set safe [interp create -safe]
} -body {
$safe eval {
interp alias {} foo {} gorp
info cmdtype foo
}
} -returnCodes error -cleanup {
interp delete $safe
} -result {not allowed to invoke subcommand cmdtype of info}
namespace delete ::testinfocmdtype
# -------------------------------------------------------------------------
unset -nocomplain res
test info-39.2 {Bug 4b61afd660} -setup {
proc probe {} {
return [dict get [info frame -1] line]
}
|
| ︙ | ︙ |
Changes to tests/interp.test.
| ︙ | ︙ | |||
16 17 18 19 20 21 22 | } ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] testConstraint testinterpdelete [llength [info commands testinterpdelete]] | | | 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 |
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testinterpdelete [llength [info commands testinterpdelete]]
set hidden_cmds {cd encoding exec exit fconfigure file glob load open pwd socket source tcl:encoding:dirs tcl:encoding:system tcl:file:atime tcl:file:attributes tcl:file:copy tcl:file:delete tcl:file:dirname tcl:file:executable tcl:file:exists tcl:file:extension tcl:file:isdirectory tcl:file:isfile tcl:file:link tcl:file:lstat tcl:file:mkdir tcl:file:mtime tcl:file:nativename tcl:file:normalize tcl:file:owned tcl:file:readable tcl:file:readlink tcl:file:rename tcl:file:rootname tcl:file:size tcl:file:stat tcl:file:tail tcl:file:tempdir tcl:file:tempfile tcl:file:type tcl:file:volumes tcl:file:writable tcl:info:cmdtype tcl:info:nameofexecutable tcl:process:autopurge tcl:process:list tcl:process:purge tcl:process:status tcl:zipfs:lmkimg tcl:zipfs:lmkzip tcl:zipfs:mkimg tcl:zipfs:mkkey tcl:zipfs:mkzip tcl:zipfs:mount tcl:zipfs:mount_data tcl:zipfs:unmount unload}
foreach i [interp slaves] {
interp delete $i
}
# Part 0: Check out options for interp command
test interp-1.1 {options for interp command} -returnCodes error -body {
|
| ︙ | ︙ |
Changes to tests/io.test.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 |
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
| < < < < < < > > > > > > > > < < < < | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 |
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
}
namespace eval ::tcl::test::io {
namespace import ::tcltest::*
variable umaskValue
variable path
variable f
variable i
variable n
variable v
variable msg
variable expected
catch {
::tcltest::loadTestedCommands
package require -exact Tcltest [info patchlevel]
set ::tcltestlib [lindex [package ifneeded Tcltest [info patchlevel]] 1]
}
package require tcltests
testConstraint testbytestring [llength [info commands testbytestring]]
testConstraint testchannel [llength [info commands testchannel]]
testConstraint openpipe 1
testConstraint testfevent [llength [info commands testfevent]]
testConstraint testchannelevent [llength [info commands testchannelevent]]
testConstraint testmainthread [llength [info commands testmainthread]]
testConstraint testobj [llength [info commands testobj]]
# You need a *very* special environment to do some tests. In
# particular, many file systems do not support large-files...
testConstraint largefileSupport [expr {$::tcl_platform(os) ne "Darwin"}]
# some tests can only be run is umask is 2
|
| ︙ | ︙ | |||
5961 5962 5963 5964 5965 5966 5967 5968 5969 5970 5971 5972 5973 5974 |
vwait [namespace which -variable x]
vwait [namespace which -variable x]
close $f4
set x
} {initial foo eof}
close $f
makeFile "foo bar" foo
test io-45.1 {DeleteFileEvent, cleanup on close} {fileevent} {
set f [open $path(foo) r]
fileevent $f readable [namespace code {
lappend x "binding triggered: \"[gets $f]\""
fileevent $f readable {}
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 5959 5960 5961 5962 5963 5964 5965 5966 5967 5968 5969 5970 5971 5972 5973 5974 5975 5976 5977 5978 5979 5980 5981 5982 5983 5984 5985 5986 5987 5988 5989 5990 5991 5992 5993 5994 5995 5996 5997 5998 5999 6000 6001 6002 6003 6004 6005 6006 6007 6008 6009 6010 6011 6012 6013 6014 6015 6016 6017 6018 6019 6020 6021 6022 6023 6024 6025 6026 6027 6028 6029 6030 6031 6032 6033 6034 6035 |
vwait [namespace which -variable x]
vwait [namespace which -variable x]
close $f4
set x
} {initial foo eof}
close $f
test chan-io-44.6 {FileEventProc procedure: write-only non-blocking channel} -setup {
} -constraints {stdio unixExecs fileevent openpipe} -body {
namespace eval refchan {
namespace ensemble create
namespace export *
proc finalize {chan args} {
namespace delete c_$chan
}
proc initialize {chan args} {
namespace eval c_$chan {}
namespace upvar c_$chan watching watching
set watching {}
list finalize initialize seek watch write
}
proc watch {chan args} {
namespace upvar c_$chan watching watching
foreach arg $args {
switch $arg {
write {
if {$arg ni $watching} {
lappend watching $arg
}
chan postevent $chan $arg
}
}
}
}
proc write {chan args} {
chan postevent $chan write
return 1
}
}
set f [chan create w [namespace which refchan]]
chan configure $f -blocking 0
set data "some data"
set x 0
chan event $f writable [namespace code {
puts $f $data
incr count [string length $data]
if {$count > 262144} {
chan event $f writable {}
set x done
}
}]
after 10000 [namespace code {
set x timeout
}]
vwait [namespace which -variable x]
return $x
} -cleanup {
catch {chan close $f}
} -result done
makeFile "foo bar" foo
test io-45.1 {DeleteFileEvent, cleanup on close} {fileevent} {
set f [open $path(foo) r]
fileevent $f readable [namespace code {
lappend x "binding triggered: \"[gets $f]\""
fileevent $f readable {}
|
| ︙ | ︙ | |||
8271 8272 8273 8274 8275 8276 8277 8278 8279 8280 8281 8282 8283 8284 |
string equal $result [testmainthread]
} {1}
test io-60.1 {writing illegal utf sequences} {openpipe fileevent testbytestring} {
# This test will hang in older revisions of the core.
set out [open $path(script) w]
puts $out {
puts [testbytestring \xe2]
exit 1
}
proc readit {pipe} {
variable x
variable result
| > | 8332 8333 8334 8335 8336 8337 8338 8339 8340 8341 8342 8343 8344 8345 8346 |
string equal $result [testmainthread]
} {1}
test io-60.1 {writing illegal utf sequences} {openpipe fileevent testbytestring} {
# This test will hang in older revisions of the core.
set out [open $path(script) w]
puts $out "catch {load $::tcltestlib Tcltest}"
puts $out {
puts [testbytestring \xe2]
exit 1
}
proc readit {pipe} {
variable x
variable result
|
| ︙ | ︙ |
Changes to tests/ioCmd.test.
| ︙ | ︙ | |||
10 11 12 13 14 15 16 |
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
| | > > < < | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 |
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
package require tcltests
# Custom constraints used in this file
testConstraint testchannel [llength [info commands testchannel]]
#----------------------------------------------------------------------
test iocmd-1.1 {puts command} {
list [catch {puts} msg] $msg
} {1 {wrong # args: should be "puts ?-nonewline? ?channelId? string"}}
test iocmd-1.2 {puts command} {
|
| ︙ | ︙ | |||
150 151 152 153 154 155 156 |
close $f
string compare [string tolower $x] \
[list 1 [format "channel \"%s\" wasn't opened for reading" $f] none]
} 0
test iocmd-4.12 {read command} -setup {
set f [open $path(test1)]
} -body {
| | | | 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 |
close $f
string compare [string tolower $x] \
[list 1 [format "channel \"%s\" wasn't opened for reading" $f] none]
} 0
test iocmd-4.12 {read command} -setup {
set f [open $path(test1)]
} -body {
read $f 12z
} -cleanup {
close $f
} -result {expected non-negative integer but got "12z"} -errorCode {TCL VALUE NUMBER}
test iocmd-5.1 {seek command} -returnCodes error -body {
seek
} -result {wrong # args: should be "seek channelId offset ?origin?"}
test iocmd-5.2 {seek command} -returnCodes error -body {
seek a b c d e f g
} -result {wrong # args: should be "seek channelId offset ?origin?"}
|
| ︙ | ︙ | |||
202 203 204 205 206 207 208 |
set chan [open [info script] r]
} -body {
chan close $chan write
} -cleanup {
close $chan
} -returnCodes error -result "Half-close of write-side not possible, side not opened or already closed"
| > > > > > > > > | | | | | | | | | | > | > | < | | | | | | | > | > | < | | > > < > | < | | > | > | < | | | | | | > | | < | | > | | < | | > | | < | | 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 |
set chan [open [info script] r]
} -body {
chan close $chan write
} -cleanup {
close $chan
} -returnCodes error -result "Half-close of write-side not possible, side not opened or already closed"
proc expectedOpts {got extra} {
set basicOpts {
-blocking -buffering -buffersize -encoding -eofchar -translation
}
set opts [list {*}$basicOpts {*}$extra]
lset opts end [string cat "or " [lindex $opts end]]
return [format {bad option "%s": should be one of %s} $got [join $opts ", "]]
}
test iocmd-8.1 {fconfigure command} -returnCodes error -body {
fconfigure
} -result {wrong # args: should be "fconfigure channelId ?-option value ...?"}
test iocmd-8.2 {fconfigure command} -returnCodes error -body {
fconfigure a b c d e f
} -result {wrong # args: should be "fconfigure channelId ?-option value ...?"}
test iocmd-8.3 {fconfigure command} -returnCodes error -body {
fconfigure a b
} -result {can not find channel named "a"}
test iocmd-8.4 {fconfigure command} -setup {
file delete $path(test1)
set f1 [open $path(test1) w]
} -body {
fconfigure $f1 froboz
} -returnCodes error -cleanup {
close $f1
} -result [expectedOpts "froboz" {}]
test iocmd-8.5 {fconfigure command} -returnCodes error -body {
fconfigure stdin -buffering froboz
} -result {bad value for -buffering: must be one of full, line, or none}
test iocmd-8.6 {fconfigure command} -returnCodes error -body {
fconfigure stdin -translation froboz
} -result {bad value for -translation: must be one of auto, binary, cr, lf, crlf, or platform}
test iocmd-8.7 {fconfigure command} -setup {
file delete $path(test1)
} -body {
set f1 [open $path(test1) w]
fconfigure $f1 -translation lf -eofchar {} -encoding unicode
fconfigure $f1
} -cleanup {
catch {close $f1}
} -result {-blocking 1 -buffering full -buffersize 4096 -encoding unicode -eofchar {} -translation lf}
test iocmd-8.8 {fconfigure command} -setup {
file delete $path(test1)
set x {}
} -body {
set f1 [open $path(test1) w]
fconfigure $f1 -translation lf -buffering line -buffersize 3030 \
-eofchar {} -encoding unicode
lappend x [fconfigure $f1 -buffering]
lappend x [fconfigure $f1]
} -cleanup {
catch {close $f1}
} -result {line {-blocking 1 -buffering line -buffersize 3030 -encoding unicode -eofchar {} -translation lf}}
test iocmd-8.9 {fconfigure command} -setup {
file delete $path(test1)
} -body {
set f1 [open $path(test1) w]
fconfigure $f1 -translation binary -buffering none -buffersize 4040 \
-eofchar {} -encoding binary
fconfigure $f1
} -cleanup {
catch {close $f1}
} -result {-blocking 1 -buffering none -buffersize 4040 -encoding binary -eofchar {} -translation lf}
test iocmd-8.10 {fconfigure command} -returnCodes error -body {
fconfigure a b
} -result {can not find channel named "a"}
set path(fconfigure.dummy) [makeFile {} fconfigure.dummy]
test iocmd-8.11 {fconfigure command} -body {
set chan [open $path(fconfigure.dummy) r]
fconfigure $chan -froboz blarfo
} -returnCodes error -cleanup {
catch {close $chan}
} -result [expectedOpts "-froboz" {}]
test iocmd-8.12 {fconfigure command} -body {
set chan [open $path(fconfigure.dummy) r]
fconfigure $chan -b blarfo
} -returnCodes error -cleanup {
catch {close $chan}
} -result [expectedOpts "-b" {}]
test iocmd-8.13 {fconfigure command} -body {
set chan [open $path(fconfigure.dummy) r]
fconfigure $chan -buffer blarfo
} -returnCodes error -cleanup {
catch {close $chan}
} -result [expectedOpts "-buffer" {}]
removeFile fconfigure.dummy
test iocmd-8.14 {fconfigure command} {
fconfigure stdin -buffers
} 4096
test iocmd-8.15.1 {fconfigure command / tcp channel} -constraints {socket unixOrPc} -setup {
set srv [socket -server iocmdSRV -myaddr 127.0.0.1 0]
set port [lindex [fconfigure $srv -sockname] 2]
proc iocmdSRV {sock ip port} {close $sock}
set cli [socket 127.0.0.1 $port]
} -body {
fconfigure $cli -blah
} -cleanup {
close $cli
close $srv
unset cli srv port
rename iocmdSRV {}
} -returnCodes error -result [expectedOpts "-blah" {-connecting -peername -sockname}]
test iocmd-8.16 {fconfigure command / tcp channel} -constraints socket -setup {
set srv [socket -server iocmdSRV -myaddr 127.0.0.1 0]
set port [lindex [fconfigure $srv -sockname] 2]
proc iocmdSRV {sock ip port} {close $sock}
set cli [socket 127.0.0.1 $port]
} -body {
expr {[lindex [fconfigure $cli -peername] 2] == $port}
|
| ︙ | ︙ | |||
333 334 335 336 337 338 339 |
# might fail if /dev/ttya is unavailable
set tty [open /dev/ttya]
fconfigure $tty -blah blih
} -cleanup {
if {$tty ne ""} {
close $tty
}
| | > > > > > > | | 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 |
# might fail if /dev/ttya is unavailable
set tty [open /dev/ttya]
fconfigure $tty -blah blih
} -cleanup {
if {$tty ne ""} {
close $tty
}
} -returnCodes error -result [expectedOpts "-blah" {-closemode -inputmode -mode -queue -ttystatus -xchar}]
test iocmd-8.19 {fconfigure command / win tty channel} -constraints {nonPortable win} -setup {
set tty ""
} -body {
# might fail early if com1 is unavailable
set tty [open com1]
fconfigure $tty -blah blih
} -cleanup {
if {$tty ne ""} {
close $tty
}
} -returnCodes error -result [expectedOpts "-blah" {-closemode -mode -handshake -pollinterval -sysbuffer -timeout -ttycontrol -xchar}]
test iocmd-8.20 {fconfigure command / win console channel} -constraints {nonPortable win} -setup {
# I don't know how else to open the console, but this is non-portable
set console stdin
} -body {
fconfigure $console -blah blih
} -returnCodes error -result [expectedOpts "-blah" {-inputmode}]
# TODO: Test parsing of serial channel options (nonPortable, since requires an
# open channel to work with).
test iocmd-9.1 {eof command} {
list [catch {eof} msg] $msg $::errorCode
} {1 {wrong # args: should be "eof channelId"} {TCL WRONGARGS}}
test iocmd-9.2 {eof command} {
|
| ︙ | ︙ | |||
391 392 393 394 395 396 397 |
} {1 {can't write input to command: standard input was redirected} {TCL OPERATION EXEC BADREDIRECT}}
test iocmd-11.2 {I/O to command pipelines} {unixOrPc unixExecs} {
list [catch {open "| echo > \"$path(test5)\"" r} msg] $msg $::errorCode
} {1 {can't read output from command: standard output was redirected} {TCL OPERATION EXEC BADREDIRECT}}
test iocmd-11.3 {I/O to command pipelines} {unixOrPc unixExecs} {
list [catch {open "| echo > \"$path(test5)\"" r+} msg] $msg $::errorCode
} {1 {can't read output from command: standard output was redirected} {TCL OPERATION EXEC BADREDIRECT}}
| | | 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 |
} {1 {can't write input to command: standard input was redirected} {TCL OPERATION EXEC BADREDIRECT}}
test iocmd-11.2 {I/O to command pipelines} {unixOrPc unixExecs} {
list [catch {open "| echo > \"$path(test5)\"" r} msg] $msg $::errorCode
} {1 {can't read output from command: standard output was redirected} {TCL OPERATION EXEC BADREDIRECT}}
test iocmd-11.3 {I/O to command pipelines} {unixOrPc unixExecs} {
list [catch {open "| echo > \"$path(test5)\"" r+} msg] $msg $::errorCode
} {1 {can't read output from command: standard output was redirected} {TCL OPERATION EXEC BADREDIRECT}}
test iocmd-11.4 {I/O to command pipelines} {notValgrind unixOrPc} {
list [catch {open "| no_such_command_exists" rb} msg] $msg $::errorCode
} {1 {couldn't execute "no_such_command_exists": no such file or directory} {POSIX ENOENT {no such file or directory}}}
test iocmd-12.1 {POSIX open access modes: RDONLY} {
file delete $path(test1)
set f [open $path(test1) w]
puts $f "Two lines: this one"
|
| ︙ | ︙ | |||
908 909 910 911 912 913 914 915 916 917 918 919 920 921 |
return -code return $args
}
proc onfinal {} {
upvar args hargs
if {[lindex $hargs 0] ne "finalize"} {return}
return -code return ""
}
}
# Set everything up in the main thread.
eval $helperscript
# --- --- --- --------- --------- ---------
# method finalize
| > > > > > > > > > > > | 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 |
return -code return $args
}
proc onfinal {} {
upvar args hargs
if {[lindex $hargs 0] ne "finalize"} {return}
return -code return ""
}
proc onwatch {} {
upvar args hargs
lassign $hargs watch chan eventspec
if {$watch ne "watch"} return
foreach spec $eventspec {
chan postevent $chan $spec
}
return
}
}
# Set everything up in the main thread.
eval $helperscript
# --- --- --- --------- --------- ---------
# method finalize
|
| ︙ | ︙ | |||
1980 1981 1982 1983 1984 1985 1986 |
rename foo {}
set res
} -result {{unmatched open brace in list}}
test iocmd-31.6 {chan postevent, posted events do happen} -match glob -body {
set res {}
proc foo {args} {oninit; onfinal; track; return}
set c [chan create {r w} foo]
| > | | | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > | 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 |
rename foo {}
set res
} -result {{unmatched open brace in list}}
test iocmd-31.6 {chan postevent, posted events do happen} -match glob -body {
set res {}
proc foo {args} {oninit; onfinal; track; return}
set c [chan create {r w} foo]
set tock {}
note [fileevent $c readable {lappend res TOCK; set tock 1}]
set stop [after 10000 {lappend res TIMEOUT; set tock 1}]
after 1000 {note [chan postevent $c r]}
vwait ::tock
catch {after cancel $stop}
close $c
rename foo {}
set res
} -result {{watch rc* read} {} {} TOCK {watch rc* {}}}
test iocmd-31.7 {chan postevent, posted events do happen} -match glob -body {
set res {}
proc foo {args} {oninit; onfinal; track; return}
set c [chan create {r w} foo]
note [fileevent $c writable {lappend res TOCK; set tock 1}]
set stop [after 10000 {lappend res TIMEOUT; set tock 1}]
after 1000 {note [chan postevent $c w]}
vwait ::tock
catch {after cancel $stop}
close $c
rename foo {}
set res
} -result {{watch rc* write} {} {} TOCK {watch rc* {}}}
test iocmd-31.8 {chan postevent after close throws error} -match glob -setup {
proc foo {args} {oninit; onfinal; track; return}
proc dummy args { return }
set c [chan create {r w} foo]
fileevent $c readable dummy
} -body {
close $c
chan postevent $c read
} -cleanup {
rename foo {}
rename dummy {}
} -returnCodes error -result {can not find reflected channel named "rc*"}
test iocmd-31.9 {
chan postevent
call to current coroutine
see 67a5eabbd3d1
} -match glob -body {
set res {}
proc foo {args} {oninit; onwatch; onfinal; track; return}
set c [chan create {r w} foo]
after 0 [list ::apply [list c {
coroutine c1 ::apply [list c {
chan event $c readable [list [info coroutine]]
yield
set ::done READING
} [namespace current]] $c
} [namespace current]] $c]
set stop [after 10000 {set done TIMEOUT}]
vwait ::done
catch {after cancel $stop}
lappend res $done
close $c
rename foo {}
set res
} -result {{watch rc* read} READING {watch rc* {}}}
# --- === *** ###########################
# 'Pull the rug' tests. Create channel in a interpreter A, move to
# other interpreter B, destroy the origin interpreter (A) before or
# during access from B. Must not crash, must return proper errors.
test iocmd-32.0 {origin interpreter of moved channel gone} -match glob -body {
|
| ︙ | ︙ | |||
3777 3778 3779 3780 3781 3782 3783 | # channel operation does not hang. There's no way to test this without actually # exiting a thread in mid-operation, and that action is unavoidably leaky (which # is why [thread::exit] is advised against). # # Use constraints to skip this test while valgrinding so this expected leak # doesn't prevent a finding of "leak-free". # | < | 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 |
# channel operation does not hang. There's no way to test this without actually
# exiting a thread in mid-operation, and that action is unavoidably leaky (which
# is why [thread::exit] is advised against).
#
# Use constraints to skip this test while valgrinding so this expected leak
# doesn't prevent a finding of "leak-free".
#
test iocmd.tf-32.1 {origin thread of moved channel destroyed during access} -match glob -body {
#puts <<$tcltest::mainThread>>main
set tida [thread::create -preserved];#puts <<$tida>>
thread::send $tida {load {} Tcltest}
set tidb [thread::create -preserved];#puts <<$tidb>>
thread::send $tidb {load {} Tcltest}
|
| ︙ | ︙ | |||
3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 |
# ### ### ### ######### ######### #########
# ### ### ### ######### ######### #########
rename track {}
# cleanup
foreach file [list test1 test2 test3 test4] {
removeFile $file
}
# delay long enough for background processes to finish
after 500
removeFile test5
cleanupTests
return
| > > > > > > > > > > | 3884 3885 3886 3887 3888 3889 3890 3891 3892 3893 3894 3895 3896 3897 3898 3899 3900 3901 3902 3903 3904 3905 3906 3907 3908 |
# ### ### ### ######### ######### #########
# ### ### ### ######### ######### #########
rename track {}
# cleanup
# Eliminate valgrind "still reachable" reports on outstanding "Detached"
# structures in the detached list which stem from PipeClose2Proc not waiting
# around for background processes to complete, meaning that previous calls to
# Tcl_ReapDetachedProcs might not have had a chance to reap all processes.
after 10
exec [info nameofexecutable] << {}
foreach file [list test1 test2 test3 test4] {
removeFile $file
}
# delay long enough for background processes to finish
after 500
removeFile test5
cleanupTests
return
|
Changes to tests/ioTrans.test.
| ︙ | ︙ | |||
1236 1237 1238 1239 1240 1241 1242 |
# Wait a bit, give the main thread the time to start its event loop to
# wait for the response from B
after 50
catch { puts $chan shoo } res
set res
}]
} -cleanup {
| < > | 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 |
# Wait a bit, give the main thread the time to start its event loop to
# wait for the response from B
after 50
catch { puts $chan shoo } res
set res
}]
} -cleanup {
interp delete $idb
tempdone
} -result {Owner lost}
test iortrans-11.2 {delete interp of reflected transform} -setup {
interp create slave
# Magic to get the test* commands into the slave
load {} Tcltest slave
} -constraints {testchannel} -body {
# Get base channel into the slave
|
| ︙ | ︙ |
Changes to tests/iogt.test.
| ︙ | ︙ | |||
604 605 606 607 608 609 610 |
} {}
test iogt-3.0 {Tcl_Channel valid after stack/unstack, fevent handling} -setup {
proc DoneCopy {n {err {}}} {
variable copy 1
}
} -constraints {testchannel knownBug} -body {
| | | 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 |
} {}
test iogt-3.0 {Tcl_Channel valid after stack/unstack, fevent handling} -setup {
proc DoneCopy {n {err {}}} {
variable copy 1
}
} -constraints {testchannel knownBug} -body {
# This test to check the validity of acquired Tcl_Channel references is not
# possible because even a backgrounded fcopy will immediately start to
# copy data, without waiting for the event loop. This is done only in case
# of an underflow on the read size!. So stacking transforms after the
# fcopy will miss information, or are not used at all.
#
# I was able to circumvent this by using the echo.tcl server with a big
# delay, causing the fcopy to underflow immediately.
|
| ︙ | ︙ |
Changes to tests/link.test.
| ︙ | ︙ | |||
16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 |
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testlink [llength [info commands testlink]]
foreach i {int real bool string} {
unset -nocomplain $i
}
test link-1.1 {reading C variables from Tcl} -constraints {testlink} -setup {
testlink delete
} -body {
testlink set 43 1.23 4 - 12341234 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234
testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1
list $int $real $bool $string $wide
| > > > > > > > > > > > | 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 |
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testlink [llength [info commands testlink]]
testConstraint testlinkarray [llength [info commands testlinkarray]]
foreach i {int real bool string} {
unset -nocomplain $i
}
test link-0.1 {leak test} {testlink} {
interp create i
load {} Tcltest i
i eval {
testlink create 1 0 0 0 0 0 0 0 0 0 0 0 0 0
namespace delete ::
}
interp delete i
} {}
test link-1.1 {reading C variables from Tcl} -constraints {testlink} -setup {
testlink delete
} -body {
testlink set 43 1.23 4 - 12341234 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234
testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1
list $int $real $bool $string $wide
|
| ︙ | ︙ | |||
84 85 86 87 88 89 90 |
} -result {1 {can't set "bool": variable must have boolean value} 1}
test link-2.5 {writing bad values into variables} -setup {
testlink delete
} -constraints {testlink} -body {
testlink set 43 1.23 4 - 56785678 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234
testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1
list [catch {set wide gorp} msg] $msg $bool
| | | 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 |
} -result {1 {can't set "bool": variable must have boolean value} 1}
test link-2.5 {writing bad values into variables} -setup {
testlink delete
} -constraints {testlink} -body {
testlink set 43 1.23 4 - 56785678 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234
testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1
list [catch {set wide gorp} msg] $msg $bool
} -result {1 {can't set "wide": variable must have wide integer value} 1}
test link-2.6 {writing C variables from Tcl} -constraints {testlink} -setup {
testlink delete
} -body {
testlink set 43 1.21 4 - 56785678 64 250 30000 60000 0xbaadbeef 12321 32123 3.25 1231231234
testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1
set int "+"
set real "+"
|
| ︙ | ︙ | |||
359 360 361 362 363 364 365 |
proc x {} {
upvar wide y
set y abc
}
testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1
testlink set -4 16.3 1 {} 778899 {} {} {} {} {} {} {} {} {}
list [catch x msg] $msg $wide
| | | 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 |
proc x {} {
upvar wide y
set y abc
}
testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1
testlink set -4 16.3 1 {} 778899 {} {} {} {} {} {} {} {} {}
list [catch x msg] $msg $wide
} -result {1 {can't set "y": variable must have wide integer value} 778899}
test link-8.1 {Tcl_UpdateLinkedVar procedure} {testlink} {
proc x args {
global x int real bool string wide
lappend x $args $int $real $bool $string $wide
}
set x {}
|
| ︙ | ︙ | |||
394 395 396 397 398 399 400 401 402 403 404 405 406 407 |
} {}
test link-8.3 {Tcl_UpdateLinkedVar procedure, read-only variable} {testlink} {
testlink create 0 0 0 0 0 0 0 0 0 0 0 0 0 0
list [catch {
testlink update 47 {} {} {} {} {} {} {} {} {} {} {} {} {}
} msg] $msg $int
} {0 {} 47}
catch {testlink set 0 0 0 - 0 0 0 0 0 0 0 0 0 0}
catch {testlink delete}
foreach i {int real bool string wide} {
unset -nocomplain $i
}
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 |
} {}
test link-8.3 {Tcl_UpdateLinkedVar procedure, read-only variable} {testlink} {
testlink create 0 0 0 0 0 0 0 0 0 0 0 0 0 0
list [catch {
testlink update 47 {} {} {} {} {} {} {} {} {} {} {} {} {}
} msg] $msg $int
} {0 {} 47}
test link-9.1 {linkarray usage messages} -returnCodes error -body {
testlinkarray
} -result {wrong # args: should be "testlinkarray option args"}
test link-9.2 {linkarray usage messages} -returnCodes error -body {
testlinkarray x
} -result {bad option "x": must be update, remove, or create}
test link-9.3 {linkarray usage messages} -body {
testlinkarray update
} -result {}
test link-9.4 {linkarray usage messages} -body {
testlinkarray remove
} -result {}
test link-9.5 {linkarray usage messages} -returnCodes error -body {
testlinkarray create
} -result {wrong # args: should be "testlinkarray create ?-readonly? type size name ?address?"}
test link-9.6 {linkarray usage messages} -returnCodes error -body {
testlinkarray create xx 1 my
} -result {bad type "xx": must be char, uchar, short, ushort, int, uint, long, ulong, wide, uwide, float, double, string, char*, or binary}
test link-9.7 {linkarray usage messages} -returnCodes error -body {
testlinkarray create char* 0 my
} -result {wrong array size given}
test link-10.1 {linkarray char*} -setup {
set mylist [list]
} -body {
testlinkarray create char* 1 ::my(var)
lappend mylist [set ::my(var) ""]
catch {set ::my(var) x} msg
lappend mylist $msg
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {{} {can't set "::my(var)": wrong size of char* value}}
test link-10.2 {linkarray char*} -body {
testlinkarray create char* 4 ::my(var)
set ::my(var) x
catch {set ::my(var) xyzz} msg
return $msg
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {can't set "::my(var)": wrong size of char* value}
test link-10.3 {linkarray char*} -body {
testlinkarray create -r char* 4 ::my(var)
catch {set ::my(var) x} msg
return $msg
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {can't set "::my(var)": linked variable is read-only}
test link-11.1 {linkarray char} -setup {
set mylist [list]
} -body {
testlinkarray create char 1 ::my(var)
catch {set ::my(var) x} msg
lappend mylist $msg
lappend mylist [set ::my(var) 120]
catch {set ::my(var) 1234} msg
lappend mylist $msg
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {{can't set "::my(var)": variable must have char value} 120 {can't set "::my(var)": variable must have char value}}
test link-11.2 {linkarray char} -setup {
set mylist [list]
} -body {
testlinkarray create char 4 ::my(var)
catch {set ::my(var) {1 2 3}} msg
lappend mylist $msg
set ::my(var) {1 2 3 4}
lappend mylist $my(var)
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}}
test link-11.3 {linkarray char} -body {
testlinkarray create -r char 2 ::my(var)
catch {set ::my(var) {1 2}} msg
return $msg
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {can't set "::my(var)": linked variable is read-only}
test link-12.1 {linkarray unsigned char} -setup {
set mylist [list]
} -body {
testlinkarray create uchar 1 ::my(var)
catch {set ::my(var) x} msg
lappend mylist $msg
lappend mylist [set ::my(var) 120]
catch {set ::my(var) 1234} msg
lappend mylist $msg
catch {set ::my(var) -1} msg
lappend mylist $msg
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {{can't set "::my(var)": variable must have unsigned char value} 120 {can't set "::my(var)": variable must have unsigned char value} {can't set "::my(var)": variable must have unsigned char value}}
test link-12.2 {linkarray unsigned char} -setup {
set mylist [list]
} -body {
testlinkarray create uchar 4 ::my(var)
catch {set ::my(var) {1 2 3}} msg
lappend mylist $msg
set ::my(var) {1 2 3 4}
lappend mylist $my(var)
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}}
test link-12.3 {linkarray unsigned char} -body {
testlinkarray create -r uchar 2 ::my(var)
catch {set ::my(var) {1 2}} msg
return $msg
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {can't set "::my(var)": linked variable is read-only}
test link-13.1 {linkarray short} -setup {
set mylist [list]
} -body {
testlinkarray create short 1 ::my(var)
catch {set ::my(var) x} msg
lappend mylist $msg
lappend mylist [set ::my(var) 120]
catch {set ::my(var) 123456} msg
lappend mylist $msg
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {{can't set "::my(var)": variable must have short value} 120 {can't set "::my(var)": variable must have short value}}
test link-13.2 {linkarray short} -setup {
set mylist [list]
} -body {
testlinkarray create short 4 ::my(var)
catch {set ::my(var) {1 2 3}} msg
lappend mylist $msg
set ::my(var) {1 2 3 4}
lappend mylist $my(var)
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}}
test link-13.3 {linkarray short} -body {
testlinkarray create -r short 2 ::my(var)
catch {set ::my(var) {1 2}} msg
return $msg
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {can't set "::my(var)": linked variable is read-only}
test link-14.1 {linkarray unsigned short} -setup {
set mylist [list]
} -body {
testlinkarray create ushort 1 ::my(var)
catch {set ::my(var) x} msg
lappend mylist $msg
lappend mylist [set ::my(var) 120]
catch {set ::my(var) 123456} msg
lappend mylist $msg
catch {set ::my(var) -1} msg
lappend mylist $msg
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {{can't set "::my(var)": variable must have unsigned short value} 120 {can't set "::my(var)": variable must have unsigned short value} {can't set "::my(var)": variable must have unsigned short value}}
test link-14.2 {linkarray unsigned short} -setup {
set mylist [list]
} -body {
testlinkarray create ushort 4 ::my(var)
catch {set ::my(var) {1 2 3}} msg
lappend mylist $msg
set ::my(var) {1 2 3 4}
lappend mylist $my(var)
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}}
test link-14.3 {linkarray unsigned short} -body {
testlinkarray create -r ushort 2 ::my(var)
catch {set ::my(var) {1 2}} msg
return $msg
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {can't set "::my(var)": linked variable is read-only}
test link-15.1 {linkarray int} -setup {
set mylist [list]
} -body {
testlinkarray create int 1 ::my(var)
catch {set ::my(var) x} msg
lappend mylist $msg
lappend mylist [set ::my(var) 120]
catch {set ::my(var) 1e3} msg
lappend mylist $msg
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {{can't set "::my(var)": variable must have integer value} 120 {can't set "::my(var)": variable must have integer value}}
test link-15.2 {linkarray int} -setup {
set mylist [list]
} -body {
testlinkarray create int 4 ::my(var)
catch {set ::my(var) {1 2 3}} msg
lappend mylist $msg
set ::my(var) {1 2 3 4}
lappend mylist $my(var)
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}}
test link-15.3 {linkarray int} -body {
testlinkarray create -r int 2 ::my(var)
catch {set ::my(var) {1 2}} msg
return $msg
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {can't set "::my(var)": linked variable is read-only}
test link-16.1 {linkarray unsigned int} -setup {
set mylist [list]
} -body {
testlinkarray create uint 1 ::my(var)
catch {set ::my(var) x} msg
lappend mylist $msg
lappend mylist [set ::my(var) 120]
catch {set ::my(var) 1e33} msg
lappend mylist $msg
catch {set ::my(var) -1} msg
lappend mylist $msg
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain ::my
} -result {{can't set "::my(var)": variable must have unsigned int value} 120 {can't set "::my(var)": variable must have unsigned int value} {can't set "::my(var)": variable must have unsigned int value}}
test link-16.2 {linkarray unsigned int} -setup {
set mylist [list]
} -body {
testlinkarray create uint 4 ::my(var)
catch {set ::my(var) {1 2 3}} msg
lappend mylist $msg
set ::my(var) {1 2 3 4}
lappend mylist $my(var)
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain ::my
} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}}
test link-16.3 {linkarray unsigned int} -body {
testlinkarray create -r uint 2 ::my(var)
catch {set ::my(var) {1 2}} msg
return $msg
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {can't set "::my(var)": linked variable is read-only}
test link-17.1 {linkarray long} -setup {
set mylist [list]
} -body {
testlinkarray create long 1 ::my(var)
catch {set ::my(var) x} msg
lappend mylist $msg
lappend mylist [set ::my(var) 120]
catch {set ::my(var) 1e33} msg
lappend mylist $msg
} -match glob -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {{can't set "::my(var)": variable must have * value} 120 {can't set "::my(var)": variable must have * value}}
test link-17.2 {linkarray long} -setup {
set mylist [list]
} -body {
testlinkarray create long 4 ::my(var)
catch {set ::my(var) {1 2 3}} msg
lappend mylist $msg
set ::my(var) {1 2 3 4}
lappend mylist $my(var)
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}}
test link-17.3 {linkarray long} -body {
testlinkarray create -r long 2 ::my(var)
catch {set ::my(var) {1 2}} msg
return $msg
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {can't set "::my(var)": linked variable is read-only}
test link-18.1 {linkarray unsigned long} -setup {
set mylist [list]
} -body {
testlinkarray create ulong 1 ::my(var)
catch {set ::my(var) x} msg
lappend mylist $msg
lappend mylist [set ::my(var) 120]
catch {set ::my(var) 1e33} msg
lappend mylist $msg
} -match glob -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {{can't set "::my(var)": variable must have unsigned * value} 120 {can't set "::my(var)": variable must have unsigned * value}}
test link-18.2 {linkarray unsigned long} -body {
testlinkarray create ulong 1 ::my(var)
set ::my(var) 120
catch {set ::my(var) -1} msg
return $msg
} -match glob -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {can't set "::my(var)": variable must have unsigned * value}
test link-18.3 {linkarray unsigned long} -setup {
set mylist [list]
} -body {
testlinkarray create ulong 4 ::my(var)
catch {set ::my(var) {1 2 3}} msg
lappend mylist $msg
set ::my(var) {1 2 3 4}
lappend mylist $my(var)
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}}
test link-18.4 {linkarray unsigned long} -body {
testlinkarray create -r ulong 2 ::my(var)
catch {set ::my(var) {1 2}} msg
return $msg
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {can't set "::my(var)": linked variable is read-only}
test link-19.1 {linkarray wide} -setup {
set mylist [list]
} -body {
testlinkarray create wide 1 ::my(var)
catch {set ::my(var) x} msg
lappend mylist $msg
lappend mylist [set ::my(var) 120]
catch {set ::my(var) 1e33} msg
lappend mylist $msg
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {{can't set "::my(var)": variable must have wide integer value} 120 {can't set "::my(var)": variable must have wide integer value}}
test link-19.2 {linkarray wide} -setup {
set mylist [list]
} -body {
testlinkarray create wide 4 ::my(var)
catch {set ::my(var) {1 2 3}} msg
lappend mylist $msg
set ::my(var) {1 2 3 4}
lappend mylist $my(var)
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}}
test link-19.3 {linkarray wide} -body {
testlinkarray create -r wide 2 ::my(var)
catch {set ::my(var) {1 2}} msg
return $msg
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {can't set "::my(var)": linked variable is read-only}
test link-20.1 {linkarray unsigned wide} -setup {
set mylist [list]
} -body {
testlinkarray create uwide 1 ::my(var)
catch {set ::my(var) x} msg
lappend mylist $msg
lappend mylist [set ::my(var) 120]
catch {set ::my(var) 1e33} msg
lappend mylist $msg
lappend mylist [set ::my(var) 0xbabed00dbabed00d]
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {{can't set "::my(var)": variable must have unsigned wide int value} 120 {can't set "::my(var)": variable must have unsigned wide int value} 0xbabed00dbabed00d}
test link-20.2 {linkarray unsigned wide} -body {
testlinkarray create uwide 1 ::my(var)
set ::my(var) 120
catch {set ::my(var) -1} msg
return $msg
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {can't set "::my(var)": variable must have unsigned wide int value}
test link-20.3 {linkarray unsigned wide} -setup {
set mylist [list]
} -body {
testlinkarray create uwide 4 ::my(var)
catch {set ::my(var) {1 2 3}} msg
lappend mylist $msg
set ::my(var) {1 2 3 4}
lappend mylist $my(var)
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}}
test link-20.4 {linkarray unsigned wide} -body {
testlinkarray create -r uwide 2 ::my(var)
catch {set ::my(var) {1 2}} msg
return $msg
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {can't set "::my(var)": linked variable is read-only}
test link-21.1 {linkarray string} -setup {
set mylist [list]
} -body {
testlinkarray create string 1 ::my(var)
lappend mylist [set ::my(var) ""]
lappend mylist [set ::my(var) "xyz"]
lappend mylist $::my(var)
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {{} xyz xyz}
test link-21.2 {linkarray string} -body {
testlinkarray create -r string 4 ::my(var)
catch {set ::my(var) x} msg
return $msg
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {can't set "::my(var)": linked variable is read-only}
test link-22.1 {linkarray binary} -setup {
set mylist [list]
} -body {
testlinkarray create binary 1 ::my(var)
set ::my(var) x
catch {set ::my(var) xy} msg
lappend mylist $msg
lappend mylist $::my(var)
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {{can't set "::my(var)": wrong size of binary value} x}
test link-22.2 {linkarray binary} -setup {
set mylist [list]
} -body {
testlinkarray create binary 4 ::my(var)
catch {set ::my(var) abc} msg
lappend mylist $msg
catch {set ::my(var) abcde} msg
lappend mylist $msg
set ::my(var) abcd
lappend mylist $::my(var)
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {{can't set "::my(var)": wrong size of binary value} {can't set "::my(var)": wrong size of binary value} abcd}
test link-22.3 {linkarray binary} -body {
testlinkarray create -r binary 4 ::my(var)
catch {set ::my(var) xyzv} msg
return $msg
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {can't set "::my(var)": linked variable is read-only}
catch {testlink set 0 0 0 - 0 0 0 0 0 0 0 0 0 0}
catch {testlink delete}
foreach i {int real bool string wide} {
unset -nocomplain $i
}
|
| ︙ | ︙ |
Changes to tests/list.test.
| ︙ | ︙ | |||
124 125 126 127 128 129 130 131 132 133 134 |
test list-3.1 {SetListFromAny and lrange/concat results} {
slowsort {fred julie alex carol bill annie}
} {alex annie bill carol fred julie}
test list-4.1 {Bug 3173086} {
string is list "{[list \\\\\}]}"
} 1
# cleanup
::tcltest::cleanupTests
return
| > > > > > > > > > > > > > > > > > > | 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 |
test list-3.1 {SetListFromAny and lrange/concat results} {
slowsort {fred julie alex carol bill annie}
} {alex annie bill carol fred julie}
test list-4.1 {Bug 3173086} {
string is list "{[list \\\\\}]}"
} 1
test list-4.2 {Bug 35a8f1c04a, check correct str-rep} {
set result {}
foreach i {
{#"} {#"""} {#"""""""""""""""}
"#\"{" "#\"\"\"{" "#\"\"\"\"\"\"\"\"\"\"\"\"\"\"\"\{"
"#\"}" "#\"\"\"}" "#\"\"\"\"\"\"\"\"\"\"\"\"\"\"\"\}"
} {
set list [list $i]
set list [string trim " $list "]
if {[llength $list] > 1 || $i ne [lindex $list 0]} {
lappend result "wrong string-representation of list by '$i', length: [llength $list], list: '$list'"
}
}
set result [join $result \n]
} {}
test list-4.3 {Bug 35a8f1c04a, check correct string length} {
string length [list #""]
} 5
# cleanup
::tcltest::cleanupTests
return
|
Added tests/lpop.test.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 |
# Commands covered: lpop
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
test lpop-1.1 {error conditions} -returnCodes error -body {
lpop no
} -result {can't read "no": no such variable}
test lpop-1.2 {error conditions} -returnCodes error -body {
lpop no 0
} -result {can't read "no": no such variable}
test lpop-1.3 {error conditions} -returnCodes error -body {
set no "x {}x"
lpop no
} -result {list element in braces followed by "x" instead of space}
test lpop-1.4 {error conditions} -returnCodes error -body {
set no "x y"
lpop no -1
} -result {list index out of range}
test lpop-1.5 {error conditions} -returnCodes error -body {
set no "x y z"
lpop no 3
} -result {list index out of range} ;#-errorCode {TCL OPERATION LPOP BADINDEX}
test lpop-1.6 {error conditions} -returnCodes error -body {
set no "x y"
lpop no end+1
} -result {list index out of range}
test lpop-1.7 {error conditions} -returnCodes error -body {
set no "x y"
lpop no {}
} -match glob -result {bad index *}
test lpop-1.8 {error conditions} -returnCodes error -body {
set no "x y"
lpop no 0 0 0 0 1
} -result {list index out of range}
test lpop-1.9 {error conditions} -returnCodes error -body {
set no "x y"
lpop no {1 0}
} -match glob -result {bad index *}
test lpop-2.1 {basic functionality} -body {
set l "x y z"
list [lpop l 0] $l
} -result {x {y z}}
test lpop-2.2 {basic functionality} -body {
set l "x y z"
list [lpop l 1] $l
} -result {y {x z}}
test lpop-2.3 {basic functionality} -body {
set l "x y z"
list [lpop l] $l
} -result {z {x y}}
test lpop-2.4 {basic functionality} -body {
set l "x y z"
set l2 $l
list [lpop l] $l $l2
} -result {z {x y} {x y z}}
test lpop-3.1 {nested} -body {
set l "x y"
set l2 $l
list [lpop l 0 0 0 0] $l $l2
} -result {x {{{{}}} y} {x y}}
test lpop-3.2 {nested} -body {
set l "{x y} {a b}"
list [lpop l 0 1] $l
} -result {y {x {a b}}}
test lpop-3.3 {nested} -body {
set l "{x y} {a b}"
list [lpop l 1 0] $l
} -result {a {{x y} b}}
test lpop-99.1 {performance} -constraints perf -body {
set l [lrepeat 10000 x]
set l2 $l
set t1 [time {
while {[llength $l] >= 2} {
lpop l end
}
}]
set l [lrepeat 30000 x]
set l2 $l
set t2 [time {
while {[llength $l] >= 2} {
lpop l end
}
}]
regexp {\d+} $t1 ms1
regexp {\d+} $t2 ms2
set ratio [expr {double($ms2)/$ms1}]
# Deleting from end should have linear performance
expr {$ratio > 4 ? $ratio : 4}
} -result {4}
test lpop-99.2 {performance} -constraints perf -body {
set l [lrepeat 10000 x]
set l2 $l
set t1 [time {
while {[llength $l] >= 2} {
lpop l 1
}
}]
set l [lrepeat 30000 x]
set l2 $l
set t2 [time {
while {[llength $l] >= 2} {
lpop l 1
}
}]
regexp {\d+} $t1 ms1
regexp {\d+} $t2 ms2
set ratio [expr {double($ms2)/$ms1}]
expr {$ratio > 10 ? $ratio : 10}
} -result {10}
# cleanup
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Changes to tests/lrange.test.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
test lrange-1.1 {range of list elements} {
lrange {a b c d} 1 2
} {b c}
test lrange-1.2 {range of list elements} {
lrange {a {bcd e {f g {}}} l14 l15 d} 1 1
} {{bcd e {f g {}}}}
| > > > > > > | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 |
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testpurebytesobj [llength [info commands testpurebytesobj]]
test lrange-1.1 {range of list elements} {
lrange {a b c d} 1 2
} {b c}
test lrange-1.2 {range of list elements} {
lrange {a {bcd e {f g {}}} l14 l15 d} 1 1
} {{bcd e {f g {}}}}
|
| ︙ | ︙ | |||
86 87 88 89 90 91 92 |
} {1 {unmatched open brace in list}}
test lrange-3.1 {Bug 3588366: end-offsets before start} {
apply {l {
lrange $l 0 end-5
}} {1 2 3 4 5}
} {}
| < > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 |
} {1 {unmatched open brace in list}}
test lrange-3.1 {Bug 3588366: end-offsets before start} {
apply {l {
lrange $l 0 end-5
}} {1 2 3 4 5}
} {}
test lrange-3.2 {compiled with static indices out of range, negative} {
list [lrange {a b c} -1 -2] [lrange {a b c} -2 -1] [lrange {a b c} -3 -2] [lrange {a b c} -2 -3]
} [lrepeat 4 {}]
test lrange-3.3 {compiled with calculated indices out of range, negative constant} {
list [lrange {a b c} 0-1 -1-1] [lrange {a b c} -2+0 0-1] [lrange {a b c} -2-1 -2+1] [lrange {a b c} -2+1 -2-1]
} [lrepeat 4 {}]
test lrange-3.4 {compiled with calculated indices out of range, after end} {
list [lrange {a b c} end+1 end+2] [lrange {a b c} end+2 end+1] [lrange {a b c} end+2 end+3] [lrange {a b c} end+3 end+2]
} [lrepeat 4 {}]
test lrange-3.5 {compiled with calculated indices, start out of range (negative)} {
list [lrange {a b c} -1 1] [lrange {a b c} -1+0 end-1] [lrange {a b c} -2 1] [lrange {a b c} -2+0 0+1]
} [lrepeat 4 {a b}]
test lrange-3.6 {compiled with calculated indices, end out of range (after end)} {
list [lrange {a b c} 1 end+1] [lrange {a b c} 1+0 2+1] [lrange {a b c} 1 end+1] [lrange {a b c} end-1 3+1]
} [lrepeat 4 {b c}]
test lrange-3.7a {compiled on empty not canonical list (with static and dynamic indices), regression test, bug [cc1e91552c]} {
list [lrange { } 0 1] [lrange [format %c 32] 0 1] [lrange [set a { }] 0 1] \
[lrange { } 0-1 end+1] [lrange [format %c 32] 0-1 end+1] [lrange $a 0-1 end+1]
} [lrepeat 6 {}]
test lrange-3.7b {not compiled on empty not canonical list (with static and dynamic indices), regression test, bug [cc1e91552c]} {
set cmd lrange
list [$cmd { } 0 1] [$cmd [format %c 32] 0 1] [$cmd [set a { }] 0 1] \
[$cmd { } 0-1 end+1] [$cmd [format %c 32] 0-1 end+1] [$cmd $a 0-1 end+1]
} [lrepeat 6 {}]
# following 4 tests could cause a segfault on empty non-lists with tclEmptyStringRep
# (as before the fix [58c46e74b931d3a1]):
test lrange-3.7a.2 {compiled on empty not list object, 2nd regression test, bug [cc1e91552c]} {
list [lrange {} 0 1] [lrange [lindex a -1] 0 1] [lrange [set a {}] 0 1] \
[lrange {} 0-1 end+1] [lrange [lindex a -1] 0-1 end+1] [lrange $a 0-1 end+1]
} [lrepeat 6 {}]
test lrange-3.7b.2 {not compiled on empty not list object, 2nd regression test, bug [cc1e91552c]} {
set cmd lrange
list [$cmd {} 0 1] [$cmd [lindex a -1] 0 1] [$cmd [set a {}] 0 1] \
[$cmd {} 0-1 end+1] [$cmd [lindex a -1] 0-1 end+1] [$cmd $a 0-1 end+1]
} [lrepeat 6 {}]
test lrange-3.7c.2 {compiled on empty pure bytes object, 2nd regression test, bug [cc1e91552c]} {
list [lrange [testpurebytesobj] 0 1] [lrange [testpurebytesobj { }] 0 1] [lrange [set a [testpurebytesobj {}]] 0 1] \
[lrange [testpurebytesobj] 0-1 end+1] [lrange [testpurebytesobj { }] 0-1 end+1] [lrange $a 0-1 end+1]
} [lrepeat 6 {}]
test lrange-3.7d.2 {not compiled on empty pure bytes object, 2nd regression test, bug [cc1e91552c]} {
set cmd lrange
list [$cmd [testpurebytesobj] 0 1] [$cmd [testpurebytesobj { }] 0 1] [$cmd [set a [testpurebytesobj {}]] 0 1] \
[$cmd [testpurebytesobj] 0-1 end+1] [$cmd [testpurebytesobj { }] 0-1 end+1] [$cmd $a 0-1 end+1]
} [lrepeat 6 {}]
test lrange-4.1 {lrange pure promise} -body {
set ll1 [list $tcl_version 2 3 4]
# Shared
set ll2 $ll1
# With string rep
string length $ll1
set rep1 [tcl::unsupported::representation $ll1]
# Get new pure object
set x [lrange $ll1 0 end]
set rep2 [tcl::unsupported::representation $x]
regexp {object pointer at (\S+)} $rep1 -> obj1
regexp {object pointer at (\S+)} $rep2 -> obj2
list $rep1 $rep2 [string equal $obj1 $obj2]
# Check for a new clean object
} -match glob -result {*value is *refcount of 3,*, string rep*value is*refcount of 2,* no string rep* 0}
test lrange-4.2 {lrange pure promise} -body {
set ll1 [list $tcl_version 2 3 4]
# Shared
set ll2 $ll1
# With string rep
string length $ll1
set rep1 [tcl::unsupported::representation $ll1]
# Get new pure object, not compiled
set x [[string cat l range] $ll1 0 end]
set rep2 [tcl::unsupported::representation $x]
regexp {object pointer at (\S+)} $rep1 -> obj1
regexp {object pointer at (\S+)} $rep2 -> obj2
list $rep1 $rep2 [string equal $obj1 $obj2]
# Check for a new clean object
} -match glob -result {*value is *refcount of 3,*, string rep*value is*refcount of 2,* no string rep* 0}
test lrange-4.3 {lrange pure promise} -body {
set ll1 [list $tcl_version 2 3 4]
# With string rep
string length $ll1
set rep1 [tcl::unsupported::representation $ll1]
# Get pure object, unshared
set ll2 [lrange $ll1[set ll1 {}] 0 end]
set rep2 [tcl::unsupported::representation $ll2]
regexp {object pointer at (\S+)} $rep1 -> obj1
regexp {object pointer at (\S+)} $rep2 -> obj2
list $rep1 $rep2 [string equal $obj1 $obj2]
# Internal optimisations should keep the same object
} -match glob -result {*value is *refcount of 2,*, string rep*value is*refcount of 2,* no string rep* 1}
test lrange-4.4 {lrange pure promise} -body {
set ll1 [list $tcl_version 2 3 4]
# With string rep
string length $ll1
set rep1 [tcl::unsupported::representation $ll1]
# Get pure object, unshared, not compiled
set ll2 [[string cat l range] $ll1[set ll1 {}] 0 end]
set rep2 [tcl::unsupported::representation $ll2]
regexp {object pointer at (\S+)} $rep1 -> obj1
regexp {object pointer at (\S+)} $rep2 -> obj2
list $rep1 $rep2 [string equal $obj1 $obj2]
# Internal optimisations should keep the same object
} -match glob -result {*value is *refcount of 2,*, string rep*value is*refcount of 2,* no string rep* 1}
# Testing for compiled vs non-compiled behaviour, and shared vs non-shared.
# Far too many variations to check with spelt-out tests.
# Note that this *just* checks whether the different versions are the same
# not whether any of them is correct.
apply {{} {
set lss {{} {a} {a b c} {a b c d}}
set idxs {-2 -1 0 1 2 3 end-3 end-2 end-1 end end+1 end+2}
set lrange lrange
foreach ls $lss {
foreach a $idxs {
foreach b $idxs {
# Shared, uncompiled
set ls2 $ls
set expected [list [catch {$lrange $ls $a $b} m] $m]
# Shared, compiled
set tester [list lrange $ls $a $b]
set script [list catch $tester m]
set script "list \[$script\] \$m"
test lrange-5.[incr n].1 {lrange shared compiled} \
[list apply [list {} $script]] $expected
# Unshared, uncompiled
set tester [string map [list %l [list $ls] %a $a %b $b] {
[string cat l range] [lrange %l 0 end] %a %b
}]
set script [list catch $tester m]
set script "list \[$script\] \$m"
test lrange-5.$n.2 {lrange unshared uncompiled} \
[list apply [list {} $script]] $expected
# Unshared, compiled
set tester [string map [list %l [list $ls] %a $a %b $b] {
lrange [lrange %l 0 end] %a %b
}]
set script [list catch $tester m]
set script "list \[$script\] \$m"
test lrange-5.$n.3 {lrange unshared compiled} \
[list apply [list {} $script]] $expected
}
}
}
}}
# cleanup
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Changes to tests/lreplace.test.
| ︙ | ︙ | |||
96 97 98 99 100 101 102 |
set foo {a b}
list [set foo [lreplace $foo end end]] \
[set foo [lreplace $foo end end]] \
[set foo [lreplace $foo end end]]
} {a {} {}}
test lreplace-1.27 {lreplace command} -body {
lreplace x 1 1
| | | | 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 |
set foo {a b}
list [set foo [lreplace $foo end end]] \
[set foo [lreplace $foo end end]] \
[set foo [lreplace $foo end end]]
} {a {} {}}
test lreplace-1.27 {lreplace command} -body {
lreplace x 1 1
} -result x
test lreplace-1.28 {lreplace command} -body {
lreplace x 1 1 y
} -result {x y}
test lreplace-1.29 {lreplace command} -body {
lreplace x 1 1 [error foo]
} -returnCodes 1 -result {foo}
test lreplace-1.30 {lreplace command} -body {
lreplace {not {}alist} 0 0 [error foo]
} -returnCodes 1 -result {foo}
|
| ︙ | ︙ | |||
124 125 126 127 128 129 130 |
list [catch {lreplace x 10 x} msg] $msg
} {1 {bad index "x": must be integer?[+-]integer? or end?[+-]integer?}}
test lreplace-2.5 {lreplace errors} {
list [catch {lreplace x 10 1x} msg] $msg
} {1 {bad index "1x": must be integer?[+-]integer? or end?[+-]integer?}}
test lreplace-2.6 {lreplace errors} {
list [catch {lreplace x 3 2} msg] $msg
| | | | 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 |
list [catch {lreplace x 10 x} msg] $msg
} {1 {bad index "x": must be integer?[+-]integer? or end?[+-]integer?}}
test lreplace-2.5 {lreplace errors} {
list [catch {lreplace x 10 1x} msg] $msg
} {1 {bad index "1x": must be integer?[+-]integer? or end?[+-]integer?}}
test lreplace-2.6 {lreplace errors} {
list [catch {lreplace x 3 2} msg] $msg
} {0 x}
test lreplace-2.7 {lreplace errors} {
list [catch {lreplace x 2 2} msg] $msg
} {0 x}
test lreplace-3.1 {lreplace won't modify shared argument objects} {
proc p {} {
lreplace "a b c" 1 1 "x y"
return "a b c"
}
p
|
| ︙ | ︙ |
Changes to tests/macOSXFCmd.test.
| ︙ | ︙ | |||
95 96 97 98 99 100 101 |
test macOSXFCmd-2.6 {MacOSXSetFileAttribute - hidden} {macosxFileAttr notRoot} {
catch {file delete -force -- foo.test}
close [open foo.test w]
list [catch {file attributes foo.test -hidden 1} msg] $msg \
[catch {file attributes foo.test -hidden} msg] $msg \
[file delete -force -- foo.test]
} {0 {} 0 1 {}}
| | | 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 |
test macOSXFCmd-2.6 {MacOSXSetFileAttribute - hidden} {macosxFileAttr notRoot} {
catch {file delete -force -- foo.test}
close [open foo.test w]
list [catch {file attributes foo.test -hidden 1} msg] $msg \
[catch {file attributes foo.test -hidden} msg] $msg \
[file delete -force -- foo.test]
} {0 {} 0 1 {}}
test macOSXFCmd-2.7 {MacOSXSetFileAttribute - rsrclength} {macosxFileAttr notRoot nonPortable} {
catch {file delete -force -- foo.test}
close [open foo.test w]
catch {
set f [open foo.test/..namedfork/rsrc w]
fconfigure $f -translation lf -eofchar {}
puts -nonewline $f "foo"
close $f
|
| ︙ | ︙ | |||
147 148 149 150 151 152 153 |
file attributes baz.test -creator FOOC -type FOOT
file attributes foo.test -creator FOOC
file attributes inv.test -hidden 1
file attributes inw.test -hidden 1 -type FOOT
file attributes dir.test -hidden 1
}
set res [list \
| | | | | | | | | | | | 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 |
file attributes baz.test -creator FOOC -type FOOT
file attributes foo.test -creator FOOC
file attributes inv.test -hidden 1
file attributes inw.test -hidden 1 -type FOOT
file attributes dir.test -hidden 1
}
set res [list \
[catch {lsort [glob *.test]} msg] $msg \
[catch {lsort [glob -types FOOT *.test]} msg] $msg \
[catch {lsort [glob -types {{macintosh type FOOT}} *.test]} msg] $msg \
[catch {lsort [glob -types FOOTT *.test]} msg] $msg \
[catch {lsort [glob -types {{macintosh type FOOTT}} *.test]} msg] $msg \
[catch {lsort [glob -types {{macintosh type {}}} *.test]} msg] $msg \
[catch {lsort [glob -types {{macintosh creator FOOC}} *.test]} msg] $msg \
[catch {lsort [glob -types {{macintosh creator FOOC} {macintosh type FOOT}} *.test]} msg] $msg \
[catch {lsort [glob -types hidden *.test]} msg] $msg \
[catch {lsort [glob -types {hidden FOOT} *.test]} msg] $msg \
]
cd ..
file delete -force globtest
set res
} [list \
0 {bar.test baz.test dir.test foo.test inv.test inw.test reg.test} \
0 {bar.test baz.test inw.test} 0 {bar.test baz.test inw.test} \
|
| ︙ | ︙ |
Changes to tests/main.test.
| ︙ | ︙ | |||
1206 1207 1208 1209 1210 1211 1212 |
file delete result
} -result "1\nExit MainLoop\n"
test Tcl_Main-8.13 {
Bug 1775878
} -constraints {
exec Tcltest
| < < | 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 |
file delete result
} -result "1\nExit MainLoop\n"
test Tcl_Main-8.13 {
Bug 1775878
} -constraints {
exec Tcltest
} -body {
exec [interpreter] << "testsetmainloop\nputs \\\npwd\ntestexitmainloop" >& result
set f [open result]
read $f
} -cleanup {
close $f
file delete result
|
| ︙ | ︙ |
Changes to tests/mathop.test.
| ︙ | ︙ | |||
1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 |
test mathop-25.2 { exp operator } {TestOp ** 0 } 0
test mathop-25.3 { exp operator } {TestOp ** 0 5} 0
test mathop-25.4 { exp operator } {TestOp ** 7.5 } 7.5
test mathop-25.5 { exp operator } {TestOp ** 1 5} 1
test mathop-25.6 { exp operator } {TestOp ** 5 1} 5
test mathop-25.7 { exp operator } {TestOp ** 4 3 2 1} 262144
test mathop-25.8 { exp operator } {TestOp ** 5.5 4} 915.0625
test mathop-25.9 { exp operator } {TestOp ** 16 3.5} 16384.0
test mathop-25.10 { exp operator } {TestOp ** 3.5 0} 1.0
test mathop-25.11 { exp operator } {TestOp ** 378 0} 1
test mathop-25.12 { exp operator } {TestOp ** 7.8 1} 7.8
test mathop-25.13 { exp operator } {TestOp ** 748 1} 748
test mathop-25.14 { exp operator } {TestOp ** 1.6 -1} 0.625
test mathop-25.15 { exp operator } {TestOp ** 683 -1} 0
test mathop-25.16 { exp operator } {TestOp ** 1 -1} 1
test mathop-25.17 { exp operator } {TestOp ** -1 -1} -1
test mathop-25.18 { exp operator } {TestOp ** -1 -2} 1
test mathop-25.19 { exp operator } {TestOp ** -1 3} -1
test mathop-25.20 { exp operator } {TestOp ** -1 4} 1
test mathop-25.21 { exp operator } {TestOp ** 2 63} 9223372036854775808
| > > > > | > > > > > > > > > > > > > > > > > > > > > > | | 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 |
test mathop-25.2 { exp operator } {TestOp ** 0 } 0
test mathop-25.3 { exp operator } {TestOp ** 0 5} 0
test mathop-25.4 { exp operator } {TestOp ** 7.5 } 7.5
test mathop-25.5 { exp operator } {TestOp ** 1 5} 1
test mathop-25.6 { exp operator } {TestOp ** 5 1} 5
test mathop-25.7 { exp operator } {TestOp ** 4 3 2 1} 262144
test mathop-25.8 { exp operator } {TestOp ** 5.5 4} 915.0625
test mathop-25.8a { exp operator } {TestOp ** 4.0 -1} 0.25
test mathop-25.8b { exp operator } {TestOp ** 2.0 -2} 0.25
test mathop-25.9 { exp operator } {TestOp ** 16 3.5} 16384.0
test mathop-25.10 { exp operator } {TestOp ** 3.5 0} 1.0
test mathop-25.11 { exp operator } {TestOp ** 378 0} 1
test mathop-25.12 { exp operator } {TestOp ** 7.8 1} 7.8
test mathop-25.13 { exp operator } {TestOp ** 748 1} 748
test mathop-25.14 { exp operator } {TestOp ** 1.6 -1} 0.625
test mathop-25.15 { exp operator } {TestOp ** 683 -1} 0
test mathop-25.16 { exp operator } {TestOp ** 1 -1} 1
test mathop-25.17 { exp operator } {TestOp ** -1 -1} -1
test mathop-25.18 { exp operator } {TestOp ** -1 -2} 1
test mathop-25.19 { exp operator } {TestOp ** -1 3} -1
test mathop-25.20 { exp operator } {TestOp ** -1 4} 1
test mathop-25.21 { exp operator } {TestOp ** 2 63} 9223372036854775808
test mathop-25.22 { exp operator } {TestOp ** 2 256} 115792089237316195423570985008687907853269984665640564039457584007913129639936
set big 83756485763458746358734658473567847567473
test mathop-25.23 { exp operator } {TestOp ** $big 2} 7015148907444467657897585474493757781161998914521537835809623408157343003287605729
test mathop-25.24 { exp operator } {TestOp ** $big 0} 1
test mathop-25.25 { exp operator } {TestOp ** $big 1} $big
test mathop-25.26 { exp operator } {TestOp ** $big -1} 0
test mathop-25.27 { exp operator } {TestOp ** $big -2} 0
test mathop-25.28 { exp operator } {TestOp ** $big -$big} 0
test mathop-25.29 { exp operator } {expr {[set res [TestOp ** $big -1.0]] > 0 && $res < 1.2e-41}} 1
test mathop-25.30 { exp operator } {expr {[set res [TestOp ** $big -1e-18]] > 0 && $res < 1}} 1
test mathop-25.31 { exp operator } {expr {[set res [TestOp ** -$big -1.0]] > -1 && $res < 0}} 1
test mathop-25.32 { exp operator } {expr {[set res [TestOp ** -$big -2.0]] > 0 && $res < 1}} 1
test mathop-25.33 { exp operator } {expr {[set res [TestOp ** -$big -3.0]] > -1 && $res < 0}} 1
test mathop-25.34 { exp operator } {TestOp ** $big -1e-30} 1.0
test mathop-25.35 { exp operator } {TestOp ** $big -1e+30} 0.0
test mathop-25.36 { exp operator } {TestOp ** 0 $big} 0
test mathop-25.37 { exp operator } {TestOp ** 1 $big} 1
test mathop-25.38 { exp operator } {TestOp ** -1 $big} -1
test mathop-25.39 { exp operator } {TestOp ** -1 [expr {$big+1}]} 1
test mathop-25.40 { exp operator (small exponent power helper and its boundaries) } {
set pwr 0
set res 1
while {[incr pwr] <= 17 && [set i [TestOp ** 15 $pwr]] == [set res [expr {$res * 15}]]} {}
list [incr pwr -1] $res
} {17 98526125335693359375}
test mathop-25.41 { exp operator errors } {
set res {}
set exp {}
set huge [string repeat 145782 1000]
set big 12135435435354435435342423948763867876
set wide 12345678912345
set small 2
|
| ︙ | ︙ |
Changes to tests/msgcat.test.
| ︙ | ︙ | |||
689 690 691 692 693 694 695 |
removeFile l1.msg $msgdir1
removeDirectory msgdir1
set msgdir2 [makeDirectory msgdir2]
set msgdir3 [makeDirectory msgdir3]
makeFile "::msgcat::mcflset k2 v2 ; ::msgcat::mcload [list $msgdir3]"\
l2.msg $msgdir2
| | | | | | 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 |
removeFile l1.msg $msgdir1
removeDirectory msgdir1
set msgdir2 [makeDirectory msgdir2]
set msgdir3 [makeDirectory msgdir3]
makeFile "::msgcat::mcflset k2 v2 ; ::msgcat::mcload [list $msgdir3]"\
l2.msg $msgdir2
makeFile {::msgcat::mcflset k3 v3 ; ::msgcat::mcflmset {k4 v4 k5 v5}} l2.msg $msgdir3
# chained mcload
test msgcat-8.2 {mcflset/mcflmset} -setup {
variable locale [mclocale]
mclocale l2
mcload $msgdir2
} -cleanup {
mclocale $locale
} -body {
return [mc k2][mc k3]--[mc k4][mc k5]
} -result v2v3--v4v5
removeFile l2.msg $msgdir2
removeDirectory msgdir2
removeDirectory msgdir3
# Tests msgcat-9.*: [mcexists]
|
| ︙ | ︙ | |||
995 996 997 998 999 1000 1001 |
mcforgetpackage
} -body {
mclocale foo
mcpackagelocale preferences
mcpackagelocale isset
} -result {0}
| | | 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 |
mcforgetpackage
} -body {
mclocale foo
mcpackagelocale preferences
mcpackagelocale isset
} -result {0}
# Tests msgcat-13.*: [mcpackageconfig subcmds]
test msgcat-13.1 {mcpackageconfig no subcommand} -body {
mcpackageconfig
} -returnCodes 1\
-result {wrong # args: should be "mcpackageconfig subcommand option ?value?"}
|
| ︙ | ︙ | |||
1149 1150 1151 1152 1153 1154 1155 |
mclocale foo_bar
mc k1
} -returnCodes 1\
-result {fail}
# Tests msgcat-15.*: tcloo coverage
| | | 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 |
mclocale foo_bar
mc k1
} -returnCodes 1\
-result {fail}
# Tests msgcat-15.*: tcloo coverage
# There are 4 use-cases, where 3 must be tested now:
# - namespace defined, in class definition, class defined oo, classless
test msgcat-15.1 {mc in class setup} -setup {
# full namespace is ::msgcat::test:bar
namespace eval bar {
::msgcat::mcset foo_BAR con2 con2bar
|
| ︙ | ︙ | |||
1206 1207 1208 1209 1210 1211 1212 |
} -cleanup {
mclocale $locale
namespace eval bar {::msgcat::mcforgetpackage}
namespace delete bar
} -body {
bar::ObjCur method1
} -result con2bar
| | | 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 |
} -cleanup {
mclocale $locale
namespace eval bar {::msgcat::mcforgetpackage}
namespace delete bar
} -body {
bar::ObjCur method1
} -result con2bar
test msgcat-15.4 {mc in classless object with explicite namespace eval}\
-setup {
# full namespace is ::msgcat::test:bar
namespace eval bar {
::msgcat::mcset foo_BAR con2 con2bar
oo::object create ObjCur
oo::objdefine ObjCur method method1 {} {
|
| ︙ | ︙ | |||
1232 1233 1234 1235 1236 1237 1238 |
mclocale $locale
namespace eval bar {::msgcat::mcforgetpackage}
namespace eval baz {::msgcat::mcforgetpackage}
namespace delete bar baz
} -body {
bar::ObjCur method1
} -result con2baz
| | | 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 |
mclocale $locale
namespace eval bar {::msgcat::mcforgetpackage}
namespace eval baz {::msgcat::mcforgetpackage}
namespace delete bar baz
} -body {
bar::ObjCur method1
} -result con2baz
# Test msgcat-16.*: command mcpackagenamespaceget
test msgcat-16.1 {mcpackagenamespaceget in namespace procedure} -body {
namespace eval baz {msgcat::mcpackagenamespaceget}
} -result ::msgcat::test::baz
test msgcat-16.2 {mcpackagenamespaceget in class setup} -setup {
|
| ︙ | ︙ | |||
1294 1295 1296 1297 1298 1299 1300 |
namespace delete bar baz
} -body {
bar::ObjCur method1
} -result ::msgcat::test::baz
# Test msgcat-17.*: mcn command
| | | | | | | | | | | | | | | | | | 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 |
namespace delete bar baz
} -body {
bar::ObjCur method1
} -result ::msgcat::test::baz
# Test msgcat-17.*: mcn command
test msgcat-17.1 {mcn no parameters} -body {
mcn
} -returnCodes 1\
-result {wrong # args: should be "mcn ns src ?arg ...?"}
test msgcat-17.2 {mcn} -setup {
namespace eval bar {::msgcat::mcset foo_BAR con1 con1bar}
variable locale [mclocale]
mclocale foo_BAR
} -cleanup {
mclocale $locale
} -body {
::msgcat::mcn [namespace current]::bar con1
} -result con1bar
interp bgerror {} $bgerrorsaved
# Tests msgcat-18.*: [mcutil]
test msgcat-18.1 {mcutil - no argument} -body {
mcutil
} -returnCodes 1\
-result {wrong # args: should be "mcutil subcommand ?arg ...?"}
test msgcat-18.2 {mcutil - wrong argument} -body {
mcutil junk
} -returnCodes 1\
-result {unknown subcommand "junk": must be getpreferences, or getsystemlocale}
test msgcat-18.3 {mcutil - partial argument} -body {
mcutil getsystem
} -returnCodes 1\
-result {unknown subcommand "getsystem": must be getpreferences, or getsystemlocale}
test msgcat-18.4 {mcutil getpreferences - no argument} -body {
mcutil getpreferences
} -returnCodes 1\
-result {wrong # args: should be "mcutil getpreferences locale"}
test msgcat-18.5 {mcutil getpreferences - DE_de} -body {
mcutil getpreferences DE_de
} -result {de_de de {}}
test msgcat-18.6 {mcutil getsystemlocale - wrong argument} -body {
mcutil getsystemlocale DE_de
} -returnCodes 1\
-result {wrong # args: should be "mcutil getsystemlocale"}
# The result is system dependent
# So just test if it runs
# The environment variable version was test with test 0.x
test msgcat-18.7 {mcutil getsystemlocale} -body {
mcutil getsystemlocale
set ok ok
} -result {ok}
cleanupTests
}
namespace delete ::msgcat::test
return
# Local Variables:
# mode: tcl
# End:
|
Changes to tests/namespace.test.
| ︙ | ︙ | |||
201 202 203 204 205 206 207 |
namespace ensemble create
}
trace add command ns1 delete {
namespace delete ns1
}
} -body {
| | | 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 |
namespace ensemble create
}
trace add command ns1 delete {
namespace delete ns1
}
} -body {
# No segmentation fault given --enable-symbols=mem.
namespace delete ns1
} -result {}
test namespace-8.1 {TclTeardownNamespace, delete global namespace} {
catch {interp delete test_interp}
interp create test_interp
interp eval test_interp {
|
| ︙ | ︙ |
Changes to tests/obj.test.
| ︙ | ︙ | |||
16 17 18 19 20 21 22 |
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testobj [llength [info commands testobj]]
| | | | 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 |
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testobj [llength [info commands testobj]]
testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}]
testConstraint wideIs64bit [expr {wide(0x8000000000000000) < 0}]
test obj-1.1 {Tcl_AppendAllObjTypes, and InitTypeTable, Tcl_RegisterObjType} testobj {
set r 1
foreach {t} {
bytearray
bytecode
cmdName
|
| ︙ | ︙ | |||
472 473 474 475 476 477 478 |
test obj-26.1 {UpdateStringOfInt} testobj {
set result ""
lappend result [testintobj set 1 512]
lappend result [testintobj mult10 1]
lappend result [testintobj get 1] ;# must update string rep
} {512 5120 5120}
| | | | | | | | | | | | | | | < | | | | | | | | 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 |
test obj-26.1 {UpdateStringOfInt} testobj {
set result ""
lappend result [testintobj set 1 512]
lappend result [testintobj mult10 1]
lappend result [testintobj get 1] ;# must update string rep
} {512 5120 5120}
test obj-27.1 {Tcl_NewWideObj} testobj {
set result ""
lappend result [testobj freeallvars]
testintobj setmax 1
lappend result [testintobj ismax 1]
lappend result [testobj type 1]
lappend result [testobj refcount 1]
} {{} 1 int 1}
test obj-28.1 {Tcl_SetLongObj, existing "empty string" object} testobj {
set result ""
lappend result [testobj freeallvars]
lappend result [testobj newobj 1]
lappend result [testintobj setint 1 77] ;# makes existing obj int
lappend result [testobj type 1]
lappend result [testobj refcount 1]
} {{} {} 77 int 2}
test obj-28.2 {Tcl_SetLongObj, existing non-"empty string" object} testobj {
set result ""
lappend result [testobj freeallvars]
lappend result [testdoubleobj set 1 12.34]
lappend result [testintobj setint 1 77] ;# makes existing obj int
lappend result [testobj type 1]
lappend result [testobj refcount 1]
} {{} 12.34 77 int 2}
test obj-29.1 {Tcl_GetWideIntFromObj, existing int object} testobj {
set result ""
lappend result [testintobj setint 1 22]
lappend result [testintobj mult10 1] ;# gets existingint rep
} {22 220}
test obj-29.2 {Tcl_GetWideIntFromObj, convert to int} testobj {
set result ""
lappend result [testintobj setint 1 477]
lappend result [testintobj div10 1] ;# must convert to bool
lappend result [testobj type 1]
} {477 47 int}
test obj-29.3 {Tcl_GetWideIntFromObj, error converting to int} testobj {
set result ""
lappend result [teststringobj set 1 abc]
lappend result [catch {testintobj ismax 1} msg] ;# cvts to long int
lappend result $msg
} {abc 1 {expected integer but got "abc"}}
test obj-29.4 {Tcl_GetWideIntFromObj, error converting from "empty string"} testobj {
set result ""
lappend result [testobj newobj 1]
lappend result [catch {testintobj ismax 1} msg] ;# cvts to long int
lappend result $msg
} {{} 1 {expected integer but got ""}}
test obj-30.1 {Ref counting and object deletion, simple types} testobj {
set result ""
lappend result [testobj freeallvars]
lappend result [testintobj set 1 1024]
lappend result [testobj assign 1 2] ;# vars 1 and 2 share the int obj
lappend result [testobj type 2]
lappend result [testobj refcount 1]
lappend result [testobj refcount 2]
lappend result [testbooleanobj set 2 0] ;# must copy on write, now 2 objs
lappend result [testobj type 2]
lappend result [testobj refcount 1]
lappend result [testobj refcount 2]
} {{} 1024 1024 int 4 4 0 int 3 2}
test obj-32.1 {freeing very large object trees} {
set x {}
for {set i 0} {$i<100000} {incr i} {
set x [list $x {}]
}
unset x
} {}
test obj-33.1 {integer overflow on input} {longIs32bit wideIs64bit} {
set x 0x8000; append x 0000
list [string is integer $x] [expr { wide($x) }]
} {1 2147483648}
test obj-33.2 {integer overflow on input} {longIs32bit wideIs64bit} {
set x 0xffff; append x ffff
list [string is integer $x] [expr { wide($x) }]
} {1 4294967295}
test obj-33.3 {integer overflow on input} {
set x 0x10000; append x 0000
list [string is integer $x] [expr { wide($x) }]
} {1 4294967296}
test obj-33.4 {integer overflow on input} {longIs32bit wideIs64bit} {
set x -0x8000; append x 0000
list [string is integer $x] [expr { wide($x) }]
} {1 -2147483648}
test obj-33.5 {integer overflow on input} {longIs32bit wideIs64bit} {
set x -0x8000; append x 0001
list [string is integer $x] [expr { wide($x) }]
} {1 -2147483649}
test obj-33.6 {integer overflow on input} {longIs32bit wideIs64bit} {
set x -0xffff; append x ffff
list [string is integer $x] [expr { wide($x) }]
} {1 -4294967295}
test obj-33.7 {integer overflow on input} {
set x -0x10000; append x 0000
list [string is integer $x] [expr { wide($x) }]
} {1 -4294967296}
test obj-34.1 {mp_iseven} testobj {
set result ""
lappend result [testbignumobj set 1 0]
lappend result [testbignumobj iseven 1] ;
lappend result [testobj type 1]
} {0 1 int}
|
| ︙ | ︙ |
Changes to tests/oo.test.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 |
package require TclOO 1.0.3
package require tcltest 2
if {"::tcltest" in [namespace children]} {
namespace import -force ::tcltest::*
}
| < < | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 |
package require TclOO 1.0.3
package require tcltest 2
if {"::tcltest" in [namespace children]} {
namespace import -force ::tcltest::*
}
# The foundational objects oo::object and oo::class are sensitive to reference
# counting errors and are deallocated only when an interp is deleted, so in
# this test suite, interp creation and interp deletion are often used in
# leaktests in order to leverage this sensitivity.
testConstraint memory [llength [info commands memory]]
if {[testConstraint memory]} {
proc getbytes {} {
set lines [split [memory info] \n]
return [lindex $lines 3 3]
}
|
| ︙ | ︙ | |||
127 128 129 130 131 132 133 |
}
}]
lappend result [foo bar a b c]
lappend result [foo destroy] [info commands foo]
} {::foo {} a b c 3 {} {}}
test oo-1.2 {basic test of OO functionality: no classes} -body {
oo::define oo::object method missingArgs
| | | | 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 |
}
}]
lappend result [foo bar a b c]
lappend result [foo destroy] [info commands foo]
} {::foo {} a b c 3 {} {}}
test oo-1.2 {basic test of OO functionality: no classes} -body {
oo::define oo::object method missingArgs
} -returnCodes 1 -result "wrong # args: should be \"oo::define oo::object method name ?option? args body\""
test oo-1.3 {basic test of OO functionality: no classes} {
catch {oo::define oo::object method missingArgs}
set errorInfo
} "wrong # args: should be \"oo::define oo::object method name ?option? args body\"
while executing
\"oo::define oo::object method missingArgs\""
test oo-1.4 {basic test of OO functionality} -body {
oo::object create {}
} -returnCodes 1 -result {object name must not be empty}
test oo-1.4.1 {fully-qualified nested name} -body {
oo::object create ::one::two::three
|
| ︙ | ︙ | |||
327 328 329 330 331 332 333 334 |
obj destroy
info commands ::AGlobalName
} -result {}
test oo-1.21 {basic test of OO functionality: default relations} -setup {
set fresh [interp create]
} -body {
lmap x [$fresh eval {
foreach cmd {instances subclasses mixins superclass} {
| > | | | | | | | 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 |
obj destroy
info commands ::AGlobalName
} -result {}
test oo-1.21 {basic test of OO functionality: default relations} -setup {
set fresh [interp create]
} -body {
lmap x [$fresh eval {
set initials {::oo::object ::oo::class ::oo::Slot}
foreach cmd {instances subclasses mixins superclass} {
foreach initial $initials {
lappend x [info class $cmd $initial]
}
}
foreach initial $initials {
lappend x [info object class $initial]
}
return $x
}] {lsort [lsearch -all -not -inline $x *::delegate]}
} -cleanup {
interp delete $fresh
} -result {{} {::oo::Slot ::oo::abstract ::oo::class ::oo::object ::oo::singleton} {::oo::define::filter ::oo::define::mixin ::oo::define::superclass ::oo::define::variable ::oo::objdefine::filter ::oo::objdefine::mixin ::oo::objdefine::variable} {::oo::Slot ::oo::class} {::oo::abstract ::oo::singleton} {} {} {} {} {} ::oo::object ::oo::object ::oo::class ::oo::class ::oo::class}
test oo-2.1 {basic test of OO functionality: constructor} -setup {
# This is a bit complex because it needs to run in a sub-interp as
# we're modifying the root object class's constructor
interp create subinterp
subinterp eval {
package require TclOO
|
| ︙ | ︙ | |||
776 777 778 779 780 781 782 783 784 785 786 787 788 789 |
unexport foo
method foo {} {return ok}
}
[testClass new] foo
} -cleanup {
testClass destroy
} -result ok
test oo-5.1 {OO: manipulation of classes as objects} -setup {
set obj [oo::object new]
} -body {
oo::objdefine oo::object method foo {} { return "in object" }
catch {$obj foo} result
list [catch {$obj foo} result] $result [oo::object foo]
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 |
unexport foo
method foo {} {return ok}
}
[testClass new] foo
} -cleanup {
testClass destroy
} -result ok
test oo-4.7 {basic test of OO functionality: method -export flag} -setup {
set o [oo::object new]
unset -nocomplain result
} -body {
oo::objdefine $o {
method Foo {} {
lappend ::result Foo
return foo
}
method Bar -export {} {
lappend ::result Bar
return bar
}
}
lappend result [catch {$o Foo} msg] $msg
lappend result [$o Bar]
} -cleanup {
$o destroy
} -result {1 {unknown method "Foo": must be Bar or destroy} Bar bar}
test oo-4.8 {basic test of OO functionality: method -unexport flag} -setup {
set o [oo::object new]
unset -nocomplain result
} -body {
oo::objdefine $o {
method foo {} {
lappend ::result foo
return Foo
}
method bar -unexport {} {
lappend ::result bar
return Bar
}
}
lappend result [$o foo]
lappend result [catch {$o bar} msg] $msg
} -cleanup {
$o destroy
} -result {foo Foo 1 {unknown method "bar": must be destroy or foo}}
test oo-4.9 {basic test of OO functionality: method -private flag} -setup {
set o [oo::object new]
unset -nocomplain result
} -body {
oo::objdefine $o {
method foo {} {
lappend ::result foo
return Foo
}
method bar -private {} {
lappend ::result bar
return Bar
}
export eval
method gorp {} {
my bar
}
}
lappend result [$o foo]
lappend result [catch {$o bar} msg] $msg
lappend result [catch {$o eval my bar} msg] $msg
lappend result [$o gorp]
} -cleanup {
$o destroy
} -result {foo Foo 1 {unknown method "bar": must be destroy, eval, foo or gorp} 1 {unknown method "bar": must be <cloned>, destroy, eval, foo, gorp, unknown, variable or varname} bar Bar}
test oo-4.10 {basic test of OO functionality: method flag parsing} -setup {
set o [oo::object new]
} -body {
oo::objdefine $o method foo -gorp xyz {return Foo}
} -returnCodes error -cleanup {
$o destroy
} -result {bad export flag "-gorp": must be -export, -private, or -unexport}
test oo-5.1 {OO: manipulation of classes as objects} -setup {
set obj [oo::object new]
} -body {
oo::objdefine oo::object method foo {} { return "in object" }
catch {$obj foo} result
list [catch {$obj foo} result] $result [oo::object foo]
|
| ︙ | ︙ | |||
1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 |
oo::define B deletemethod b
lappend result [C a] [C b] [C c] -
oo::define B renamemethod a b
lappend result [C a] [C b] [C c] -
oo::define B deletemethod b c
lappend result [C a] [C b] [C c]
} -result {A.a,B.a A.b,B.b A.c,B.c - A.a,B.a A.b A.c,B.c - A.a A.b,B.a A.c,B.c - A.a A.b A.c}
test oo-11.1 {OO: cleanup} {
oo::object create foo
set result [list [catch {oo::object create foo} msg] $msg]
lappend result [foo destroy] [oo::object create foo] [foo destroy]
} {1 {can't create object "foo": command already exists with that name} {} ::foo {}}
test oo-11.2 {OO: cleanup} {
| > > > > > > > > > > > > > > > > > > > > > > > > | 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 |
oo::define B deletemethod b
lappend result [C a] [C b] [C c] -
oo::define B renamemethod a b
lappend result [C a] [C b] [C c] -
oo::define B deletemethod b c
lappend result [C a] [C b] [C c]
} -result {A.a,B.a A.b,B.b A.c,B.c - A.a,B.a A.b A.c,B.c - A.a A.b,B.a A.c,B.c - A.a A.b A.c}
test oo-10.4 {OO: invoke and modify} -setup {
oo::class create A {
method a {} {return A.a}
method b {} {return A.b}
method c {} {return A.c}
}
A create B
oo::objdefine B {
method a {} {return [next],B.a}
method b {} {return [next],B.b}
method c {} {return [next],B.c}
}
set result {}
} -cleanup {
A destroy
} -body {
lappend result [B a] [B b] [B c] -
oo::objdefine B deletemethod b
lappend result [B a] [B b] [B c] -
oo::objdefine B renamemethod a b
lappend result [B a] [B b] [B c] -
oo::objdefine B deletemethod b c
lappend result [B a] [B b] [B c]
} -result {A.a,B.a A.b,B.b A.c,B.c - A.a,B.a A.b A.c,B.c - A.a A.b,B.a A.c,B.c - A.a A.b A.c}
test oo-11.1 {OO: cleanup} {
oo::object create foo
set result [list [catch {oo::object create foo} msg] $msg]
lappend result [foo destroy] [oo::object create foo] [foo destroy]
} {1 {can't create object "foo": command already exists with that name} {} ::foo {}}
test oo-11.2 {OO: cleanup} {
|
| ︙ | ︙ | |||
1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 |
}
oo::class create bar
[foo new] m
} -cleanup {
foo destroy
bar destroy
} -result {::foo ::foo ::foo ::bar}
# todo: changing a class subtype (metaclass) to another class subtype
test oo-14.1 {OO: mixins} {
oo::class create Aclass
oo::define Aclass method bar {} {lappend ::result "[self object] in bar"}
oo::class create Bclass
oo::define Bclass method boo {} {lappend ::result "[self object] in boo"}
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 |
}
oo::class create bar
[foo new] m
} -cleanup {
foo destroy
bar destroy
} -result {::foo ::foo ::foo ::bar}
test oo-13.5 {OO: changing an object's class: non-class to class} -setup {
oo::object create fooObj
} -body {
oo::objdefine fooObj {
class oo::class
}
oo::define fooObj {
method x {} {expr 1+2+3}
}
[fooObj new] x
} -cleanup {
fooObj destroy
} -result 6
test oo-13.6 {OO: changing an object's class: class to non-class} -setup {
oo::class create foo
unset -nocomplain ::result
} -body {
set result dangling
oo::define foo {
method x {} {expr 1+2+3}
}
oo::class create boo {
superclass foo
destructor {set ::result "ok"}
}
boo new
foo create bar
oo::objdefine foo {
class oo::object
}
list $result [catch {bar x} msg] $msg
} -cleanup {
catch {bar destroy}
foo destroy
} -result {ok 1 {invalid command name "bar"}}
test oo-13.7 {OO: changing an object's class} -setup {
oo::class create foo
oo::class create bar
unset -nocomplain result
} -body {
oo::define bar method x {} {return ok}
oo::define foo {
method x {} {expr 1+2+3}
self mixin foo
}
lappend result [foo x]
oo::objdefine foo class bar
lappend result [foo x]
} -cleanup {
foo destroy
bar destroy
} -result {6 ok}
test oo-13.8 {OO: changing an object's class to itself} -setup {
oo::class create foo
} -body {
oo::define foo {
method x {} {expr 1+2+3}
}
oo::objdefine foo class foo
} -cleanup {
foo destroy
} -returnCodes error -result {may not change classes into an instance of themselves}
test oo-13.9 {OO: changing an object's class: roots are special} -setup {
set i [interp create]
} -body {
$i eval {
oo::objdefine oo::object {
class oo::class
}
}
} -cleanup {
interp delete $i
} -returnCodes error -result {may not modify the class of the root object class}
test oo-13.10 {OO: changing an object's class: roots are special} -setup {
set i [interp create]
} -body {
$i eval {
oo::objdefine oo::class {
class oo::object
}
}
} -cleanup {
interp delete $i
} -returnCodes error -result {may not modify the class of the class of classes}
test oo-13.11 {OO: changing an object's class in a tricky place} -setup {
oo::class create cls
unset -nocomplain result
} -body {
set result gorp
list [catch {
oo::define cls {
method x {} {return}
self class oo::object
::set ::result ok
method y {} {return}; # I'm sorry, Dave. I'm afraid I can't do that.
}
} msg] $msg $result
} -cleanup {
cls destroy
} -result {1 {attempt to misuse API} ok}
# todo: changing a class subtype (metaclass) to another class subtype
test oo-14.1 {OO: mixins} {
oo::class create Aclass
oo::define Aclass method bar {} {lappend ::result "[self object] in bar"}
oo::class create Bclass
oo::define Bclass method boo {} {lappend ::result "[self object] in boo"}
|
| ︙ | ︙ | |||
2149 2150 2151 2152 2153 2154 2155 |
oo::class create Cls {}
} -body {
oo::copy Cls Cls2 ::dupens
return done
} -cleanup {
Cls destroy
Cls2 destroy
| | | 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 |
oo::class create Cls {}
} -body {
oo::copy Cls Cls2 ::dupens
return done
} -cleanup {
Cls destroy
Cls2 destroy
} -result done
test oo-15.13.2 {OO: object cloning with target NS} -setup {
oo::class create Super
oo::class create Cls {superclass Super}
} -body {
list [namespace exist ::dupens] [oo::copy Cls Cls2 ::dupens] [namespace exist ::dupens]
} -cleanup {
Super destroy
|
| ︙ | ︙ | |||
2198 2199 2200 2201 2202 2203 2204 |
while executing
\"info object\""
test oo-16.2 {OO: object introspection} -body {
info object class NOTANOBJECT
} -returnCodes 1 -result {NOTANOBJECT does not refer to an object}
test oo-16.3 {OO: object introspection} -body {
info object gorp oo::object
| | | 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 |
while executing
\"info object\""
test oo-16.2 {OO: object introspection} -body {
info object class NOTANOBJECT
} -returnCodes 1 -result {NOTANOBJECT does not refer to an object}
test oo-16.3 {OO: object introspection} -body {
info object gorp oo::object
} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be call, class, creationid, definition, filters, forward, isa, methods, methodtype, mixins, namespace, variables, or vars}
test oo-16.4 {OO: object introspection} -setup {
oo::class create meta { superclass oo::class }
[meta create instance1] create instance2
} -body {
list [list [info object class oo::object] \
[info object class oo::class] \
[info object class meta] \
|
| ︙ | ︙ | |||
2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 |
[info object isa mixin list NOTANOBJECT] \
[info object isa mixin NOTANOBJECT list] \
[info object isa mixin oo::object list] \
[info object isa mixin list oo::object]]
} -cleanup {
meta destroy
} -result {class {0 0} meta {0 0 0} type {0 0 0 0 0 0} mix {0 0 0 0 0 0}}
test oo-17.1 {OO: class introspection} -body {
info class
} -returnCodes 1 -result "wrong \# args: should be \"info class subcommand ?arg ...?\""
test oo-17.1.1 {OO: class introspection} -body {
catch {info class} m o
dict get $o -errorinfo
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 |
[info object isa mixin list NOTANOBJECT] \
[info object isa mixin NOTANOBJECT list] \
[info object isa mixin oo::object list] \
[info object isa mixin list oo::object]]
} -cleanup {
meta destroy
} -result {class {0 0} meta {0 0 0} type {0 0 0 0 0 0} mix {0 0 0 0 0 0}}
test oo-16.15 {OO: object introspection: creationid #500} -setup {
oo::class create cls
} -body {
info object creationid [cls new]
} -cleanup {
cls destroy
} -result {^\d+$} -match regexp
test oo-16.16 {OO: object introspection: creationid #500} -setup {
oo::class create cls
} -body {
set obj [cls new]
set id [info object creationid $obj]
rename $obj gorp
set id2 [info object creationid gorp]
list $id $id2
} -cleanup {
cls destroy
} -result {^(\d+) \1$} -match regexp
test oo-16.17 {OO: object introspection: creationid #500} -body {
info object creationid nosuchobject
} -returnCodes error -result {nosuchobject does not refer to an object}
test oo-16.18 {OO: object introspection: creationid #500} -body {
info object creationid
} -returnCodes error -result {wrong # args: should be "info object creationid objName"}
test oo-16.18.1 {OO: object introspection: creationid #500} -body {
info object creationid oo::object gorp
} -returnCodes error -result {wrong # args: should be "info object creationid objName"}
test oo-16.19 {OO: object introspection: creationid #500} -setup {
oo::class create cls
} -body {
set id1 [info object creationid [set o1 [cls new]]]
set id2 [info object creationid [set o2 [cls new]]]
if {$id1 == $id2} {
format "objects %s and %s have same creation id: %d" $o1 $o2 $id1
} else {
string cat not-equal
}
} -cleanup {
cls destroy
} -result not-equal
test oo-16.20 {OO: object introspection: creationid #500} -setup {
oo::class create cls
} -body {
set id1 [info object creationid [set o1 [cls new]]]
$o1 destroy
set id2 [info object creationid [set o2 [cls new]]]
if {$id1 == $id2} {
format "objects %s and %s have same creation id: %d" $o1 $o2 $id1
} else {
string cat not-equal
}
} -cleanup {
cls destroy
} -result not-equal
test oo-16.21 {OO: object introspection: creationid #500} -setup {
oo::class create cls
} -body {
set id1 [info object creationid [set o1 [cls new]]]
set id2 [info object creationid [set o2 [oo::copy $o1]]]
if {$id1 == $id2} {
format "objects %s and %s have same creation id: %d" $o1 $o2 $id1
} else {
string cat not-equal
}
} -cleanup {
cls destroy
} -result not-equal
test oo-17.1 {OO: class introspection} -body {
info class
} -returnCodes 1 -result "wrong \# args: should be \"info class subcommand ?arg ...?\""
test oo-17.1.1 {OO: class introspection} -body {
catch {info class} m o
dict get $o -errorinfo
|
| ︙ | ︙ | |||
2350 2351 2352 2353 2354 2355 2356 |
} -body {
info class superclass foo
} -returnCodes 1 -cleanup {
foo destroy
} -result {"foo" is not a class}
test oo-17.4 {OO: class introspection} -body {
info class gorp oo::object
| | | 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 |
} -body {
info class superclass foo
} -returnCodes 1 -cleanup {
foo destroy
} -result {"foo" is not a class}
test oo-17.4 {OO: class introspection} -body {
info class gorp oo::object
} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be call, constructor, definition, definitionnamespace, destructor, filters, forward, instances, methods, methodtype, mixins, subclasses, superclasses, or variables}
test oo-17.5 {OO: class introspection} -setup {
oo::class create testClass
} -body {
testClass create foo
testClass create bar
testClass create spong
lsort [info class instances testClass]
|
| ︙ | ︙ | |||
3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 |
}
method Set {lst} {
variable contents $lst
variable ops
lappend ops [info level] Set $lst
return
}
}
}
append script0 \n$script
}
proc SampleSlotCleanup script {
set script0 {
| > > > > > | 4027 4028 4029 4030 4031 4032 4033 4034 4035 4036 4037 4038 4039 4040 4041 4042 4043 4044 4045 |
}
method Set {lst} {
variable contents $lst
variable ops
lappend ops [info level] Set $lst
return
}
method Resolve {lst} {
variable ops
lappend ops [info level] Resolve $lst
return $lst
}
}
}
append script0 \n$script
}
proc SampleSlotCleanup script {
set script0 {
|
| ︙ | ︙ | |||
3801 3802 3803 3804 3805 3806 3807 |
test oo-32.3 {TIP 380: slots - class test} -setup [SampleSlotSetup {
SampleSlot create sampleSlot
}] -body {
list [info level] [sampleSlot -append g h i] \
[sampleSlot contents] [sampleSlot ops]
} -cleanup [SampleSlotCleanup {
rename sampleSlot {}
| | | | > > > > > > > > > > > > > > > > | 4066 4067 4068 4069 4070 4071 4072 4073 4074 4075 4076 4077 4078 4079 4080 4081 4082 4083 4084 4085 4086 4087 4088 4089 4090 4091 4092 4093 4094 4095 4096 4097 4098 4099 4100 4101 4102 4103 4104 4105 4106 4107 4108 4109 4110 4111 4112 |
test oo-32.3 {TIP 380: slots - class test} -setup [SampleSlotSetup {
SampleSlot create sampleSlot
}] -body {
list [info level] [sampleSlot -append g h i] \
[sampleSlot contents] [sampleSlot ops]
} -cleanup [SampleSlotCleanup {
rename sampleSlot {}
}] -result {0 {} {a b c g h i} {1 Resolve g 1 Resolve h 1 Resolve i 1 Get 1 Set {a b c g h i}}}
test oo-32.4 {TIP 380: slots - class test} -setup [SampleSlotSetup {
SampleSlot create sampleSlot
}] -body {
list [info level] [sampleSlot -set d e f] \
[sampleSlot contents] [sampleSlot ops]
} -cleanup [SampleSlotCleanup {
rename sampleSlot {}
}] -result {0 {} {d e f} {1 Resolve d 1 Resolve e 1 Resolve f 1 Set {d e f}}}
test oo-32.5 {TIP 380: slots - class test} -setup [SampleSlotSetup {
SampleSlot create sampleSlot
}] -body {
list [info level] [sampleSlot -set d e f] [sampleSlot -append g h i] \
[sampleSlot contents] [sampleSlot ops]
} -cleanup [SampleSlotCleanup {
rename sampleSlot {}
}] -result {0 {} {} {d e f g h i} {1 Resolve d 1 Resolve e 1 Resolve f 1 Set {d e f} 1 Resolve g 1 Resolve h 1 Resolve i 1 Get 1 Set {d e f g h i}}}
test oo-32.6 {TIP 516: slots - class test} -setup [SampleSlotSetup {
SampleSlot create sampleSlot
}] -body {
list [info level] [sampleSlot -prepend g h i] \
[sampleSlot contents] [sampleSlot ops]
} -cleanup [SampleSlotCleanup {
rename sampleSlot {}
}] -result {0 {} {g h i a b c} {1 Resolve g 1 Resolve h 1 Resolve i 1 Get 1 Set {g h i a b c}}}
test oo-32.7 {TIP 516: slots - class test} -setup [SampleSlotSetup {
SampleSlot create sampleSlot
}] -body {
list [info level] [sampleSlot -remove c a] \
[sampleSlot contents] [sampleSlot ops]
} -cleanup [SampleSlotCleanup {
rename sampleSlot {}
}] -result {0 {} b {1 Resolve c 1 Resolve a 1 Get 1 Set b}}
test oo-33.1 {TIP 380: slots - defaulting} -setup [SampleSlotSetup {
set s [SampleSlot new]
}] -body {
list [$s x y] [$s contents]
} -cleanup [SampleSlotCleanup {
rename $s {}
|
| ︙ | ︙ | |||
3840 3841 3842 3843 3844 3845 3846 |
test oo-33.3 {TIP 380: slots - defaulting} -setup [SampleSlotSetup {
set s [SampleSlot new]
}] -body {
oo::objdefine $s forward --default-operation my -set
list [$s destroy; $s unknown] [$s contents] [$s ops]
} -cleanup [SampleSlotCleanup {
rename $s {}
| | | | 4121 4122 4123 4124 4125 4126 4127 4128 4129 4130 4131 4132 4133 4134 4135 4136 4137 4138 4139 4140 4141 4142 4143 4144 |
test oo-33.3 {TIP 380: slots - defaulting} -setup [SampleSlotSetup {
set s [SampleSlot new]
}] -body {
oo::objdefine $s forward --default-operation my -set
list [$s destroy; $s unknown] [$s contents] [$s ops]
} -cleanup [SampleSlotCleanup {
rename $s {}
}] -result {{} unknown {1 Resolve destroy 1 Set destroy 1 Resolve unknown 1 Set unknown}}
test oo-33.4 {TIP 380: slots - errors} -setup [SampleSlotSetup {
set s [SampleSlot new]
}] -body {
# Method names beginning with "-" are special to slots
$s -grill q
} -returnCodes error -cleanup [SampleSlotCleanup {
rename $s {}
}] -result \
{unknown method "-grill": must be -append, -clear, -prepend, -remove, -set, contents or ops}
test oo-34.1 {TIP 380: slots - presence} -setup {
set obj [oo::object new]
set result {}
} -body {
oo::define oo::object {
::lappend ::result [::info object class filter]
|
| ︙ | ︙ | |||
3879 3880 3881 3882 3883 3884 3885 |
} {::oo::define::filter ::oo::define::mixin ::oo::define::superclass ::oo::define::variable ::oo::objdefine::filter ::oo::objdefine::mixin ::oo::objdefine::variable}
proc getMethods obj {
list [lsort [info object methods $obj -all]] \
[lsort [info object methods $obj -private]]
}
test oo-34.3 {TIP 380: slots - presence} {
getMethods oo::define::filter
| | | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 4160 4161 4162 4163 4164 4165 4166 4167 4168 4169 4170 4171 4172 4173 4174 4175 4176 4177 4178 4179 4180 4181 4182 4183 4184 4185 4186 4187 4188 4189 4190 4191 4192 4193 4194 4195 4196 4197 4198 4199 4200 4201 4202 4203 4204 4205 4206 4207 4208 4209 4210 4211 4212 4213 4214 4215 4216 4217 4218 4219 4220 4221 4222 4223 4224 4225 4226 4227 4228 4229 4230 4231 4232 4233 4234 4235 |
} {::oo::define::filter ::oo::define::mixin ::oo::define::superclass ::oo::define::variable ::oo::objdefine::filter ::oo::objdefine::mixin ::oo::objdefine::variable}
proc getMethods obj {
list [lsort [info object methods $obj -all]] \
[lsort [info object methods $obj -private]]
}
test oo-34.3 {TIP 380: slots - presence} {
getMethods oo::define::filter
} {{-append -clear -prepend -remove -set} {Get Set}}
test oo-34.4 {TIP 380: slots - presence} {
getMethods oo::define::mixin
} {{-append -clear -prepend -remove -set} {--default-operation Get Resolve Set}}
test oo-34.5 {TIP 380: slots - presence} {
getMethods oo::define::superclass
} {{-append -clear -prepend -remove -set} {--default-operation Get Resolve Set}}
test oo-34.6 {TIP 380: slots - presence} {
getMethods oo::define::variable
} {{-append -clear -prepend -remove -set} {Get Set}}
test oo-34.7 {TIP 380: slots - presence} {
getMethods oo::objdefine::filter
} {{-append -clear -prepend -remove -set} {Get Set}}
test oo-34.8 {TIP 380: slots - presence} {
getMethods oo::objdefine::mixin
} {{-append -clear -prepend -remove -set} {--default-operation Get Resolve Set}}
test oo-34.9 {TIP 380: slots - presence} {
getMethods oo::objdefine::variable
} {{-append -clear -prepend -remove -set} {Get Set}}
test oo-34.10 {TIP 516: slots - resolution} -setup {
oo::class create parent
set result {}
oo::class create 516a { superclass parent }
oo::class create 516b { superclass parent }
oo::class create 516c { superclass parent }
namespace eval 516test {
oo::class create 516a { superclass parent }
oo::class create 516b { superclass parent }
oo::class create 516c { superclass parent }
}
} -body {
# Must find the right classes when making the mixin
namespace eval 516test {
oo::define 516a {
mixin 516b 516c
}
}
lappend result [info class mixin 516test::516a]
# Must not remove class with just simple name match
oo::define 516test::516a {
mixin -remove 516b
}
lappend result [info class mixin 516test::516a]
# Must remove class with resolved name match
oo::define 516test::516a {
mixin -remove 516test::516c
}
lappend result [info class mixin 516test::516a]
# Must remove class with resolved name match even after renaming, but only
# with the renamed name; it is a slot of classes, not strings!
rename 516test::516b 516test::516d
oo::define 516test::516a {
mixin -remove 516test::516b
}
lappend result [info class mixin 516test::516a]
oo::define 516test::516a {
mixin -remove 516test::516d
}
lappend result [info class mixin 516test::516a]
} -cleanup {
parent destroy
} -result {{::516test::516b ::516test::516c} {::516test::516b ::516test::516c} ::516test::516b ::516test::516d {}}
test oo-35.1 {Bug 9d61624b3d: Empty superclass must not cause crash} -setup {
oo::class create fruit {
method eat {} {}
}
set result {}
} -body {
|
| ︙ | ︙ | |||
4098 4099 4100 4101 4102 4103 4104 4105 4106 4107 4108 4109 4110 4111 |
}
Cls create obj
list [oo::objdefine obj testself] $result
} -cleanup {
Cls destroy
catch {rename oo::objdefine::testself {}}
} -result {{} {1 {this command may only be called from within the context of an ::oo::define or ::oo::objdefine command} 0 ::obj}}
cleanupTests
return
# Local Variables:
# mode: tcl
# End:
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 4422 4423 4424 4425 4426 4427 4428 4429 4430 4431 4432 4433 4434 4435 4436 4437 4438 4439 4440 4441 4442 4443 4444 4445 4446 4447 4448 4449 4450 4451 4452 4453 4454 4455 4456 4457 4458 4459 4460 4461 4462 4463 4464 4465 4466 4467 4468 4469 4470 4471 4472 4473 4474 4475 4476 4477 4478 4479 4480 4481 4482 4483 4484 4485 4486 4487 4488 4489 4490 4491 4492 4493 4494 4495 4496 4497 4498 4499 4500 4501 4502 4503 4504 4505 4506 4507 4508 4509 4510 4511 4512 4513 4514 4515 4516 4517 4518 4519 4520 4521 4522 4523 4524 4525 4526 4527 4528 4529 4530 4531 4532 4533 4534 4535 4536 4537 4538 4539 4540 4541 4542 4543 4544 4545 4546 4547 4548 4549 4550 4551 4552 4553 4554 4555 4556 4557 4558 4559 4560 4561 4562 4563 4564 4565 4566 4567 4568 4569 4570 4571 4572 4573 4574 4575 4576 4577 4578 4579 4580 4581 4582 4583 4584 4585 4586 4587 4588 4589 4590 4591 4592 4593 4594 4595 4596 4597 4598 4599 4600 4601 4602 4603 4604 4605 4606 4607 4608 4609 4610 4611 4612 4613 4614 4615 4616 4617 4618 4619 4620 4621 4622 4623 4624 4625 4626 4627 4628 4629 4630 4631 4632 4633 4634 4635 4636 4637 4638 4639 4640 4641 4642 4643 4644 4645 4646 4647 4648 4649 4650 4651 4652 4653 4654 4655 4656 4657 4658 4659 4660 4661 4662 4663 4664 4665 4666 4667 4668 4669 4670 4671 4672 4673 4674 4675 4676 4677 4678 4679 4680 4681 4682 4683 4684 4685 4686 4687 4688 4689 4690 4691 4692 4693 4694 4695 4696 4697 4698 4699 4700 4701 4702 4703 4704 4705 4706 4707 4708 4709 4710 4711 4712 4713 4714 4715 4716 4717 4718 4719 4720 4721 4722 4723 4724 4725 4726 4727 4728 4729 4730 4731 4732 4733 4734 4735 4736 4737 4738 4739 4740 4741 4742 4743 4744 4745 4746 4747 4748 4749 4750 4751 4752 4753 4754 4755 4756 4757 4758 4759 4760 4761 4762 4763 4764 4765 4766 4767 4768 4769 4770 4771 4772 4773 4774 4775 4776 4777 4778 4779 4780 4781 4782 4783 4784 4785 4786 4787 4788 4789 4790 4791 4792 4793 4794 4795 4796 4797 4798 4799 4800 4801 4802 4803 4804 4805 4806 4807 4808 4809 4810 4811 4812 4813 4814 4815 4816 4817 4818 4819 4820 4821 4822 4823 4824 4825 4826 4827 4828 4829 4830 4831 4832 4833 4834 4835 4836 4837 4838 4839 4840 4841 4842 4843 4844 4845 4846 4847 4848 4849 4850 4851 4852 4853 4854 4855 4856 4857 4858 4859 4860 4861 4862 4863 4864 4865 4866 4867 4868 4869 4870 4871 4872 4873 4874 4875 4876 4877 4878 4879 4880 4881 4882 4883 4884 4885 4886 4887 4888 4889 4890 4891 4892 4893 4894 4895 4896 4897 4898 4899 4900 4901 4902 4903 4904 4905 4906 4907 4908 4909 4910 4911 4912 4913 4914 4915 4916 4917 4918 4919 4920 4921 4922 4923 4924 4925 4926 4927 4928 4929 4930 4931 4932 4933 4934 4935 4936 4937 4938 4939 4940 4941 4942 4943 4944 4945 4946 4947 4948 4949 4950 4951 4952 4953 4954 4955 4956 4957 4958 4959 4960 4961 4962 4963 4964 4965 4966 4967 4968 4969 4970 4971 4972 4973 4974 4975 4976 4977 4978 4979 4980 4981 4982 4983 4984 4985 4986 4987 4988 4989 4990 4991 4992 4993 4994 4995 4996 4997 4998 4999 5000 5001 5002 5003 5004 5005 5006 5007 5008 5009 5010 5011 5012 5013 5014 5015 5016 5017 5018 5019 5020 5021 5022 5023 5024 5025 5026 5027 5028 5029 5030 5031 5032 5033 5034 5035 5036 5037 5038 5039 5040 5041 5042 5043 5044 5045 5046 5047 5048 5049 5050 5051 5052 5053 5054 5055 5056 5057 5058 5059 5060 5061 5062 5063 5064 5065 5066 5067 5068 5069 5070 5071 5072 5073 5074 5075 5076 5077 5078 5079 5080 5081 5082 5083 5084 5085 5086 5087 5088 5089 5090 5091 5092 5093 5094 5095 5096 5097 5098 5099 5100 5101 5102 5103 5104 5105 5106 5107 5108 5109 5110 5111 5112 5113 5114 5115 5116 5117 5118 5119 5120 5121 5122 5123 5124 5125 5126 5127 5128 5129 5130 5131 5132 5133 5134 5135 5136 5137 5138 5139 5140 5141 5142 5143 5144 5145 5146 5147 5148 5149 5150 5151 5152 5153 5154 5155 5156 5157 5158 5159 5160 5161 5162 5163 5164 5165 5166 5167 5168 5169 5170 5171 5172 5173 5174 5175 5176 5177 5178 5179 5180 5181 5182 5183 5184 5185 5186 5187 5188 5189 5190 5191 5192 5193 5194 5195 5196 5197 5198 5199 5200 5201 5202 5203 5204 5205 5206 5207 5208 5209 5210 5211 5212 5213 5214 5215 5216 5217 5218 5219 5220 5221 5222 5223 5224 5225 5226 5227 5228 5229 5230 5231 5232 5233 5234 5235 5236 5237 5238 5239 5240 5241 5242 5243 5244 5245 5246 5247 5248 5249 5250 5251 5252 5253 5254 5255 5256 5257 5258 5259 5260 5261 5262 5263 5264 5265 5266 5267 5268 5269 5270 5271 5272 5273 5274 5275 5276 5277 5278 5279 5280 5281 5282 5283 5284 5285 5286 5287 5288 5289 5290 5291 5292 5293 5294 5295 5296 5297 5298 5299 5300 5301 5302 5303 5304 5305 5306 5307 5308 5309 5310 5311 5312 5313 5314 5315 5316 5317 5318 5319 5320 5321 5322 5323 5324 5325 5326 5327 5328 5329 5330 5331 5332 5333 5334 5335 5336 5337 5338 5339 5340 5341 5342 5343 5344 5345 5346 5347 5348 5349 5350 5351 5352 5353 5354 5355 5356 5357 5358 5359 5360 5361 5362 5363 5364 5365 5366 5367 5368 5369 5370 5371 5372 5373 5374 5375 5376 5377 5378 5379 5380 5381 5382 5383 5384 5385 5386 5387 5388 5389 5390 5391 5392 5393 5394 5395 5396 5397 5398 5399 5400 5401 5402 5403 5404 5405 5406 5407 5408 5409 5410 5411 5412 5413 5414 5415 5416 5417 5418 5419 5420 5421 5422 5423 5424 5425 5426 5427 5428 |
}
Cls create obj
list [oo::objdefine obj testself] $result
} -cleanup {
Cls destroy
catch {rename oo::objdefine::testself {}}
} -result {{} {1 {this command may only be called from within the context of an ::oo::define or ::oo::objdefine command} 0 ::obj}}
test oo-37.1 {TIP 500: private command propagates errors} -setup {
oo::class create cls
} -body {
oo::define cls {
private ::error "this is an error"
}
} -cleanup {
cls destroy
} -returnCodes error -result {this is an error}
test oo-37.2 {TIP 500: private command propagates errors} -setup {
oo::class create cls
} -body {
oo::define cls {
private {
::error "this is an error"
}
}
} -cleanup {
cls destroy
} -returnCodes error -result {this is an error}
test oo-37.3 {TIP 500: private command propagates errors} -setup {
oo::object create obj
} -body {
oo::objdefine obj {
private ::error "this is an error"
}
} -cleanup {
obj destroy
} -returnCodes error -result {this is an error}
test oo-37.4 {TIP 500: private command propagates errors} -setup {
oo::object create obj
} -body {
oo::objdefine obj {
private {
::error "this is an error"
}
}
} -cleanup {
obj destroy
} -returnCodes error -result {this is an error}
test oo-37.5 {TIP 500: private command can't be used outside definitions} -body {
oo::define::private error "xyz"
} -returnCodes error -result {this command may only be called from within the context of an ::oo::define or ::oo::objdefine command}
test oo-37.6 {TIP 500: private command can't be used outside definitions} -body {
oo::objdefine::private error "xyz"
} -returnCodes error -result {this command may only be called from within the context of an ::oo::define or ::oo::objdefine command}
test oo-38.1 {TIP 500: private variables don't cross-interfere with each other or normal ones} -setup {
oo::class create parent
} -body {
oo::class create clsA {
superclass parent
private variable x
constructor {} {
set x 1
}
method getA {} {
return $x
}
}
oo::class create clsB {
superclass clsA
private {
variable x
}
constructor {} {
set x 2
next
}
method getB {} {
return $x
}
}
oo::class create clsC {
superclass clsB
variable x
constructor {} {
set x 3
next
}
method getC {} {
return $x
}
}
clsC create obj
oo::objdefine obj {
private {
variable x
}
method setup {} {
set x 4
}
method getO {} {
return $x
}
}
obj setup
list [obj getA] [obj getB] [obj getC] [obj getO] \
[lsort [string map [list [info object creationid clsA] CLASS-A \
[info object creationid clsB] CLASS-B \
[info object creationid obj] OBJ] \
[info object vars obj]]]
} -cleanup {
parent destroy
} -result {1 2 3 4 {{CLASS-A : x} {CLASS-B : x} {OBJ : x} x}}
test oo-38.2 {TIP 500: private variables introspection} -setup {
oo::class create parent
} -body {
oo::class create cls {
superclass parent
private {
variable x1
variable x2
}
variable y1 y2
}
cls create obj
oo::objdefine obj {
private variable a1 a2
variable b1 b2
}
list [lsort [info class variables cls]] \
[lsort [info class variables cls -private]] \
[lsort [info object variables obj]] \
[lsort [info object variables obj -private]]
} -cleanup {
parent destroy
} -result {{y1 y2} {x1 x2} {b1 b2} {a1 a2}}
test oo-38.3 {TIP 500: private variables and oo::object·varname} -setup {
oo::class create parent
} -body {
oo::class create clsA {
superclass parent
private {
variable x
}
method getx {} {
set x 1
my varname x
}
method readx {} {
return $x
}
}
oo::class create clsB {
superclass clsA
variable x
method gety {} {
set x 1
my varname x
}
method ready {} {
return $x
}
}
clsB create obj
set [obj getx] 2
set [obj gety] 3
list [obj readx] [obj ready]
} -cleanup {
parent destroy
} -result {2 3}
test oo-38.4 {TIP 500: private variables introspection} -setup {
oo::class create parent
} -body {
oo::class create cls {
superclass parent
private {
variable x1 x2
}
variable y1 y2
constructor {} {
variable z boo
set x1 a
set y1 c
}
method list {} {
variable z
set ok 1
list [info locals] [lsort [info vars]] [info exist x2]
}
}
cls create obj
oo::objdefine obj {
private variable a1 a2
variable b1 b2
method init {} {
# Because we don't have a constructor to do this setup for us
set a1 p
set b1 r
}
method list {} {
variable z
set yes 1
list {*}[next] [info locals] [lsort [info vars]] [info exist a2]
}
}
obj init
obj list
} -cleanup {
parent destroy
} -result {ok {ok x1 x2 y1 y2 z} 0 yes {a1 a2 b1 b2 yes z} 0}
test oo-38.5 {TIP 500: private variables and oo::object·variable} -setup {
oo::class create parent
} -body {
oo::class create cls1 {
superclass parent
private variable x
method abc val {
my variable x
set x $val
}
method def val {
my variable y
set y $val
}
method get1 {} {
my variable x y
return [list $x $y]
}
}
oo::class create cls2 {
superclass cls1
private variable x
method x-exists {} {
return [info exists x],[uplevel 1 {info exists x}]
}
method ghi x {
# Additional instrumentation to show that we're not using the
# resolved variable until we ask for it; the argument nixed that
# happening by default.
set val $x
set before [my x-exists]
unset x
set x $val
set mid [my x-exists]
unset x
set mid2 [my x-exists]
my variable x
set x $val
set after [my x-exists]
return "$before;$mid;$mid2;$after"
}
method jkl val {
my variable y
set y $val
}
method get2 {} {
my variable x y
return [list $x $y]
}
}
cls2 create a
a abc 123
a def 234
set tmp [a ghi 345]
a jkl 456
list $tmp [a get1] [a get2]
} -cleanup {
parent destroy
} -result {{0,1;0,1;0,0;1,1} {123 456} {345 456}}
test oo-39.1 {TIP 500: private methods internal call; class private} -setup {
oo::class create parent
} -body {
oo::class create clsA {
superclass parent
variable x
constructor {} {
set x 1
}
method act {} {
my step
my step
my step
return
}
private {
method step {} {
incr x 2
}
}
method x {} {
return $x
}
}
clsA create obj
obj act
list [obj x] [catch {obj step} msg] $msg
} -cleanup {
parent destroy
} -result {7 1 {unknown method "step": must be act, destroy or x}}
test oo-39.2 {TIP 500: private methods internal call; class private} -setup {
oo::class create parent
} -body {
oo::class create clsA {
superclass parent
variable x
constructor {} {
set x 1
}
method act {} {
my step
my step
my step
return
}
private {
method step {} {
incr x 2
}
}
method x {} {
return $x
}
}
oo::class create clsB {
superclass clsA
variable x
method step {} {
incr x 5
}
}
clsB create obj
obj act
list [obj x] [obj step]
} -cleanup {
parent destroy
} -result {7 12}
test oo-39.3 {TIP 500: private methods internal call; class private} -setup {
oo::class create parent
} -body {
oo::class create clsA {
superclass parent
variable x
constructor {} {
set x 1
}
method act {} {
my Step
my Step
my Step
return
}
method x {} {
return $x
}
}
oo::class create clsB {
superclass clsA
variable x
method Step {} {
incr x 5
}
}
clsB create obj
obj act
set result [obj x]
oo::define clsA {
private {
method Step {} {
incr x 2
}
}
}
obj act
lappend result [obj x]
} -cleanup {
parent destroy
} -result {16 22}
test oo-39.4 {TIP 500: private methods internal call; instance private} -setup {
oo::class create parent
} -body {
oo::class create clsA {
superclass parent
variable x
constructor {} {
set x 1
}
method act {} {
my step
return
}
method step {} {
incr x
}
method x {} {
return $x
}
}
clsA create obj
obj act
set result [obj x]
oo::objdefine obj {
variable x
private {
method step {} {
incr x 2
}
}
}
obj act
lappend result [obj x]
oo::objdefine obj {
method act {} {
my step
next
}
}
obj act
lappend result [obj x]
} -cleanup {
parent destroy
} -result {2 3 6}
test oo-39.5 {TIP 500: private methods internal call; cross object} -setup {
oo::class create parent
} -body {
oo::class create cls {
superclass parent
variable x
constructor {val} {
set x $val
}
private method x {} {
return $x
}
method equal {other} {
expr {$x == [$other x]}
}
}
cls create a 1
cls create b 2
cls create c 1
list [a equal b] [b equal c] [c equal a] [catch {a x} msg] $msg
} -cleanup {
parent destroy
} -result {0 0 1 1 {unknown method "x": must be destroy or equal}}
test oo-39.6 {TIP 500: private methods internal call; error reporting} -setup {
oo::class create parent
} -body {
oo::class create cls {
superclass parent
variable x
constructor {val} {
set x $val
}
private method x {} {
return $x
}
method equal {other} {
expr {$x == [$other y]}
}
}
cls create a 1
cls create b 2
a equal b
} -returnCodes error -cleanup {
parent destroy
} -result {unknown method "y": must be destroy, equal or x}
test oo-39.7 {TIP 500: private methods internal call; error reporting} -setup {
oo::class create parent
} -body {
oo::class create cls {
superclass parent
variable x
constructor {val} {
set x $val
}
private method x {} {
return $x
}
method equal {other} {
expr {[[self] y] == [$other x]}
}
}
cls create a 1
cls create b 2
a equal b
} -returnCodes error -cleanup {
parent destroy
} -result {unknown method "y": must be destroy, equal or x}
test oo-39.8 {TIP 500: private methods internal call; error reporting} -setup {
oo::class create parent
} -body {
oo::class create cls {
superclass parent
variable x
constructor {val} {
set x $val
}
private method x {} {
return $x
}
method equal {other} {
expr {[my y] == [$other x]}
}
}
cls create a 1
cls create b 2
a equal b
} -returnCodes error -cleanup {
parent destroy
} -result {unknown method "y": must be <cloned>, destroy, equal, eval, unknown, variable, varname or x}
test oo-39.9 {TIP 500: private methods internal call; error reporting} -setup {
oo::class create parent
} -body {
oo::class create cls {
superclass parent
variable x
constructor {val} {
set x $val
}
private method x {} {
return $x
}
}
oo::class create cls2 {
superclass cls
method equal {other} {
expr {[my y] == [$other x]}
}
}
cls2 create a 1
cls2 create b 2
a equal b
} -returnCodes error -cleanup {
parent destroy
} -result {unknown method "y": must be <cloned>, destroy, equal, eval, unknown, variable or varname}
test oo-39.10 {TIP 500: private methods internal call; error reporting} -setup {
oo::class create parent
} -body {
oo::class create cls {
superclass parent
variable x
constructor {val} {
set x $val
}
private method x {} {
return $x
}
}
oo::class create cls2 {
superclass cls
method equal {other} {
expr {[my x] == [$other x]}
}
}
cls2 create a 1
cls2 create b 2
a equal b
} -returnCodes error -cleanup {
parent destroy
} -result {unknown method "x": must be <cloned>, destroy, equal, eval, unknown, variable or varname}
test oo-39.11 {TIP 500: private methods; call chain caching and reporting} -setup {
oo::class create parent
} -body {
oo::class create cls {
superclass parent
method chain {} {
return [self call]
}
}
oo::class create cls2 {
superclass cls
private method chain {} {
next
}
method chain2 {} {
my chain
}
method chain3 {} {
[self] chain
}
}
cls create a
cls2 create b
list [a chain] [b chain] [b chain2] [b chain3]
} -cleanup {
parent destroy
} -result {{{{method chain ::cls method}} 0} {{{method chain ::cls method}} 0} {{{private chain ::cls2 method} {method chain ::cls method}} 1} {{{private chain ::cls2 method} {method chain ::cls method}} 1}}
test oo-39.12 {TIP 500: private methods; introspection} -setup {
oo::class create parent
} -body {
oo::class create cls {
superclass parent
method chain {} {
return [self call]
}
private method abc {} {}
}
oo::class create cls2 {
superclass cls
method chain2 {} {
my chain
}
method chain3 {} {
[self] chain
}
private method def {} {}
unexport chain3
}
cls create a
cls2 create b
oo::objdefine b {
private method ghi {} {}
method ABC {} {}
method foo {} {}
}
set scopes {public unexported private}
list a: [lmap s $scopes {info object methods a -scope $s}] \
b: [lmap s $scopes {info object methods b -scope $s}] \
cls: [lmap s $scopes {info class methods cls -scope $s}] \
cls2: [lmap s $scopes {info class methods cls2 -scope $s}] \
} -cleanup {
parent destroy
} -result {a: {{} {} {}} b: {foo ABC ghi} cls: {chain {} abc} cls2: {chain2 chain3 def}}
test oo-40.1 {TIP 500: private and self} -setup {
oo::class create cls
} -body {
oo::define cls {
self {
private {
variable a
}
variable b
}
private {
self {
variable c
}
variable d
}
variable e
}
list \
[lsort [info class variables cls]] \
[lsort [info class variables cls -private]] \
[lsort [info object variables cls]] \
[lsort [info object variables cls -private]]
} -cleanup {
cls destroy
} -result {e d b {a c}}
test oo-40.2 {TIP 500: private and export} -setup {
oo::class create cls
} -body {
oo::define cls {
private method foo {} {}
}
set result [lmap s {public unexported private} {
info class methods cls -scope $s}]
oo::define cls {
export foo
}
lappend result {*}[lmap s {public unexported private} {
info class methods cls -scope $s}]
} -cleanup {
cls destroy
} -result {{} {} foo foo {} {}}
test oo-40.3 {TIP 500: private and unexport} -setup {
oo::class create cls
} -body {
oo::define cls {
private method foo {} {}
}
set result [lmap s {public unexported private} {
info class methods cls -scope $s}]
oo::define cls {
unexport foo
}
lappend result {*}[lmap s {public unexported private} {
info class methods cls -scope $s}]
} -cleanup {
cls destroy
} -result {{} {} foo {} foo {}}
test oo-41.1 {TIP 478: myclass command, including class morphing} -setup {
oo::class create parent
set result {}
} -body {
oo::class create cls1 {
superclass parent
self method count {} {
my variable c
incr c
}
method act {} {
myclass count
}
}
cls1 create x
lappend result [x act] [x act]
cls1 create y
lappend result [y act] [y act] [x act]
oo::class create cls2 {
superclass cls1
self method count {} {
my variable d
expr {1.0 * [incr d]}
}
}
oo::objdefine x {class cls2}
lappend result [x act] [y act] [x act] [y act]
} -cleanup {
parent destroy
} -result {1 2 3 4 5 1.0 6 2.0 7}
test oo-41.2 {TIP 478: myclass command cleanup} -setup {
oo::class create parent
set result {}
} -body {
oo::class create cls1 {
superclass parent
self method hi {} {
return "this is [self]"
}
method hi {} {
return "this is [self]"
}
}
cls1 create x
rename [info object namespace x]::my foo
rename [info object namespace x]::myclass bar
lappend result [cls1 hi] [x hi] [foo hi] [bar hi]
x destroy
lappend result [catch {foo hi}] [catch {bar hi}]
} -cleanup {
parent destroy
} -result {{this is ::cls1} {this is ::x} {this is ::x} {this is ::cls1} 1 1}
test oo-41.3 {TIP 478: myclass command calls unexported methods, via forward} -setup {
oo::class create parent
set result {}
} -body {
oo::class create cls1 {
superclass parent
self method Hi {} {
return "this is [self]"
}
forward poke myclass Hi
}
cls1 create x
lappend result [catch {cls1 Hi}] [x poke]
} -cleanup {
parent destroy
} -result {1 {this is ::cls1}}
test oo-42.1 {TIP 524: definition namespace control: introspection} {
info class definitionnamespace oo::object
} {}
test oo-42.2 {TIP 524: definition namespace control: introspection} {
info class definitionnamespace oo::object -class
} {}
test oo-42.3 {TIP 524: definition namespace control: introspection} {
info class definitionnamespace oo::object -instance
} ::oo::objdefine
test oo-42.4 {TIP 524: definition namespace control: introspection} -body {
info class definitionnamespace oo::object -gorp
} -returnCodes error -result {bad kind "-gorp": must be -class or -instance}
test oo-42.5 {TIP 524: definition namespace control: introspection} -body {
info class definitionnamespace oo::object -class x
} -returnCodes error -result {wrong # args: should be "info class definitionnamespace className ?kind?"}
test oo-42.6 {TIP 524: definition namespace control: introspection} {
info class definitionnamespace oo::class
} ::oo::define
test oo-42.7 {TIP 524: definition namespace control: introspection} {
info class definitionnamespace oo::class -class
} ::oo::define
test oo-42.8 {TIP 524: definition namespace control: introspection} {
info class definitionnamespace oo::class -instance
} {}
test oo-43.1 {TIP 524: definition namespace control: semantics} -setup {
oo::class create parent
namespace eval foodef {}
} -body {
namespace eval foodef {
proc sparkle {} {return ok}
}
oo::class create foocls {
superclass oo::class parent
definitionnamespace foodef
}
oo::class create foo {
superclass parent
self class foocls
}
oo::define foo {
sparkle
}
} -cleanup {
parent destroy
namespace delete foodef
} -result ok
test oo-43.2 {TIP 524: definition namespace control: semantics} -setup {
oo::class create parent
namespace eval foodef {}
unset -nocomplain ::result
} -body {
namespace eval foodef {
namespace path ::oo::define
proc sparkle {} {return ok}
}
oo::class create foocls {
superclass oo::class parent
definitionnamespace foodef
}
foocls create foo {
superclass parent
lappend ::result [sparkle]
}
return $result
} -cleanup {
parent destroy
namespace delete foodef
} -result ok
test oo-43.3 {TIP 524: definition namespace control: semantics} -setup {
oo::class create parent
namespace eval foodef {}
unset -nocomplain ::result
} -body {
namespace eval foodef {
namespace path ::oo::define
proc sparkle {} {return ok}
}
oo::class create foocls {
superclass oo::class parent
definitionnamespace -class foodef
}
foocls create foo {
superclass parent
lappend ::result [sparkle]
}
return $result
} -cleanup {
parent destroy
namespace delete foodef
} -result ok
test oo-43.4 {TIP 524: definition namespace control: semantics} -setup {
oo::class create parent
namespace eval foodef {}
} -body {
namespace eval foodef {
namespace path ::oo::objdefine
proc sparkle {} {return ok}
}
oo::class create foocls {
superclass oo::class parent
definitionnamespace -instance foodef
}
foocls create foo {
sparkle
}
} -returnCodes error -cleanup {
parent destroy
namespace delete foodef
} -result {invalid command name "sparkle"}
test oo-43.5 {TIP 524: definition namespace control: semantics} -setup {
oo::class create parent
namespace eval foodef {}
} -body {
namespace eval foodef {
namespace path ::oo::objdefine
proc sparkle {} {return ok}
}
oo::class create foocls {
superclass oo::class parent
definitionnamespace foodef
}
namespace delete foodef
foocls create foo {
sparkle
}
} -returnCodes error -cleanup {
parent destroy
catch {namespace delete foodef}
} -result {invalid command name "sparkle"}
test oo-43.6 {TIP 524: definition namespace control: semantics} -setup {
oo::class create parent
namespace eval foodef {}
unset -nocomplain result
} -body {
namespace eval foodef {
namespace path ::oo::objdefine
proc sparkle {} {return ok}
}
oo::class create foocls {
superclass oo::class parent
definitionnamespace foodef
}
foocls create foo
lappend result [catch {oo::define foo sparkle} msg] $msg
namespace delete foodef
lappend result [catch {oo::define foo sparkle} msg] $msg
namespace eval foodef {
namespace path ::oo::objdefine
proc sparkle {} {return ok}
}
lappend result [catch {oo::define foo sparkle} msg] $msg
} -cleanup {
parent destroy
catch {namespace delete foodef}
} -result {0 ok 1 {invalid command name "sparkle"} 0 ok}
test oo-43.7 {TIP 524: definition namespace control: semantics} -setup {
oo::class create parent
namespace eval foodef {}
} -body {
namespace eval foodef {
namespace path ::oo::define
proc sparkle {x} {return ok}
}
oo::class create foocls {
superclass oo::class parent
definitionnamespace foodef
}
foocls create foo {
superclass parent
}
oo::define foo spar gorp
} -cleanup {
parent destroy
namespace delete foodef
} -result ok
test oo-43.8 {TIP 524: definition namespace control: semantics} -setup {
oo::class create parent
namespace eval foodef {}
} -body {
namespace eval foodef {
namespace path ::oo::objdefine
proc sparkle {} {return ok}
}
oo::class create foo {
superclass parent
definitionnamespace -instance foodef
}
oo::objdefine [foo new] {
method x y z
sparkle
}
} -cleanup {
parent destroy
namespace delete foodef
} -result ok
test oo-43.9 {TIP 524: definition namespace control: syntax} -body {
oo::class create foo {
definitionnamespace -gorp foodef
}
} -returnCodes error -result {bad kind "-gorp": must be -class or -instance}
test oo-43.10 {TIP 524: definition namespace control: syntax} -body {
oo::class create foo {
definitionnamespace -class foodef x
}
} -returnCodes error -result {wrong # args: should be "definitionnamespace ?kind? namespace"}
test oo-43.11 {TIP 524: definition namespace control: syntax} -setup {
catch {namespace delete ::no_such_ns}
} -body {
oo::class create foo {
definitionnamespace -class ::no_such_ns
}
} -returnCodes error -result {namespace "::no_such_ns" not found}
test oo-43.12 {TIP 524: definition namespace control: user-level introspection} -setup {
oo::class create parent
namespace eval foodef {}
} -body {
namespace eval foodef {}
oo::class create foo {
superclass oo::class parent
}
list [info class definitionnamespace foo] \
[oo::define foo definitionnamespace foodef] \
[info class definitionnamespace foo] \
[oo::define foo definitionnamespace {}] \
[info class definitionnamespace foo]
} -cleanup {
parent destroy
namespace delete foodef
} -result {{} {} ::foodef {} {}}
test oo-43.13 {TIP 524: definition namespace control: user-level introspection} -setup {
oo::class create parent
namespace eval foodef {}
} -body {
namespace eval foodef {}
oo::class create foo {
superclass parent
}
list [info class definitionnamespace foo -instance] \
[oo::define foo definitionnamespace -instance foodef] \
[info class definitionnamespace foo -instance] \
[oo::define foo definitionnamespace -instance {}] \
[info class definitionnamespace foo -instance]
} -cleanup {
parent destroy
namespace delete foodef
} -result {{} {} ::foodef {} {}}
cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Added tests/ooUtil.test.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 |
# This file contains a collection of tests for functionality originally
# sourced from the ooutil package in Tcllib. Sourcing this file into Tcl runs
# the tests and generates output for errors. No output means no errors were
# found.
#
# Copyright (c) 2014-2016 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.
package require TclOO 1.0.3
package require tcltest 2
if {"::tcltest" in [namespace children]} {
namespace import -force ::tcltest::*
}
test ooUtil-1.1 {TIP 478: classmethod} -setup {
oo::class create parent
} -body {
oo::class create ActiveRecord {
superclass parent
classmethod find args {
return "[self] called with arguments: $args"
}
}
oo::class create Table {
superclass ActiveRecord
}
Table find foo bar
} -cleanup {
parent destroy
} -result {::Table called with arguments: foo bar}
test ooUtil-1.2 {TIP 478: classmethod in namespace} -setup {
namespace eval ::testns {}
} -body {
namespace eval ::testns {
oo::class create ActiveRecord {
classmethod find args {
return "[self] called with arguments: $args"
}
}
oo::class create Table {
superclass ActiveRecord
}
}
testns::Table find foo bar
} -cleanup {
namespace delete ::testns
} -result {::testns::Table called with arguments: foo bar}
test ooUtil-1.3 {TIP 478: classmethod must not interfere with constructor signatures} -setup {
oo::class create parent
} -body {
oo::class create TestClass {
superclass oo::class parent
self method create {name ignore body} {
next $name $body
}
}
TestClass create okay {} {}
} -cleanup {
parent destroy
} -result {::okay}
test ooUtil-1.4 {TIP 478: classmethod with several inheritance levels} -setup {
oo::class create parent
} -body {
oo::class create ActiveRecord {
superclass parent
classmethod find args {
return "[self] called with arguments: $args"
}
}
oo::class create Table {
superclass ActiveRecord
}
oo::class create SubTable {
superclass Table
}
SubTable find foo bar
} -cleanup {
parent destroy
} -result {::SubTable called with arguments: foo bar}
test ooUtil-1.5 {TIP 478: classmethod and instances} -setup {
oo::class create parent
} -body {
oo::class create ActiveRecord {
superclass parent
classmethod find args {
return "[self] called with arguments: $args"
}
}
oo::class create Table {
superclass ActiveRecord
}
set t [Table new]
$t find 1 2 3
} -cleanup {
parent destroy
} -result {::Table called with arguments: 1 2 3}
test ooUtil-1.6 {TIP 478: classmethod and instances} -setup {
oo::class create parent
} -body {
oo::class create ActiveRecord {
superclass parent
classmethod find args {
return "[self] called with arguments: $args"
}
}
oo::class create Table {
superclass ActiveRecord
unexport find
}
set t [Table new]
$t find 1 2 3
} -returnCodes error -cleanup {
parent destroy
} -match glob -result {unknown method "find": must be *}
test ooUtil-1.7 {} -setup {
oo::class create parent
} -body {
oo::class create Foo {
superclass parent
classmethod bar {} {
puts "This is in the class; self is [self]"
my meee
}
classmethod meee {} {
puts "This is meee"
}
}
oo::class create Grill {
superclass Foo
classmethod meee {} {
puts "This is meee 2"
}
}
list [Foo bar] [Grill bar] [[Foo new] bar] [[Grill new] bar]
} -cleanup {
parent destroy
} -result {{} {} {} {}} -output "This is in the class; self is ::Foo\nThis is meee\nThis is in the class; self is ::Grill\nThis is meee 2\nThis is in the class; self is ::Foo\nThis is meee\nThis is in the class; self is ::Grill\nThis is meee 2\n"
# Two tests to confirm that we correctly initialise the scripted part of TclOO
# in child interpreters. This is slightly tricky at the implementation level
# because we cannot count on either [source] or [open] being available.
test ooUtil-1.8 {TIP 478: classmethod in child interp} -setup {
set childinterp [interp create]
} -body {
$childinterp eval {
oo::class create ActiveRecord {
classmethod find args {
return "[self] called with arguments: $args"
}
}
oo::class create Table {
superclass ActiveRecord
}
# This is confirming that this is not the master interpreter
list [Table find foo bar] [info globals childinterp]
}
} -cleanup {
interp delete $childinterp
} -result {{::Table called with arguments: foo bar} {}}
test ooUtil-1.9 {TIP 478: classmethod in safe child interp} -setup {
set safeinterp [interp create -safe]
} -body {
$safeinterp eval {
oo::class create ActiveRecord {
classmethod find args {
return "[self] called with arguments: $args"
}
}
oo::class create Table {
superclass ActiveRecord
}
# This is confirming that this is a (basic) safe interpreter
list [Table find foo bar] [info commands source]
}
} -cleanup {
interp delete $safeinterp
} -result {{::Table called with arguments: foo bar} {}}
test ooUtil-2.1 {TIP 478: callback generation} -setup {
oo::class create parent
} -body {
oo::class create c {
superclass parent
method CallMe {} { return ok,[self] }
method makeCall {} {
return [callback CallMe]
}
}
c create ::context
set cb [context makeCall]
{*}$cb
} -cleanup {
parent destroy
} -result {ok,::context}
test ooUtil-2.2 {TIP 478: callback generation} -setup {
oo::class create parent
} -body {
oo::class create c {
superclass parent
method CallMe {a b c} { return ok,[self],$a,$b,$c }
method makeCall {b} {
return [callback CallMe 123 $b]
}
}
c create ::context
set cb [context makeCall "a b c"]
{*}$cb PQR
} -cleanup {
parent destroy
} -result {ok,::context,123,a b c,PQR}
test ooUtil-2.3 {TIP 478: callback generation, alternate name} -setup {
oo::class create parent
} -body {
oo::class create c {
superclass parent
method CallMe {} { return ok,[self] }
method makeCall {} {
return [mymethod CallMe]
}
}
c create ::context
set cb [context makeCall]
{*}$cb
} -cleanup {
parent destroy
} -result {ok,::context}
test ooUtil-2.4 {TIP 478: callback generation, alternate name} -setup {
oo::class create parent
} -body {
oo::class create c {
superclass parent
method CallMe {a b c} { return ok,[self],$a,$b,$c }
method makeCall {b} {
return [mymethod CallMe 123 $b]
}
}
c create ::context
set cb [context makeCall "a b c"]
{*}$cb PQR
} -cleanup {
parent destroy
} -result {ok,::context,123,a b c,PQR}
test ooUtil-2.5 {TIP 478: callbacks and method lifetime} -setup {
oo::class create parent
} -body {
oo::class create c {
superclass parent
method makeCall {b} {
return [callback CallMe 123 $b]
}
}
c create ::context
set cb [context makeCall "a b c"]
set result [list [catch {{*}$cb PQR} msg] $msg]
oo::objdefine context {
method CallMe {a b c} { return ok,[self],$a,$b,$c }
}
lappend result [{*}$cb PQR]
} -cleanup {
parent destroy
} -result {1 {unknown method "CallMe": must be <cloned>, destroy, eval, makeCall, unknown, variable or varname} {ok,::context,123,a b c,PQR}}
test ooUtil-2.6 {TIP 478: callback use case} -setup {
oo::class create parent
unset -nocomplain x
} -body {
oo::class create c {
superclass parent
variable count
constructor {var} {
set count 0
upvar 1 $var v
trace add variable v write [callback TraceCallback]
}
method count {} {return $count}
method TraceCallback {name1 name2 op} {
incr count
}
}
set o [c new x]
for {set x 0} {$x < 5} {incr x} {}
$o count
} -cleanup {
unset -nocomplain x
parent destroy
} -result 6
test ooUtil-3.1 {TIP 478: class initialisation} -setup {
oo::class create parent
catch {rename ::foobar-3.1 {}}
} -body {
oo::class create ::cls {
superclass parent
initialise {
proc foobar-3.1 {} {return ok}
}
method calls {} {
list [catch foobar-3.1 msg] $msg \
[namespace eval [info object namespace [self class]] foobar-3.1]
}
}
[cls new] calls
} -cleanup {
parent destroy
} -result {1 {invalid command name "foobar-3.1"} ok}
test ooUtil-3.2 {TIP 478: class variables} -setup {
oo::class create parent
catch {rename ::foobar-3.1 {}}
} -body {
oo::class create ::cls {
superclass parent
initialise {
variable x 123
}
method call {} {
classvariable x
incr x
}
}
cls create a
cls create b
cls create c
list [a call] [b call] [c call] [a call] [b call] [c call]
} -cleanup {
parent destroy
} -result {124 125 126 127 128 129}
test ooUtil-3.3 {TIP 478: class initialisation} -setup {
oo::class create parent
catch {rename ::foobar-3.3 {}}
} -body {
oo::class create ::cls {
superclass parent
initialize {
proc foobar-3.3 {} {return ok}
}
method calls {} {
list [catch foobar-3.3 msg] $msg \
[namespace eval [info object namespace [self class]] foobar-3.3]
}
}
[cls new] calls
} -cleanup {
parent destroy
} -result {1 {invalid command name "foobar-3.3"} ok}
test ooUtil-3.4 {TIP 478: class initialisation} -setup {
oo::class create parent
catch {rename ::appendToResultVar {}}
proc ::appendToResultVar args {
lappend ::result {*}$args
}
set result {}
} -body {
trace add execution oo::define::initialise enter appendToResultVar
oo::class create ::cls {
superclass parent
initialize {proc xyzzy {} {}}
}
return $result
} -cleanup {
catch {
trace remove execution oo::define::initialise enter appendToResultVar
}
rename ::appendToResultVar {}
parent destroy
} -result {{initialize {proc xyzzy {} {}}} enter}
test ooUtil-3.5 {TIP 478: class initialisation} -body {
oo::define oo::object {
::list [::namespace which initialise] [::namespace which initialize] \
[::namespace origin initialise] [::namespace origin initialize]
}
} -result {::oo::define::initialise ::oo::define::initialize ::oo::define::initialise ::oo::define::initialise}
test ooUtil-4.1 {TIP 478: singleton} -setup {
oo::class create parent
} -body {
oo::singleton create xyz {
superclass parent
}
set x [xyz new]
set y [xyz new]
set z [xyz new]
set code [catch {$x destroy} msg]
set p [xyz new]
lappend code [catch {rename $x ""}]
set q [xyz new]
string map [list $x ONE $q TWO] [list {*}$code $x $y $z $p $q [xyz new]]
} -cleanup {
parent destroy
} -result {1 0 ONE ONE ONE ONE TWO TWO}
test ooUtil-4.2 {TIP 478: singleton errors} -setup {
oo::class create parent
} -body {
oo::singleton create xyz {
superclass parent
}
[xyz new] destroy
} -returnCodes error -cleanup {
parent destroy
} -result {may not destroy a singleton object}
test ooUtil-4.3 {TIP 478: singleton errors} -setup {
oo::class create parent
} -body {
oo::singleton create xyz {
superclass parent
}
oo::copy [xyz new]
} -returnCodes error -cleanup {
parent destroy
} -result {may not clone a singleton object}
test ooUtil-5.1 {TIP 478: abstract} -setup {
oo::class create parent
} -body {
oo::abstract create xyz {
superclass parent
method foo {} {return 123}
}
oo::class create pqr {
superclass xyz
method bar {} {return 456}
}
set codes [list [catch {xyz new}] [catch {xyz create x}] [catch {xyz createWithNamespace x y}]]
set x [pqr new]
set y [pqr create ::y]
lappend codes [$x foo] [$x bar] $y
} -cleanup {
parent destroy
} -result {1 1 1 123 456 ::y}
test ooUtil-6.1 {TIP 478: classvarable} -setup {
oo::class create parent
} -body {
oo::class create xyz {
superclass parent
initialise {
variable x 1 y 2
}
method a {} {
classvariable x
incr x
}
method b {} {
classvariable y
incr y
}
method c {} {
classvariable x y
list $x $y
}
}
set p [xyz new]
set q [xyz new]
set result [list [$p c] [$q c]]
$p a
$q b
lappend result [[xyz new] c]
} -cleanup {
parent destroy
} -result {{1 2} {1 2} {2 3}}
test ooUtil-6.2 {TIP 478: classvarable error case} -setup {
oo::class create parent
} -body {
oo::class create xyz {
superclass parent
method a {} {
classvariable x(1)
incr x(1)
}
}
set p [xyz new]
set q [xyz new]
list [$p a] [$q a]
} -returnCodes error -cleanup {
parent destroy
} -result {bad variable name "x(1)": can't create a scalar variable that looks like an array element}
test ooUtil-6.3 {TIP 478: classvarable error case} -setup {
oo::class create parent
} -body {
oo::class create xyz {
superclass parent
method a {} {
classvariable ::x
incr x
}
}
set p [xyz new]
set q [xyz new]
list [$p a] [$q a]
} -returnCodes error -cleanup {
parent destroy
} -result {bad variable name "::x": can't create a local variable with a namespace separator in it}
test ooUtil-7.1 {TIP 478: link calling pattern} -setup {
oo::class create parent
} -body {
oo::class create cls {
superclass parent
method foo {} {return "in foo of [self]"}
method Bar {} {return "in bar of [self]"}
method Grill {} {return "in grill of [self]"}
export eval
constructor {} {
link foo
link {bar Bar} {grill Grill}
}
}
cls create o
o eval {list [foo] [bar] [grill]}
} -cleanup {
parent destroy
} -result {{in foo of ::o} {in bar of ::o} {in grill of ::o}}
test ooUtil-7.2 {TIP 478: link removed when [my] disappears} -setup {
oo::class create parent
} -body {
oo::class create cls {
superclass parent
method foo {} {return "in foo of [self]"}
constructor {cmd} {
link [list ::$cmd foo]
}
}
cls create o pqr
list [o foo] [pqr] [rename [info object namespace o]::my {}] [catch pqr msg] $msg
} -cleanup {
parent destroy
} -result {{in foo of ::o} {in foo of ::o} {} 1 {invalid command name "pqr"}}
# Tests that verify issues detected with the tcllib version of the code
test ooUtil-tcllib-ticket-b3577ed586 {test scoping of delegation in oo::class.Delegate } -setup {
oo::class create animal {}
namespace eval ::ooutiltest {
oo::class create pet { superclass animal }
}
} -body {
namespace eval ::ooutiltest {
oo::class create dog { superclass pet }
}
} -cleanup {
namespace delete ooutiltest
rename animal {}
} -result {::ooutiltest::dog}
test ooUtil-tcllib-ticket-fe7a0e0a3a {classmethod must not interfere with constructor signatures} -setup {
oo::class create TestClass {
superclass oo::class
self method create {name ignore body} {
next $name $body
}
}
} -body {
TestClass create okay {} {}
} -cleanup {
rename TestClass {}
} -result {::okay}
cleanupTests
return
# Local Variables:
# fill-column: 78
# mode: tcl
# End:
|
Changes to tests/package.test.
| ︙ | ︙ | |||
19 20 21 22 23 24 25 |
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
# Do all this in a slave interp to avoid garbaging the package list
set i [interp create]
tcltest::loadIntoSlaveInterpreter $i {*}$argv
| | | 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 |
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
# Do all this in a slave interp to avoid garbaging the package list
set i [interp create]
tcltest::loadIntoSlaveInterpreter $i {*}$argv
catch [list load {} Tcltest $i]
interp eval $i {
namespace import -force ::tcltest::*
#package forget {*}[package names]
set oldPkgUnknown [package unknown]
package unknown {}
set oldPath $auto_path
set auto_path ""
|
| ︙ | ︙ | |||
626 627 628 629 630 631 632 |
set x
} -result {1.1}
test package-3.54 {Tcl_PkgRequire procedure, coroutine support} -setup {
package forget t
} -body {
coroutine coro1 apply {{} {
package ifneeded t 2.1 {
| | | | 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 |
set x
} -result {1.1}
test package-3.54 {Tcl_PkgRequire procedure, coroutine support} -setup {
package forget t
} -body {
coroutine coro1 apply {{} {
package ifneeded t 2.1 {
yield
package provide t 2.1
}
package require t 2.1
}}
list [catch {coro1} msg] $msg
} -match glob -result {0 2.1}
test package-4.1 {Tcl_PackageCmd procedure} -returnCodes error -body {
package
} -result {wrong # args: should be "package option ?arg ...?"}
test package-4.2 {Tcl_PackageCmd procedure, "forget" option} -setup {
interp create child
|
| ︙ | ︙ |
Changes to tests/parseExpr.test.
| ︙ | ︙ | |||
1040 1041 1042 1043 1044 1045 1046 |
dict get $o -errorcode
} -result {TCL PARSE EXPR EMPTY}
test parseExpr-22.13 {Bug 3401704} -constraints testexprparser -body {
testexprparser naner() -1
} -result {- {} 0 subexpr naner() 1 operator naner 0 {}}
test parseExpr-22.14 {Bug 3401704} -constraints testexprparser -body {
| | | | 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 |
dict get $o -errorcode
} -result {TCL PARSE EXPR EMPTY}
test parseExpr-22.13 {Bug 3401704} -constraints testexprparser -body {
testexprparser naner() -1
} -result {- {} 0 subexpr naner() 1 operator naner 0 {}}
test parseExpr-22.14 {Bug 3401704} -constraints testexprparser -body {
testexprparser 07 -1
} -result {- {} 0 subexpr 07 1 text 07 0 {}}
test parseExpr-22.15 {Bug 3401704} -constraints testexprparser -body {
catch {testexprparser 0o8 -1} m o
dict get $o -errorcode
} -result {TCL PARSE EXPR BADNUMBER OCTAL}
test parseExpr-22.16 {Bug 3401704} -constraints testexprparser -body {
catch {testexprparser 0o08 -1} m o
dict get $o -errorcode
|
| ︙ | ︙ |
Added tests/pkgIndex.tcl.
> > > | 1 2 3 | #! /usr/bin/env tclsh package ifneeded tcltests 0.1 [list source $dir/tcltests.tcl] |
Changes to tests/platform.test.
| ︙ | ︙ | |||
18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 |
# This is not how [variable] works. See TIP 276.
#variable ::tcl_platform
namespace upvar :: tcl_platform tcl_platform
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testCPUID [llength [info commands testcpuid]]
test platform-1.0 {tcl_platform(engine)} {
set tcl_platform(engine)
} {Tcl}
test platform-1.1 {TclpSetVariables: tcl_platform} {
interp create i
i eval {catch {unset tcl_platform(debug)}}
i eval {catch {unset tcl_platform(threaded)}}
set result [i eval {lsort [array names tcl_platform]}]
interp delete i
set result
} {byteOrder engine machine os osVersion pathSeparator platform pointerSize user wordSize}
| > > < < < < | | < < < | | > > > | 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 |
# This is not how [variable] works. See TIP 276.
#variable ::tcl_platform
namespace upvar :: tcl_platform tcl_platform
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
package require tcltests
testConstraint testCPUID [llength [info commands testcpuid]]
testConstraint testlongsize [llength [info commands testlongsize]]
test platform-1.0 {tcl_platform(engine)} {
set tcl_platform(engine)
} {Tcl}
test platform-1.1 {TclpSetVariables: tcl_platform} {
interp create i
i eval {catch {unset tcl_platform(debug)}}
i eval {catch {unset tcl_platform(threaded)}}
set result [i eval {lsort [array names tcl_platform]}]
interp delete i
set result
} {byteOrder engine machine os osVersion pathSeparator platform pointerSize user wordSize}
test platform-2.1 {tcl_platform(wordSize) indicates size of native word} testlongsize {
expr {$tcl_platform(wordSize) == [testlongsize]}
} {1}
# On Windows/UNIX, test that the CPU ID works
test platform-3.1 {CPU ID on Windows/UNIX} \
-constraints testCPUID \
-body {
set cpudata [testcpuid 0]
binary format iii \
[lindex $cpudata 1] \
[lindex $cpudata 3] \
[lindex $cpudata 2]
} \
-match regexp \
-result {^(?:AuthenticAMD|CentaurHauls|CyrixInstead|GenuineIntel)$}
# The platform package makes very few promises, but does promise that the
# format of string it produces consists of two non-empty words separated by a
# hyphen.
package require platform
test platform-4.1 {format of platform::identify result} -constraints notValgrind -match regexp -body {
# [identify] may attempt to [exec] dpkg-architecture, which may not exist,
# in which case fork will not be followed by exec, and valgrind will issue
# "still reachable" reports.
platform::identify
} -result {^([^-]+-)+[^-]+$}
test platform-4.2 {format of platform::generic result} -match regexp -body {
platform::generic
} -result {^([^-]+-)+[^-]+$}
# cleanup
|
| ︙ | ︙ |
Changes to tests/proc.test.
| ︙ | ︙ | |||
106 107 108 109 110 111 112 113 114 115 116 117 118 119 |
} -result {formal parameter "a(1)" is an array element}
test proc-1.8 {Tcl_ProcObjCmd, check that formal parameter names are simple names} -setup {
catch {rename p ""}
} -body {
proc p {b:a b::a} {
}
} -returnCodes error -result {formal parameter "b::a" is not a simple name}
test proc-2.1 {TclFindProc, simple proc name and proc not in namespace} -setup {
catch {namespace delete {*}[namespace children :: test_ns_*]}
catch {rename p ""}
} -body {
proc p {} {return "p in [namespace current]"}
info body p
| > > > > > > > > | 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 |
} -result {formal parameter "a(1)" is an array element}
test proc-1.8 {Tcl_ProcObjCmd, check that formal parameter names are simple names} -setup {
catch {rename p ""}
} -body {
proc p {b:a b::a} {
}
} -returnCodes error -result {formal parameter "b::a" is not a simple name}
test proc-1.9 {Tcl_ProcObjCmd, arguments via canonical list (string-representation bug [631b4c45df])} -body {
set v 2
binary scan AB cc a b
proc p [list [list a $a] [list b $b] [list v [expr {$v + 2}]]] {expr {$a + $b + $v}}
p
} -result [expr {65+66+4}] -cleanup {
rename p {}
}
test proc-2.1 {TclFindProc, simple proc name and proc not in namespace} -setup {
catch {namespace delete {*}[namespace children :: test_ns_*]}
catch {rename p ""}
} -body {
proc p {} {return "p in [namespace current]"}
info body p
|
| ︙ | ︙ | |||
309 310 311 312 313 314 315 316 317 318 319 320 321 322 |
set end [getbytes]
}
set leakedBytes [expr {$end - $tmp}]
} -cleanup {
rename getbytes {}
unset -nocomplain end i tmp leakedBytes
} -result 0
test proc-5.1 {Bytecompiling noop; test for correct argument substitution} -body {
proc p args {} ; # this will be bytecompiled into t
proc t {} {
set res {}
set a 0
set b 0
| > > > | 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 |
set end [getbytes]
}
set leakedBytes [expr {$end - $tmp}]
} -cleanup {
rename getbytes {}
unset -nocomplain end i tmp leakedBytes
} -result 0
test proc-4.9 {[39fed4dae5] Valid Tcl_PkgPresent return} procbodytest {
procbodytest::check
} 1
test proc-5.1 {Bytecompiling noop; test for correct argument substitution} -body {
proc p args {} ; # this will be bytecompiled into t
proc t {} {
set res {}
set a 0
set b 0
|
| ︙ | ︙ | |||
379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 |
set lambda x
lappend lambda {set a 1}
interp create slave
slave eval [list apply $lambda foo]
interp delete slave
unset lambda
} {}
# cleanup
catch {rename p ""}
catch {rename t ""}
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# fill-column: 78
# End:
| > > > > > > > > | 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 |
set lambda x
lappend lambda {set a 1}
interp create slave
slave eval [list apply $lambda foo]
interp delete slave
unset lambda
} {}
test proc-7.5 {[631b4c45df] Crash in argument processing} {
binary scan A c val
proc foo [list [list from $val]] {}
rename foo {}
unset -nocomplain val
} {}
# cleanup
catch {rename p ""}
catch {rename t ""}
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# fill-column: 78
# End:
|
Changes to tests/process.test.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 16 17 18 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
test process-1.1 {tcl::process command basic syntax} -returnCodes error -body {
tcl::process
} -result {wrong # args: should be "tcl::process subcommand ?arg ...?"}
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > | | > > > | > | > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
# Utilities
file delete [set path(test-signalfile) [makeFile {} test-signalfile]]
set path(test-signalfile2) [makeFile {} test-signalfile2]
# $path(sleep) time ?filename? -- sleep for time (in ms) and stop if it gets signaled (file gets deleted)
set path(sleep) [makeFile {
after [expr {[lindex $argv 0]*1000}] {set stop 1}
if {[set fn [lindex $::argv 1]] ne ""} {
close [open $fn w]
proc check {} {
if {![file exists $::fn]} { # exit signaled
after 10 {set ::stop 2}
}
after 10 check
}
after 10 check
}
vwait stop
exit
} sleep]
proc wait_for_file {fn {timeout 10000}} {
if {![file exists $fn]} {
set toev [after $timeout {set found 0}]
proc check {fn} {
if {[file exists $fn]} {
set ::found 1
return
}
after 10 [list check $fn]
}
after 10 [list check $fn]
vwait ::found
after cancel $toev
unset ::found
}
file exists $fn
}
proc signal_exit {fn {wait 1}} {
# wait for until file created if expected:
if {!$wait || [wait_for_file $fn]} {
# delete file to signal exit for child-process:
while {1} {
if {![catch { file delete $fn } msg opt]
|| [lrange [dict get $opt -errorcode] 0 1] ne {POSIX EACCES}
} break
}
}
}
set path(exit) [makeFile {
exit [lindex $argv 0]
} exit]
# Basic syntax checking
test process-1.1 {tcl::process command basic syntax} -returnCodes error -body {
tcl::process
} -result {wrong # args: should be "tcl::process subcommand ?arg ...?"}
test process-1.2 {tcl::process subcommands} -returnCodes error -body {
tcl::process ?
} -match glob -result {unknown or ambiguous subcommand "?": must be autopurge, list, purge, or status}
# Autopurge flag
# - Default state
test process-2.1 {autopurge default} -body {
tcl::process autopurge
} -result {1}
# - Enabling autopurge
test process-2.2 {enable autopurge} -body {
tcl::process autopurge true
tcl::process autopurge
} -result {1}
# - Disabling autopurge
test process-2.3 {disable autopurge} -body {
tcl::process autopurge false
tcl::process autopurge
} -result {0} -cleanup {tcl::process autopurge true}
# Subprocess list & status
test process-3.1 {empty subprocess list} -body {
llength [tcl::process list]
} -result {0}
test process-3.2 {empty subprocess status} -body {
dict size [tcl::process status]
} -result {0}
# Spawn subprocesses using [exec]
# - One child
test process-4.1 {exec one child} -body {
tcl::process autopurge 0
set pid [exec [interpreter] $path(exit) 0 &]
set list [tcl::process list]
set statuses [tcl::process status -wait]
set status [lindex [tcl::process status $pid] 1]
expr {
[llength $list] eq 1
&& [lindex $list 0] eq $pid
&& [dict size $statuses] eq 1
&& [dict get $statuses $pid] eq $status
&& $status eq 0
}
} -result {1} -cleanup {
tcl::process purge
tcl::process autopurge 1
}
# - Two children
test process-4.2 {exec two children in parallel} -body {
tcl::process autopurge 0
set pid1 [exec [interpreter] $path(exit) 0 &]
set pid2 [exec [interpreter] $path(exit) 0 &]
set list [tcl::process list]
set statuses [tcl::process status -wait]
set status1 [lindex [tcl::process status $pid1] 1]
set status2 [lindex [tcl::process status $pid2] 1]
expr {
[llength $list] eq 2
&& [lsearch $list $pid1] >= 0
&& [lsearch $list $pid2] >= 0
&& [dict size $statuses] eq 2
&& [dict get $statuses $pid1] eq $status1
&& [dict get $statuses $pid2] eq $status2
&& $status1 eq 0
&& $status2 eq 0
}
} -result {1} -cleanup {
tcl::process purge
tcl::process autopurge 1
}
# - 3-stage pipe
test process-4.3 {exec 3-stage pipe} -body {
tcl::process autopurge 0
set pids [exec \
[interpreter] $path(exit) 0 \
| [interpreter] $path(exit) 0 \
| [interpreter] $path(exit) 0 \
&]
lassign $pids pid1 pid2 pid3
set list [tcl::process list]
set statuses [tcl::process status -wait]
set status1 [lindex [tcl::process status $pid1] 1]
set status2 [lindex [tcl::process status $pid2] 1]
set status3 [lindex [tcl::process status $pid3] 1]
expr {
[llength $pids] eq 3
&& [llength $list] eq 3
&& [lsearch $list $pid1] >= 0
&& [lsearch $list $pid2] >= 0
&& [lsearch $list $pid3] >= 0
&& [dict size $statuses] eq 3
&& [dict get $statuses $pid1] eq $status1
&& [dict get $statuses $pid2] eq $status2
&& [dict get $statuses $pid3] eq $status3
&& $status1 eq 0
&& $status2 eq 0
&& $status3 eq 0
}
} -result {1} -cleanup {
tcl::process purge
tcl::process autopurge 1
}
# Spawn subprocesses using [open "|"]
# - One child
test process-5.1 {exec one child} -body {
tcl::process autopurge 0
set f [open "|\"[interpreter]\" \"$path(exit)\" 0"]
set pid [pid $f]
set list [tcl::process list]
set statuses [tcl::process status -wait]
set status [lindex [tcl::process status $pid] 1]
expr {
[llength $list] eq 1
&& [lindex $list 0] eq $pid
&& [dict size $statuses] eq 1
&& [dict get $statuses $pid] eq $status
&& $status eq 0
}
} -result {1} -cleanup {
close $f
tcl::process purge
tcl::process autopurge 1
}
# - Two children
test process-5.2 {exec two children in parallel} -body {
tcl::process autopurge 0
set f1 [open "|\"[interpreter]\" \"$path(exit)\" 0"]
set f2 [open "|\"[interpreter]\" \"$path(exit)\" 0"]
set pid1 [pid $f1]
set pid2 [pid $f2]
set list [tcl::process list]
set statuses [tcl::process status -wait]
set status1 [lindex [tcl::process status $pid1] 1]
set status2 [lindex [tcl::process status $pid2] 1]
expr {
[llength $list] eq 2
&& [lsearch $list $pid1] >= 0
&& [lsearch $list $pid2] >= 0
&& [dict size $statuses] eq 2
&& [dict get $statuses $pid1] eq $status1
&& [dict get $statuses $pid2] eq $status2
&& $status1 eq 0
&& $status2 eq 0
}
} -result {1} -cleanup {
close $f1
close $f2
tcl::process purge
tcl::process autopurge 1
}
# - 3-stage pipe
test process-5.3 {exec 3-stage pipe} -body {
tcl::process autopurge 0
set f [open "|
\"[interpreter]\" \"$path(exit)\" 0
| \"[interpreter]\" \"$path(exit)\" 0
| \"[interpreter]\" \"$path(exit)\" 0
"]
set pids [pid $f]
lassign $pids pid1 pid2 pid3
set list [tcl::process list]
set statuses [tcl::process status -wait]
set status1 [lindex [tcl::process status $pid1] 1]
set status2 [lindex [tcl::process status $pid2] 1]
set status3 [lindex [tcl::process status $pid3] 1]
expr {
[llength $pids] eq 3
&& [llength $list] eq 3
&& [lsearch $list $pid1] >= 0
&& [lsearch $list $pid2] >= 0
&& [lsearch $list $pid3] >= 0
&& [dict size $statuses] eq 3
&& [dict get $statuses $pid1] eq $status1
&& [dict get $statuses $pid2] eq $status2
&& [dict get $statuses $pid3] eq $status3
&& $status1 eq 0
&& $status2 eq 0
&& $status3 eq 0
}
} -result {1} -cleanup {
close $f
tcl::process purge
tcl::process autopurge 1
}
# Async child status
test process-6.1 {async status} -setup {
signal_exit $path(test-signalfile) 0; # clean signal-file
} -body {
tcl::process autopurge 0
set pid [exec [interpreter] $path(sleep) 1 $path(test-signalfile) &]
set status1 [lindex [tcl::process status $pid] 1]
signal_exit $path(test-signalfile); # signal exit (stop sleep)
set status2 [lindex [tcl::process status -wait $pid] 1]
expr {
$status1 eq {}
&& $status2 eq 0
}
} -result {1} -cleanup {
tcl::process purge
tcl::process autopurge 1
}
test process-6.2 {selective wait} -setup {
signal_exit $path(test-signalfile) 0; # clean signal-files
signal_exit $path(test-signalfile2) 0;
} -body {
tcl::process autopurge 0
# Child 1 sleeps 1s
set pid1 [exec [interpreter] $path(sleep) 1 $path(test-signalfile) &]
# Child 2 sleeps 1s
set pid2 [exec [interpreter] $path(sleep) 2 $path(test-signalfile2) &]
# Initial status
set status1_1 [lindex [tcl::process status $pid1] 1]
set status1_2 [lindex [tcl::process status $pid2] 1]
# Wait until child 1 termination
signal_exit $path(test-signalfile); # signal exit for pid1 (stop sleep)
set status2_1 [lindex [tcl::process status -wait $pid1] 1]
set status2_2 [lindex [tcl::process status $pid2] 1]
# Wait until child 2 termination
signal_exit $path(test-signalfile2); # signal exit for pid2 (stop sleep)
set status3_2 [lindex [tcl::process status -wait $pid2] 1]
set status3_1 [lindex [tcl::process status $pid1] 1]
expr {
$status1_1 eq {}
&& $status1_2 eq {}
&& $status2_1 eq 0
&& $status2_2 eq {}
&& $status3_1 eq 0
&& $status3_2 eq 0
}
} -result {1} -cleanup {
tcl::process purge
tcl::process autopurge 1
}
# Error codes
test process-7.1 {normal exit} -body {
tcl::process autopurge 0
set pid [exec [interpreter] $path(exit) 0 &]
lindex [tcl::process status -wait $pid] 1
} -result {0} -cleanup {
tcl::process purge
tcl::process autopurge 1
}
test process-7.2 {abnormal exit} -body {
tcl::process autopurge 0
set pid [exec [interpreter] $path(exit) 1 &]
lindex [tcl::process status -wait $pid] 1
} -match glob -result {1 {child process exited abnormally} {CHILDSTATUS * 1}} -cleanup {
tcl::process purge
tcl::process autopurge 1
}
test process-7.3 {child killed} -constraints {win} -body {
tcl::process autopurge 0
set pid [exec [interpreter] $path(exit) -1 &]
lindex [tcl::process status -wait $pid] 1
} -match glob -result {1 {child killed: unknown signal} {CHILDKILLED * {unknown signal} {unknown signal}}} -cleanup {
tcl::process purge
tcl::process autopurge 1
}
removeFile $path(exit)
removeFile $path(sleep)
rename wait_for_file {}
rename signal_exit {}
::tcltest::cleanupTests
return
|
Changes to tests/reg.test.
| ︙ | ︙ | |||
509 510 511 512 513 514 515 |
expectMatch 9.37 bE {a[\]]b} "a\\]b" "a\\]b"
expectMatch 9.38 eE {a[\]]b} "a\\]b" "a\\]b"
expectMatch 9.39 EP {a[\\]b} "a\\b" "a\\b"
expectMatch 9.40 eE {a[\\]b} "a\\b" "a\\b"
expectMatch 9.41 bE {a[\\]b} "a\\b" "a\\b"
expectError 9.42 - {a[\Z]b} EESCAPE
expectMatch 9.43 & {a[[b]c} "a\[c" "a\[c"
| | | 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 |
expectMatch 9.37 bE {a[\]]b} "a\\]b" "a\\]b"
expectMatch 9.38 eE {a[\]]b} "a\\]b" "a\\]b"
expectMatch 9.39 EP {a[\\]b} "a\\b" "a\\b"
expectMatch 9.40 eE {a[\\]b} "a\\b" "a\\b"
expectMatch 9.41 bE {a[\\]b} "a\\b" "a\\b"
expectError 9.42 - {a[\Z]b} EESCAPE
expectMatch 9.43 & {a[[b]c} "a\[c" "a\[c"
expectMatch 9.44 EMP* {a[\u00fe-\u0507][\u00ff-\u0300]b} \
"a\u0102\u02ffb" "a\u0102\u02ffb"
doing 10 "anchors and newlines"
expectMatch 10.1 & ^a a a
expectNomatch 10.2 &^ ^a a
expectIndices 10.3 &N ^ a {0 -1}
|
| ︙ | ︙ | |||
620 621 622 623 624 625 626 | expectMatch 13.9 MP "a\\chb" "a\bb" "a\bb" expectMatch 13.10 MP "a\\cHb" "a\bb" "a\bb" expectMatch 13.11 LMP "a\\e" "a\033" "a\033" expectMatch 13.12 P "a\\fb" "a\fb" "a\fb" expectMatch 13.13 P "a\\nb" "a\nb" "a\nb" expectMatch 13.14 P "a\\rb" "a\rb" "a\rb" expectMatch 13.15 P "a\\tb" "a\tb" "a\tb" | | > > | | | > | > | > | > | 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 |
expectMatch 13.9 MP "a\\chb" "a\bb" "a\bb"
expectMatch 13.10 MP "a\\cHb" "a\bb" "a\bb"
expectMatch 13.11 LMP "a\\e" "a\033" "a\033"
expectMatch 13.12 P "a\\fb" "a\fb" "a\fb"
expectMatch 13.13 P "a\\nb" "a\nb" "a\nb"
expectMatch 13.14 P "a\\rb" "a\rb" "a\rb"
expectMatch 13.15 P "a\\tb" "a\tb" "a\tb"
expectMatch 13.16 P "a\\u0008x" "a\bx" "a\bx"
expectMatch 13.17 P {a\u008x} "a\bx" "a\bx"
expectMatch 13.18 P "a\\u00088x" "a\b8x" "a\b8x"
expectMatch 13.19 P "a\\U00000008x" "a\bx" "a\bx"
expectMatch 13.20 P {a\U0000008x} "a\bx" "a\bx"
expectMatch 13.21 P "a\\vb" "a\vb" "a\vb"
expectMatch 13.22 MP "a\\x08x" "a\bx" "a\bx"
expectError 13.23 - {a\xq} EESCAPE
expectMatch 13.24 MP "a\\x08x" "a\bx" "a\bx"
expectError 13.25 - {a\z} EESCAPE
expectMatch 13.26 MP "a\\010b" "a\bb" "a\bb"
expectMatch 13.27 P "a\\U00001234x" "a\u1234x" "a\u1234x"
expectMatch 13.28 P {a\U00001234x} "a\u1234x" "a\u1234x"
expectMatch 13.29 P "a\\U0001234x" "a\u1234x" "a\u1234x"
expectMatch 13.30 P {a\U0001234x} "a\u1234x" "a\u1234x"
expectMatch 13.31 P "a\\U000012345x" "a\u12345x" "a\u12345x"
expectMatch 13.32 P {a\U000012345x} "a\u12345x" "a\u12345x"
expectMatch 13.33 P "a\\U1000000x" "a\ufffd0x" "a\ufffd0x"
expectMatch 13.34 P {a\U1000000x} "a\ufffd0x" "a\ufffd0x"
doing 14 "back references"
# ugh
expectMatch 14.1 RP {a(b*)c\1} abbcbb abbcbb bb
expectMatch 14.2 RP {a(b*)c\1} ac ac ""
expectNomatch 14.3 RP {a(b*)c\1} abbcb
|
| ︙ | ︙ |
Changes to tests/registry.test.
| ︙ | ︙ | |||
15 16 17 18 19 20 21 |
namespace import -force ::tcltest::*
}
testConstraint reg 0
if {[testConstraint win]} {
if {![catch {
::tcltest::loadTestedCommands
| | | | 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 |
namespace import -force ::tcltest::*
}
testConstraint reg 0
if {[testConstraint win]} {
if {![catch {
::tcltest::loadTestedCommands
set ::regver [package require registry 1.3.3]
}]} {
testConstraint reg 1
}
}
# determine the current locale
testConstraint english [expr {
[llength [info commands testlocale]]
&& [string match "English*" [testlocale all ""]]
}]
test registry-1.0 {check if we are testing the right dll} {win reg} {
set ::regver
} {1.3.3}
test registry-1.1 {argument parsing for registry command} {win reg} {
list [catch {registry} msg] $msg
} {1 {wrong # args: should be "registry ?-32bit|-64bit? option ?arg ...?"}}
test registry-1.1a {argument parsing for registry command} {win reg} {
list [catch {registry -32bit} msg] $msg
} {1 {wrong # args: should be "registry ?-32bit|-64bit? option ?arg ...?"}}
test registry-1.1b {argument parsing for registry command} {win reg} {
|
| ︙ | ︙ |
Changes to tests/safe.test.
| ︙ | ︙ | |||
88 89 90 91 92 93 94 |
test safe-3.2 {calling safe::interpCreate on trusted interp} -setup {
catch {safe::interpDelete a}
} -body {
safe::interpCreate a
lsort [a aliases]
} -cleanup {
safe::interpDelete a
| | | 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 |
test safe-3.2 {calling safe::interpCreate on trusted interp} -setup {
catch {safe::interpDelete a}
} -body {
safe::interpCreate a
lsort [a aliases]
} -cleanup {
safe::interpDelete a
} -result {::tcl::encoding::system ::tcl::file::dirname ::tcl::file::extension ::tcl::file::rootname ::tcl::file::tail ::tcl::info::nameofexecutable clock encoding exit file glob load source}
test safe-3.3 {calling safe::interpCreate on trusted interp} -setup {
catch {safe::interpDelete a}
} -body {
safe::interpCreate a
interp eval a {source [file join $tcl_library init.tcl]}
} -cleanup {
safe::interpDelete a
|
| ︙ | ︙ | |||
304 305 306 307 308 309 310 |
$i eval {source [file join [info lib] xxxxxxxxxxx.tcl]}
} msg] $msg $log
} -cleanup {
safe::setLogCmd $prevlog
unset log
safe::interpDelete $i
} -result [list 1 {no such file or directory} [list "ERROR for slave a : [file join [info library] xxxxxxxxxxx.tcl]:no such file or directory"]]
| | | | | < < < < | 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 |
$i eval {source [file join [info lib] xxxxxxxxxxx.tcl]}
} msg] $msg $log
} -cleanup {
safe::setLogCmd $prevlog
unset log
safe::interpDelete $i
} -result [list 1 {no such file or directory} [list "ERROR for slave a : [file join [info library] xxxxxxxxxxx.tcl]:no such file or directory"]]
test safe-8.8 {safe source forbids -rsrc} emptyTest {
# Disabled this test. It was only useful for long unsupported
# Mac OS 9 systems. [Bug 860a9f1945]
} {}
test safe-8.9 {safe source and return} -setup {
set returnScript [makeFile {return "ok"} return.tcl]
catch {safe::interpDelete $i}
} -body {
safe::interpCreate $i
set token [safe::interpAddToAccessPath $i [file dirname $returnScript]]
$i eval [list source $token/[file tail $returnScript]]
|
| ︙ | ︙ | |||
464 465 466 467 468 469 470 |
test safe-11.1 {testing safe encoding} -setup {
set i [safe::interpCreate]
} -body {
interp eval $i encoding
} -returnCodes error -cleanup {
safe::interpDelete $i
| | | | 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 |
test safe-11.1 {testing safe encoding} -setup {
set i [safe::interpCreate]
} -body {
interp eval $i encoding
} -returnCodes error -cleanup {
safe::interpDelete $i
} -result {wrong # args: should be "encoding subcommand ?arg ...?"}
test safe-11.1a {testing safe encoding} -setup {
set i [safe::interpCreate]
} -body {
interp eval $i encoding foobar
} -returnCodes error -cleanup {
safe::interpDelete $i
} -match glob -result {unknown or ambiguous subcommand "foobar": must be *}
test safe-11.2 {testing safe encoding} -setup {
set i [safe::interpCreate]
} -body {
interp eval $i encoding system cp775
} -returnCodes error -cleanup {
safe::interpDelete $i
} -result {wrong # args: should be "encoding system"}
|
| ︙ | ︙ | |||
526 527 528 529 530 531 532 |
} -returnCodes ok -match glob -cleanup {
unset -nocomplain m o
safe::interpDelete $i
} -result {wrong # args: should be "encoding convertfrom ?encoding? data"
while executing
"encoding convertfrom"
invoked from within
| < < | 522 523 524 525 526 527 528 529 530 531 532 533 534 535 |
} -returnCodes ok -match glob -cleanup {
unset -nocomplain m o
safe::interpDelete $i
} -result {wrong # args: should be "encoding convertfrom ?encoding? data"
while executing
"encoding convertfrom"
invoked from within
"encoding convertfrom"
invoked from within
"interp eval $i encoding convertfrom"}
test safe-11.8 {testing safe encoding} -setup {
set i [safe::interpCreate]
} -body {
interp eval $i encoding convertto
|
| ︙ | ︙ | |||
550 551 552 553 554 555 556 |
} -returnCodes ok -match glob -cleanup {
unset -nocomplain m o
safe::interpDelete $i
} -result {wrong # args: should be "encoding convertto ?encoding? data"
while executing
"encoding convertto"
invoked from within
| < < | 544 545 546 547 548 549 550 551 552 553 554 555 556 557 |
} -returnCodes ok -match glob -cleanup {
unset -nocomplain m o
safe::interpDelete $i
} -result {wrong # args: should be "encoding convertto ?encoding? data"
while executing
"encoding convertto"
invoked from within
"encoding convertto"
invoked from within
"interp eval $i encoding convertto"}
test safe-12.1 {glob is restricted [Bug 2906841]} -setup {
set i [safe::interpCreate]
} -body {
|
| ︙ | ︙ | |||
765 766 767 768 769 770 771 |
interp expose $i file
lappend result [catch {interp eval $i {file split a/b/c}} msg] $msg
lappend result [catch {interp eval $i {file isdirectory .}} msg] $msg
} -cleanup {
unset -nocomplain msg
interp delete $i
} -result {1 {a b c} 1 {a b c} 1 {invalid command name "file"} 1 0 {a b c} 1 {not allowed to invoke subcommand isdirectory of file}}
| | | 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 |
interp expose $i file
lappend result [catch {interp eval $i {file split a/b/c}} msg] $msg
lappend result [catch {interp eval $i {file isdirectory .}} msg] $msg
} -cleanup {
unset -nocomplain msg
interp delete $i
} -result {1 {a b c} 1 {a b c} 1 {invalid command name "file"} 1 0 {a b c} 1 {not allowed to invoke subcommand isdirectory of file}}
test safe-15.2 {safe file ensemble does not surprise code} -setup {
set i [interp create -safe]
} -body {
set result [expr {"file" in [interp hidden $i]}]
lappend result [interp eval $i {tcl::file::split a/b/c}]
lappend result [catch {interp eval $i {tcl::file::isdirectory .}}]
lappend result [interp invokehidden $i file split a/b/c]
lappend result [catch {interp eval $i {file split a/b/c}} msg] $msg
|
| ︙ | ︙ |
Changes to tests/scan.test.
| ︙ | ︙ | |||
15 16 17 18 19 20 21 |
package require tcltest 2
namespace import -force ::tcltest::*
}
# procedure that returns the range of integers
proc int_range {} {
| < | < | < | 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 |
package require tcltest 2
namespace import -force ::tcltest::*
}
# procedure that returns the range of integers
proc int_range {} {
set MAX_INT [expr {[format %u -2]/2}]
set MIN_INT [expr { ~ $MAX_INT }]
return [list $MIN_INT $MAX_INT]
}
# Big test for correct ordering of data in [expr]
proc testIEEE {} {
variable ieeeValues
|
| ︙ | ︙ | |||
81 82 83 84 85 86 87 |
default {
return 0
}
}
}
testConstraint ieeeFloatingPoint [testIEEE]
| | < | 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 |
default {
return 0
}
}
}
testConstraint ieeeFloatingPoint [testIEEE]
testConstraint wideIs64bit [expr {wide(0x8000000000000000) < 0}]
test scan-1.1 {BuildCharSet, CharInSet} {
list [scan foo {%[^o]} x] $x
} {1 f}
test scan-1.2 {BuildCharSet, CharInSet} {
list [scan \]foo {%[]f]} x] $x
} {1 \]f}
|
| ︙ | ︙ |
Changes to tests/set-old.test.
| ︙ | ︙ | |||
336 337 338 339 340 341 342 |
}
foo
} {1 {"x" isn't an array}}
test set-old-8.6 {array command} {
catch {unset a}
set a(22) 3
list [catch {array gorp a} msg] $msg
| | | 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 |
}
foo
} {1 {"x" isn't an array}}
test set-old-8.6 {array command} {
catch {unset a}
set a(22) 3
list [catch {array gorp a} msg] $msg
} {1 {unknown or ambiguous subcommand "gorp": must be anymore, default, donesearch, exists, for, get, names, nextelement, set, size, startsearch, statistics, or unset}}
test set-old-8.7 {array command, anymore option} {
catch {unset a}
list [catch {array anymore a x} msg] $msg
} {1 {"a" isn't an array}}
test set-old-8.8 {array command, anymore option, array doesn't exist yet but has compiler-allocated procedure slot} {
proc foo {x} {
if {$x==1} {
|
| ︙ | ︙ | |||
696 697 698 699 700 701 702 |
}}} msg] $msg
} {1 {list must have an even number of elements}}
test set-old-9.1 {ids for array enumeration} {
catch {unset a}
set a(a) 1
list [array star a] [array star a] [array done a s-1-a; array star a] \
| | | 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 |
}}} msg] $msg
} {1 {list must have an even number of elements}}
test set-old-9.1 {ids for array enumeration} {
catch {unset a}
set a(a) 1
list [array star a] [array star a] [array done a s-1-a; array star a] \
[array done a s-2-a; array do a s-3-a; array start a]
} {s-1-a s-2-a s-3-a s-1-a}
test set-old-9.2 {array enumeration} {
catch {unset a}
set a(a) 1
set a(b) 1
set a(c) 1
set x [array startsearch a]
|
| ︙ | ︙ |
Changes to tests/socket.test.
| ︙ | ︙ | |||
63 64 65 66 67 68 69 70 71 72 73 74 75 76 |
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
# Some tests require the Thread package or exec command
testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}]
testConstraint exec [llength [info commands exec]]
# Produce a random port number in the Dynamic/Private range
# from 49152 through 65535.
| > > > > | 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 |
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
if {[expr {[info exists ::env(TRAVIS_OSX_IMAGE)] && [string match xcode* $::env(TRAVIS_OSX_IMAGE)]}]} {
return
}
# Some tests require the Thread package or exec command
testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}]
testConstraint exec [llength [info commands exec]]
# Produce a random port number in the Dynamic/Private range
# from 49152 through 65535.
|
| ︙ | ︙ | |||
121 122 123 124 125 126 127 |
# additional [after]s in some tests that are not needed on systems that fail
# immediately.
set t1 [clock milliseconds]
catch {socket 127.0.0.1 [randport]}
set t2 [clock milliseconds]
set lat2 [expr {($t2-$t1)*3}]
| | | | 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 |
# additional [after]s in some tests that are not needed on systems that fail
# immediately.
set t1 [clock milliseconds]
catch {socket 127.0.0.1 [randport]}
set t2 [clock milliseconds]
set lat2 [expr {($t2-$t1)*3}]
# Use the maximum of the two latency calculations, but at least 200ms
set latency [expr {$lat1 > $lat2 ? $lat1 : $lat2}]
set latency [expr {$latency > 200 ? $latency : 200}]
unset t1 t2 s1 s2 lat1 lat2 server
# If remoteServerIP or remoteServerPort are not set, check in the environment
# variables for externally set values.
#
if {![info exists remoteServerIP]} {
|
| ︙ | ︙ | |||
664 665 666 667 668 669 670 |
set s [socket -server accept 0]
set sock ""
} -body {
set s2 [socket $localhost [lindex [fconfigure $s -sockname] 2]]
vwait sock
puts $s2 one
flush $s2
| | | 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 |
set s [socket -server accept 0]
set sock ""
} -body {
set s2 [socket $localhost [lindex [fconfigure $s -sockname] 2]]
vwait sock
puts $s2 one
flush $s2
after $latency {set x 1}; # Spurious failures in Travis CI, if we do [after idle]
vwait x
fconfigure $sock -blocking 0
set result a:[gets $sock]
lappend result b:[gets $sock]
fconfigure $sock -blocking 1
puts $s2 two
flush $s2
|
| ︙ | ︙ |
Changes to tests/source.test.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 | # Copyright (c) 1994-1996 Sun Microsystems, Inc. # Copyright (c) 1998-2000 by Scriptics Corporation. # Contributions from Don Porter, NIST, 2003. (not subject to US copyright) # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. | | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 |
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-2000 by Scriptics Corporation.
# Contributions from Don Porter, NIST, 2003. (not subject to US copyright)
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[catch {package require tcltest 2.5}]} {
puts stderr "Skipping tests in [info script]. tcltest 2.5 required."
return
}
namespace eval ::tcl::test::source {
namespace import ::tcltest::*
test source-1.1 {source command} -setup {
|
| ︙ | ︙ | |||
99 100 101 102 103 104 105 |
} -cleanup {
removeFile source.file
} -returnCodes continue
test source-2.6 {source error conditions} -setup {
set sourcefile [makeFile {} _non_existent_]
removeFile _non_existent_
} -body {
| | < | | | 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 |
} -cleanup {
removeFile source.file
} -returnCodes continue
test source-2.6 {source error conditions} -setup {
set sourcefile [makeFile {} _non_existent_]
removeFile _non_existent_
} -body {
source $sourcefile
} -match glob -result {couldn't read file "*_non_existent_": no such file or directory} \
-errorCode {POSIX ENOENT {no such file or directory}}
test source-2.7 {utf-8 with BOM} -setup {
set sourcefile [makeFile {} source.file]
} -body {
set out [open $sourcefile w]
fconfigure $out -encoding utf-8
puts $out "\ufeffset y new-y"
close $out
|
| ︙ | ︙ |
Changes to tests/string.test.
| ︙ | ︙ | |||
16 17 18 19 20 21 22 23 24 |
package require tcltest
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
# Some tests require the testobj command
| > > > > > > | | > | > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > | | | | | > > > > > > | > > > | | | | | | | | | | | | | | | | | | | | | | > > > > > > > > > | | | | > | > > | | | > > > > > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | < | | < > > > > > > > > > | | | | | | | | | | | | | | | | > > > > > > > > > > > > > > > > > > > > > | | | | | | | | > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | > | > > | > | > > > > > > > | | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | | | | | | | | | | > > > > > > > > > > > > > > > > > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > | > > | > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < < < | > > > | | | | | | | | | | | | | | | | < < < | > > | > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 |
package require tcltest
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
# Helper commands to test various optimizations, code paths, and special cases.
proc makeByteArray {s} {binary format a* $s}
proc makeUnicode {s} {lindex [regexp -inline .* $s] 0}
proc makeList {args} {return $args}
proc makeShared {s} {uplevel 1 [list lappend copy $s]; return $s}
# Some tests require the testobj command
testConstraint testobj [expr {[info commands testobj] ne {}}]
testConstraint testindexobj [expr {[info commands testindexobj] ne {}}]
testConstraint testevalex [expr {[info commands testevalex] ne {}}]
testConstraint tip389 [expr {[string length \U010000] == 2}]
# Used for constraining memory leak tests
testConstraint memory [llength [info commands memory]]
if {[testConstraint memory]} {
proc getbytes {} {
set lines [split [memory info] \n]
return [lindex $lines 3 3]
}
proc leaktest {script {iterations 3}} {
set end [getbytes]
for {set i 0} {$i < $iterations} {incr i} {
uplevel 1 $script
set tmp $end
set end [getbytes]
}
return [expr {$end - $tmp}]
}
}
proc representationpoke s {
set r [::tcl::unsupported::representation $s]
list [lindex $r 3] [string match {*, string representation "*"} $r]
}
foreach noComp {0 1} {
if {$noComp} {
if {[info commands testevalex] eq {}} {
test string-0.1.$noComp "show testevalex availability" {testevalex} {list} {}
continue
}
interp alias {} run {} testevalex
set constraints testevalex
} else {
interp alias {} run {} try
set constraints {}
}
test string-1.1.$noComp {error conditions} {
list [catch {run {string gorp a b}} msg] $msg
} {1 {unknown or ambiguous subcommand "gorp": must be bytelength, cat, compare, equal, first, index, insert, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}}
test string-1.2.$noComp {error conditions} {
list [catch {run {string}} msg] $msg
} {1 {wrong # args: should be "string subcommand ?arg ...?"}}
test stringComp-1.3.$noComp {error condition - undefined method during compile} {
# We don't want this to complain about 'never' because it may never
# be called, or string may get redefined. This must compile OK.
proc foo {str i} {
if {"yes" == "no"} { string never called but complains here }
string index $str $i
}
foo abc 0
} a
test string-2.1.$noComp {string compare, too few args} {
list [catch {run {string compare a}} msg] $msg
} {1 {wrong # args: should be "string compare ?-nocase? ?-length int? string1 string2"}}
test string-2.2.$noComp {string compare, bad args} {
list [catch {run {string compare a b c}} msg] $msg
} {1 {bad option "a": must be -nocase or -length}}
test string-2.3.$noComp {string compare, bad args} {
list [catch {run {string compare -length -nocase str1 str2}} msg] $msg
} {1 {expected integer but got "-nocase"}}
test string-2.4.$noComp {string compare, too many args} {
list [catch {run {string compare -length 10 -nocase str1 str2 str3}} msg] $msg
} {1 {wrong # args: should be "string compare ?-nocase? ?-length int? string1 string2"}}
test string-2.5.$noComp {string compare with length unspecified} {
list [catch {run {string compare -length 10 10}} msg] $msg
} {1 {wrong # args: should be "string compare ?-nocase? ?-length int? string1 string2"}}
test string-2.6.$noComp {string compare} {
run {string compare abcde abdef}
} -1
test string-2.7.$noComp {string compare, shortest method name} {
run {string co abcde ABCDE}
} 1
test string-2.8.$noComp {string compare} {
run {string compare abcde abcde}
} 0
test string-2.9.$noComp {string compare with length} {
run {string compare -length 2 abcde abxyz}
} 0
test string-2.10.$noComp {string compare with special index} {
list [catch {run {string compare -length end-3 abcde abxyz}} msg] $msg
} {1 {expected integer but got "end-3"}}
test string-2.11.$noComp {string compare, unicode} {
run {string compare ab\u7266 ab\u7267}
} -1
test string-2.11.1.$noComp {string compare, unicode} {
run {string compare \334 \u00dc}
} 0
test string-2.11.2.$noComp {string compare, unicode} {
run {string compare \334 \u00fc}
} -1
test string-2.11.3.$noComp {string compare, unicode} {
run {string compare \334\334\334\374\374 \334\334\334\334\334}
} 1
test string-2.12.$noComp {string compare, high bit} {
# This test will fail if the underlying comparaison
# is using signed chars instead of unsigned chars.
# (like SunOS's default memcmp thus the compat/memcmp.c)
run {string compare "\x80" "@"}
# Nb this tests works also in utf8 space because \x80 is
# translated into a 2 or more bytelength but whose first byte has
# the high bit set.
} 1
test string-2.13.$noComp {string compare -nocase} {
run {string compare -nocase abcde abdef}
} -1
test string-2.13.1.$noComp {string compare -nocase} {
run {string compare -nocase abcde Abdef}
} -1
test string-2.14.$noComp {string compare -nocase} {
run {string compare -nocase abcde ABCDE}
} 0
test string-2.15.$noComp {string compare -nocase} {
run {string compare -nocase abcde abcde}
} 0
test string-2.15.1.$noComp {string compare -nocase} {
run {string compare -nocase \334 \u00dc}
} 0
test string-2.15.2.$noComp {string compare -nocase} {
run {string compare -nocase \334\334\334\374\u00fc \334\334\334\334\334}
} 0
test string-2.16.$noComp {string compare -nocase with length} {
run {string compare -length 2 -nocase abcde Abxyz}
} 0
test string-2.17.$noComp {string compare -nocase with length} {
run {string compare -nocase -length 3 abcde Abxyz}
} -1
test string-2.18.$noComp {string compare -nocase with length <= 0} {
run {string compare -nocase -length -1 abcde AbCdEf}
} -1
test string-2.19.$noComp {string compare -nocase with excessive length} {
run {string compare -nocase -length 50 AbCdEf abcde}
} 1
test string-2.20.$noComp {string compare -len unicode} {
# These are strings that are 6 BYTELENGTH long, but the length
# shouldn't make a different because there are actually 3 CHARS long
run {string compare -len 5 \334\334\334 \334\334\374}
} -1
test string-2.21.$noComp {string compare -nocase with special index} {
list [catch {run {string compare -nocase -length end-3 Abcde abxyz}} msg] $msg
} {1 {expected integer but got "end-3"}}
test string-2.22.$noComp {string compare, null strings} {
run {string compare "" ""}
} 0
test string-2.23.$noComp {string compare, null strings} {
run {string compare "" foo}
} -1
test string-2.24.$noComp {string compare, null strings} {
run {string compare foo ""}
} 1
test string-2.25.$noComp {string compare -nocase, null strings} {
run {string compare -nocase "" ""}
} 0
test string-2.26.$noComp {string compare -nocase, null strings} {
run {string compare -nocase "" foo}
} -1
test string-2.27.$noComp {string compare -nocase, null strings} {
run {string compare -nocase foo ""}
} 1
test string-2.28.$noComp {string compare with length, unequal strings} {
run {string compare -length 2 abc abde}
} 0
test string-2.29.$noComp {string compare with length, unequal strings} {
run {string compare -length 2 ab abde}
} 0
test string-2.30.$noComp {string compare with NUL character vs. other ASCII} {
# Be careful here, since UTF-8 rep comparison with memcmp() of
# these puts chars in the wrong order
run {string compare \x00 \x01}
} -1
test string-2.31.$noComp {string compare, high bit} {
run {string compare "a\x80" "a@"}
} 1
test string-2.32.$noComp {string compare, high bit} {
run {string compare "a\x00" "a\x01"}
} -1
test string-2.33.$noComp {string compare, high bit} {
run {string compare "\x00\x00" "\x00\x01"}
} -1
test string-2.34.$noComp {string compare, binary equal} {
run {string compare [binary format a100 0] [binary format a100 0]}
} 0
test string-2.35.$noComp {string compare, binary neq} {
run {string compare [binary format a100a 0 1] [binary format a100a 0 0]}
} 1
test string-2.36.$noComp {string compare, binary neq unequal length} {
run {string compare [binary format a20a 0 1] [binary format a100a 0 0]}
} 1
# only need a few tests on equal, since it uses the same code as
# string compare, but just modifies the return output
test string-3.1.$noComp {string equal} {
run {string equal abcde abdef}
} 0
test string-3.2.$noComp {string equal} {
run {string e abcde ABCDE}
} 0
test string-3.3.$noComp {string equal} {
run {string equal abcde abcde}
} 1
test string-3.4.$noComp {string equal -nocase} {
run {string equal -nocase \334\334\334\334\374\374\374\374 \334\334\334\334\334\334\334\334}
} 1
test string-3.5.$noComp {string equal -nocase} {
run {string equal -nocase abcde abdef}
} 0
test string-3.6.$noComp {string equal -nocase} {
run {string eq -nocase abcde ABCDE}
} 1
test string-3.7.$noComp {string equal -nocase} {
run {string equal -nocase abcde abcde}
} 1
test string-3.8.$noComp {string equal with length, unequal strings} {
run {string equal -length 2 abc abde}
} 1
test string-3.9.$noComp {string equal, too few args} {
list [catch {run {string equal a}} msg] $msg
} {1 {wrong # args: should be "string equal ?-nocase? ?-length int? string1 string2"}}
test string-3.10.$noComp {string equal, bad args} {
list [catch {run {string equal a b c}} msg] $msg
} {1 {bad option "a": must be -nocase or -length}}
test string-3.11.$noComp {string equal, bad args} {
list [catch {run {string equal -length -nocase str1 str2}} msg] $msg
} {1 {expected integer but got "-nocase"}}
test string-3.12.$noComp {string equal, too many args} {
list [catch {run {string equal -length 10 -nocase str1 str2 str3}} msg] $msg
} {1 {wrong # args: should be "string equal ?-nocase? ?-length int? string1 string2"}}
test string-3.13.$noComp {string equal with length unspecified} {
list [catch {run {string equal -length 10 10}} msg] $msg
} {1 {wrong # args: should be "string equal ?-nocase? ?-length int? string1 string2"}}
test string-3.14.$noComp {string equal with length} {
run {string equal -length 2 abcde abxyz}
} 1
test string-3.15.$noComp {string equal with special index} {
list [catch {run {string equal -length end-3 abcde abxyz}} msg] $msg
} {1 {expected integer but got "end-3"}}
test string-3.16.$noComp {string equal, unicode} {
run {string equal ab\u7266 ab\u7267}
} 0
test string-3.17.$noComp {string equal, unicode} {
run {string equal \334 \u00dc}
} 1
test string-3.18.$noComp {string equal, unicode} {
run {string equal \334 \u00fc}
} 0
test string-3.19.$noComp {string equal, unicode} {
run {string equal \334\334\334\374\374 \334\334\334\334\334}
} 0
test string-3.20.$noComp {string equal, high bit} {
# This test will fail if the underlying comparaison
# is using signed chars instead of unsigned chars.
# (like SunOS's default memcmp thus the compat/memcmp.c)
run {string equal "\x80" "@"}
# Nb this tests works also in utf8 space because \x80 is
# translated into a 2 or more bytelength but whose first byte has
# the high bit set.
} 0
test string-3.21.$noComp {string equal -nocase} {
run {string equal -nocase abcde Abdef}
} 0
test string-3.22.$noComp {string equal, -nocase unicode} {
run {string equal -nocase \334 \u00dc}
} 1
test string-3.23.$noComp {string equal, -nocase unicode} {
run {string equal -nocase \334\334\334\374\u00fc \334\334\334\334\334}
} 1
test string-3.24.$noComp {string equal -nocase with length} {
run {string equal -length 2 -nocase abcde Abxyz}
} 1
test string-3.25.$noComp {string equal -nocase with length} {
run {string equal -nocase -length 3 abcde Abxyz}
} 0
test string-3.26.$noComp {string equal -nocase with length <= 0} {
run {string equal -nocase -length -1 abcde AbCdEf}
} 0
test string-3.27.$noComp {string equal -nocase with excessive length} {
run {string equal -nocase -length 50 AbCdEf abcde}
} 0
test string-3.28.$noComp {string equal -len unicode} {
# These are strings that are 6 BYTELENGTH long, but the length
# shouldn't make a different because there are actually 3 CHARS long
run {string equal -len 5 \334\334\334 \334\334\374}
} 0
test string-3.29.$noComp {string equal -nocase with special index} {
list [catch {run {string equal -nocase -length end-3 Abcde abxyz}} msg] $msg
} {1 {expected integer but got "end-3"}}
test string-3.30.$noComp {string equal, null strings} {
run {string equal "" ""}
} 1
test string-3.31.$noComp {string equal, null strings} {
run {string equal "" foo}
} 0
test string-3.32.$noComp {string equal, null strings} {
run {string equal foo ""}
} 0
test string-3.33.$noComp {string equal -nocase, null strings} {
run {string equal -nocase "" ""}
} 1
test string-3.34.$noComp {string equal -nocase, null strings} {
run {string equal -nocase "" foo}
} 0
test string-3.35.$noComp {string equal -nocase, null strings} {
run {string equal -nocase foo ""}
} 0
test string-3.36.$noComp {string equal with NUL character vs. other ASCII} {
# Be careful here, since UTF-8 rep comparison with memcmp() of
# these puts chars in the wrong order
run {string equal \x00 \x01}
} 0
test string-3.37.$noComp {string equal, high bit} {
run {string equal "a\x80" "a@"}
} 0
test string-3.38.$noComp {string equal, high bit} {
run {string equal "a\x00" "a\x01"}
} 0
test string-3.39.$noComp {string equal, high bit} {
run {string equal "a\x00\x00" "a\x00\x01"}
} 0
test string-3.40.$noComp {string equal, binary equal} {
run {string equal [binary format a100 0] [binary format a100 0]}
} 1
test string-3.41.$noComp {string equal, binary neq} {
run {string equal [binary format a100a 0 1] [binary format a100a 0 0]}
} 0
test string-3.42.$noComp {string equal, binary neq inequal length} {
run {string equal [binary format a20a 0 1] [binary format a100a 0 0]}
} 0
test string-4.1.$noComp {string first, too few args} {
list [catch {run {string first a}} msg] $msg
} {1 {wrong # args: should be "string first needleString haystackString ?startIndex?"}}
test string-4.2.$noComp {string first, bad args} {
list [catch {run {string first a b c}} msg] $msg
} {1 {bad index "c": must be integer?[+-]integer? or end?[+-]integer?}}
test string-4.3.$noComp {string first, too many args} {
list [catch {run {string first a b 5 d}} msg] $msg
} {1 {wrong # args: should be "string first needleString haystackString ?startIndex?"}}
test string-4.4.$noComp {string first} {
run {string first bq abcdefgbcefgbqrs}
} 12
test string-4.5.$noComp {string first} {
run {string fir bcd abcdefgbcefgbqrs}
} 1
test string-4.6.$noComp {string first} {
run {string f b abcdefgbcefgbqrs}
} 1
test string-4.7.$noComp {string first} {
run {string first xxx x123xx345xxx789xxx012}
} 9
test string-4.8.$noComp {string first} {
run {string first "" x123xx345xxx789xxx012}
} -1
test string-4.9.$noComp {string first, unicode} {
run {string first x abc\u7266x}
} 4
test string-4.10.$noComp {string first, unicode} {
run {string first \u7266 abc\u7266x}
} 3
test string-4.11.$noComp {string first, start index} {
run {string first \u7266 abc\u7266x 3}
} 3
test string-4.12.$noComp {string first, start index} {
run {string first \u7266 abc\u7266x 4}
} -1
test string-4.13.$noComp {string first, start index} {
run {string first \u7266 abc\u7266x end-2}
} 3
test string-4.14.$noComp {string first, negative start index} {
run {string first b abc -1}
} 1
test string-4.15.$noComp {string first, ability to two-byte encoded utf-8 chars} {
# Test for a bug in Tcl 8.3 where test for all-single-byte-encoded
# strings was incorrect, leading to an index returned by [string first]
# which pointed past the end of the string.
set uchar \u057e ;# character with two-byte encoding in utf-8
run {string first % %#$uchar$uchar#$uchar$uchar#% 3}
} 8
test string-4.16.$noComp {string first, normal string vs pure unicode string} {
set s hello
regexp ll $s m
# Representation checks are canaries
run {list [representationpoke $s] [representationpoke $m] \
[string first $m $s]}
} {{string 1} {string 0} 2}
test string-4.17.$noComp {string first, corner case} {
run {string first a aaa 4294967295}
} {-1}
test string-4.18.$noComp {string first, corner case} {
run {string first a aaa -1}
} {0}
test string-4.19.$noComp {string first, corner case} {
run {string first a aaa end-5}
} {0}
test string-4.20.$noComp {string last, corner case} {
run {string last a aaa 4294967295}
} {2}
test string-4.21.$noComp {string last, corner case} {
run {string last a aaa -1}
} {-1}
test string-4.22.$noComp {string last, corner case} {
run {string last a aaa end-5}
} {-1}
test string-5.1.$noComp {string index} {
list [catch {run {string index}} msg] $msg
} {1 {wrong # args: should be "string index string charIndex"}}
test string-5.2.$noComp {string index} {
list [catch {run {string index a b c}} msg] $msg
} {1 {wrong # args: should be "string index string charIndex"}}
test string-5.3.$noComp {string index} {
run {string index abcde 0}
} a
test string-5.4.$noComp {string index} {
run {string ind abcde 4}
} e
test string-5.5.$noComp {string index} {
run {string index abcde 5}
} {}
test string-5.6.$noComp {string index} {
list [catch {run {string index abcde -10}} msg] $msg
} {0 {}}
test string-5.7.$noComp {string index} {
list [catch {run {string index a xyz}} msg] $msg
} {1 {bad index "xyz": must be integer?[+-]integer? or end?[+-]integer?}}
test string-5.8.$noComp {string index} {
run {string index abc end}
} c
test string-5.9.$noComp {string index} {
run {string index abc end-1}
} b
test string-5.10.$noComp {string index, unicode} {
run {string index abc\u7266d 4}
} d
test string-5.11.$noComp {string index, unicode} {
run {string index abc\u7266d 3}
} \u7266
test string-5.12.$noComp {string index, unicode over char length, under byte length} {
run {string index \334\374\334\374 6}
} {}
test string-5.13.$noComp {string index, bytearray object} {
run {string index [binary format a5 fuz] 0}
} f
test string-5.14.$noComp {string index, bytearray object} {
run {string index [binary format I* {0x50515253 0x52}] 3}
} S
test string-5.15.$noComp {string index, bytearray object} {
set b [binary format I* {0x50515253 0x52}]
set i1 [run {string index $b end-6}]
set i2 [run {string index $b 1}]
run {string compare $i1 $i2}
} 0
test string-5.16.$noComp {string index, bytearray object with string obj shimmering} {
set str "0123456789\x00 abcdedfghi"
binary scan $str H* dump
run {string compare [run {string index $str 10}] \x00}
} 0
test string-5.17.$noComp {string index, bad integer} -body {
list [catch {run {string index "abc" 0o8}} msg] $msg
} -match glob -result {1 {*}}
test string-5.18.$noComp {string index, bad integer} -body {
list [catch {run {string index "abc" end-0o0289}} msg] $msg
} -match glob -result {1 {*}}
test string-5.19.$noComp {string index, bytearray object out of bounds} {
run {string index [binary format I* {0x50515253 0x52}] -1}
} {}
test string-5.20.$noComp {string index, bytearray object out of bounds} {
run {string index [binary format I* {0x50515253 0x52}] 20}
} {}
test string-5.21.$noComp {string index, surrogates, bug [11ae2be95dac9417]} tip389 {
run {list [string index a\U100000b 1] [string index a\U100000b 2] [string index a\U100000b 3]}
} [list \U100000 {} b]
proc largest_int {} {
# This will give us what the largest valid int on this machine is,
# so we can test for overflow properly below on >32 bit systems
set int 1
set exp 7; # assume we get at least 8 bits
while {wide($int) > 0} { set int [expr {wide(1) << [incr exp]}] }
return [expr {$int-1}]
}
test string-6.1.$noComp {string is, too few args} {
list [catch {run {string is}} msg] $msg
} {1 {wrong # args: should be "string is class ?-strict? ?-failindex var? str"}}
test string-6.2.$noComp {string is, too few args} {
list [catch {run {string is alpha}} msg] $msg
} {1 {wrong # args: should be "string is class ?-strict? ?-failindex var? str"}}
test string-6.3.$noComp {string is, bad args} {
list [catch {run {string is alpha -failin str}} msg] $msg
} {1 {wrong # args: should be "string is alpha ?-strict? ?-failindex var? str"}}
test string-6.4.$noComp {string is, too many args} {
list [catch {run {string is alpha -failin var -strict str more}} msg] $msg
} {1 {wrong # args: should be "string is class ?-strict? ?-failindex var? str"}}
test string-6.5.$noComp {string is, class check} {
list [catch {run {string is bogus str}} msg] $msg
} {1 {bad class "bogus": must be alnum, alpha, ascii, control, boolean, dict, digit, double, entier, false, graph, integer, list, lower, print, punct, space, true, upper, wideinteger, wordchar, or xdigit}}
test string-6.6.$noComp {string is, ambiguous class} {
list [catch {run {string is al str}} msg] $msg
} {1 {ambiguous class "al": must be alnum, alpha, ascii, control, boolean, dict, digit, double, entier, false, graph, integer, list, lower, print, punct, space, true, upper, wideinteger, wordchar, or xdigit}}
test string-6.7.$noComp {string is alpha, all ok} {
run {string is alpha -strict -failindex var abc}
} 1
test string-6.8.$noComp {string is, error in var} {
list [run {string is alpha -failindex var abc5def}] $var
} {0 3}
test string-6.9.$noComp {string is, var shouldn't get set} {
catch {unset var}
list [catch {run {string is alpha -failindex var abc; set var}} msg] $msg
} {1 {can't read "var": no such variable}}
test string-6.10.$noComp {string is, ok on empty} {
run {string is alpha {}}
} 1
test string-6.11.$noComp {string is, -strict check against empty} {
run {string is alpha -strict {}}
} 0
test string-6.12.$noComp {string is alnum, true} {
run {string is alnum abc123}
} 1
test string-6.13.$noComp {string is alnum, false} {
list [run {string is alnum -failindex var abc1.23}] $var
} {0 4}
test string-6.14.$noComp {string is alnum, unicode} "run {string is alnum abc\xfc}" 1
test string-6.15.$noComp {string is alpha, true} {
run {string is alpha abc}
} 1
test string-6.16.$noComp {string is alpha, false} {
list [run {string is alpha -fail var a1bcde}] $var
} {0 1}
test string-6.17.$noComp {string is alpha, unicode} {
run {string is alpha abc\374}
} 1
test string-6.18.$noComp {string is ascii, true} {
run {string is ascii abc\u007Fend\u0000}
} 1
test string-6.19.$noComp {string is ascii, false} {
list [run {string is ascii -fail var abc\u0000def\u0080more}] $var
} {0 7}
test string-6.20.$noComp {string is boolean, true} {
run {string is boolean true}
} 1
test string-6.21.$noComp {string is boolean, true} {
run {string is boolean f}
} 1
test string-6.22.$noComp {string is boolean, true based on type} {
run {string is bool [run {string compare a a}]}
} 1
test string-6.23.$noComp {string is boolean, false} {
list [run {string is bool -fail var yada}] $var
} {0 0}
test string-6.24.$noComp {string is digit, true} {
run {string is digit 0123456789}
} 1
test string-6.25.$noComp {string is digit, false} {
list [run {string is digit -fail var 0123\u00dc567}] $var
} {0 4}
test string-6.26.$noComp {string is digit, false} {
list [run {string is digit -fail var +123567}] $var
} {0 0}
test string-6.27.$noComp {string is double, true} {
run {string is double 1}
} 1
test string-6.28.$noComp {string is double, true} {
run {string is double [expr double(1)]}
} 1
test string-6.29.$noComp {string is double, true} {
run {string is double 1.0}
} 1
test string-6.30.$noComp {string is double, true} {
run {string is double [run {string compare a a}]}
} 1
test string-6.31.$noComp {string is double, true} {
run {string is double " +1.0e-1 "}
} 1
test string-6.32.$noComp {string is double, true} {
run {string is double "\n1.0\v"}
} 1
test string-6.33.$noComp {string is double, false} {
list [run {string is double -fail var 1abc}] $var
} {0 1}
test string-6.34.$noComp {string is double, false} {
list [run {string is double -fail var abc}] $var
} {0 0}
test string-6.35.$noComp {string is double, false} {
list [run {string is double -fail var " 1.0e4e4 "}] $var
} {0 8}
test string-6.36.$noComp {string is double, false} {
list [run {string is double -fail var "\n"}] $var
} {0 0}
test string-6.37.$noComp {string is double, false on int overflow} -setup {
set var priorValue
} -body {
# Make it the largest int recognizable, with one more digit for overflow
# Since bignums arrived in Tcl 8.5, the sense of this test changed.
# Now integer values that exceed native limits become bignums, and
# bignums can convert to doubles without error.
list [run {string is double -fail var [largest_int]0}] $var
} -result {1 priorValue}
# string-6.38 removed, underflow on input is no longer an error.
test string-6.39.$noComp {string is double, false} {
# This test is non-portable because IRIX thinks
# that .e1 is a valid double - this is really a bug
# on IRIX as .e1 should NOT be a valid double
#
# Portable now. Tcl 8.5 does its own double parsing.
list [run {string is double -fail var .e1}] $var
} {0 0}
test string-6.40.$noComp {string is false, true} {
run {string is false false}
} 1
test string-6.41.$noComp {string is false, true} {
run {string is false FaLsE}
} 1
test string-6.42.$noComp {string is false, true} {
run {string is false N}
} 1
test string-6.43.$noComp {string is false, true} {
run {string is false 0}
} 1
test string-6.44.$noComp {string is false, true} {
run {string is false off}
} 1
test string-6.45.$noComp {string is false, false} {
list [run {string is false -fail var abc}] $var
} {0 0}
test string-6.46.$noComp {string is false, false} {
catch {unset var}
list [run {string is false -fail var Y}] $var
} {0 0}
test string-6.47.$noComp {string is false, false} {
catch {unset var}
list [run {string is false -fail var offensive}] $var
} {0 0}
test string-6.48.$noComp {string is integer, true} {
run {string is integer +1234567890}
} 1
test string-6.49.$noComp {string is integer, true on type} {
run {string is integer [expr int(50.0)]}
} 1
test string-6.50.$noComp {string is integer, true} {
run {string is integer [list -10]}
} 1
test string-6.51.$noComp {string is integer, true as hex} {
run {string is integer 0xabcdef}
} 1
test string-6.52.$noComp {string is integer, true as octal} {
run {string is integer 012345}
} 1
test string-6.53.$noComp {string is integer, true with whitespace} {
run {string is integer " \n1234\v"}
} 1
test string-6.54.$noComp {string is integer, false} {
list [run {string is integer -fail var 123abc}] $var
} {0 3}
test string-6.55.$noComp {string is integer, no overflow possible} {
run {string is integer +[largest_int]0}
} 1
test string-6.56.$noComp {string is integer, false} {
list [run {string is integer -fail var [expr double(1)]}] $var
} {0 1}
test string-6.57.$noComp {string is integer, false} {
list [run {string is integer -fail var " "}] $var
} {0 0}
test string-6.58.$noComp {string is integer, false on bad octal} {
list [run {string is integer -fail var 0o36963}] $var
} {0 4}
test string-6.58.1.$noComp {string is integer, false on bad octal} {
list [run {string is integer -fail var 0o36963}] $var
} {0 4}
test string-6.59.$noComp {string is integer, false on bad hex} {
list [run {string is integer -fail var 0X345XYZ}] $var
} {0 5}
test string-6.60.$noComp {string is lower, true} {
run {string is lower abc}
} 1
test string-6.61.$noComp {string is lower, unicode true} {
run {string is lower abc\u00fcue}
} 1
test string-6.62.$noComp {string is lower, false} {
list [run {string is lower -fail var aBc}] $var
} {0 1}
test string-6.63.$noComp {string is lower, false} {
list [run {string is lower -fail var abc1}] $var
} {0 3}
test string-6.64.$noComp {string is lower, unicode false} {
list [run {string is lower -fail var ab\u00dcUE}] $var
} {0 2}
test string-6.65.$noComp {string is space, true} {
run {string is space " \t\n\v\f"}
} 1
test string-6.66.$noComp {string is space, false} {
list [run {string is space -fail var " \t\n\v1\f"}] $var
} {0 4}
test string-6.67.$noComp {string is true, true} {
run {string is true true}
} 1
test string-6.68.$noComp {string is true, true} {
run {string is true TrU}
} 1
test string-6.69.$noComp {string is true, true} {
run {string is true ye}
} 1
test string-6.70.$noComp {string is true, true} {
run {string is true 1}
} 1
test string-6.71.$noComp {string is true, true} {
run {string is true on}
} 1
test string-6.72.$noComp {string is true, false} {
list [run {string is true -fail var onto}] $var
} {0 0}
test string-6.73.$noComp {string is true, false} {
catch {unset var}
list [run {string is true -fail var 25}] $var
} {0 0}
test string-6.74.$noComp {string is true, false} {
catch {unset var}
list [run {string is true -fail var no}] $var
} {0 0}
test string-6.75.$noComp {string is upper, true} {
run {string is upper ABC}
} 1
test string-6.76.$noComp {string is upper, unicode true} {
run {string is upper ABC\u00dcUE}
} 1
test string-6.77.$noComp {string is upper, false} {
list [run {string is upper -fail var AbC}] $var
} {0 1}
test string-6.78.$noComp {string is upper, false} {
list [run {string is upper -fail var AB2C}] $var
} {0 2}
test string-6.79.$noComp {string is upper, unicode false} {
list [run {string is upper -fail var ABC\u00fcue}] $var
} {0 3}
test string-6.80.$noComp {string is wordchar, true} {
run {string is wordchar abc_123}
} 1
test string-6.81.$noComp {string is wordchar, unicode true} {
run {string is wordchar abc\u00fcab\u00dcAB\u5001}
} 1
test string-6.82.$noComp {string is wordchar, false} {
list [run {string is wordchar -fail var abcd.ef}] $var
} {0 4}
test string-6.83.$noComp {string is wordchar, unicode false} {
list [run {string is wordchar -fail var abc\u0080def}] $var
} {0 3}
test string-6.84.$noComp {string is control} {
## Control chars are in the ranges
## 00..1F && 7F..9F
list [run {string is control -fail var \x00\x01\x10\x1F\x7F\x80\x9F\x60}] $var
} {0 7}
test string-6.85.$noComp {string is control} {
run {string is control \u0100}
} 0
test string-6.86.$noComp {string is graph} {
## graph is any print char, except space
list [run {string is gra -fail var "0123abc!@#\$\u0100\UE0100\UE01EF "}] $var
} {0 14}
test string-6.87.$noComp {string is print} {
## basically any printable char
list [run {string is print -fail var "0123abc!@#\$\u0100 \UE0100\UE01EF\u0010"}] $var
} {0 15}
test string-6.88.$noComp {string is punct} {
## any graph char that isn't alnum
list [run {string is punct -fail var "_!@#\u00beq0"}] $var
} {0 4}
test string-6.89.$noComp {string is xdigit} {
list [run {string is xdigit -fail var 0123456789\u0061bcdefABCDEFg}] $var
} {0 22}
test string-6.90.$noComp {string is integer, bad integers} {
# SF bug #634856
set result ""
set numbers [list 1 +1 ++1 +-1 -+1 -1 --1 "- +1"]
foreach num $numbers {
lappend result [run {string is int -strict $num}]
}
return $result
} {1 1 0 0 0 1 0 0}
test string-6.91.$noComp {string is double, bad doubles} {
set result ""
set numbers [list 1.0 +1.0 ++1.0 +-1.0 -+1.0 -1.0 --1.0 "- +1.0"]
foreach num $numbers {
lappend result [run {string is double -strict $num}]
}
return $result
} {1 1 0 0 0 1 0 0}
test string-6.92.$noComp {string is integer, no 64-bit overflow} {
# Bug 718878
set x 0x10000000000000000
run {string is integer $x}
} 1
test string-6.93.$noComp {string is integer, no 64-bit overflow} {
# Bug 718878
set x 0x10000000000000000
append x ""
run {string is integer $x}
} 1
test string-6.94.$noComp {string is integer, no 64-bit overflow} {
# Bug 718878
set x 0x10000000000000000
run {string is integer [expr {$x}]}
} 1
test string-6.95.$noComp {string is wideinteger, true} {
run {string is wideinteger +1234567890}
} 1
test string-6.96.$noComp {string is wideinteger, true on type} {
run {string is wideinteger [expr wide(50.0)]}
} 1
test string-6.97.$noComp {string is wideinteger, true} {
run {string is wideinteger [list -10]}
} 1
test string-6.98.$noComp {string is wideinteger, true as hex} {
run {string is wideinteger 0xabcdef}
} 1
test string-6.99.$noComp {string is wideinteger, true as octal} {
run {string is wideinteger 0123456}
} 1
test string-6.100.$noComp {string is wideinteger, true with whitespace} {
run {string is wideinteger " \n1234\v"}
} 1
test string-6.101.$noComp {string is wideinteger, false} {
list [run {string is wideinteger -fail var 123abc}] $var
} {0 3}
test string-6.102.$noComp {string is wideinteger, false on overflow} {
list [run {string is wideinteger -fail var +[largest_int]0}] $var
} {0 -1}
test string-6.103.$noComp {string is wideinteger, false} {
list [run {string is wideinteger -fail var [expr double(1)]}] $var
} {0 1}
test string-6.104.$noComp {string is wideinteger, false} {
list [run {string is wideinteger -fail var " "}] $var
} {0 0}
test string-6.105.$noComp {string is wideinteger, false on bad octal} {
list [run {string is wideinteger -fail var 0o36963}] $var
} {0 4}
test string-6.105.1.$noComp {string is wideinteger, false on bad octal} {
list [run {string is wideinteger -fail var 0o36963}] $var
} {0 4}
test string-6.106.$noComp {string is wideinteger, false on bad hex} {
list [run {string is wideinteger -fail var 0X345XYZ}] $var
} {0 5}
test string-6.107.$noComp {string is integer, bad integers} {
# SF bug #634856
set result ""
set numbers [list 1 +1 ++1 +-1 -+1 -1 --1 "- +1"]
foreach num $numbers {
lappend result [run {string is wideinteger -strict $num}]
}
return $result
} {1 1 0 0 0 1 0 0}
test string-6.108.$noComp {string is double, Bug 1382287} {
set x 2turtledoves
run {string is double $x}
run {string is double $x}
} 0
test string-6.109.$noComp {string is double, Bug 1360532} {
run {string is double 1\u00a0}
} 0
test string-6.110.$noComp {string is entier, true} {
run {string is entier +1234567890}
} 1
test string-6.111.$noComp {string is entier, true on type} {
run {string is entier [expr wide(50.0)]}
} 1
test string-6.112.$noComp {string is entier, true} {
run {string is entier [list -10]}
} 1
test string-6.113.$noComp {string is entier, true as hex} {
run {string is entier 0xabcdef}
} 1
test string-6.114.$noComp {string is entier, true as octal} {
run {string is entier 0123456}
} 1
test string-6.115.$noComp {string is entier, true with whitespace} {
run {string is entier " \n1234\v"}
} 1
test string-6.116.$noComp {string is entier, false} {
list [run {string is entier -fail var 123abc}] $var
} {0 3}
test string-6.117.$noComp {string is entier, false} {
list [run {string is entier -fail var 123123123123123123123123123123123123123123123123123123123123123123123123123123123123abc}] $var
} {0 84}
test string-6.118.$noComp {string is entier, false} {
list [run {string is entier -fail var [expr double(1)]}] $var
} {0 1}
test string-6.119.$noComp {string is entier, false} {
list [run {string is entier -fail var " "}] $var
} {0 0}
test string-6.120.$noComp {string is entier, false on bad octal} {
list [run {string is entier -fail var 0o36963}] $var
} {0 4}
test string-6.121.1.$noComp {string is entier, false on bad octal} {
list [run {string is entier -fail var 0o36963}] $var
} {0 4}
test string-6.122.$noComp {string is entier, false on bad hex} {
list [run {string is entier -fail var 0X345XYZ}] $var
} {0 5}
test string-6.123.$noComp {string is entier, bad integers} {
# SF bug #634856
set result ""
set numbers [list 1 +1 ++1 +-1 -+1 -1 --1 "- +1"]
foreach num $numbers {
lappend result [run {string is entier -strict $num}]
}
return $result
} {1 1 0 0 0 1 0 0}
test string-6.124.$noComp {string is entier, true} {
run {string is entier +1234567890123456789012345678901234567890}
} 1
test string-6.125.$noComp {string is entier, true} {
run {string is entier [list -10000000000000000000000000000000000000000000000000000000000000000000000000000000000000]}
} 1
test string-6.126.$noComp {string is entier, true as hex} {
run {string is entier 0xabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdef}
} 1
test string-6.127.$noComp {string is entier, true as octal} {
run {string is entier 0123456112341234561234565623456123456123456123456123456123456123456123456123456123456}
} 1
test string-6.128.$noComp {string is entier, true with whitespace} {
run {string is entier " \n12340000000000000000000000000000000000000000000000000000000000000000000000000000000000000\v"}
} 1
test string-6.129.$noComp {string is entier, false on bad octal} {
list [run {string is entier -fail var 0o1234561123412345612345656234561234561234561234561234561234561234561234561234561234536963}] $var
} {0 87}
test string-6.130.1.$noComp {string is entier, false on bad octal} {
list [run {string is entier -fail var 0o1234561123412345612345656234561234561234561234561234561234561234561234561234561234536963}] $var
} {0 87}
test string-6.131.$noComp {string is entier, false on bad hex} {
list [run {string is entier -fail var 0X12345611234123456123456562345612345612345612345612345612345612345612345612345612345345XYZ}] $var
} {0 88}
catch {rename largest_int {}}
test string-7.1.$noComp {string last, too few args} {
list [catch {run {string last a}} msg] $msg
} {1 {wrong # args: should be "string last needleString haystackString ?lastIndex?"}}
test string-7.2.$noComp {string last, bad args} {
list [catch {run {string last a b c}} msg] $msg
} {1 {bad index "c": must be integer?[+-]integer? or end?[+-]integer?}}
test string-7.3.$noComp {string last, too many args} {
list [catch {run {string last a b c d}} msg] $msg
} {1 {wrong # args: should be "string last needleString haystackString ?lastIndex?"}}
test string-7.4.$noComp {string last} {
run {string la xxx xxxx123xx345x678}
} 1
test string-7.5.$noComp {string last} {
run {string last xx xxxx123xx345x678}
} 7
test string-7.6.$noComp {string last} {
run {string las x xxxx123xx345x678}
} 12
test string-7.7.$noComp {string last, unicode} {
run {string las x xxxx12\u7266xx345x678}
} 12
test string-7.8.$noComp {string last, unicode} {
run {string las \u7266 xxxx12\u7266xx345x678}
} 6
test string-7.9.$noComp {string last, stop index} {
run {string las \u7266 xxxx12\u7266xx345x678}
} 6
test string-7.10.$noComp {string last, unicode} {
run {string las \u7266 xxxx12\u7266xx345x678}
} 6
test string-7.11.$noComp {string last, start index} {
run {string last \u7266 abc\u7266x 3}
} 3
test string-7.12.$noComp {string last, start index} {
run {string last \u7266 abc\u7266x 2}
} -1
test string-7.13.$noComp {string last, start index} {
## Constrain to last 'a' should work
run {string last ba badbad end-1}
} 3
test string-7.14.$noComp {string last, start index} {
## Constrain to last 'b' should skip last 'ba'
run {string last ba badbad end-2}
} 0
test string-7.15.$noComp {string last, start index} {
run {string last \334a \334ad\334ad 0}
} -1
test string-7.16.$noComp {string last, start index} {
run {string last \334a \334ad\334ad end-1}
} 3
test string-8.1.$noComp {string bytelength} {
list [catch {run {string bytelength}} msg] $msg
} {1 {wrong # args: should be "string bytelength string"}}
test string-8.2.$noComp {string bytelength} {
list [catch {run {string bytelength a b}} msg] $msg
} {1 {wrong # args: should be "string bytelength string"}}
test string-8.3.$noComp {string bytelength} {
run {string bytelength "\u00c7"}
} 2
test string-8.4.$noComp {string bytelength} {
run {string b ""}
} 0
test string-9.1.$noComp {string length} {
list [catch {run {string length}} msg] $msg
} {1 {wrong # args: should be "string length string"}}
test string-9.2.$noComp {string length} {
list [catch {run {string length a b}} msg] $msg
} {1 {wrong # args: should be "string length string"}}
test string-9.3.$noComp {string length} {
run {string length "a little string"}
} 15
test string-9.4.$noComp {string length} {
run {string le ""}
} 0
test string-9.5.$noComp {string length, unicode} {
run {string le "abcd\u7266"}
} 5
test string-9.6.$noComp {string length, bytearray object} {
run {string length [binary format a5 foo]}
} 5
test string-9.7.$noComp {string length, bytearray object} {
run {string length [binary format I* {0x50515253 0x52}]}
} 8
test string-10.1.$noComp {string map, too few args} {
list [catch {run {string map}} msg] $msg
} {1 {wrong # args: should be "string map ?-nocase? charMap string"}}
test string-10.2.$noComp {string map, bad args} {
list [catch {run {string map {a b} abba oops}} msg] $msg
} {1 {bad option "a b": must be -nocase}}
test string-10.3.$noComp {string map, too many args} {
list [catch {run {string map -nocase {a b} str1 str2}} msg] $msg
} {1 {wrong # args: should be "string map ?-nocase? charMap string"}}
test string-10.4.$noComp {string map} {
run {string map {a b} abba}
} {bbbb}
test string-10.5.$noComp {string map} {
run {string map {a b} a}
} {b}
test string-10.6.$noComp {string map -nocase} {
run {string map -nocase {a b} Abba}
} {bbbb}
test string-10.7.$noComp {string map} {
run {string map {abc 321 ab * a A} aabcabaababcab}
} {A321*A*321*}
test string-10.8.$noComp {string map -nocase} {
run {string map -nocase {aBc 321 Ab * a A} aabcabaababcab}
} {A321*A*321*}
test string-10.9.$noComp {string map -nocase} {
run {string map -no {abc 321 Ab * a A} aAbCaBaAbAbcAb}
} {A321*A*321*}
test string-10.10.$noComp {string map} {
list [catch {run {string map {a b c} abba}} msg] $msg
} {1 {char map list unbalanced}}
test string-10.11.$noComp {string map, nulls} {
run {string map {\x00 NULL blah \x00nix} {qwerty}}
} {qwerty}
test string-10.12.$noComp {string map, unicode} {
run {string map [list \374 ue UE \334] "a\374ueUE\000EU"}
} aueue\334\0EU
test string-10.13.$noComp {string map, -nocase unicode} {
run {string map -nocase [list \374 ue UE \334] "a\374ueUE\000EU"}
} aue\334\334\0EU
test string-10.14.$noComp {string map, -nocase null arguments} {
run {string map -nocase {{} abc} foo}
} foo
test string-10.15.$noComp {string map, one pair case} {
run {string map -nocase {abc 32} aAbCaBaAbAbcAb}
} {a32aBaAb32Ab}
test string-10.16.$noComp {string map, one pair case} {
run {string map -nocase {ab 4321} aAbCaBaAbAbcAb}
} {a4321C4321a43214321c4321}
test string-10.17.$noComp {string map, one pair case} {
run {string map {Ab 4321} aAbCaBaAbAbcAb}
} {a4321CaBa43214321c4321}
test string-10.18.$noComp {string map, empty argument} {
run {string map -nocase {{} abc} foo}
} foo
test string-10.19.$noComp {string map, empty arguments} {
run {string map -nocase {{} abc f bar {} def} foo}
} baroo
test string-10.20.$noComp {string map, dictionaries don't alter map ordering} {
set map {aa X a Y}
list [run {string map [dict create aa X a Y] aaa}] [run {string map $map aaa}] [dict size $map] [run {string map $map aaa}]
} {XY XY 2 XY}
test string-10.20.1.$noComp {string map, dictionaries don't alter map ordering} {
set map {a X b Y a Z}
list [run {string map [dict create a X b Y a Z] aaa}] [run {string map $map aaa}] [dict size $map] [run {string map $map aaa}]
} {ZZZ XXX 2 XXX}
test string-10.21.$noComp {string map, ABR checks} {
run {string map {longstring foob} long}
} long
test string-10.22.$noComp {string map, ABR checks} {
run {string map {long foob} long}
} foob
test string-10.23.$noComp {string map, ABR checks} {
run {string map {lon foob} long}
} foobg
test string-10.24.$noComp {string map, ABR checks} {
run {string map {lon foob} longlo}
} foobglo
test string-10.25.$noComp {string map, ABR checks} {
run {string map {lon foob} longlon}
} foobgfoob
test string-10.26.$noComp {string map, ABR checks} {
run {string map {longstring foob longstring bar} long}
} long
test string-10.27.$noComp {string map, ABR checks} {
run {string map {long foob longstring bar} long}
} foob
test string-10.28.$noComp {string map, ABR checks} {
run {string map {lon foob longstring bar} long}
} foobg
test string-10.29.$noComp {string map, ABR checks} {
run {string map {lon foob longstring bar} longlo}
} foobglo
test string-10.30.$noComp {string map, ABR checks} {
run {string map {lon foob longstring bar} longlon}
} foobgfoob
test string-10.31.$noComp {string map, nasty sharing crash from [Bug 1018562]} {
set a {a b}
run {string map $a $a}
} {b b}
test string-11.1.$noComp {string match, too few args} {
list [catch {run {string match a}} msg] $msg
} {1 {wrong # args: should be "string match ?-nocase? pattern string"}}
test string-11.2.$noComp {string match, too many args} {
list [catch {run {string match a b c d}} msg] $msg
} {1 {wrong # args: should be "string match ?-nocase? pattern string"}}
test string-11.3.$noComp {string match} {
run {string match abc abc}
} 1
test string-11.4.$noComp {string match} {
run {string mat abc abd}
} 0
test string-11.5.$noComp {string match} {
run {string match ab*c abc}
} 1
test string-11.6.$noComp {string match} {
run {string match ab**c abc}
} 1
test string-11.7.$noComp {string match} {
run {string match ab* abcdef}
} 1
test string-11.8.$noComp {string match} {
run {string match *c abc}
} 1
test string-11.9.$noComp {string match} {
run {string match *3*6*9 0123456789}
} 1
test string-11.9.1.$noComp {string match} {
run {string match *3*6*89 0123456789}
} 1
test string-11.9.2.$noComp {string match} {
run {string match *3*456*89 0123456789}
} 1
test string-11.9.3.$noComp {string match} {
run {string match *3*6* 0123456789}
} 1
test string-11.9.4.$noComp {string match} {
run {string match *3*56* 0123456789}
} 1
test string-11.9.5.$noComp {string match} {
run {string match *3*456*** 0123456789}
} 1
test string-11.9.6.$noComp {string match} {
run {string match **3*456** 0123456789}
} 1
test string-11.9.7.$noComp {string match} {
run {string match *3***456* 0123456789}
} 1
test string-11.9.8.$noComp {string match} {
run {string match *3***\[456]* 0123456789}
} 1
test string-11.9.9.$noComp {string match} {
run {string match *3***\[4-6]* 0123456789}
} 1
test string-11.9.10.$noComp {string match} {
run {string match *3***\[4-6] 0123456789}
} 0
test string-11.9.11.$noComp {string match} {
run {string match *3***\[4-6] 0123456}
} 1
test string-11.10.$noComp {string match} {
run {string match *3*6*9 01234567890}
} 0
test string-11.10.1.$noComp {string match} {
run {string match *3*6*89 01234567890}
} 0
test string-11.10.2.$noComp {string match} {
run {string match *3*456*89 01234567890}
} 0
test string-11.10.3.$noComp {string match} {
run {string match **3*456*89 01234567890}
} 0
test string-11.10.4.$noComp {string match} {
run {string match *3*456***89 01234567890}
} 0
test string-11.11.$noComp {string match} {
run {string match a?c abc}
} 1
test string-11.12.$noComp {string match} {
run {string match a??c abc}
} 0
test string-11.13.$noComp {string match} {
run {string match ?1??4???8? 0123456789}
} 1
test string-11.14.$noComp {string match} {
run {string match {[abc]bc} abc}
} 1
test string-11.15.$noComp {string match} {
run {string match {a[abc]c} abc}
} 1
test string-11.16.$noComp {string match} {
run {string match {a[xyz]c} abc}
} 0
test string-11.17.$noComp {string match} {
run {string match {12[2-7]45} 12345}
} 1
test string-11.18.$noComp {string match} {
run {string match {12[ab2-4cd]45} 12345}
} 1
test string-11.19.$noComp {string match} {
run {string match {12[ab2-4cd]45} 12b45}
} 1
test string-11.20.$noComp {string match} {
run {string match {12[ab2-4cd]45} 12d45}
} 1
test string-11.21.$noComp {string match} {
run {string match {12[ab2-4cd]45} 12145}
} 0
test string-11.22.$noComp {string match} {
run {string match {12[ab2-4cd]45} 12545}
} 0
test string-11.23.$noComp {string match} {
run {string match {a\*b} a*b}
} 1
test string-11.24.$noComp {string match} {
run {string match {a\*b} ab}
} 0
test string-11.25.$noComp {string match} {
run {string match {a\*\?\[\]\\\x} "a*?\[\]\\x"}
} 1
test string-11.26.$noComp {string match} {
run {string match ** ""}
} 1
test string-11.27.$noComp {string match} {
run {string match *. ""}
} 0
test string-11.28.$noComp {string match} {
run {string match "" ""}
} 1
test string-11.29.$noComp {string match} {
run {string match \[a a}
} 1
test string-11.30.$noComp {string match, bad args} {
list [catch {run {string match - b c}} msg] $msg
} {1 {bad option "-": must be -nocase}}
test string-11.31.$noComp {string match case} {
run {string match a A}
} 0
test string-11.32.$noComp {string match nocase} {
run {string match -n a A}
} 1
test string-11.33.$noComp {string match nocase} {
run {string match -nocase a\334 A\374}
} 1
test string-11.34.$noComp {string match nocase} {
run {string match -nocase a*f ABCDEf}
} 1
test string-11.35.$noComp {string match case, false hope} {
# This is true because '_' lies between the A-Z and a-z ranges
run {string match {[A-z]} _}
} 1
test string-11.36.$noComp {string match nocase range} {
# This is false because although '_' lies between the A-Z and a-z ranges,
# we lower case the end points before checking the ranges.
run {string match -nocase {[A-z]} _}
} 0
test string-11.37.$noComp {string match nocase} {
run {string match -nocase {[A-fh-Z]} g}
} 0
test string-11.38.$noComp {string match case, reverse range} {
run {string match {[A-fh-Z]} g}
} 1
test string-11.39.$noComp {string match, *\ case} {
run {string match {*\abc} abc}
} 1
test string-11.39.1.$noComp {string match, *\ case} {
run {string match {*ab\c} abc}
} 1
test string-11.39.2.$noComp {string match, *\ case} {
run {string match {*ab\*} ab*}
} 1
test string-11.39.3.$noComp {string match, *\ case} {
run {string match {*ab\*} abc}
} 0
test string-11.39.4.$noComp {string match, *\ case} {
run {string match {*ab\\*} {ab\c}}
} 1
test string-11.39.5.$noComp {string match, *\ case} {
run {string match {*ab\\*} {ab\*}}
} 1
test string-11.40.$noComp {string match, *special case} {
run {string match {*[ab]} abc}
} 0
test string-11.41.$noComp {string match, *special case} {
run {string match {*[ab]*} abc}
} 1
test string-11.42.$noComp {string match, *special case} {
run {string match "*\\" "\\"}
} 0
test string-11.43.$noComp {string match, *special case} {
run {string match "*\\\\" "\\"}
} 1
test string-11.44.$noComp {string match, *special case} {
run {string match "*???" "12345"}
} 1
test string-11.45.$noComp {string match, *special case} {
run {string match "*???" "12"}
} 0
test string-11.46.$noComp {string match, *special case} {
run {string match "*\\*" "abc*"}
} 1
test string-11.47.$noComp {string match, *special case} {
run {string match "*\\*" "*"}
} 1
test string-11.48.$noComp {string match, *special case} {
run {string match "*\\*" "*abc"}
} 0
test string-11.49.$noComp {string match, *special case} {
run {string match "?\\*" "a*"}
} 1
test string-11.50.$noComp {string match, *special case} {
run {string match "\\" "\\"}
} 0
test string-11.51.$noComp {string match; *, -nocase and UTF-8} {
run {string match -nocase [binary format I 717316707] \
[binary format I 2028036707]}
} 1
test string-11.52.$noComp {string match, null char in string} {
set out ""
set ptn "*abc*"
foreach elem [list "\u0000@abc" "@abc" "\u0000@abc\u0000" "blahabcblah"] {
lappend out [run {string match $ptn $elem}]
}
set out
} {1 1 1 1}
test string-11.53.$noComp {string match, null char in pattern} {
set out ""
foreach {ptn elem} [list \
"*\u0000abc\u0000" "\u0000abc\u0000" \
"*\u0000abc\u0000" "\u0000abc\u0000ef" \
"*\u0000abc\u0000*" "\u0000abc\u0000ef" \
"*\u0000abc\u0000" "@\u0000abc\u0000ef" \
"*\u0000abc\u0000*" "@\u0000abc\u0000ef" \
] {
lappend out [run {string match $ptn $elem}]
}
set out
} {1 0 1 0 1}
test string-11.54.$noComp {string match, failure} {
set longString ""
for {set i 0} {$i < 10} {incr i} {
append longString "abcdefghijklmnopqrstuvwxy\u0000z01234567890123"
}
run {string first $longString 123}
list [run {string match *cba* $longString}] \
[run {string match *a*l*\u0000* $longString}] \
[run {string match *a*l*\u0000*123 $longString}] \
[run {string match *a*l*\u0000*123* $longString}] \
[run {string match *a*l*\u0000*cba* $longString}] \
[run {string match *===* $longString}]
} {0 1 1 1 0 0}
test string-11.55.$noComp {string match, invalid binary optimization} {
[format string] match \u0141 [binary format c 65]
} 0
test stringComp-12.1.0.$noComp {Bug 3588366: end-offsets before start} {
apply {s {
string range $s 0 end-5
}} 12345
} {}
test string-12.1.$noComp {string range} {
list [catch {run {string range}} msg] $msg
} {1 {wrong # args: should be "string range string first last"}}
test string-12.2.$noComp {string range} {
list [catch {run {string range a 1}} msg] $msg
} {1 {wrong # args: should be "string range string first last"}}
test string-12.3.$noComp {string range} {
list [catch {run {string range a 1 2 3}} msg] $msg
} {1 {wrong # args: should be "string range string first last"}}
test string-12.4.$noComp {string range} {
run {string range abcdefghijklmnop 2 14}
} {cdefghijklmno}
test string-12.5.$noComp {string range, last > length} {
run {string range abcdefghijklmnop 7 1000}
} {hijklmnop}
test string-12.6.$noComp {string range} {
run {string range abcdefghijklmnop 10 end}
} {klmnop}
test string-12.7.$noComp {string range, last < first} {
run {string range abcdefghijklmnop 10 9}
} {}
test string-12.8.$noComp {string range, first < 0} {
run {string range abcdefghijklmnop -3 2}
} {abc}
test string-12.9.$noComp {string range} {
run {string range abcdefghijklmnop -3 -2}
} {}
test string-12.10.$noComp {string range} {
run {string range abcdefghijklmnop 1000 1010}
} {}
test string-12.11.$noComp {string range} {
run {string range abcdefghijklmnop -100 end}
} {abcdefghijklmnop}
test string-12.12.$noComp {string range} {
list [catch {run {string range abc abc 1}} msg] $msg
} {1 {bad index "abc": must be integer?[+-]integer? or end?[+-]integer?}}
test string-12.13.$noComp {string range} {
list [catch {run {string range abc 1 eof}} msg] $msg
} {1 {bad index "eof": must be integer?[+-]integer? or end?[+-]integer?}}
test string-12.14.$noComp {string range} {
run {string range abcdefghijklmnop end-1 end}
} {op}
test string-12.15.$noComp {string range} {
run {string range abcdefghijklmnop end 1000}
} {p}
test string-12.16.$noComp {string range} {
run {string range abcdefghijklmnop end end-1}
} {}
test string-12.17.$noComp {string range, unicode} {
run {string range ab\u7266cdefghijklmnop 5 5}
} e
test string-12.18.$noComp {string range, unicode} {
run {string range ab\u7266cdefghijklmnop 2 3}
} \u7266c
test string-12.19.$noComp {string range, bytearray object} {
set b [binary format I* {0x50515253 0x52}]
set r1 [run {string range $b 1 end-1}]
set r2 [run {string range $b 1 6}]
run {string equal $r1 $r2}
} 1
test string-12.20.$noComp {string range, out of bounds indices} {
run {string range \u00ff 0 1}
} \u00ff
# Bug 1410553
test string-12.21.$noComp {string range, regenerates correct reps, bug 1410553} {
set bytes "\x00 \x03 \x41"
set rxBuffer {}
foreach ch $bytes {
append rxBuffer $ch
if {$ch eq "\x03"} {
run {string length $rxBuffer}
}
}
set rxCRC [run {string range $rxBuffer end-1 end}]
binary scan [join $bytes {}] "H*" input_hex
binary scan $rxBuffer "H*" rxBuffer_hex
binary scan $rxCRC "H*" rxCRC_hex
list $input_hex $rxBuffer_hex $rxCRC_hex
} {000341 000341 0341}
test string-12.22.$noComp {string range, shimmering binary/index} {
set s 0000000001
binary scan $s a* x
run {string range $s $s end}
} 000000001
test string-12.23.$noComp {string range, surrogates, bug [11ae2be95dac9417]} tip389 {
run {list [string range a\U100000b 1 1] [string range a\U100000b 2 2] [string range a\U100000b 3 3]}
} [list \U100000 {} b]
test string-13.1.$noComp {string repeat} {
list [catch {run {string repeat}} msg] $msg
} {1 {wrong # args: should be "string repeat string count"}}
test string-13.2.$noComp {string repeat} {
list [catch {run {string repeat abc 10 oops}} msg] $msg
} {1 {wrong # args: should be "string repeat string count"}}
test string-13.3.$noComp {string repeat} {
run {string repeat {} 100}
} {}
test string-13.4.$noComp {string repeat} {
run {string repeat { } 5}
} { }
test string-13.5.$noComp {string repeat} {
run {string repeat abc 3}
} {abcabcabc}
test string-13.6.$noComp {string repeat} {
run {string repeat abc -1}
} {}
test string-13.7.$noComp {string repeat} {
list [catch {run {string repeat abc end}} msg] $msg
} {1 {expected integer but got "end"}}
test string-13.8.$noComp {string repeat} {
run {string repeat {} -1000}
} {}
test string-13.9.$noComp {string repeat} {
run {string repeat {} 0}
} {}
test string-13.10.$noComp {string repeat} {
run {string repeat def 0}
} {}
test string-13.11.$noComp {string repeat} {
run {string repeat def 1}
} def
test string-13.12.$noComp {string repeat} {
run {string repeat ab\u7266cd 3}
} ab\u7266cdab\u7266cdab\u7266cd
test string-13.13.$noComp {string repeat} {
run {string repeat \x00 3}
} \x00\x00\x00
test string-13.14.$noComp {string repeat} {
# The string range will ensure us that string repeat gets a unicode string
run {string repeat [run {string range ab\u7266cd 2 3}] 3}
} \u7266c\u7266c\u7266c
test string-14.1.$noComp {string replace} {
list [catch {run {string replace}} msg] $msg
} {1 {wrong # args: should be "string replace string first last ?string?"}}
test string-14.2.$noComp {string replace} {
list [catch {run {string replace a 1}} msg] $msg
} {1 {wrong # args: should be "string replace string first last ?string?"}}
test string-14.3.$noComp {string replace} {
list [catch {run {string replace a 1 2 3 4}} msg] $msg
} {1 {wrong # args: should be "string replace string first last ?string?"}}
test string-14.4.$noComp {string replace} {
} {}
test string-14.5.$noComp {string replace} {
run {string replace abcdefghijklmnop 2 14}
} {abp}
test string-14.6.$noComp {string replace} {
run {string replace abcdefghijklmnop 7 1000}
} {abcdefg}
test string-14.7.$noComp {string replace} {
run {string replace abcdefghijklmnop 10 end}
} {abcdefghij}
test string-14.8.$noComp {string replace} {
run {string replace abcdefghijklmnop 10 9}
} {abcdefghijklmnop}
test string-14.9.$noComp {string replace} {
run {string replace abcdefghijklmnop -3 2}
} {defghijklmnop}
test string-14.10.$noComp {string replace} {
run {string replace abcdefghijklmnop -3 -2}
} {abcdefghijklmnop}
test string-14.11.$noComp {string replace} {
run {string replace abcdefghijklmnop 1000 1010}
} {abcdefghijklmnop}
test string-14.12.$noComp {string replace} {
run {string replace abcdefghijklmnop -100 end}
} {}
test string-14.13.$noComp {string replace} {
list [catch {run {string replace abc abc 1}} msg] $msg
} {1 {bad index "abc": must be integer?[+-]integer? or end?[+-]integer?}}
test string-14.14.$noComp {string replace} {
list [catch {run {string replace abc 1 eof}} msg] $msg
} {1 {bad index "eof": must be integer?[+-]integer? or end?[+-]integer?}}
test string-14.15.$noComp {string replace} {
run {string replace abcdefghijklmnop end-10 end-2 NEW}
} {abcdeNEWop}
test string-14.16.$noComp {string replace} {
run {string replace abcdefghijklmnop 0 end foo}
} {foo}
test string-14.17.$noComp {string replace} {
run {string replace abcdefghijklmnop end end-1}
} {abcdefghijklmnop}
test string-14.18.$noComp {string replace} {
run {string replace abcdefghijklmnop 10 9 XXX}
} {abcdefghijklmnop}
test string-14.19.$noComp {string replace} {
run {string replace {} -1 0 A}
} A
test string-14.20.$noComp {string replace} {
run {string replace [makeByteArray abcdefghijklmnop] end-10 end-2\
[makeByteArray NEW]}
} {abcdeNEWop}
test stringComp-14.21.$noComp {Bug 82e7f67325} {
apply {x {
set a [join $x {}]
lappend b [string length [string replace ___! 0 2 $a]]
lappend b [string length [string replace ___! 0 2 $a[unset a]]]
}} {a b}
} {3 3}
test stringComp-14.22.$noComp {Bug 82e7f67325} memory {
# As in stringComp-14.1, but make sure we don't retain too many refs
leaktest {
apply {x {
set a [join $x {}]
lappend b [string length [string replace ___! 0 2 $a]]
lappend b [string length [string replace ___! 0 2 $a[unset a]]]
}} {a b}
}
} {0}
test stringComp-14.23.$noComp {Bug 0dca3bfa8f} {
apply {arg {
set argCopy $arg
set arg [string replace $arg 1 2 aa]
# Crashes in comparison before fix
expr {$arg ne $argCopy}
}} abcde
} 1
test stringComp-14.24.$noComp {Bug 1af8de570511} {
apply {{x y} {
# Generate an unshared string value
set val ""
for { set i 0 } { $i < $x } { incr i } {
set val [format "0%s" $val]
}
string replace $val[unset val] 1 1 $y
}} 4 x
} 0x00
test stringComp-14.25.$noComp {} {
string length [string replace [string repeat a\u00fe 2] 3 end {}]
} 3
test string-15.1.$noComp {string tolower too few args} {
list [catch {run {string tolower}} msg] $msg
} {1 {wrong # args: should be "string tolower string ?first? ?last?"}}
test string-15.2.$noComp {string tolower bad args} {
list [catch {run {string tolower a b}} msg] $msg
} {1 {bad index "b": must be integer?[+-]integer? or end?[+-]integer?}}
test string-15.3.$noComp {string tolower too many args} {
list [catch {run {string tolower ABC 1 end oops}} msg] $msg
} {1 {wrong # args: should be "string tolower string ?first? ?last?"}}
test string-15.4.$noComp {string tolower} {
run {string tolower ABCDeF}
} {abcdef}
test string-15.5.$noComp {string tolower} {
run {string tolower "ABC XyZ"}
} {abc xyz}
test string-15.6.$noComp {string tolower} {
run {string tolower {123#$&*()}}
} {123#$&*()}
test string-15.7.$noComp {string tolower} {
run {string tolower ABC 1}
} AbC
test string-15.8.$noComp {string tolower} {
run {string tolower ABC 1 end}
} Abc
test string-15.9.$noComp {string tolower} {
run {string tolower ABC 0 end-1}
} abC
test string-15.10.$noComp {string tolower, unicode} {
run {string tolower ABCabc\xc7\xe7}
} "abcabc\xe7\xe7"
test string-15.11.$noComp {string tolower, compiled} {
lindex [run {string tolower [list A B [list C]]}] 1
} b
test string-16.1.$noComp {string toupper} {
list [catch {run {string toupper}} msg] $msg
} {1 {wrong # args: should be "string toupper string ?first? ?last?"}}
test string-16.2.$noComp {string toupper} {
list [catch {run {string toupper a b}} msg] $msg
} {1 {bad index "b": must be integer?[+-]integer? or end?[+-]integer?}}
test string-16.3.$noComp {string toupper} {
list [catch {run {string toupper a 1 end oops}} msg] $msg
} {1 {wrong # args: should be "string toupper string ?first? ?last?"}}
test string-16.4.$noComp {string toupper} {
run {string toupper abCDEf}
} {ABCDEF}
test string-16.5.$noComp {string toupper} {
run {string toupper "abc xYz"}
} {ABC XYZ}
test string-16.6.$noComp {string toupper} {
run {string toupper {123#$&*()}}
} {123#$&*()}
test string-16.7.$noComp {string toupper} {
run {string toupper abc 1}
} aBc
test string-16.8.$noComp {string toupper} {
run {string toupper abc 1 end}
} aBC
test string-16.9.$noComp {string toupper} {
run {string toupper abc 0 end-1}
} ABc
test string-16.10.$noComp {string toupper, unicode} {
run {string toupper ABCabc\xc7\xe7}
} "ABCABC\xc7\xc7"
test string-16.11.$noComp {string toupper, compiled} {
lindex [run {string toupper [list a b [list c]]}] 1
} B
test string-17.1.$noComp {string totitle} {
list [catch {run {string totitle}} msg] $msg
} {1 {wrong # args: should be "string totitle string ?first? ?last?"}}
test string-17.2.$noComp {string totitle} {
list [catch {run {string totitle a b}} msg] $msg
} {1 {bad index "b": must be integer?[+-]integer? or end?[+-]integer?}}
test string-17.3.$noComp {string totitle} {
run {string totitle abCDEf}
} {Abcdef}
test string-17.4.$noComp {string totitle} {
run {string totitle "abc xYz"}
} {Abc xyz}
test string-17.5.$noComp {string totitle} {
run {string totitle {123#$&*()}}
} {123#$&*()}
test string-17.6.$noComp {string totitle, unicode} {
run {string totitle ABCabc\xc7\xe7}
} "Abcabc\xe7\xe7"
test string-17.7.$noComp {string totitle, unicode} {
run {string totitle \u01f3BCabc\xc7\xe7}
} "\u01f2bcabc\xe7\xe7"
test string-17.8.$noComp {string totitle, compiled} {
lindex [run {string totitle [list aa bb [list cc]]}] 0
} Aa
test string-17.9.$noComp {string totitle, surrogates, bug [11ae2be95dac9417]} tip389 {
run {list [string totitle a\U118c0c 1 1] [string totitle a\U118c0c 2 2] \
[string totitle a\U118c0c 3 3]}
} [list a\U118a0c a\U118c0C a\U118c0C]
test string-18.1.$noComp {string trim} {
list [catch {run {string trim}} msg] $msg
} {1 {wrong # args: should be "string trim string ?chars?"}}
test string-18.2.$noComp {string trim} {
list [catch {run {string trim a b c}} msg] $msg
} {1 {wrong # args: should be "string trim string ?chars?"}}
test string-18.3.$noComp {string trim} {
run {string trim " XYZ "}
} {XYZ}
test string-18.4.$noComp {string trim} {
run {string trim "\t\nXYZ\t\n\r\n"}
} {XYZ}
test string-18.5.$noComp {string trim} {
run {string trim " A XYZ A "}
} {A XYZ A}
test string-18.6.$noComp {string trim} {
run {string trim "XXYYZZABC XXYYZZ" ZYX}
} {ABC }
test string-18.7.$noComp {string trim} {
run {string trim " \t\r "}
} {}
test string-18.8.$noComp {string trim} {
run {string trim {abcdefg} {}}
} {abcdefg}
test string-18.9.$noComp {string trim} {
run {string trim {}}
} {}
test string-18.10.$noComp {string trim} {
run {string trim ABC DEF}
} {ABC}
test string-18.11.$noComp {string trim, unicode} {
run {string trim "\xe7\xe8 AB\xe7C \xe8\xe7" \xe7\xe8}
} " AB\xe7C "
test string-18.12.$noComp {string trim, unicode default} {
run {string trim \ufeff\x00\u0085\u00a0\u1680\u180eABC\u1361\u2000\u2001\u2002\u2003\u2004\u2005\u2006\u2007\u2008\u2009\u200a\u200b\u2028\u2029\u202f\u205f\u3000}
} ABC\u1361
test string-19.1.$noComp {string trimleft} {
list [catch {run {string trimleft}} msg] $msg
} {1 {wrong # args: should be "string trimleft string ?chars?"}}
test string-19.2.$noComp {string trimleft} {
run {string trimleft " XYZ "}
} {XYZ }
test string-19.3.$noComp {string trimleft, unicode default} {
run {string trimleft \ufeff\u0085\u00a0\x00\u1680\u180e\u2000\u2001\u2002\u2003\u2004\u2005\u2006\u2007\u2008\u2009\u200a\u200b\u2028\u2029\u202f\u205f\u3000\u1361ABC}
} \u1361ABC
test string-20.1.$noComp {string trimright errors} {
list [catch {run {string trimright}} msg] $msg
} {1 {wrong # args: should be "string trimright string ?chars?"}}
test string-20.2.$noComp {string trimright errors} {
list [catch {run {string trimg a}} msg] $msg
} {1 {unknown or ambiguous subcommand "trimg": must be bytelength, cat, compare, equal, first, index, insert, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}}
test string-20.3.$noComp {string trimright} {
run {string trimright " XYZ "}
} { XYZ}
test string-20.4.$noComp {string trimright} {
run {string trimright " "}
} {}
test string-20.5.$noComp {string trimright} {
run {string trimright ""}
} {}
test string-20.6.$noComp {string trimright, unicode default} {
run {string trimright ABC\u1361\u0085\x00\u00a0\u1680\u180e\u2000\u2001\u2002\u2003\u2004\u2005\u2006\u2007\u2008\u2009\u200a\u200b\u2028\u2029\u202f\u205f\u3000}
} ABC\u1361
test string-21.1.$noComp {string wordend} {
list [catch {run {string wordend a}} msg] $msg
} {1 {wrong # args: should be "string wordend string index"}}
test string-21.2.$noComp {string wordend} {
list [catch {run {string wordend a b c}} msg] $msg
} {1 {wrong # args: should be "string wordend string index"}}
test string-21.3.$noComp {string wordend} {
list [catch {run {string wordend a gorp}} msg] $msg
} {1 {bad index "gorp": must be integer?[+-]integer? or end?[+-]integer?}}
test string-21.4.$noComp {string wordend} {
run {string wordend abc. -1}
} 3
test string-21.5.$noComp {string wordend} {
run {string wordend abc. 100}
} 4
test string-21.6.$noComp {string wordend} {
run {string wordend "word_one two three" 2}
} 8
test string-21.7.$noComp {string wordend} {
run {string wordend "one .&# three" 5}
} 6
test string-21.8.$noComp {string wordend} {
run {string worde "x.y" 0}
} 1
test string-21.9.$noComp {string wordend} {
run {string worde "x.y" end-1}
} 2
test string-21.10.$noComp {string wordend, unicode} {
run {string wordend "xyz\u00c7de fg" 0}
} 6
test string-21.11.$noComp {string wordend, unicode} {
run {string wordend "xyz\uc700de fg" 0}
} 6
test string-21.12.$noComp {string wordend, unicode} {
run {string wordend "xyz\u203fde fg" 0}
} 6
test string-21.13.$noComp {string wordend, unicode} {
run {string wordend "xyz\u2045de fg" 0}
} 3
test string-21.14.$noComp {string wordend, unicode} {
run {string wordend "\uc700\uc700 abc" 8}
} 6
test string-22.1.$noComp {string wordstart} {
list [catch {run {string word a}} msg] $msg
} {1 {unknown or ambiguous subcommand "word": must be bytelength, cat, compare, equal, first, index, insert, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}}
test string-22.2.$noComp {string wordstart} {
list [catch {run {string wordstart a}} msg] $msg
} {1 {wrong # args: should be "string wordstart string index"}}
test string-22.3.$noComp {string wordstart} {
list [catch {run {string wordstart a b c}} msg] $msg
} {1 {wrong # args: should be "string wordstart string index"}}
test string-22.4.$noComp {string wordstart} {
list [catch {run {string wordstart a gorp}} msg] $msg
} {1 {bad index "gorp": must be integer?[+-]integer? or end?[+-]integer?}}
test string-22.5.$noComp {string wordstart} {
run {string wordstart "one two three_words" 400}
} 8
test string-22.6.$noComp {string wordstart} {
run {string wordstart "one two three_words" 2}
} 0
test string-22.7.$noComp {string wordstart} {
run {string wordstart "one two three_words" -2}
} 0
test string-22.8.$noComp {string wordstart} {
run {string wordstart "one .*&^ three" 6}
} 6
test string-22.9.$noComp {string wordstart} {
run {string wordstart "one two three" 4}
} 4
test string-22.10.$noComp {string wordstart} {
run {string wordstart "one two three" end-5}
} 7
test string-22.11.$noComp {string wordstart, unicode} {
run {string wordstart "one tw\u00c7o three" 7}
} 4
test string-22.12.$noComp {string wordstart, unicode} {
run {string wordstart "ab\uc700\uc700 cdef ghi" 12}
} 10
test string-22.13.$noComp {string wordstart, unicode} {
run {string wordstart "\uc700\uc700 abc" 8}
} 3
test string-23.0.$noComp {string is boolean, Bug 1187123} testindexobj {
set x 5
catch {testindexobj $x foo bar soom}
run {string is boolean $x}
} 0
test string-23.1.$noComp {string is command with empty string} {
set s ""
list \
[run {string is alnum $s}] \
[run {string is alpha $s}] \
[run {string is ascii $s}] \
[run {string is control $s}] \
[run {string is boolean $s}] \
[run {string is digit $s}] \
[run {string is double $s}] \
[run {string is false $s}] \
[run {string is graph $s}] \
[run {string is integer $s}] \
[run {string is lower $s}] \
[run {string is print $s}] \
[run {string is punct $s}] \
[run {string is space $s}] \
[run {string is true $s}] \
[run {string is upper $s}] \
[run {string is wordchar $s}] \
[run {string is xdigit $s}] \
} {1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1}
test string-23.2.$noComp {string is command with empty string} {
set s ""
list \
[run {string is alnum -strict $s}] \
[run {string is alpha -strict $s}] \
[run {string is ascii -strict $s}] \
[run {string is control -strict $s}] \
[run {string is boolean -strict $s}] \
[run {string is digit -strict $s}] \
[run {string is double -strict $s}] \
[run {string is false -strict $s}] \
[run {string is graph -strict $s}] \
[run {string is integer -strict $s}] \
[run {string is lower -strict $s}] \
[run {string is print -strict $s}] \
[run {string is punct -strict $s}] \
[run {string is space -strict $s}] \
[run {string is true -strict $s}] \
[run {string is upper -strict $s}] \
[run {string is wordchar -strict $s}] \
[run {string is xdigit -strict $s}] \
} {0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0}
test string-24.1.$noComp {string reverse command} -body {
run {string reverse}
} -returnCodes error -result "wrong # args: should be \"string reverse string\""
test string-24.2.$noComp {string reverse command} -body {
run {string reverse a b}
} -returnCodes error -result "wrong # args: should be \"string reverse string\""
test string-24.3.$noComp {string reverse command - shared string} {
set x abcde
run {string reverse $x}
} edcba
test string-24.4.$noComp {string reverse command - unshared string} {
set x abc
set y de
run {string reverse $x$y}
} edcba
test string-24.5.$noComp {string reverse command - shared unicode string} {
set x abcde\ud0ad
run {string reverse $x}
} \ud0adedcba
test string-24.6.$noComp {string reverse command - unshared string} {
set x abc
set y de\ud0ad
run {string reverse $x$y}
} \ud0adedcba
test string-24.7.$noComp {string reverse command - simple case} {
run {string reverse a}
} a
test string-24.8.$noComp {string reverse command - simple case} {
run {string reverse \ud0ad}
} \ud0ad
test string-24.9.$noComp {string reverse command - simple case} {
run {string reverse {}}
} {}
test string-24.10.$noComp {string reverse command - corner case} {
set x \ubeef\ud0ad
run {string reverse $x}
} \ud0ad\ubeef
test string-24.11.$noComp {string reverse command - corner case} {
set x \ubeef
set y \ud0ad
run {string reverse $x$y}
} \ud0ad\ubeef
test string-24.12.$noComp {string reverse command - corner case} {
set x \ubeef
set y \ud0ad
run {string is ascii [run {string reverse $x$y}]}
} 0
test string-24.13.$noComp {string reverse command - pure Unicode string} {
run {string reverse [run {string range \ubeef\ud0ad\ubeef\ud0ad\ubeef\ud0ad 1 5}]}
} \ud0ad\ubeef\ud0ad\ubeef\ud0ad
test string-24.14.$noComp {string reverse command - pure bytearray} {
binary scan [run {string reverse [binary format H* 010203]}] H* x
set x
} 030201
test string-24.15.$noComp {string reverse command - pure bytearray} {
binary scan [run {tcl::string::reverse [binary format H* 010203]}] H* x
set x
} 030201
test string-25.1.$noComp {string is list} {
run {string is list {a b c}}
} 1
test string-25.2.$noComp {string is list} {
run {string is list "a \{b c"}
} 0
test string-25.3.$noComp {string is list} {
run {string is list {a {b c}d e}}
} 0
test string-25.4.$noComp {string is list} {
run {string is list {}}
} 1
test string-25.5.$noComp {string is list} {
run {string is list -strict {a b c}}
} 1
test string-25.6.$noComp {string is list} {
run {string is list -strict "a \{b c"}
} 0
test string-25.7.$noComp {string is list} {
run {string is list -strict {a {b c}d e}}
} 0
test string-25.8.$noComp {string is list} {
run {string is list -strict {}}
} 1
test string-25.9.$noComp {string is list} {
set x {}
list [run {string is list -failindex x {a b c}}] $x
} {1 {}}
test string-25.10.$noComp {string is list} {
set x {}
list [run {string is list -failindex x "a \{b c"}] $x
} {0 2}
test string-25.11.$noComp {string is list} {
set x {}
list [run {string is list -failindex x {a b {b c}d e}}] $x
} {0 4}
test string-25.12.$noComp {string is list} {
set x {}
list [run {string is list -failindex x {}}] $x
} {1 {}}
test string-25.13.$noComp {string is list} {
set x {}
list [run {string is list -failindex x { {b c}d e}}] $x
} {0 2}
test string-25.14.$noComp {string is list} {
set x {}
list [run {string is list -failindex x "\uabcd {b c}d e"}] $x
} {0 2}
test string-26.1.$noComp {tcl::prefix, too few args} -body {
tcl::prefix match a
} -returnCodes 1 -result {wrong # args: should be "tcl::prefix match ?options? table string"}
test string-26.2.$noComp {tcl::prefix, bad args} -body {
tcl::prefix match a b c
} -returnCodes 1 -result {bad option "a": must be -error, -exact, or -message}
test string-26.2.1.$noComp {tcl::prefix, empty table} -body {
tcl::prefix match {} foo
} -returnCodes 1 -result {bad option "foo": no valid options}
test string-26.3.$noComp {tcl::prefix, bad args} -body {
tcl::prefix match -error "{}x" -exact str1 str2
} -returnCodes 1 -result {list element in braces followed by "x" instead of space}
test string-26.3.1.$noComp {tcl::prefix, bad args} -body {
tcl::prefix match -error "x" -exact str1 str2
} -returnCodes 1 -result {error options must have an even number of elements}
test string-26.3.2.$noComp {tcl::prefix, bad args} -body {
tcl::prefix match -error str1 str2
} -returnCodes 1 -result {missing value for -error}
test string-26.4.$noComp {tcl::prefix, bad args} -body {
tcl::prefix match -message str1 str2
} -returnCodes 1 -result {missing value for -message}
test string-26.5.$noComp {tcl::prefix} {
tcl::prefix match {apa bepa cepa depa} cepa
} cepa
test string-26.6.$noComp {tcl::prefix} {
tcl::prefix match {apa bepa cepa depa} be
} bepa
test string-26.7.$noComp {tcl::prefix} -body {
tcl::prefix match -exact {apa bepa cepa depa} be
} -returnCodes 1 -result {bad option "be": must be apa, bepa, cepa, or depa}
test string-26.8.$noComp {tcl::prefix} -body {
tcl::prefix match -message wombat {apa bepa bear depa} be
} -returnCodes 1 -result {ambiguous wombat "be": must be apa, bepa, bear, or depa}
test string-26.9.$noComp {tcl::prefix} -body {
tcl::prefix match -error {} {apa bepa bear depa} be
} -returnCodes 0 -result {}
test string-26.10.$noComp {tcl::prefix} -body {
tcl::prefix match -error {-level 1} {apa bepa bear depa} be
} -returnCodes 2 -result {ambiguous option "be": must be apa, bepa, bear, or depa}
test string-26.10.1.$noComp {tcl::prefix} -setup {
proc _testprefix {args} {
array set opts {-a x -b y -c y}
foreach {opt val} $args {
set opt [tcl::prefix match -error {-level 1} {-a -b -c} $opt]
set opts($opt) $val
}
array get opts
|
| ︙ | ︙ | |||
1870 1871 1872 1873 1874 1875 1876 |
set end [lindex [lindex [split [memory info] "\n"] 3] 3]
}
lappend res [expr {$end - $tmp}]
}
return $res
}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | | | | | | | | | | | | | | | | | | | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 |
set end [lindex [lindex [split [memory info] "\n"] 3] 3]
}
lappend res [expr {$end - $tmp}]
}
return $res
}
test string-26.11.$noComp {tcl::prefix: testing for leaks} -body {
# This test is made to stress object reference management
MemStress {
set table {hejj miff gurk}
set item [lindex $table 1]
# If not careful, this can cause a circular reference
# that will cause a leak.
tcl::prefix match $table $item
} {
# A similar case with nested lists
set table2 {hejj {miff maff} gurk}
set item [lindex [lindex $table2 1] 0]
tcl::prefix match $table2 $item
} {
# A similar case with dict
set table3 {hejj {miff maff} gurk2}
set item [lindex [dict keys [lindex $table3 1]] 0]
tcl::prefix match $table3 $item
}
} -constraints memory -result {0 0 0}
test string-26.12.$noComp {tcl::prefix: testing for leaks} -body {
# This is a memory leak test in a form that might actually happen
# in real code. The shared literal "miff" causes a connection
# between the item and the table.
MemStress {
proc stress1 {item} {
set table [list hejj miff gurk]
tcl::prefix match $table $item
}
proc stress2 {} {
stress1 miff
}
stress2
rename stress1 {}
rename stress2 {}
}
} -constraints memory -result 0
test string-26.13.$noComp {tcl::prefix: testing for leaks} -body {
# This test is made to stress object reference management
MemStress {
set table [list hejj miff]
set item $table
set error $table
# Use the same objects in all places
catch {
tcl::prefix match -error $error $table $item
}
}
} -constraints memory -result {0}
test string-27.1.$noComp {tcl::prefix all, too few args} -body {
tcl::prefix all a
} -returnCodes 1 -result {wrong # args: should be "tcl::prefix all table string"}
test string-27.2.$noComp {tcl::prefix all, bad args} -body {
tcl::prefix all a b c
} -returnCodes 1 -result {wrong # args: should be "tcl::prefix all table string"}
test string-27.3.$noComp {tcl::prefix all, bad args} -body {
tcl::prefix all "{}x" str2
} -returnCodes 1 -result {list element in braces followed by "x" instead of space}
test string-27.4.$noComp {tcl::prefix all} {
tcl::prefix all {apa bepa cepa depa} c
} cepa
test string-27.5.$noComp {tcl::prefix all} {
tcl::prefix all {apa bepa cepa depa} cepa
} cepa
test string-27.6.$noComp {tcl::prefix all} {
tcl::prefix all {apa bepa cepa depa} cepax
} {}
test string-27.7.$noComp {tcl::prefix all} {
tcl::prefix all {apa aska appa} a
} {apa aska appa}
test string-27.8.$noComp {tcl::prefix all} {
tcl::prefix all {apa aska appa} ap
} {apa appa}
test string-27.9.$noComp {tcl::prefix all} {
tcl::prefix all {apa aska appa} p
} {}
test string-27.10.$noComp {tcl::prefix all} {
tcl::prefix all {apa aska appa} {}
} {apa aska appa}
test string-28.1.$noComp {tcl::prefix longest, too few args} -body {
tcl::prefix longest a
} -returnCodes 1 -result {wrong # args: should be "tcl::prefix longest table string"}
test string-28.2.$noComp {tcl::prefix longest, bad args} -body {
tcl::prefix longest a b c
} -returnCodes 1 -result {wrong # args: should be "tcl::prefix longest table string"}
test string-28.3.$noComp {tcl::prefix longest, bad args} -body {
tcl::prefix longest "{}x" str2
} -returnCodes 1 -result {list element in braces followed by "x" instead of space}
test string-28.4.$noComp {tcl::prefix longest} {
tcl::prefix longest {apa bepa cepa depa} c
} cepa
test string-28.5.$noComp {tcl::prefix longest} {
tcl::prefix longest {apa bepa cepa depa} cepa
} cepa
test string-28.6.$noComp {tcl::prefix longest} {
tcl::prefix longest {apa bepa cepa depa} cepax
} {}
test string-28.7.$noComp {tcl::prefix longest} {
tcl::prefix longest {apa aska appa} a
} a
test string-28.8.$noComp {tcl::prefix longest} {
tcl::prefix longest {apa aska appa} ap
} ap
test string-28.9.$noComp {tcl::prefix longest} {
tcl::prefix longest {apa bska appa} a
} ap
test string-28.10.$noComp {tcl::prefix longest} {
tcl::prefix longest {apa bska appa} {}
} {}
test string-28.11.$noComp {tcl::prefix longest} {
tcl::prefix longest {{} bska appa} {}
} {}
test string-28.12.$noComp {tcl::prefix longest} {
tcl::prefix longest {apa {} appa} {}
} {}
test string-28.13.$noComp {tcl::prefix longest} {
# Test UTF8 handling
tcl::prefix longest {ax\x90 bep ax\x91} a
} ax
test string-29.1.$noComp {string cat, no arg} {
run {string cat}
} ""
test string-29.2.$noComp {string cat, single arg} {
set x FOO
run {string compare $x [run {string cat $x}]}
} 0
test string-29.3.$noComp {string cat, two args} {
set x FOO
run {string compare $x$x [run {string cat $x $x}]}
} 0
test string-29.4.$noComp {string cat, many args} {
set x FOO
set n 260
set xx [run {string repeat $x $n}]
set vv [run {string repeat {$x} $n}]
set vvs [run {string repeat {$x } $n}]
set r1 [run {string compare $xx [subst $vv]}]
set r2 [run {string compare $xx [eval "run {string cat $vvs}"]}]
list $r1 $r2
} {0 0}
if {$noComp} {
test string-29.5.$noComp {string cat, efficiency} -body {
tcl::unsupported::representation [run {string cat [list x] [list]}]
} -match glob -result {*no string representation}
test string-29.6.$noComp {string cat, efficiency} -body {
tcl::unsupported::representation [run {string cat [list] [list x]}]
} -match glob -result {*no string representation}
test string-29.7.$noComp {string cat, efficiency} -body {
tcl::unsupported::representation [run {string cat [list x] [list] [list]}]
} -match glob -result {*no string representation}
test string-29.8.$noComp {string cat, efficiency} -body {
tcl::unsupported::representation [run {string cat [list] [list x] [list]}]
} -match glob -result {*no string representation}
test string-29.9.$noComp {string cat, efficiency} -body {
tcl::unsupported::representation [run {string cat [list] [list] [list x]}]
} -match glob -result {*no string representation}
test string-29.10.$noComp {string cat, efficiency} -body {
tcl::unsupported::representation [run {string cat [list x] [list x]}]
} -match glob -result {*, string representation "xx"}
test string-29.11.$noComp {string cat, efficiency} -body {
tcl::unsupported::representation \
[run {string cat [list x] [encoding convertto utf-8 {}]}]
} -match glob -result {*no string representation}
test string-29.12.$noComp {string cat, efficiency} -body {
tcl::unsupported::representation \
[run {string cat [encoding convertto utf-8 {}] [list x]}]
} -match glob -result {*, string representation "x"}
test string-29.13.$noComp {string cat, efficiency} -body {
tcl::unsupported::representation [run {string cat \
[encoding convertto utf-8 {}] [encoding convertto utf-8 {}] [list x]}]
} -match glob -result {*, string representation "x"}
test string-29.14.$noComp {string cat, efficiency} -setup {
set e [encoding convertto utf-8 {}]
} -cleanup {
unset e
} -body {
tcl::unsupported::representation [run {string cat $e $e [list x]}]
} -match glob -result {*no string representation}
test string-29.15.$noComp {string cat, efficiency} -setup {
set e [encoding convertto utf-8 {}]
set f [encoding convertto utf-8 {}]
} -cleanup {
unset e f
} -body {
tcl::unsupported::representation [run {string cat $e $f $e $f [list x]}]
} -match glob -result {*no string representation}
}
test string-30.1.1.$noComp {[Bug ba921a8d98]: string cat} {
run {string cat [set data [binary format a* hello]] [encoding convertto $data] [unset data]}
} hellohello
test string-30.1.2.$noComp {[Bug ba921a8d98]: inplace cat by subst (compiled to "strcat" instruction)} {
run {set x "[set data [binary format a* hello]][encoding convertto $data][unset data]"}
} hellohello
# Note: string-31.* tests use [tcl::string::insert] rather than [string insert]
# to dodge ticket [3397978fff] which would cause all arguments to be shared,
# thereby preventing the optimizations from being tested.
test string-31.1.$noComp {string insert, start of string} {
run {tcl::string::insert 0123 0 _}
} _0123
test string-31.2.$noComp {string insert, middle of string} {
run {tcl::string::insert 0123 2 _}
} 01_23
test string-31.3.$noComp {string insert, end of string} {
run {tcl::string::insert 0123 4 _}
} 0123_
test string-31.4.$noComp {string insert, start of string, end-relative} {
run {tcl::string::insert 0123 end-4 _}
} _0123
test string-31.5.$noComp {string insert, middle of string, end-relative} {
run {tcl::string::insert 0123 end-2 _}
} 01_23
test string-31.6.$noComp {string insert, end of string, end-relative} {
run {tcl::string::insert 0123 end _}
} 0123_
test string-31.7.$noComp {string insert, empty target string} {
run {tcl::string::insert {} 0 _}
} _
test string-31.8.$noComp {string insert, empty insert string} {
run {tcl::string::insert 0123 0 {}}
} 0123
test string-31.9.$noComp {string insert, empty strings} {
run {tcl::string::insert {} 0 {}}
} {}
test string-31.10.$noComp {string insert, negative index} {
run {tcl::string::insert 0123 -1 _}
} _0123
test string-31.11.$noComp {string insert, index beyond end} {
run {tcl::string::insert 0123 5 _}
} 0123_
test string-31.12.$noComp {string insert, start of string, pure byte array} {
run {tcl::string::insert [makeByteArray 0123] 0 [makeByteArray _]}
} _0123
test string-31.13.$noComp {string insert, middle of string, pure byte array} {
run {tcl::string::insert [makeByteArray 0123] 2 [makeByteArray _]}
} 01_23
test string-31.14.$noComp {string insert, end of string, pure byte array} {
run {tcl::string::insert [makeByteArray 0123] 4 [makeByteArray _]}
} 0123_
test string-31.15.$noComp {string insert, pure byte array, neither shared} {
run {tcl::string::insert [makeByteArray 0123] 2 [makeByteArray _]}
} 01_23
test string-31.16.$noComp {string insert, pure byte array, first shared} {
run {tcl::string::insert [makeShared [makeByteArray 0123]] 2\
[makeByteArray _]}
} 01_23
test string-31.17.$noComp {string insert, pure byte array, second shared} {
run {tcl::string::insert [makeByteArray 0123] 2\
[makeShared [makeByteArray _]]}
} 01_23
test string-31.18.$noComp {string insert, pure byte array, both shared} {
run {tcl::string::insert [makeShared [makeByteArray 0123]] 2\
[makeShared [makeByteArray _]]}
} 01_23
test string-31.19.$noComp {string insert, start of string, pure Unicode} {
run {tcl::string::insert [makeUnicode 0123] 0 [makeUnicode _]}
} _0123
test string-31.20.$noComp {string insert, middle of string, pure Unicode} {
run {tcl::string::insert [makeUnicode 0123] 2 [makeUnicode _]}
} 01_23
test string-31.21.$noComp {string insert, end of string, pure Unicode} {
run {tcl::string::insert [makeUnicode 0123] 4 [makeUnicode _]}
} 0123_
test string-31.22.$noComp {string insert, str start, pure Uni, first shared} {
run {tcl::string::insert [makeShared [makeUnicode 0123]] 0 [makeUnicode _]}
} _0123
test string-31.23.$noComp {string insert, string mid, pure Uni, 2nd shared} {
run {tcl::string::insert [makeUnicode 0123] 2 [makeShared [makeUnicode _]]}
} 01_23
test string-31.24.$noComp {string insert, string end, pure Uni, both shared} {
run {tcl::string::insert [makeShared [makeUnicode 0123]] 4\
[makeShared [makeUnicode _]]}
} 0123_
test string-31.25.$noComp {string insert, neither byte array nor Unicode} {
run {tcl::string::insert [makeList a b c] 1 zzzzzz}
} {azzzzzz b c}
test string-32.1.$noComp {string is dict} {
string is dict {a b c d}
} 1
test string-32.1a.$noComp {string is dict} {
string is dict {a b c}
} 0
test string-32.2.$noComp {string is dict} {
string is dict "a \{b c"
} 0
test string-32.3.$noComp {string is dict} {
string is dict {a {b c}d e}
} 0
test string-32.4.$noComp {string is dict} {
string is dict {}
} 1
test string-32.5.$noComp {string is dict} {
string is dict -strict {a b c d}
} 1
test string-32.5a.$noComp {string is dict} {
string is dict -strict {a b c}
} 0
test string-32.6.$noComp {string is dict} {
string is dict -strict "a \{b c"
} 0
test string-32.7.$noComp {string is dict} {
string is dict -strict {a {b c}d e}
} 0
test string-32.8.$noComp {string is dict} {
string is dict -strict {}
} 1
test string-32.9.$noComp {string is dict} {
set x {}
list [string is dict -failindex x {a b c d}] $x
} {1 {}}
test string-32.9a.$noComp {string is dict} {
set x {}
list [string is dict -failindex x {a b c}] $x
} {0 -1}
test string-32.10.$noComp {string is dict} {
set x {}
list [string is dict -failindex x "a \{b c d"] $x
} {0 2}
test string-32.10a.$noComp {string is dict} {
set x {}
list [string is dict -failindex x "a \{b c"] $x
} {0 2}
test string-32.11.$noComp {string is dict} {
set x {}
list [string is dict -failindex x {a b {b c}d e}] $x
} {0 4}
test string-32.12.$noComp {string is dict} {
set x {}
list [string is dict -failindex x {}] $x
} {1 {}}
test string-32.13.$noComp {string is dict} {
set x {}
list [string is dict -failindex x { {b c}d e}] $x
} {0 2}
test string-32.14.$noComp {string is dict} {
set x {}
list [string is dict -failindex x "\uabcd {b c}d e"] $x
} {0 2}
test string-32.15.$noComp {string is dict, valid dict} {
string is dict {a b c d e f}
} 1
test string-32.16.$noComp {string is dict, invalid dict} {
string is dict a
} 0
test string-32.17.$noComp {string is dict, valid dict packed in invalid dict} {
string is dict {{a b c d e f g h}}
} 0
}; # foreach noComp {0 1}
# cleanup
rename MemStress {}
rename makeByteArray {}
rename makeUnicode {}
rename makeList {}
rename makeShared {}
catch {rename foo {}}
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Deleted tests/stringComp.test.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Changes to tests/tailcall.test.
| ︙ | ︙ | |||
684 685 686 687 688 689 690 691 692 693 694 695 696 |
} {0 ok NONE}
if {[testConstraint testnrelevels]} {
namespace forget testnre::*
namespace delete testnre
}
# cleanup
::tcltest::cleanupTests
# Local Variables:
# mode: tcl
# End:
| > > > > > > > > > > > > > > > > > > > > | 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 |
} {0 ok NONE}
if {[testConstraint testnrelevels]} {
namespace forget testnre::*
namespace delete testnre
}
test tailcall-14.1 {in a deleted namespace} -body {
namespace eval ns {
proc p args {
tailcall [namespace current] $args
}
namespace delete [namespace current]
p
}
} -returnCodes 1 -result {namespace "::ns" not found}
test tailcall-14.1-bc {{in a deleted namespace} {byte compiled}} -body {
namespace eval ns {
proc p args {
tailcall [namespace current] {*}$args
}
namespace delete [namespace current]
p
}
} -returnCodes 1 -result {namespace "::ns" not found}
# cleanup
::tcltest::cleanupTests
# Local Variables:
# mode: tcl
# End:
|
Changes to tests/tcltest.test.
| ︙ | ︙ | |||
547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 |
switch -- $::tcl_platform(platform) {
unix {
file attributes $notReadableDir -permissions 00333
file attributes $notWriteableDir -permissions 00555
}
default {
catch {file attributes $notWriteableDir -readonly 1}
catch {testchmod 0 $notWriteableDir}
}
}
test tcltest-8.3 {tcltest a.tcl -tmpdir notReadableDir} {
-constraints {unix notRoot}
-body {
slave msg $a -tmpdir $notReadableDir
return $msg
}
-result {*not readable*}
-match glob
}
# This constraint doesn't go at the top of the file so that it doesn't
# interfere with tcltest-5.5
testConstraint notFAT [expr {
| > | > | | 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 |
switch -- $::tcl_platform(platform) {
unix {
file attributes $notReadableDir -permissions 00333
file attributes $notWriteableDir -permissions 00555
}
default {
# note in FAT/NTFS we won't be able to protect directory with read-only attribute...
catch {file attributes $notWriteableDir -readonly 1}
catch {testchmod 0 $notWriteableDir}
}
}
test tcltest-8.3 {tcltest a.tcl -tmpdir notReadableDir} {
-constraints {unix notRoot}
-body {
slave msg $a -tmpdir $notReadableDir
return $msg
}
-result {*not readable*}
-match glob
}
# This constraint doesn't go at the top of the file so that it doesn't
# interfere with tcltest-5.5
testConstraint notFAT [expr {
![regexp {^(FAT\d*|NTFS)$} [lindex [file system $notWriteableDir] 1]]
|| $::tcl_platform(platform) eq "unix" || [llength [info commands testchmod]]
}]
# FAT/NTFS permissions are fairly hopeless; ignore this test if that FS is used
test tcltest-8.4 {tcltest a.tcl -tmpdir notWriteableDir} {
-constraints {unixOrPc notRoot notFAT}
-body {
slave msg $a -tmpdir $notWriteableDir
return $msg
}
-result {*not writeable*}
|
| ︙ | ︙ | |||
903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 |
set ::tcltest::loadFile $oldf
}
}
removeFile load.tcl
# [interpreter]
test tcltest-13.1 {interpreter} {
-setup {
set old $::tcltest::tcltest
set ::tcltest::tcltest tcltest
}
-body {
set f1 [interpreter]
set f2 [interpreter tclsh]
set f3 [interpreter]
list $f1 $f2 $f3
}
-result {tcltest tclsh tclsh}
-cleanup {
set ::tcltest::tcltest $old
}
}
# -singleproc, [singleProcess]
set spd [makeDirectory singleprocdir]
makeFile {
| > > > > > > > | 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 |
set ::tcltest::loadFile $oldf
}
}
removeFile load.tcl
# [interpreter]
test tcltest-13.1 {interpreter} {
-constraints notValgrind
-setup {
#to do: Why is $::tcltest::tcltest being saved and restored here?
set old $::tcltest::tcltest
set ::tcltest::tcltest tcltest
}
-body {
set f1 [interpreter]
set f2 [interpreter tclsh]
set f3 [interpreter]
list $f1 $f2 $f3
}
-result {tcltest tclsh tclsh}
-cleanup {
# writing ::tcltest::tcltest triggers a trace that sets up the stdio
# constraint, which involves a call to [exec] that might fail after
# "fork" and before "exec", in which case the forked process will not
# have a chance to clean itself up before exiting, which causes
# valgrind to issue numerous "still reachable" reports.
set ::tcltest::tcltest $old
}
}
# -singleproc, [singleProcess]
set spd [makeDirectory singleprocdir]
makeFile {
|
| ︙ | ︙ | |||
1195 1196 1197 1198 1199 1200 1201 |
test tcltest-21.2 {force a test command failure} {
-body {
test tcltest-21.2.0 {
return 2
} {1}
}
-returnCodes 1
| | | 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 |
test tcltest-21.2 {force a test command failure} {
-body {
test tcltest-21.2.0 {
return 2
} {1}
}
-returnCodes 1
-result {bad option "1": must be -body, -cleanup, -constraints, -errorCode, -errorOutput, -match, -output, -result, -returnCodes, or -setup}
}
test tcltest-21.3 {test command with setup} {
-setup {
set foo 1
}
-body {
|
| ︙ | ︙ | |||
1288 1289 1290 1291 1292 1293 1294 |
-cleanup {set ::tcltest::currentFailure $fail}
-body {
test tcltest-21.7.0 {foo-4} {
-foobar {}
}
}
-returnCodes 1
| | | | 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 |
-cleanup {set ::tcltest::currentFailure $fail}
-body {
test tcltest-21.7.0 {foo-4} {
-foobar {}
}
}
-returnCodes 1
-result {bad option "-foobar": must be -body, -cleanup, -constraints, -errorCode, -errorOutput, -match, -output, -result, -returnCodes, or -setup}
}
# alternate test command format (these are the same as 21.1-21.6, with the
# exception of being in the all-inline format)
test tcltest-21.7a {expect with glob} \
-body {list a b c d e} \
-result {[ab] b c d e} \
-match glob
test tcltest-21.8 {force a test command failure} \
-setup {set fail $::tcltest::currentFailure} \
-body {
test tcltest-21.8.0 {
return 2
} {1}
} \
-returnCodes 1 \
-cleanup {set ::tcltest::currentFailure $fail} \
-result {bad option "1": must be -body, -cleanup, -constraints, -errorCode, -errorOutput, -match, -output, -result, -returnCodes, or -setup}
test tcltest-21.9 {test command with setup} \
-setup {set foo 1} \
-body {set foo} \
-cleanup {unset foo} \
-result {1}
|
| ︙ | ︙ |
Added tests/tcltests.tcl.
> > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 |
#! /usr/bin/env tclsh
package require tcltest 2.2
namespace import ::tcltest::*
testConstraint exec [llength [info commands exec]]
testConstraint fcopy [llength [info commands fcopy]]
testConstraint fileevent [llength [info commands fileevent]]
testConstraint thread [
expr {0 == [catch {package require Thread 2.7-}]}]
testConstraint notValgrind [expr {![testConstraint valgrind]}]
package provide tcltests 0.1
|
Changes to tests/thread.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # Commands covered: (test)thread # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1996 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # 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. | | | > > > > | < < < < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 |
# Commands covered: (test)thread
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2
namespace import -force ::tcltest::*
}
# when thread::release is used, -wait is passed in order allow the thread to
# be fully finalized, which avoids valgrind "still reachable" reports.
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
package require tcltests
# Some tests require the testthread command
testConstraint testthread [expr {[info commands testthread] ne {}}]
set threadSuperKillScript {
rename catch ""
rename while ""
rename unknown ""
rename update ""
thread::release
|
| ︙ | ︙ | |||
67 68 69 70 71 72 73 74 75 76 77 78 79 80 |
if {[string length [getThreadErrorFromInfo $info]] > 0} then {
global threadId threadError
set threadId $id
lappend threadError($id) $info
}
set threadSawError($id) true; # signal main thread to exit [vwait].
}
if {[testConstraint thread]} {
thread::errorproc ThreadError
}
if {[testConstraint testthread]} {
proc drainEventQueue {} {
| > > > > > > > > > > > | 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 |
if {[string length [getThreadErrorFromInfo $info]] > 0} then {
global threadId threadError
set threadId $id
lappend threadError($id) $info
}
set threadSawError($id) true; # signal main thread to exit [vwait].
}
proc threadSuperKill id {
variable threadSuperKillScript
try {
thread::send $id $::threadSuperKillScript
} on error {tres topts} {
if {$tres ne {target thread died}} {
return -options $topts $tres
}
}
}
if {[testConstraint thread]} {
thread::errorproc ThreadError
}
if {[testConstraint testthread]} {
proc drainEventQueue {} {
|
| ︙ | ︙ | |||
92 93 94 95 96 97 98 |
test thread-1.3 {Tcl_ThreadObjCmd: initial thread list} {thread} {
llength [thread::names]
} 1
test thread-1.4 {Tcl_ThreadObjCmd: thread create } {thread} {
set serverthread [thread::create -preserved]
set numthreads [llength [thread::names]]
| | | | | | | | | | | | | | 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 |
test thread-1.3 {Tcl_ThreadObjCmd: initial thread list} {thread} {
llength [thread::names]
} 1
test thread-1.4 {Tcl_ThreadObjCmd: thread create } {thread} {
set serverthread [thread::create -preserved]
set numthreads [llength [thread::names]]
thread::release -wait $serverthread
set numthreads
} 2
test thread-1.5 {Tcl_ThreadObjCmd: thread create one shot} {thread} {
thread::create {set x 5}
foreach try {0 1 2 4 5 6} {
# Try various ways to yield
update
after 10
set l [llength [thread::names]]
if {$l == 1} {
break
}
}
set l
} 1
test thread-1.6 {Tcl_ThreadObjCmd: thread exit} {thread} {
thread::create {{*}{}}
update
after 10
llength [thread::names]
} {1}
test thread-1.13 {Tcl_ThreadObjCmd: send args} {thread} {
set serverthread [thread::create -preserved]
set five [thread::send $serverthread {set x 5}]
thread::release -wait $serverthread
set five
} 5
test thread-1.15 {Tcl_ThreadObjCmd: wait} {thread} {
set serverthread [thread::create -preserved {set z 5 ; thread::wait}]
set five [thread::send $serverthread {set z}]
thread::release -wait $serverthread
set five
} 5
# The tests above also cover:
# TclCreateThread, except when pthread_create fails
# NewThread, safe and regular
# ThreadErrorProc, except for printing to standard error
|
| ︙ | ︙ | |||
155 156 157 158 159 160 161 |
set l1 {}
foreach t {0 1 2} {
lappend l1 [thread::create -preserved]
}
set l2 [thread::names]
set c [string compare [lsort [concat [thread::id] $l1]] [lsort $l2]]
foreach t $l1 {
| | | 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 |
set l1 {}
foreach t {0 1 2} {
lappend l1 [thread::create -preserved]
}
set l2 [thread::names]
set c [string compare [lsort [concat [thread::id] $l1]] [lsort $l2]]
foreach t $l1 {
thread::release -wait $t
}
list $len $c
} {1 0}
test thread-4.1 {TclThreadSend to self} {thread} {
catch {unset x}
thread::send [thread::id] {
|
| ︙ | ︙ | |||
883 884 885 886 887 888 889 |
}
}
foobar
}]]
# wait for other thread to signal "ready to cancel"
vwait ::threadIdStarted; after 1000
set res [thread::cancel $serverthread]
| | | 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 |
}
}
foobar
}]]
# wait for other thread to signal "ready to cancel"
vwait ::threadIdStarted; after 1000
set res [thread::cancel $serverthread]
threadSuperKill $serverthread
vwait ::threadSawError($serverthread)
thread::join $serverthread; drainEventQueue
list $res [expr {[info exists ::threadIdStarted] ? \
$::threadIdStarted == $serverthread : 0}] \
[expr {[info exists ::threadId] ? \
$::threadId == $serverthread : 0}] \
[expr {[info exists ::threadError($serverthread)] ? \
|
| ︙ | ︙ | |||
925 926 927 928 929 930 931 |
}
}
foobar
}]]
# wait for other thread to signal "ready to cancel"
vwait ::threadIdStarted; after 1000
set res [thread::cancel $serverthread]
| | | 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 |
}
}
foobar
}]]
# wait for other thread to signal "ready to cancel"
vwait ::threadIdStarted; after 1000
set res [thread::cancel $serverthread]
threadSuperKill $serverthread
vwait ::threadSawError($serverthread)
thread::join $serverthread; drainEventQueue
list $res [expr {[info exists ::threadIdStarted] ? \
$::threadIdStarted == $serverthread : 0}] \
[expr {[info exists ::threadId] ? \
$::threadId == $serverthread : 0}] \
[expr {[info exists ::threadError($serverthread)] ? \
|
| ︙ | ︙ | |||
1025 1026 1027 1028 1029 1030 1031 |
}
}
foobar
}]]
# wait for other thread to signal "ready to cancel"
vwait ::threadIdStarted; after 1000
set res [thread::send -async $serverthread {interp cancel}]
| | | 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 |
}
}
foobar
}]]
# wait for other thread to signal "ready to cancel"
vwait ::threadIdStarted; after 1000
set res [thread::send -async $serverthread {interp cancel}]
threadSuperKill $serverthread
vwait ::threadSawError($serverthread)
thread::join $serverthread; drainEventQueue
list $res [expr {[info exists ::threadIdStarted] ? \
$::threadIdStarted == $serverthread : 0}] \
[expr {[info exists ::threadId] ? \
$::threadId == $serverthread : 0}] \
[expr {[info exists ::threadError($serverthread)] ? \
|
| ︙ | ︙ | |||
1067 1068 1069 1070 1071 1072 1073 |
}
}
foobar
}]]
# wait for other thread to signal "ready to cancel"
vwait ::threadIdStarted; after 1000
set res [thread::send -async $serverthread {interp cancel}]
| | | 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 |
}
}
foobar
}]]
# wait for other thread to signal "ready to cancel"
vwait ::threadIdStarted; after 1000
set res [thread::send -async $serverthread {interp cancel}]
threadSuperKill $serverthread
vwait ::threadSawError($serverthread)
thread::join $serverthread; drainEventQueue
list $res [expr {[info exists ::threadIdStarted] ? \
$::threadIdStarted == $serverthread : 0}] \
[expr {[info exists ::threadId] ? \
$::threadId == $serverthread : 0}] \
[expr {[info exists ::threadError($serverthread)] ? \
|
| ︙ | ︙ | |||
1107 1108 1109 1110 1111 1112 1113 |
}
}
foobar
}]]
# wait for other thread to signal "ready to cancel"
vwait ::threadIdStarted; after 1000
set res [thread::send -async $serverthread {thread::cancel [thread::id]}]
| | | 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 |
}
}
foobar
}]]
# wait for other thread to signal "ready to cancel"
vwait ::threadIdStarted; after 1000
set res [thread::send -async $serverthread {thread::cancel [thread::id]}]
threadSuperKill $serverthread
vwait ::threadSawError($serverthread)
thread::join $serverthread; drainEventQueue
list $res [expr {[info exists ::threadIdStarted] ? \
$::threadIdStarted == $serverthread : 0}] \
[expr {[info exists ::threadId] ? \
$::threadId == $serverthread : 0}] \
[expr {[info exists ::threadError($serverthread)] ? \
|
| ︙ | ︙ | |||
1149 1150 1151 1152 1153 1154 1155 |
}
}
foobar
}]]
# wait for other thread to signal "ready to cancel"
vwait ::threadIdStarted; after 1000
set res [thread::send -async $serverthread {thread::cancel [thread::id]}]
| | | 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 |
}
}
foobar
}]]
# wait for other thread to signal "ready to cancel"
vwait ::threadIdStarted; after 1000
set res [thread::send -async $serverthread {thread::cancel [thread::id]}]
threadSuperKill $serverthread
vwait ::threadSawError($serverthread)
thread::join $serverthread; drainEventQueue
list $res [expr {[info exists ::threadIdStarted] ? \
$::threadIdStarted == $serverthread : 0}] \
[expr {[info exists ::threadId] ? \
$::threadId == $serverthread : 0}] \
[expr {[info exists ::threadError($serverthread)] ? \
|
| ︙ | ︙ |
Changes to tests/timer.test.
| ︙ | ︙ | |||
201 202 203 204 205 206 207 |
set y $x
after 400
update
list $y $x
} {before after}
test timer-6.5 {Tcl_AfterCmd procedure, ms argument} {
set x before
| | | | 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 |
set y $x
after 400
update
list $y $x
} {before after}
test timer-6.5 {Tcl_AfterCmd procedure, ms argument} {
set x before
after 400 set x after
after 200
update
set y $x
after 400
update
list $y $x
} {before after}
test timer-6.6 {Tcl_AfterCmd procedure, cancel option} -body {
after cancel
} -returnCodes error -result {wrong # args: should be "after cancel id|command"}
test timer-6.7 {Tcl_AfterCmd procedure, cancel option} {
|
| ︙ | ︙ |
Changes to tests/trace.test.
| ︙ | ︙ | |||
1223 1224 1225 1226 1227 1228 1229 |
} {x {} write}
# Be sure that procedure frames are released before unset traces
# are invoked.
test trace-18.1 {unset traces on procedure returns} {
proc p1 {x y} {set a 44; p2 14}
| | | 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 |
} {x {} write}
# Be sure that procedure frames are released before unset traces
# are invoked.
test trace-18.1 {unset traces on procedure returns} {
proc p1 {x y} {set a 44; p2 14}
proc p2 {z} {trace add variable z unset {traceCheck {lsort [uplevel 1 {info vars}]}}}
set info {}
p1 foo bar
set info
} {0 {a x y}}
test trace-18.2 {namespace delete / trace vdelete combo} {
namespace eval ::foo {
variable x 123
|
| ︙ | ︙ | |||
1259 1260 1261 1262 1263 1264 1265 |
append info [catch {set ::$vtraced}][llength [info vars ::ref::*]]
}
set info {}
namespace delete ::ref
rename doTrace {}
set info
} 1110
| < < < < < < < < < < < < < < < < < < < < < | 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 |
append info [catch {set ::$vtraced}][llength [info vars ::ref::*]]
}
set info {}
namespace delete ::ref
rename doTrace {}
set info
} 1110
# Delete arrays when done, so they can be re-used as scalars
# elsewhere.
unset -nocomplain x y
test trace-19.0.1 {trace add command (command existence)} {
|
| ︙ | ︙ |
Changes to tests/unixInit.test.
| ︙ | ︙ | |||
334 335 336 337 338 339 340 |
} -body {
set env(LANG) C
set f [open "|[list [interpreter]]" w+]
chan configure $f -buffering none
puts $f {puts [encoding system]; exit}
set enc [gets $f]
close $f
| | | < | 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 |
} -body {
set env(LANG) C
set f [open "|[list [interpreter]]" w+]
chan configure $f -buffering none
puts $f {puts [encoding system]; exit}
set enc [gets $f]
close $f
set enc
} -cleanup {
unset -nocomplain env(LANG)
} -match regexp -result {^(iso8859-15?|utf-8)$}
test unixInit-3.2 {TclpSetInitialEncodings} -setup {
catch {set oldlc_all $env(LC_ALL)}
} -constraints {unix stdio} -body {
set env(LANG) japanese
set env(LC_ALL) japanese
set f [open "|[list [interpreter]]" w+]
chan configure $f -buffering none
|
| ︙ | ︙ |
Changes to tests/unixNotfy.test.
| ︙ | ︙ | |||
14 15 16 17 18 19 20 |
package require tcltest 2
namespace import -force ::tcltest::*
}
# When run in a Tk shell, these tests hang.
testConstraint noTk [expr {0 != [catch {package present Tk}]}]
testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}]
| < < < < < | | | 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 |
package require tcltest 2
namespace import -force ::tcltest::*
}
# When run in a Tk shell, these tests hang.
testConstraint noTk [expr {0 != [catch {package present Tk}]}]
testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}]
# The next two tests will hang if threads are enabled because the notifier
# will not necessarily wait for ever in this case, so it does not generate
# an error.
test unixNotfy-1.1 {Tcl_DeleteFileHandler} -constraints nonPortable -body {
catch {vwait x}
set f [open [makeFile "" foo] w]
fileevent $f writable {set x 1}
vwait x
close $f
list [catch {vwait x} msg] $msg
} -result {1 {can't wait for variable "x": would wait forever}} -cleanup {
catch { close $f }
catch { removeFile foo }
}
test unixNotfy-1.2 {Tcl_DeleteFileHandler} -constraints nonPortable -body {
catch {vwait x}
set f1 [open [makeFile "" foo] w]
set f2 [open [makeFile "" foo2] w]
fileevent $f1 writable {set x 1}
fileevent $f2 writable {set y 1}
vwait x
close $f1
|
| ︙ | ︙ |
Changes to tests/uplevel.test.
| ︙ | ︙ | |||
133 134 135 136 137 138 139 |
} {}
test uplevel-4.15 {level parsing} {
apply {{} {uplevel [expr 1] {}}}
} {}
test uplevel-4.16 {level parsing} {
apply {{} {uplevel #[expr 1] {}}}
} {}
| | | | | | | | | | | | | | | 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 |
} {}
test uplevel-4.15 {level parsing} {
apply {{} {uplevel [expr 1] {}}}
} {}
test uplevel-4.16 {level parsing} {
apply {{} {uplevel #[expr 1] {}}}
} {}
test uplevel-4.17 {level parsing} -returnCodes error -body {
apply {{} {uplevel -0xffffffff {}}}
} -result {bad level "-0xffffffff"}
test uplevel-4.18 {level parsing} -returnCodes error -body {
apply {{} {uplevel #-0xffffffff {}}}
} -result {bad level "#-0xffffffff"}
test uplevel-4.19 {level parsing} -returnCodes error -body {
apply {{} {uplevel [expr -0xffffffff] {}}}
} -result {bad level "-4294967295"}
test uplevel-4.20 {level parsing} -returnCodes error -body {
apply {{} {uplevel #[expr -0xffffffff] {}}}
} -result {bad level "#-4294967295"}
test uplevel-4.21 {level parsing} -body {
apply {{} {uplevel -1 {}}}
} -returnCodes error -result {bad level "-1"}
test uplevel-4.22 {level parsing} -body {
apply {{} {uplevel #-1 {}}}
} -returnCodes error -result {bad level "#-1"}
test uplevel-4.23 {level parsing} -body {
apply {{} {uplevel [expr -1] {}}}
} -returnCodes error -result {bad level "-1"}
test uplevel-4.24 {level parsing} -body {
apply {{} {uplevel #[expr -1] {}}}
} -returnCodes error -result {bad level "#-1"}
test uplevel-4.25 {level parsing} -body {
apply {{} {uplevel 0xffffffff {}}}
} -returnCodes error -result {bad level "0xffffffff"}
test uplevel-4.26 {level parsing} -body {
apply {{} {uplevel #0xffffffff {}}}
} -returnCodes error -result {bad level "#0xffffffff"}
test uplevel-4.27 {level parsing} -body {
apply {{} {uplevel [expr 0xffffffff] {}}}
} -returnCodes error -result {bad level "4294967295"}
test uplevel-4.28 {level parsing} -body {
apply {{} {uplevel #[expr 0xffffffff] {}}}
} -returnCodes error -result {bad level "#4294967295"}
test uplevel-4.29 {level parsing} -body {
apply {{} {uplevel 0.2 {}}}
} -returnCodes error -result {invalid command name "0.2"}
test uplevel-4.30 {level parsing} -body {
apply {{} {uplevel #0.2 {}}}
} -returnCodes error -result {bad level "#0.2"}
test uplevel-4.31 {level parsing} -body {
apply {{} {uplevel [expr 0.2] {}}}
} -returnCodes error -result {invalid command name "0.2"}
test uplevel-4.32 {level parsing} -body {
apply {{} {uplevel #[expr 0.2] {}}}
} -returnCodes error -result {bad level "#0.2"}
test uplevel-4.33 {level parsing} -body {
apply {{} {uplevel .2 {}}}
} -returnCodes error -result {invalid command name ".2"}
test uplevel-4.34 {level parsing} -body {
apply {{} {uplevel #.2 {}}}
} -returnCodes error -result {bad level "#.2"}
test uplevel-4.35 {level parsing} -body {
apply {{} {uplevel [expr .2] {}}}
} -returnCodes error -result {invalid command name "0.2"}
test uplevel-4.36 {level parsing} -body {
apply {{} {uplevel #[expr .2] {}}}
} -returnCodes error -result {bad level "#0.2"}
|
| ︙ | ︙ |
Changes to tests/upvar.test.
| ︙ | ︙ | |||
352 353 354 355 356 357 358 359 360 361 362 363 364 365 |
array set upvarArray {}
upvar 0 upvarArray(elem) upvarArrayElemAlias(elem)
} -returnCodes 1 -match glob -result *
test upvar-9.1 {Tcl_UpVar2 procedure} testupvar {
list [catch {testupvar xyz a {} x global} msg] $msg
} {1 {bad level "xyz"}}
test upvar-9.2 {Tcl_UpVar2 procedure} testupvar {
catch {unset a}
catch {unset x}
set a 44
list [catch "testupvar #0 a 1 x global" msg] $msg
} {1 {can't access "a(1)": variable isn't array}}
test upvar-9.3 {Tcl_UpVar2 procedure} testupvar {
| > > > > | 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 |
array set upvarArray {}
upvar 0 upvarArray(elem) upvarArrayElemAlias(elem)
} -returnCodes 1 -match glob -result *
test upvar-9.1 {Tcl_UpVar2 procedure} testupvar {
list [catch {testupvar xyz a {} x global} msg] $msg
} {1 {bad level "xyz"}}
test upvar-9.1.1 {TclGetFrame, via Tcl_UpVar2} testupvar {
apply {{} {testupvar xyz a {} x local; set x foo}}
set a
} foo
test upvar-9.2 {Tcl_UpVar2 procedure} testupvar {
catch {unset a}
catch {unset x}
set a 44
list [catch "testupvar #0 a 1 x global" msg] $msg
} {1 {can't access "a(1)": variable isn't array}}
test upvar-9.3 {Tcl_UpVar2 procedure} testupvar {
|
| ︙ | ︙ |
Changes to tests/utf.test.
| ︙ | ︙ | |||
17 18 19 20 21 22 23 |
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testbytestring [llength [info commands testbytestring]]
catch {unset x}
# Some tests require support for 4-byte UTF-8 sequences
| | | > > > > > > > > > > > > | 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 |
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testbytestring [llength [info commands testbytestring]]
catch {unset x}
# Some tests require support for 4-byte UTF-8 sequences
testConstraint tip389 [expr {[string length \U010000] == 2}]
test utf-1.1 {Tcl_UniCharToUtf: 1 byte sequences} testbytestring {
expr {"\x01" eq [testbytestring "\x01"]}
} 1
test utf-1.2 {Tcl_UniCharToUtf: 2 byte sequences} testbytestring {
expr {"\x00" eq [testbytestring "\xc0\x80"]}
} 1
test utf-1.3 {Tcl_UniCharToUtf: 2 byte sequences} testbytestring {
expr {"\xe0" eq [testbytestring "\xc3\xa0"]}
} 1
test utf-1.4 {Tcl_UniCharToUtf: 3 byte sequences} testbytestring {
expr {"\u4e4e" eq [testbytestring "\xe4\xb9\x8e"]}
} 1
test utf-1.5 {Tcl_UniCharToUtf: overflowed Tcl_UniChar} testbytestring {
expr {[format %c 0x110000] eq [testbytestring "\xef\xbf\xbd"]}
} 1
test utf-1.6 {Tcl_UniCharToUtf: negative Tcl_UniChar} testbytestring {
expr {[format %c -1] eq [testbytestring "\xef\xbf\xbd"]}
} 1
test utf-1.7 {Tcl_UniCharToUtf: 4 byte sequences} -constraints testbytestring -body {
expr {"\U014e4e" eq [testbytestring "\xf0\x94\xb9\x8e"]}
} -result 1
test utf-1.8 {Tcl_UniCharToUtf: 3 byte sequence, high surrogate} testbytestring {
expr {"\ud842" eq [testbytestring "\xed\xa1\x82"]}
} 1
test utf-1.9 {Tcl_UniCharToUtf: 3 byte sequence, low surrogate} testbytestring {
expr {"\udc42" eq [testbytestring "\xed\xb1\x82"]}
} 1
test utf-1.10 {Tcl_UniCharToUtf: 3 byte sequence, high surrogate} testbytestring {
expr {[format %c 0xd842] eq [testbytestring "\xed\xa1\x82"]}
} 1
test utf-1.11 {Tcl_UniCharToUtf: 3 byte sequence, low surrogate} testbytestring {
expr {[format %c 0xdc42] eq [testbytestring "\xed\xb1\x82"]}
} 1
test utf-2.1 {Tcl_UtfToUniChar: low ascii} {
string length "abc"
} {3}
test utf-2.2 {Tcl_UtfToUniChar: naked trail bytes} testbytestring {
string length [testbytestring "\x82\x83\x84"]
} {3}
|
| ︙ | ︙ | |||
62 63 64 65 66 67 68 |
} {1}
test utf-2.6 {Tcl_UtfToUniChar: lead (3-byte) followed by 1 trail} testbytestring {
string length [testbytestring "\xE2\xA2"]
} {2}
test utf-2.7 {Tcl_UtfToUniChar: lead (3-byte) followed by 2 trail} testbytestring {
string length [testbytestring "\xE4\xb9\x8e"]
} {1}
| | | | 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 |
} {1}
test utf-2.6 {Tcl_UtfToUniChar: lead (3-byte) followed by 1 trail} testbytestring {
string length [testbytestring "\xE2\xA2"]
} {2}
test utf-2.7 {Tcl_UtfToUniChar: lead (3-byte) followed by 2 trail} testbytestring {
string length [testbytestring "\xE4\xb9\x8e"]
} {1}
test utf-2.8 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} -constraints {tip389 testbytestring} -body {
string length [testbytestring "\xF0\x90\x80\x80"]
} -result {2}
test utf-2.9 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} -constraints {tip389 testbytestring} -body {
string length [testbytestring "\xF4\x8F\xBF\xBF"]
} -result {2}
test utf-2.10 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail, underflow} testbytestring {
string length [testbytestring "\xF0\x8F\xBF\xBF"]
} {4}
test utf-2.11 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail, overflow} testbytestring {
string length [testbytestring "\xF4\x90\x80\x80"]
|
| ︙ | ︙ | |||
92 93 94 95 96 97 98 |
test utf-4.1 {Tcl_NumUtfChars: zero length} testnumutfchars {
testnumutfchars ""
} {0}
test utf-4.2 {Tcl_NumUtfChars: length 1} {testnumutfchars testbytestring} {
testnumutfchars [testbytestring "\xC2\xA2"]
} {1}
test utf-4.3 {Tcl_NumUtfChars: long string} {testnumutfchars testbytestring} {
| | | | 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 |
test utf-4.1 {Tcl_NumUtfChars: zero length} testnumutfchars {
testnumutfchars ""
} {0}
test utf-4.2 {Tcl_NumUtfChars: length 1} {testnumutfchars testbytestring} {
testnumutfchars [testbytestring "\xC2\xA2"]
} {1}
test utf-4.3 {Tcl_NumUtfChars: long string} {testnumutfchars testbytestring} {
testnumutfchars [testbytestring "abc\xC2\xA2\xE4\xB9\x8E\xA2\x4E"]
} {7}
test utf-4.4 {Tcl_NumUtfChars: #u0000} {testnumutfchars testbytestring} {
testnumutfchars [testbytestring "\xC0\x80"]
} {1}
test utf-4.5 {Tcl_NumUtfChars: zero length, calc len} testnumutfchars {
testnumutfchars "" 0
} {0}
test utf-4.6 {Tcl_NumUtfChars: length 1, calc len} {testnumutfchars testbytestring} {
testnumutfchars [testbytestring "\xC2\xA2"] 2
} {1}
test utf-4.7 {Tcl_NumUtfChars: long string, calc len} {testnumutfchars testbytestring} {
testnumutfchars [testbytestring "abc\xC2\xA2\xE4\xB9\x8E\xA2\x4E"] 10
} {7}
test utf-4.8 {Tcl_NumUtfChars: #u0000, calc len} {testnumutfchars testbytestring} {
testnumutfchars [testbytestring "\xC0\x80"] 2
} {1}
# Bug [2738427]: Tcl_NumUtfChars(...) no overflow check
test utf-4.9 {Tcl_NumUtfChars: #u20AC, calc len, incomplete} {testnumutfchars testbytestring} {
testnumutfchars [testbytestring "\xE2\x82\xAC"] 2
|
| ︙ | ︙ | |||
142 143 144 145 146 147 148 149 150 151 152 153 154 155 |
} "\u4e4e"
test utf-8.3 {Tcl_UniCharAtIndex: index > 0} {
string index abcd 2
} {c}
test utf-8.4 {Tcl_UniCharAtIndex: index > 0} {
string index \u4e4e\u25a\xff\u543 2
} "\uff"
test utf-9.1 {Tcl_UtfAtIndex: index = 0} {
string range abcd 0 2
} {abc}
test utf-9.2 {Tcl_UtfAtIndex: index > 0} {
string range \u4e4e\u25a\xff\u543klmnop 1 5
} "\u25a\xff\u543kl"
| > > > > > > | 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 |
} "\u4e4e"
test utf-8.3 {Tcl_UniCharAtIndex: index > 0} {
string index abcd 2
} {c}
test utf-8.4 {Tcl_UniCharAtIndex: index > 0} {
string index \u4e4e\u25a\xff\u543 2
} "\uff"
test utf-8.5 {Tcl_UniCharAtIndex: high surrogate} {
string index \ud842 0
} "\ud842"
test utf-8.6 {Tcl_UniCharAtIndex: low surrogate} {
string index \udc42 0
} "\udc42"
test utf-9.1 {Tcl_UtfAtIndex: index = 0} {
string range abcd 0 2
} {abc}
test utf-9.2 {Tcl_UtfAtIndex: index > 0} {
string range \u4e4e\u25a\xff\u543klmnop 1 5
} "\u25a\xff\u543kl"
|
| ︙ | ︙ | |||
167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 |
} 1
test utf-10.4 {Tcl_UtfBackslash: stops at first non-hex} testbytestring {
expr {"\u4e2k" eq "[testbytestring \xd3\xa2]k"}
} 1
test utf-10.5 {Tcl_UtfBackslash: stops after 4 hex chars} testbytestring {
expr {"\u4e216" eq "[testbytestring \xe4\xb8\xa1]6"}
} 1
proc bsCheck {char num} {
global errNum
test utf-10.$errNum {backslash substitution} {
scan $char %c value
set value
} $num
incr errNum
}
| > > > > > > | | 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 |
} 1
test utf-10.4 {Tcl_UtfBackslash: stops at first non-hex} testbytestring {
expr {"\u4e2k" eq "[testbytestring \xd3\xa2]k"}
} 1
test utf-10.5 {Tcl_UtfBackslash: stops after 4 hex chars} testbytestring {
expr {"\u4e216" eq "[testbytestring \xe4\xb8\xa1]6"}
} 1
test utf-10.6 {Tcl_UtfBackslash: stops after 5 hex chars} testbytestring {
expr {"\U1e2165" eq "[testbytestring \xf0\x9e\x88\x96]5"}
} 1
test utf-10.7 {Tcl_UtfBackslash: stops after 6 hex chars} testbytestring {
expr {"\U10e2165" eq "[testbytestring \xf4\x8e\x88\x96]5"}
} 1
proc bsCheck {char num} {
global errNum
test utf-10.$errNum {backslash substitution} {
scan $char %c value
set value
} $num
incr errNum
}
set errNum 8
bsCheck \b 8
bsCheck \e 101
bsCheck \f 12
bsCheck \n 10
bsCheck \r 13
bsCheck \t 9
bsCheck \v 11
|
| ︙ | ︙ | |||
224 225 226 227 228 229 230 | bsCheck \Ua 10 bsCheck \UA 10 bsCheck \Ua1 161 bsCheck \U4e21 20001 bsCheck \U004e21 20001 bsCheck \U00004e21 20001 bsCheck \U0000004e21 78 | < | | | | | | | < > > > > > > > > > > > > > > > > > > > > > | 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 |
bsCheck \Ua 10
bsCheck \UA 10
bsCheck \Ua1 161
bsCheck \U4e21 20001
bsCheck \U004e21 20001
bsCheck \U00004e21 20001
bsCheck \U0000004e21 78
bsCheck \U00110000 69632
bsCheck \U01100000 69632
bsCheck \U11000000 69632
bsCheck \U0010FFFF 1114111
bsCheck \U010FFFF0 1114111
bsCheck \U10FFFF00 1114111
bsCheck \UFFFFFFFF 1048575
test utf-11.1 {Tcl_UtfToUpper} {
string toupper {}
} {}
test utf-11.2 {Tcl_UtfToUpper} {
string toupper abc
} ABC
test utf-11.3 {Tcl_UtfToUpper} {
string toupper \u00e3ab
} \u00c3AB
test utf-11.4 {Tcl_UtfToUpper} {
string toupper \u01e3ab
} \u01e2AB
test utf-11.5 {Tcl_UtfToUpper Georgian (new in Unicode 11)} {
string toupper \u10d0\u1c90
} \u1c90\u1c90
test utf-11.6 {Tcl_UtfToUpper low/high surrogate)} {
string toupper \udc24\ud824
} \udc24\ud824
test utf-12.1 {Tcl_UtfToLower} {
string tolower {}
} {}
test utf-12.2 {Tcl_UtfToLower} {
string tolower ABC
} abc
test utf-12.3 {Tcl_UtfToLower} {
string tolower \u00c3AB
} \u00e3ab
test utf-12.4 {Tcl_UtfToLower} {
string tolower \u01e2AB
} \u01e3ab
test utf-12.5 {Tcl_UtfToLower Georgian (new in Unicode 11)} {
string tolower \u10d0\u1c90
} \u10d0\u10d0
test utf-12.6 {Tcl_UtfToUpper low/high surrogate)} {
string tolower \udc24\ud824
} \udc24\ud824
test utf-13.1 {Tcl_UtfToTitle} {
string totitle {}
} {}
test utf-13.2 {Tcl_UtfToTitle} {
string totitle abc
} Abc
test utf-13.3 {Tcl_UtfToTitle} {
string totitle \u00e3ab
} \u00c3ab
test utf-13.4 {Tcl_UtfToTitle} {
string totitle \u01f3ab
} \u01f2ab
test utf-13.5 {Tcl_UtfToTitle Georgian (new in Unicode 11)} {
string totitle \u10d0\u1c90
} \u10d0\u1c90
test utf-13.6 {Tcl_UtfToTitle Georgian (new in Unicode 11)} {
string totitle \u1c90\u10d0
} \u1c90\u10d0
test utf-13.7 {Tcl_UtfToTitle low/high surrogate)} {
string totitle \udc24\ud824
} \udc24\ud824
test utf-14.1 {Tcl_UtfNcasecmp} {
string compare -nocase a b
} -1
test utf-14.2 {Tcl_UtfNcasecmp} {
string compare -nocase b a
} 1
|
| ︙ | ︙ |
Changes to tests/util.test.
| ︙ | ︙ | |||
275 276 277 278 279 280 281 |
# pattern += Tcl_UtfToUniChar(pattern, &endChar);
# get 1 UTF-8 character
Wrapper_Tcl_StringMatch "a\[a\u4e4fc]c" "a\u4e4fc"
} 1
test util-5.18 {Tcl_StringMatch: UTF-8} testbytestring {
# pattern += Tcl_UtfToUniChar(pattern, &endChar);
# proper advance: wrong answer would match on UTF trail byte of \u4e4f
| | | 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 |
# pattern += Tcl_UtfToUniChar(pattern, &endChar);
# get 1 UTF-8 character
Wrapper_Tcl_StringMatch "a\[a\u4e4fc]c" "a\u4e4fc"
} 1
test util-5.18 {Tcl_StringMatch: UTF-8} testbytestring {
# pattern += Tcl_UtfToUniChar(pattern, &endChar);
# proper advance: wrong answer would match on UTF trail byte of \u4e4f
Wrapper_Tcl_StringMatch {a[a\u4e4fc]c} [testbytestring a\x8Fc]
} 0
test util-5.19 {Tcl_StringMatch: UTF-8} {
# pattern += Tcl_UtfToUniChar(pattern, &endChar);
# proper advance.
Wrapper_Tcl_StringMatch {a[a\u4e4fc]c} "acc"
} 1
test util-5.20 {Tcl_StringMatch} {
|
| ︙ | ︙ | |||
506 507 508 509 510 511 512 |
} d
test util-9.2.1 {TclGetIntForIndex} -body {
string index abcd { end}
} -returnCodes error -match glob -result *
test util-9.2.2 {TclGetIntForIndex} -body {
string index abcd {end }
} -returnCodes error -match glob -result *
| | | | | | 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 |
} d
test util-9.2.1 {TclGetIntForIndex} -body {
string index abcd { end}
} -returnCodes error -match glob -result *
test util-9.2.2 {TclGetIntForIndex} -body {
string index abcd {end }
} -returnCodes error -match glob -result *
test util-9.3 {TclGetIntForIndex} -body {
# Deprecated
string index abcd en
} -returnCodes error -match glob -result *
test util-9.4 {TclGetIntForIndex} -body {
# Deprecated
string index abcd e
} -returnCodes error -match glob -result *
test util-9.5.0 {TclGetIntForIndex} {
string index abcd end-1
} c
test util-9.5.1 {TclGetIntForIndex} {
string index abcd {end-1 }
} c
test util-9.5.2 {TclGetIntForIndex} -body {
|
| ︙ | ︙ | |||
609 610 611 612 613 614 615 |
string index a 0x
} -returnCodes error -match glob -result *
test util-9.31.1 {TclGetIntForIndex} -body {
string index a 0d
} -returnCodes error -match glob -result *
test util-9.32 {TclGetIntForIndex} -body {
string index a 0x1FFFFFFFF+0
| | | | | 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 |
string index a 0x
} -returnCodes error -match glob -result *
test util-9.31.1 {TclGetIntForIndex} -body {
string index a 0d
} -returnCodes error -match glob -result *
test util-9.32 {TclGetIntForIndex} -body {
string index a 0x1FFFFFFFF+0
} -result {}
test util-9.33 {TclGetIntForIndex} -body {
string index a 100000000000+0
} -result {}
test util-9.33.1 {TclGetIntForIndex} -body {
string index a 0d100000000000+0
} -result {}
test util-9.34 {TclGetIntForIndex} -body {
string index a 1.0
} -returnCodes error -match glob -result *
test util-9.35 {TclGetIntForIndex} -body {
string index a 1e23
} -returnCodes error -match glob -result *
test util-9.36 {TclGetIntForIndex} -body {
|
| ︙ | ︙ | |||
648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 |
string index a 0+1e2
} -returnCodes error -match glob -result *
test util-9.43 {TclGetIntForIndex} -body {
string index a 0+1.5e1
} -returnCodes error -match glob -result *
test util-9.44 {TclGetIntForIndex} -body {
string index a 0+1000000000000
} -returnCodes error -match glob -result *
test util-10.1 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
convertDouble 0x0000000000000000
} {0.0}
test util-10.2 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
convertDouble 0x8000000000000000
} {-0.0}
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 |
string index a 0+1e2
} -returnCodes error -match glob -result *
test util-9.43 {TclGetIntForIndex} -body {
string index a 0+1.5e1
} -returnCodes error -match glob -result *
test util-9.44 {TclGetIntForIndex} -body {
string index a 0+1000000000000
} -result {}
test util-9.45 {TclGetIntForIndex} {
string index abcd end+2305843009213693950
} {}
test util-9.46 {TclGetIntForIndex} {
string index abcd end+4294967294
} {}
# TIP 502
test util-9.47 {TclGetIntForIndex} {
string index abcd 0x10000000000000000
} {}
test util-9.48 {TclGetIntForIndex} {
string index abcd -0x10000000000000000
} {}
test util-9.49 {TclGetIntForIndex} -body {
string index abcd end*1
} -returnCodes error -match glob -result *
test util-9.50 {TclGetIntForIndex} -body {
string index abcd {end- 1}
} -returnCodes error -match glob -result *
test util-9.51 {TclGetIntForIndex} -body {
string index abcd end-end
} -returnCodes error -match glob -result *
test util-9.52 {TclGetIntForIndex} -body {
string index abcd end-x
} -returnCodes error -match glob -result *
test util-9.53 {TclGetIntForIndex} -body {
string index abcd end-0.1
} -returnCodes error -match glob -result *
test util-9.54 {TclGetIntForIndex} {
string index abcd end-0x10000000000000000
} {}
test util-9.55 {TclGetIntForIndex} {
string index abcd end+0x10000000000000000
} {}
test util-9.56 {TclGetIntForIndex} {
string index abcd end--0x10000000000000000
} {}
test util-9.57 {TclGetIntForIndex} {
string index abcd end+-0x10000000000000000
} {}
test util-9.58 {TclGetIntForIndex} {
string index abcd end--0x8000000000000000
} {}
test util-10.1 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
convertDouble 0x0000000000000000
} {0.0}
test util-10.2 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
convertDouble 0x8000000000000000
} {-0.0}
|
| ︙ | ︙ |
Changes to tests/var.test.
| ︙ | ︙ | |||
198 199 200 201 202 203 204 205 206 207 208 209 210 211 |
namespace delete [namespace current]
set result
}
} -result {0 2 1 {can't set "foo": upvar refers to element in deleted array}}
test var-1.19 {TclLookupVar, right error message when parsing variable name} -body {
[format set] thisvar(doesntexist)
} -returnCodes error -result {can't read "thisvar(doesntexist)": no such variable}
test var-2.1 {Tcl_LappendObjCmd, create var if new} {
catch {unset x}
lappend x 1 2
} {1 2}
test var-3.1 {MakeUpvar, TCL_NAMESPACE_ONLY not specified for other var} -setup {
| > > > > > > > > > > > > > > > > > > > > > > | 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 |
namespace delete [namespace current]
set result
}
} -result {0 2 1 {can't set "foo": upvar refers to element in deleted array}}
test var-1.19 {TclLookupVar, right error message when parsing variable name} -body {
[format set] thisvar(doesntexist)
} -returnCodes error -result {can't read "thisvar(doesntexist)": no such variable}
test var-1.20 {TclLookupVar, regression on utf-8 variable names} -setup {
proc p [list \u20ac \xe4] {info vars}
} -body {
# test variable with non-ascii name is available (euro and a-uml chars here):
list \
[p 1 2] \
[apply [list [list \u20ac \xe4] {info vars}] 1 2] \
[apply [list [list [list \u20ac \u20ac] [list \xe4 \xe4]] {info vars}]] \
} -cleanup {
rename p {}
} -result [lrepeat 3 [list \u20ac \xe4]]
test var-1.21 {TclLookupVar, regression on utf-8 variable names} -setup {
proc p [list [list \u20ac v\u20ac] [list \xe4 v\xe4]] {list [set \u20ac] [set \xe4]}
} -body {
# test variable with non-ascii name (and default) is resolvable (euro and a-uml chars here):
list \
[p] \
[apply [list [list \u20ac \xe4] {list [set \u20ac] [set \xe4]}] v\u20ac v\xe4] \
[apply [list [list [list \u20ac v\u20ac] [list \xe4 v\xe4]] {list [set \u20ac] [set \xe4]}]] \
} -cleanup {
rename p {}
} -result [lrepeat 3 [list v\u20ac v\xe4]]
test var-2.1 {Tcl_LappendObjCmd, create var if new} {
catch {unset x}
lappend x 1 2
} {1 2}
test var-3.1 {MakeUpvar, TCL_NAMESPACE_ONLY not specified for other var} -setup {
|
| ︙ | ︙ | |||
774 775 776 777 778 779 780 781 782 783 784 785 786 787 |
namespace eval :: {
set t(1) 1
trace variable t(1) u foo
unset t
}
set x "If you see this, it worked"
} -result "If you see this, it worked"
test var-14.1 {array names syntax} -body {
array names foo bar baz snafu
} -returnCodes 1 -match glob -result *
test var-14.2 {array names -glob} -body {
array names tcl_platform -glob os
} -result os
| > > > > > > > > > > > > > > > > | 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 |
namespace eval :: {
set t(1) 1
trace variable t(1) u foo
unset t
}
set x "If you see this, it worked"
} -result "If you see this, it worked"
test var-13.2 {unset array with search, bug 46a2410650} -body {
apply {{} {
array set a {aa 11 bb 22 cc 33 dd 44 ee 55 ff 66}
set s [array startsearch a]
unset a([array nextelement a $s])
array nextelement a $s
}}
} -returnCodes error -result {couldn't find search "s-1-a"}
test var-13.3 {unset array with search, SIGSEGV, bug 46a2410650} -body {
apply {{} {
array set a {aa 11 bb 22 cc 33 dd 44 ee 55 ff 66}
set s [array startsearch a]
unset a(ff)
array nextelement a $s
}}
} -returnCodes error -result {couldn't find search "s-1-a"}
test var-14.1 {array names syntax} -body {
array names foo bar baz snafu
} -returnCodes 1 -match glob -result *
test var-14.2 {array names -glob} -body {
array names tcl_platform -glob os
} -result os
|
| ︙ | ︙ | |||
817 818 819 820 821 822 823 824 825 826 827 828 829 830 |
set elements {1 2 3 4}
trace add variable a write "string length \$elements ;#"
array set a $elements
}
} -cleanup {
unset -nocomplain ::a ::elements
} -result {}
test var-18.1 {array unset and unset traces: Bug 2939073} -setup {
set already 0
unset -nocomplain x
} -body {
array set x {e 1 i 1}
trace add variable x unset {apply {args {
| > > > > > > > > > > > > | 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 |
set elements {1 2 3 4}
trace add variable a write "string length \$elements ;#"
array set a $elements
}
} -cleanup {
unset -nocomplain ::a ::elements
} -result {}
test var-17.2 {TclArraySet Dict shortcut only on pure value} -setup {
unset -nocomplain a d
set d {p 1 p 2}
dict get $d p
set foo 0
} -body {
trace add variable a write "[list incr [namespace which -variable foo]];#"
array set a $d
set foo
} -cleanup {
unset -nocomplain a d foo
} -result 2
test var-18.1 {array unset and unset traces: Bug 2939073} -setup {
set already 0
unset -nocomplain x
} -body {
array set x {e 1 i 1}
trace add variable x unset {apply {args {
|
| ︙ | ︙ | |||
928 929 930 931 932 933 934 935 936 937 938 939 940 941 |
vwait [namespace which -variable foo]
} -cleanup {
unset -nocomplain lambda foo
} -result {}
test var-20.10 {[bc1a96407a] array set don't compile bad varname} -body {
apply {{} {set name foo(bar); array set $name {a 1}}}
} -returnCodes error -match glob -result *
test var-21.0 {PushVarNameWord OBOE in compiled unset} -setup {
proc linenumber {} {dict get [info frame -1] line}
} -body {
apply {n {
set foo bar
unset foo {*}{
| > > > > > > > > > > > > > > > > > > > > > > | 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 |
vwait [namespace which -variable foo]
} -cleanup {
unset -nocomplain lambda foo
} -result {}
test var-20.10 {[bc1a96407a] array set don't compile bad varname} -body {
apply {{} {set name foo(bar); array set $name {a 1}}}
} -returnCodes error -match glob -result *
test var-20.11 {array set don't compile bad initializer} -setup {
unset -nocomplain foo
trace add variable foo array {set foo(bar) baz;#}
} -body {
catch {array set foo bad}
set foo(bar)
} -cleanup {
unset -nocomplain foo
} -result baz
test var-20.12 {array set don't compile bad initializer} -setup {
unset -nocomplain ::foo
trace add variable ::foo array {set ::foo(bar) baz;#}
} -body {
catch {apply {{} {
set value bad
array set ::foo $value
}}}
set ::foo(bar)
} -cleanup {
unset -nocomplain ::foo
} -result baz
test var-21.0 {PushVarNameWord OBOE in compiled unset} -setup {
proc linenumber {} {dict get [info frame -1] line}
} -body {
apply {n {
set foo bar
unset foo {*}{
|
| ︙ | ︙ | |||
994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 |
test var-22.2 {leak in parsedVarName} -constraints memory -body {
set i 0
leaktest {lappend x($i)}
} -cleanup {
unset -nocomplain i x
} -result 0
catch {namespace delete ns}
catch {unset arr}
catch {unset v}
catch {rename getbytes ""}
catch {rename p ""}
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 |
test var-22.2 {leak in parsedVarName} -constraints memory -body {
set i 0
leaktest {lappend x($i)}
} -cleanup {
unset -nocomplain i x
} -result 0
unset -nocomplain a k v
test var-23.1 {array command, for loop, too many args} -returnCodes error -body {
array for {k v} c d e {}
} -result {wrong # args: should be "array for {key value} arrayName script"}
test var-23.2 {array command, for loop, not enough args} -returnCodes error -body {
array for {k v} {}
} -result {wrong # args: should be "array for {key value} arrayName script"}
test var-23.3 {array command, for loop, too many list args} -setup {
unset -nocomplain a
} -returnCodes error -body {
array for {k v w} a {}
} -result {must have two variable names}
test var-23.4 {array command, for loop, not enough list args} -setup {
unset -nocomplain a
} -returnCodes error -body {
array for {k} a {}
} -result {must have two variable names}
test var-23.5 {array command, for loop, no array} -setup {
unset -nocomplain a
} -returnCodes error -body {
array for {k v} a {}
} -result {"a" isn't an array}
test var-23.6 {array command, for loop, array doesn't exist yet but has compiler-allocated procedure slot} -setup {
catch {rename p ""}
} -returnCodes error -body {
apply {{x} {
if {$x==1} {
return [array for {k v} a {}]
}
set a(x) 123
}} 1
} -result {"a" isn't an array}
test var-23.7 {array enumeration} -setup {
unset -nocomplain a
set reslist [list]
} -body {
array set a {a 1 b 2 c 3}
array for {k v} a {
lappend reslist $k $v
}
lsort -stride 2 -index 0 $reslist
} -cleanup {
unset -nocomplain a
unset -nocomplain reslist
} -result {a 1 b 2 c 3}
test var-23.9 {array enumeration, nested} -setup {
unset -nocomplain a
set reslist [list]
} -body {
array set a {a 1 b 2 c 3}
array for {k1 v1} a {
lappend reslist $k1 $v1
set r2 {}
array for {k2 v2} a {
lappend r2 $k2 $v2
}
lappend reslist [lsort -stride 2 -index 0 $r2]
}
# there is no guarantee in which order the array contents will be
# returned.
lsort -stride 3 -index 0 $reslist
} -cleanup {
unset -nocomplain a
unset -nocomplain reslist
} -result {a 1 {a 1 b 2 c 3} b 2 {a 1 b 2 c 3} c 3 {a 1 b 2 c 3}}
test var-23.10 {array enumeration, delete key} -match glob -setup {
unset -nocomplain a
set reslist [list]
} -body {
set retval {}
try {
array set a {a 1 b 2 c 3 d 4}
array for {k v} a {
lappend reslist $k $v
if { $k eq "a" } {
unset a(c)
}
}
lsort -stride 2 -index 0 $reslist
} on error {err res} {
set retval [dict get $res -errorinfo]
}
set retval
} -cleanup {
unset -nocomplain a
unset -nocomplain reslist
unset -nocomplain retval
} -result {array changed during iteration*}
test var-23.11 {array enumeration, insert key} -match glob -setup {
unset -nocomplain a
set reslist [list]
} -body {
set retval {}
try {
array set a {a 1 b 2 c 3 d 4}
array for {k v} a {
lappend reslist $k $v
if { $k eq "a" } {
set a(e) 5
}
}
lsort -stride 2 -index 0 $reslist
} on error {err res} {
set retval [dict get $res -errorinfo]
}
} -cleanup {
unset -nocomplain a
unset -nocomplain reslist
} -result {array changed during iteration*}
test var-23.12 {array enumeration, change value} -setup {
unset -nocomplain a
set reslist [list]
} -body {
array set a {a 1 b 2 c 3}
array for {k v} a {
lappend reslist $k $v
if { $k eq "a" } {
set a(c) 9
}
}
lsort -stride 2 -index 0 $reslist
} -cleanup {
unset -nocomplain a
unset -nocomplain reslist
} -result {a 1 b 2 c 9}
test var-23.13 {array enumeration, number of traces} -setup {
set ::countarrayfor 0
proc ::tracearrayfor { args } {
incr ::countarrayfor
}
unset -nocomplain ::a
set reslist [list]
} -body {
array set ::a {a 1 b 2 c 3}
foreach {k} [array names a] {
trace add variable ::a($k) read ::tracearrayfor
}
array for {k v} ::a {
lappend reslist $k $v
}
set ::countarrayfor
} -cleanup {
unset -nocomplain ::countarrayfor
unset -nocomplain ::a
unset -nocomplain reslist
} -result 3
test var-23.14 {array for, shared arguments} -setup {
set vn {k v}
unset -nocomplain $vn
} -body {
array set $vn {a 1 b 2 c 3}
array for $vn $vn {}
} -cleanup {
unset -nocomplain $vn vn
} -result {}
test var-24.1 {array default set and get: interpreted} -setup {
unset -nocomplain ary
} -body {
array set ary {a 3}
array default set ary 7
list $ary(a) $ary(b) [info exist ary(a)] [info exist ary(b)] \
[array default get ary]
} -cleanup {
unset -nocomplain ary
} -result {3 7 1 0 7}
test var-24.2 {array default set and get: compiled} {
apply {{} {
array set ary {a 3}
array default set ary 7
list $ary(a) $ary(b) [info exist ary(a)] [info exist ary(b)] \
[array default get ary]
}}
} {3 7 1 0 7}
test var-24.3 {array default unset: interpreted} -setup {
unset -nocomplain ary
} -body {
array set ary {a 3}
array default set ary 7
list $ary(a) $ary(b) [array default unset ary] $ary(a) [catch {set ary(b)}]
} -cleanup {
unset -nocomplain ary
} -result {3 7 {} 3 1}
test var-24.4 {array default unset: compiled} {
apply {{} {
array set ary {a 3}
array default set ary 7
list $ary(a) $ary(b) [array default unset ary] $ary(a) \
[catch {set ary(b)}]
}}
} {3 7 {} 3 1}
test var-24.5 {array default exists: interpreted} -setup {
unset -nocomplain ary result
set result {}
} -body {
array set ary {a 3}
lappend result [info exists ary],[array exists ary],[array default exists ary]
array default set ary 7
lappend result [info exists ary],[array exists ary],[array default exists ary]
array default unset ary
lappend result [info exists ary],[array exists ary],[array default exists ary]
unset ary
lappend result [info exists ary],[array exists ary],[array default exists ary]
array default set ary 11
lappend result [info exists ary],[array exists ary],[array default exists ary]
} -cleanup {
unset -nocomplain ary result
} -result {1,1,0 1,1,1 1,1,0 0,0,0 1,1,1}
test var-24.6 {array default exists: compiled} {
apply {{} {
array set ary {a 3}
lappend result [info exists ary],[array exists ary],[array default exists ary]
array default set ary 7
lappend result [info exists ary],[array exists ary],[array default exists ary]
array default unset ary
lappend result [info exists ary],[array exists ary],[array default exists ary]
unset ary
lappend result [info exists ary],[array exists ary],[array default exists ary]
array default set ary 11
lappend result [info exists ary],[array exists ary],[array default exists ary]
}}
} {1,1,0 1,1,1 1,1,0 0,0,0 1,1,1}
test var-24.7 {array default and append: interpreted} -setup {
unset -nocomplain ary result
set result {}
} -body {
array default set ary grill
lappend result [array size ary] [info exist ary(x)]
append ary(x) abc
lappend result [array size ary] $ary(x)
array default unset ary
append ary(x) def
append ary(y) ghi
lappend result [array size ary] $ary(x) $ary(y)
} -cleanup {
unset -nocomplain ary result
} -result {0 0 1 grillabc 2 grillabcdef ghi}
test var-24.8 {array default and append: compiled} {
apply {{} {
array default set ary grill
lappend result [array size ary] [info exist ary(x)]
append ary(x) abc
lappend result [array size ary] $ary(x)
array default unset ary
append ary(x) def
append ary(y) ghi
lappend result [array size ary] $ary(x) $ary(y)
}}
} {0 0 1 grillabc 2 grillabcdef ghi}
test var-24.9 {array default and lappend: interpreted} -setup {
unset -nocomplain ary result
set result {}
} -body {
array default set ary grill
lappend result [array size ary] [info exist ary(x)]
lappend ary(x) abc
lappend result [array size ary] $ary(x)
array default unset ary
lappend ary(x) def
lappend ary(y) ghi
lappend result [array size ary] $ary(x) $ary(y)
} -cleanup {
unset -nocomplain ary result
} -result {0 0 1 {grill abc} 2 {grill abc def} ghi}
test var-24.10 {array default and lappend: compiled} {
apply {{} {
array default set ary grill
lappend result [array size ary] [info exist ary(x)]
lappend ary(x) abc
lappend result [array size ary] $ary(x)
array default unset ary
lappend ary(x) def
lappend ary(y) ghi
lappend result [array size ary] $ary(x) $ary(y)
}}
} {0 0 1 {grill abc} 2 {grill abc def} ghi}
test var-24.11 {array default and incr: interpreted} -setup {
unset -nocomplain ary result
set result {}
} -body {
array default set ary 7
lappend result [array size ary] [info exist ary(x)]
incr ary(x) 11
lappend result [array size ary] $ary(x)
array default unset ary
incr ary(x)
incr ary(y)
lappend result [array size ary] $ary(x) $ary(y)
} -cleanup {
unset -nocomplain ary result
} -result {0 0 1 18 2 19 1}
test var-24.12 {array default and incr: compiled} {
apply {{} {
array default set ary 7
lappend result [array size ary] [info exist ary(x)]
incr ary(x) 11
lappend result [array size ary] $ary(x)
array default unset ary
incr ary(x)
incr ary(y)
lappend result [array size ary] $ary(x) $ary(y)
}}
} {0 0 1 18 2 19 1}
test var-24.13 {array default and dict: interpreted} -setup {
unset -nocomplain ary x y z
} -body {
array default set ary {x y}
dict lappend ary(p) x z
dict update ary(q) x y {
set y z
}
dict with ary(r) {
set x 123
}
lsort -stride 2 -index 0 [array get ary]
} -cleanup {
unset -nocomplain ary x y z
} -result {p {x {y z}} q {x z} r {x 123}}
test var-24.14 {array default and dict: compiled} {
lsort -stride 2 -index 0 [apply {{} {
array default set ary {x y}
dict lappend ary(p) x z
dict update ary(q) x y {
set y z
}
dict with ary(r) {
set x 123
}
array get ary
}}]
} {p {x {y z}} q {x z} r {x 123}}
test var-24.15 {array default set and get: two-level} {
apply {{} {
array set ary {a 3}
array default set ary 7
apply {{} {
upvar 1 ary ary ary(c) c
lappend result $ary(a) $ary(b) $c
lappend result [info exist ary(a)] [info exist ary(b)] [info exist c]
lappend result [array default get ary]
}}
}}
} {3 7 7 1 0 0 7}
test var-24.16 {array default set: errors} -setup {
unset -nocomplain ary
} -body {
set ary not-an-array
array default set ary 7
} -returnCodes error -cleanup {
unset -nocomplain ary
} -result {can't array default set "ary": variable isn't array}
test var-24.17 {array default set: errors} -setup {
unset -nocomplain ary
} -body {
array default set ary
} -returnCodes error -cleanup {
unset -nocomplain ary
} -result * -match glob
test var-24.18 {array default set: errors} -setup {
unset -nocomplain ary
} -body {
array default set ary x y
} -returnCodes error -cleanup {
unset -nocomplain ary
} -result * -match glob
test var-24.19 {array default get: errors} -setup {
unset -nocomplain ary
} -body {
set ary not-an-array
array default get ary
} -returnCodes error -cleanup {
unset -nocomplain ary
} -result {"ary" isn't an array}
test var-24.20 {array default get: errors} -setup {
unset -nocomplain ary
} -body {
array default get ary x y
} -returnCodes error -cleanup {
unset -nocomplain ary
} -result * -match glob
test var-24.21 {array default exists: errors} -setup {
unset -nocomplain ary
} -body {
set ary not-an-array
array default exists ary
} -returnCodes error -cleanup {
unset -nocomplain ary
} -result {"ary" isn't an array}
test var-24.22 {array default exists: errors} -setup {
unset -nocomplain ary
} -body {
array default exists ary x
} -returnCodes error -cleanup {
unset -nocomplain ary
} -result * -match glob
test var-24.23 {array default unset: errors} -setup {
unset -nocomplain ary
} -body {
set ary not-an-array
array default unset ary
} -returnCodes error -cleanup {
unset -nocomplain ary
} -result {"ary" isn't an array}
test var-24.24 {array default unset: errors} -setup {
unset -nocomplain ary
} -body {
array default unset ary x
} -returnCodes error -cleanup {
unset -nocomplain ary
} -result * -match glob
catch {namespace delete ns}
catch {unset arr}
catch {unset v}
catch {rename getbytes ""}
catch {rename p ""}
|
| ︙ | ︙ |
Changes to tests/winDde.test.
| ︙ | ︙ | |||
16 17 18 19 20 21 22 |
}
testConstraint debug [::tcl::pkgconfig get debug]
testConstraint dde 0
if {[testConstraint win]} {
if {![catch {
::tcltest::loadTestedCommands
| | | 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 |
}
testConstraint debug [::tcl::pkgconfig get debug]
testConstraint dde 0
if {[testConstraint win]} {
if {![catch {
::tcltest::loadTestedCommands
set ::ddever [package require dde 1.4.1]
set ::ddelib [lindex [package ifneeded dde $::ddever] 1]}]} {
testConstraint dde 1
}
}
# -------------------------------------------------------------------------
|
| ︙ | ︙ | |||
100 101 102 103 104 105 106 |
gets $f line
return $f
}
# -------------------------------------------------------------------------
test winDde-1.0 {check if we are testing the right dll} {win dde} {
set ::ddever
| | | 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 |
gets $f line
return $f
}
# -------------------------------------------------------------------------
test winDde-1.0 {check if we are testing the right dll} {win dde} {
set ::ddever
} {1.4.1}
test winDde-1.1 {Settings the server's topic name} -constraints dde -body {
list [dde servername foobar] [dde servername] [dde servername self]
} -result {foobar foobar self}
test winDde-2.1 {Checking for other services} -constraints dde -body {
expr [llength [dde services {} {}]] >= 0
|
| ︙ | ︙ |
Changes to tests/winFCmd.test.
| ︙ | ︙ | |||
52 53 54 55 56 57 58 |
if {$x != ""} {
catch {file delete -force -- {*}$x}
}
}
}
if {[testConstraint win]} {
| | < | | 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 |
if {$x != ""} {
catch {file delete -force -- {*}$x}
}
}
}
if {[testConstraint win]} {
if {$::tcl_platform(osVersion) >= 5.0} {
testConstraint winVista 1
} else {
testConstraint winXP 1
}
}
# find a CD-ROM so we can test read-only filesystems.
proc findfile {dir} {
|
| ︙ | ︙ | |||
1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 |
catch {file delete -force -- c:/td1}
} -constraints {win winXP} -body {
createfile c:/td1 {}
string tolower [file attributes c:/td1 -longname]
} -cleanup {
file delete -force -- c:/td1
} -result {c:/td1}
test winFCmd-12.7 {ConvertFileNameFormat} -body {
string tolower [file attributes //bisque/tcl/ws -longname]
} -constraints {nonPortable win} -result {//bisque/tcl/ws}
test winFCmd-12.8 {ConvertFileNameFormat} -setup {
cleanup
} -constraints {win longFileNames} -body {
createfile td1 {}
| > > > > > > > > > | 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 |
catch {file delete -force -- c:/td1}
} -constraints {win winXP} -body {
createfile c:/td1 {}
string tolower [file attributes c:/td1 -longname]
} -cleanup {
file delete -force -- c:/td1
} -result {c:/td1}
test winFCmd-12.6.2 {ConvertFileNameFormat: absolute path with drive (in temp folder)} -setup {
catch {file delete -force -- $::env(TEMP)/td1}
} -constraints {win} -body {
createfile $::env(TEMP)/td1 {}
string equal [string tolower [file attributes $::env(TEMP)/td1 -longname]] \
[string tolower [file normalize $::env(TEMP)]/td1]
} -cleanup {
file delete -force -- $::env(TEMP)/td1
} -result 1
test winFCmd-12.7 {ConvertFileNameFormat} -body {
string tolower [file attributes //bisque/tcl/ws -longname]
} -constraints {nonPortable win} -result {//bisque/tcl/ws}
test winFCmd-12.8 {ConvertFileNameFormat} -setup {
cleanup
} -constraints {win longFileNames} -body {
createfile td1 {}
|
| ︙ | ︙ |
Changes to tests/winFile.test.
| ︙ | ︙ | |||
35 36 37 38 39 40 41 |
} -match glob -result *
test winFile-1.4 {TclpGetUserHome} {win nonPortable} {
catch {glob ~stanton@workgroup}
} {0}
test winFile-2.1 {TclpMatchFiles: case sensitivity} -constraints {win} -body {
makeFile {} GlobCapS
| | | > | | 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 |
} -match glob -result *
test winFile-1.4 {TclpGetUserHome} {win nonPortable} {
catch {glob ~stanton@workgroup}
} {0}
test winFile-2.1 {TclpMatchFiles: case sensitivity} -constraints {win} -body {
makeFile {} GlobCapS
set args [list -nocomplain -tails -directory [temporaryDirectory]]
list [glob {*}$args GlobC*] [glob {*}$args globc*]} -cleanup {
removeFile GlobCapS
} -result {GlobCapS GlobCapS}
test winFile-2.2 {TclpMatchFiles: case sensitivity} -constraints {win} -body {
makeFile {} globlower
set args [list -nocomplain -tails -directory [temporaryDirectory]]
list [glob {*}$args globl*] [glob {*}$args gLOBl*]
} -cleanup {
removeFile globlower
} -result {globlower globlower}
test winFile-3.1 {file system} -constraints {win testvolumetype} -setup {
set res ""
} -body {
|
| ︙ | ︙ |
Changes to tests/winPipe.test.
| ︙ | ︙ | |||
18 19 20 21 22 23 24 |
catch {
::tcltest::loadTestedCommands
package require -exact Tcltest [info patchlevel]
set ::tcltestlib [lindex [package ifneeded Tcltest [info patchlevel]] 1]
}
| > | > > > > | 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 |
catch {
::tcltest::loadTestedCommands
package require -exact Tcltest [info patchlevel]
set ::tcltestlib [lindex [package ifneeded Tcltest [info patchlevel]] 1]
}
set org_pwd [pwd]
set bindir [file join $org_pwd [file dirname [info nameofexecutable]]]
set cat32 [file join $bindir cat32.exe]
# several test-cases here expect current directory == [temporaryDirectory]:
cd [temporaryDirectory]
testConstraint exec [llength [info commands exec]]
testConstraint cat32 [file exists $cat32]
testConstraint AllocConsole [catch {puts console1 ""}]
testConstraint RealConsole [expr {![testConstraint AllocConsole]}]
testConstraint testexcept [llength [info commands testexcept]]
testConstraint slowTest 0
set big bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb\n
append big $big
append big $big
append big $big
append big $big
|
| ︙ | ︙ | |||
304 305 306 307 308 309 310 |
puts -nonewline $f $big$big$big$big
flush $f
after 100 { lappend x timeout }
vwait x
lappend x [catch {close $f} msg] $msg
} {writable timeout 0 {}}
| > > > | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 |
puts -nonewline $f $big$big$big$big
flush $f
after 100 { lappend x timeout }
vwait x
lappend x [catch {close $f} msg] $msg
} {writable timeout 0 {}}
proc _testExecArgs {single args} {
variable path
if {![info exists path(echoArgs.tcl)] || ![file exists $path(echoArgs.tcl)]} {
set path(echoArgs.tcl) [makeFile {
puts "[list [file tail $argv0] {*}$argv]"
} echoArgs.tcl]
}
if {![info exists path(echoArgs.bat)] || ![file exists $path(echoArgs.bat)]} {
set path(echoArgs.bat) [makeFile "@[file native [interpreter]] $path(echoArgs.tcl) %*" "echoArgs.bat"]
}
set cmds [list [list [interpreter] $path(echoArgs.tcl)]]
if {!($single & 2)} {
lappend cmds [list $path(echoArgs.bat)]
} else {
if {![info exists path(echoArgs2.bat)] || ![file exists $path(echoArgs2.bat)]} {
set path(echoArgs2.bat) [makeFile \
"@[file native [interpreter]] $path(echoArgs.tcl) %*" \
"echo(Cmd)Test Args & Batch.bat" [makeDirectory test(Dir)Check]]
}
lappend cmds [list $path(echoArgs2.bat)]
}
set broken {}
foreach args $args {
if {$single & 1} {
# enclose single test-arg between 1st/3rd to be sure nothing is truncated
# (e. g. to cover unexpected trim by nts-zero case, and args don't recombined):
set args [list "1st" $args "3rd"]
}
set args [list {*}$args]; # normalized canonical list
foreach cmd $cmds {
set e [linsert $args 0 [file tail $path(echoArgs.tcl)]]
tcltest::DebugPuts 4 " ## test exec [file extension [lindex $cmd 0]] ($cmd) for\n ## $args"
if {[catch {
exec {*}$cmd {*}$args
} r]} {
set r "ERROR: $r"
}
if {$r ne $e} {
append broken "\[ERROR\]: exec [file extension [lindex $cmd 0]] on $args\n -- result:\n$r\n -- expected:\n$e\n"
}
if {$single & 8} {
# if test exe only:
break
}
}
}
return $broken
}
### validate the raw output of BuildCommandLine().
###
test winpipe-7.1 {BuildCommandLine: null arguments} {win exec} {
exec $env(COMSPEC) /c echo foo "" bar
} {foo "" bar}
test winpipe-7.2 {BuildCommandLine: null arguments} {win exec} {
|
| ︙ | ︙ | |||
364 365 366 367 368 369 370 371 372 373 |
} {foo "\ \\\\\\\"" bar}
test winpipe-7.17 {BuildCommandLine: special chars #4} {win exec} {
exec $env(COMSPEC) /c echo foo \{ bar
} "foo \{ bar"
test winpipe-7.18 {BuildCommandLine: special chars #5} {win exec} {
exec $env(COMSPEC) /c echo foo \} bar
} "foo \} bar"
### validate the pass-thru from BuildCommandLine() to the crt's parse_cmdline().
###
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > | | < | | < | | | > | > > > > > > > > > > > | | | > > | | < < | | | | | > > | | > | > > > > > | | > > > > | | | | | < > | > > > > > > > > > > > | < > | > > > | < < | | | | | | > | | > > > | > > > > > | | | > | > | | | | > > > > | 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 |
} {foo "\ \\\\\\\"" bar}
test winpipe-7.17 {BuildCommandLine: special chars #4} {win exec} {
exec $env(COMSPEC) /c echo foo \{ bar
} "foo \{ bar"
test winpipe-7.18 {BuildCommandLine: special chars #5} {win exec} {
exec $env(COMSPEC) /c echo foo \} bar
} "foo \} bar"
set injectList {
{test"whoami} {test""whoami}
{test"""whoami} {test""""whoami}
"test\"whoami\\" "test\"\"whoami\\"
"test\"\"\"whoami\\" "test\"\"\"\"whoami\\"
{test\\&\\test} {test"\\&\\test}
{"test\\&\\test} {"test"\\&\\"test"}
{test\\"&"\\test} {test"\\"&"\\test}
{"test\\"&"\\test} {"test"\\"&"\\"test"}
{test\"&whoami} {test"\"&whoami}
{test""\"&whoami} {test"""\"&whoami}
{test\"\&whoami} {test"\"\&whoami}
{test""\"\&whoami} {test"""\"\&whoami}
{test&whoami} {test|whoami}
{"test&whoami} {"test|whoami}
{test"&whoami} {test"|whoami}
{"test"&whoami} {"test"|whoami}
{""test"&whoami} {""test"|whoami}
{test&echo "} {test|echo "}
{"test&echo "} {"test|echo "}
{test"&echo "} {test"|echo "}
{"test"&echo "} {"test"|echo "}
{""test"&echo "} {""test"|echo "}
{test&echo ""} {test|echo ""}
{"test&echo ""} {"test|echo ""}
{test"&echo ""} {test"|echo ""}
{"test"&echo ""} {"test"|echo ""}
{""test"&echo ""} {""test"|echo ""}
{test>whoami} {test<whoami}
{"test>whoami} {"test<whoami}
{test">whoami} {test"<whoami}
{"test">whoami} {"test"<whoami}
{""test">whoami} {""test"<whoami}
{test(whoami)} {test(whoami)}
{test"(whoami)} {test"(whoami)}
{test^whoami} {test^^echo ^^^}
{test"^whoami} {test"^^echo ^^^}
{test"^echo ^^^"} {test""^echo" ^^^"}
{test%USERDOMAIN%\%USERNAME%}
{test" %USERDOMAIN%\%USERNAME%}
{test%USERDOMAIN%\\%USERNAME%}
{test" %USERDOMAIN%\\%USERNAME%}
{test%USERDOMAIN%&%USERNAME%}
{test" %USERDOMAIN%&%USERNAME%}
{test%USERDOMAIN%\&\%USERNAME%}
{test" %USERDOMAIN%\&\%USERNAME%}
{test%USERDOMAIN%\&\test}
{test" %USERDOMAIN%\&\test}
{test%USERDOMAIN%\\&\\test}
{test" %USERDOMAIN%\\&\\test}
{test%USERDOMAIN%\&\"test}
{test" %USERDOMAIN%\&\"test}
{test%USERDOMAIN%\\&\\"test}
{test" %USERDOMAIN%\\&\\"test}
}
### validate the pass-thru from BuildCommandLine() to the crt's parse_cmdline().
###
test winpipe-8.1 {BuildCommandLine/parse_cmdline pass-thru: dumped arguments are equal original} \
-constraints {win exec} -body {
_testExecArgs 0 \
[list foo "" bar] \
[list foo {} bar] \
[list foo "\"" bar] \
[list foo {""} bar] \
[list foo "\" " bar] \
[list foo {a="b"} bar] \
[list foo {a = "b"} bar] \
[list {"hello"} {""hello""} {"""hello"""} {"\"hello\""} {he llo} {he " llo}] \
[list foo \\ bar] \
[list foo \\\\ bar] \
[list foo \\\ \\ bar] \
[list foo \\\ \\\\ bar] \
[list foo \\\ \\\\\\ bar] \
[list foo \\\ \\\" bar] \
[list foo \\\ \\\\\" bar] \
[list foo \\\ \\\\\\\" bar] \
[list foo \{ bar] \
[list foo \} bar] \
[list foo * makefile.?c bar]
} -result {}
test winpipe-8.2 {BuildCommandLine/parse_cmdline pass-thru: check injection on special meta-chars (particular)} \
-constraints {win exec slowTest} -body {
_testExecArgs 1 {*}$injectList
} -result {}
test winpipe-8.3 {BuildCommandLine/parse_cmdline pass-thru: check injection on special meta-chars (jointly)} \
-constraints {win exec} -body {
_testExecArgs 0 \
[list START {*}$injectList END] \
[list "START\"" {*}$injectList END] \
[list START {*}$injectList "\"END"] \
[list "START\"" {*}$injectList "\"END"]
} -result {}
test winpipe-8.4 {BuildCommandLine/parse_cmdline pass-thru: check injection on special meta-chars (command/jointly args)} \
-constraints {win exec} -body {
_testExecArgs 2 \
[list START {*}$injectList END] \
[list "START\"" {*}$injectList END] \
[list START {*}$injectList "\"END"] \
[list "START\"" {*}$injectList "\"END"]
} -result {}
test winpipe-8.5 {BuildCommandLine/parse_cmdline pass-thru: check injection on special meta-chars (random mix)} \
-constraints {win exec} -body {
set lst {}
set maps {
{\&|^<>!()%}
{\&|^<>!()% }
{"\&|^<>!()%}
{"\&|^<>!()% }
{"""""\\\\\&|^<>!()%}
{"""""\\\\\&|^<>!()% }
}
set i 0
time {
set args {[incr i].}
time {
set map [lindex $maps [expr {int(rand()*[llength $maps])}]]
# be sure arg has some prefix (avoid special handling, like |& etc)
set a {x}
while {[string length $a] < 50} {
append a [string index $map [expr {int(rand()*[string length $map])}]]
}
lappend args $a
} 20
lappend lst $args
} 10
_testExecArgs 0 {*}$lst
} -result {} -cleanup {
unset -nocomplain lst args a map maps
}
set injectList {
"test\"\nwhoami" "test\"\"\nwhoami"
"test\"\"\"\nwhoami" "test\"\"\"\"\nwhoami"
"test;\n&echo \"" "\"test;\n&echo \""
"test\";\n&echo \"" "\"test\";\n&echo \""
"\"\"test\";\n&echo \""
}
test winpipe-8.6 {BuildCommandLine/parse_cmdline pass-thru: check new-line quoted in args} \
-constraints {win exec} -body {
# test exe only, because currently there is no proper way to escape a new-line char resp.
# to supply a new-line to the batch-files within arguments (command line is truncated).
_testExecArgs 8 \
[list START {*}$injectList END] \
[list "START\"" {*}$injectList END] \
[list START {*}$injectList "\"END"] \
[list "START\"" {*}$injectList "\"END"]
} -result {}
test winpipe-8.7 {BuildCommandLine/parse_cmdline pass-thru: check new-line quoted in args (batch)} \
-constraints {win exec knownBug} -body {
# this will fail if executed batch-file, because currently there is no proper way to escape a new-line char.
_testExecArgs 0 $injectList
} -result {}
rename _testExecArgs {}
# restore old values for env(TMP) and env(TEMP)
if {[catch {set env(TMP) $env_tmp}]} {
unset env(TMP)
}
if {[catch {set env(TEMP) $env_temp}]} {
unset env(TEMP)
}
# cleanup
removeFile little
removeFile big
removeFile more
removeFile stdout
removeFile stderr
removeFile nothing
if {[info exists path(echoArgs.tcl)]} { removeFile echoArgs.tcl }
if {[info exists path(echoArgs.bat)]} { removeFile echoArgs.bat }
if {[info exists path(echoArgs2.bat)]} { removeDirectory test(Dir)Check }
::tcltest::cleanupTests
# back to original directory:
cd $org_pwd; unset org_pwd
return
# Local Variables:
# mode: tcl
# End:
|
Added tests/zipfs.test.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 |
# The file tests the tclZlib.c file.
#
# This file contains a collection of tests for one or more of the Tcl built-in
# commands. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
#
# Copyright (c) 1996-1998 by Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.1
namespace import -force ::tcltest::*
}
testConstraint zipfs [expr {
[llength [info commands zlib]] && [regexp tcltest [info nameofexecutable]]
}]
testConstraint zipfslib 1
# Removed in tip430 - zipfs is no longer a static package
#test zipfs-0.0 {zipfs basics} -constraints zipfs -body {
# load {} zipfs
#} -result {}
set ziproot [zipfs root]
set CWD [pwd]
set tmpdir [file join $CWD tmp]
file mkdir $tmpdir
test zipfs-0.0 {zipfs basics} -constraints zipfs -body {
package require zipfs
} -result {2.0}
test zipfs-0.1 {zipfs basics} -constraints zipfs -body {
expr {${ziproot} in [file volumes]}
} -result 1
if {![string match ${ziproot}* $tcl_library]} {
###
# "make test" does not map tcl_library from the dynamic library on Unix
#
# Hack the environment to pretend we did pull tcl_library from a zip
# archive
###
set tclzip [file join $CWD [::tcl::pkgconfig get zipfile,runtime]]
testConstraint zipfslib [file exists $tclzip]
if {[testConstraint zipfslib]} {
zipfs mount /lib/tcl $tclzip
set ::tcl_library ${ziproot}lib/tcl/tcl_library
}
}
test zipfs-0.2 {zipfs basics} -constraints zipfslib -body {
string match ${ziproot}* $tcl_library
} -result 1
test zipfs-0.3 {zipfs basics: glob} -constraints zipfslib -setup {
set pwd [pwd]
} -body {
cd $tcl_library
expr { [file join . http] in [glob -dir . http*] }
} -cleanup {
cd $pwd
} -result 1
test zipfs-0.4 {zipfs basics: glob} -constraints zipfslib -setup {
set pwd [pwd]
} -body {
cd $tcl_library
expr { [file join $tcl_library http] in [glob -dir [pwd] http*] }
} -cleanup {
cd $pwd
} -result 1
test zipfs-0.5 {zipfs basics: glob} -constraints zipfslib -body {
expr { [file join $tcl_library http] in [glob -dir $tcl_library http*] }
} -result 1
test zipfs-0.6 {zipfs basics: glob} -constraints zipfslib -body {
expr { [file join $tcl_library http] in [glob [file join $tcl_library http*]] }
} -result 1
test zipfs-0.7 {zipfs basics: glob} -constraints zipfslib -body {
expr { "http" in [glob -tails -dir $tcl_library http*] }
} -result 1
test zipfs-0.8 {zipfs basics: glob} -constraints zipfslib -body {
expr { "http" in [glob -nocomplain -tails -types d -dir $tcl_library http*] }
} -result 1
test zipfs-0.9 {zipfs basics: glob} -constraints zipfslib -body {
glob -nocomplain -tails -types f -dir $tcl_library http*
} -result {}
test zipfs-0.10 {zipfs basics: join} -constraints {zipfs zipfslib} -body {
file join [zipfs root] bar baz
} -result "[zipfs root]bar/baz"
test zipfs-0.11 {zipfs basics: join} -constraints {zipfs zipfslib} -body {
file normalize [zipfs root]
} -result "[zipfs root]"
test zipfs-0.12 {zipfs basics: join} -constraints {zipfs zipfslib} -body {
file normalize [zipfs root]//bar/baz//qux/../
} -result "[zipfs root]bar/baz"
test zipfs-1.3 {zipfs errors} -constraints zipfs -returnCodes error -body {
zipfs mount a b c d e f
} -result {wrong # args: should be "zipfs mount ?mountpoint? ?zipfile? ?password?"}
test zipfs-1.4 {zipfs errors} -constraints zipfs -returnCodes error -body {
zipfs unmount a b c d e f
} -result {wrong # args: should be "zipfs unmount zipfile"}
test zipfs-1.5 {zipfs errors} -constraints zipfs -returnCodes error -body {
zipfs mkkey a b c d e f
} -result {wrong # args: should be "zipfs mkkey password"}
test zipfs-1.6 {zipfs errors} -constraints zipfs -returnCodes error -body {
zipfs mkimg a b c d e f
} -result {wrong # args: should be "zipfs mkimg outfile indir ?strip? ?password? ?infile?"}
test zipfs-1.7 {zipfs errors} -constraints zipfs -returnCodes error -body {
zipfs mkzip a b c d e f
} -result {wrong # args: should be "zipfs mkzip outfile indir ?strip? ?password?"}
test zipfs-1.8 {zipfs errors} -constraints zipfs -returnCodes error -body {
zipfs exists a b c d e f
} -result {wrong # args: should be "zipfs exists filename"}
test zipfs-1.9 {zipfs errors} -constraints zipfs -returnCodes error -body {
zipfs info a b c d e f
} -result {wrong # args: should be "zipfs info filename"}
test zipfs-1.10 {zipfs errors} -constraints zipfs -returnCodes error -body {
zipfs list a b c d e f
} -result {wrong # args: should be "zipfs list ?(-glob|-regexp)? ?pattern?"}
file mkdir tmp
test zipfs-2.1 {zipfs mkzip empty archive} -constraints zipfs -returnCodes error -body {
zipfs mkzip [file join $tmpdir empty.zip] $tcl_library/xxxx
} -result {empty archive}
###
# The next series of tests operate within a zipfile created a temporary
# directory.
###
set zipfile [file join $tmpdir abc.zip]
if {[file exists $zipfile]} {
file delete $zipfile
}
test zipfs-2.2 {zipfs mkzip} -constraints zipfs -body {
cd $tcl_library/encoding
zipfs mkzip $zipfile .
zipfs mount ${ziproot}abc $zipfile
zipfs list -glob ${ziproot}abc/cp850.*
} -cleanup {
cd $CWD
} -result "[zipfs root]abc/cp850.enc"
testConstraint zipfsenc [zipfs exists /abc/cp850.enc]
test zipfs-2.3 {zipfs info} -constraints {zipfs zipfsenc} -body {
set r [zipfs info ${ziproot}abc/cp850.enc]
lrange $r 0 2
} -result [list $zipfile 1090 527] ;# NOTE: Only the first 3 results are stable
test zipfs-2.4 {zipfs data} -constraints {zipfs zipfsenc} -body {
set zipfd [open ${ziproot}/abc/cp850.enc] ;# FIXME: leave open - see later test
read $zipfd
} -result {# Encoding file: cp850, single-byte
S
003F 0 1
00
0000000100020003000400050006000700080009000A000B000C000D000E000F
0010001100120013001400150016001700180019001A001B001C001D001E001F
0020002100220023002400250026002700280029002A002B002C002D002E002F
0030003100320033003400350036003700380039003A003B003C003D003E003F
0040004100420043004400450046004700480049004A004B004C004D004E004F
0050005100520053005400550056005700580059005A005B005C005D005E005F
0060006100620063006400650066006700680069006A006B006C006D006E006F
0070007100720073007400750076007700780079007A007B007C007D007E007F
00C700FC00E900E200E400E000E500E700EA00EB00E800EF00EE00EC00C400C5
00C900E600C600F400F600F200FB00F900FF00D600DC00F800A300D800D70192
00E100ED00F300FA00F100D100AA00BA00BF00AE00AC00BD00BC00A100AB00BB
2591259225932502252400C100C200C000A9256325512557255D00A200A52510
25142534252C251C2500253C00E300C3255A25542569256625602550256C00A4
00F000D000CA00CB00C8013100CD00CE00CF2518250C2588258400A600CC2580
00D300DF00D400D200F500D500B500FE00DE00DA00DB00D900FD00DD00AF00B4
00AD00B1201700BE00B600A700F700B800B000A800B700B900B300B225A000A0
} ;# FIXME: result depends on content of encodings dir
test zipfs-2.5 {zipfs exists} -constraints {zipfs zipfsenc} -body {
zipfs exists /abc/cp850.enc
} -result 1
test zipfs-2.6 {zipfs unmount while busy} -constraints {zipfs zipfsenc} -body {
zipfs unmount /abc
} -returnCodes error -result {filesystem is busy}
test zipfs-2.7 {zipfs unmount} -constraints {zipfs zipfsenc} -body {
close $zipfd
zipfs unmount /abc
zipfs exists /abc/cp850.enc
} -result 0
###
# Repeat the tests for a buffer mounted archive
###
test zipfs-2.8 {zipfs mkzip} -constraints zipfs -body {
cd $tcl_library/encoding
zipfs mkzip $zipfile .
set fin [open $zipfile r]
fconfigure $fin -translation binary
set dat [read $fin]
close $fin
zipfs mount_data def $dat
zipfs list -glob ${ziproot}def/cp850.*
} -cleanup {
cd $CWD
} -result "[zipfs root]def/cp850.enc"
testConstraint zipfsencbuf [zipfs exists /def/cp850.enc]
test zipfs-2.9 {zipfs info} -constraints {zipfs zipfsencbuf} -body {
set r [zipfs info ${ziproot}def/cp850.enc]
lrange $r 0 2
} -result [list {Memory Buffer} 1090 527] ;# NOTE: Only the first 3 results are stable
test zipfs-2.10 {zipfs data} -constraints {zipfs zipfsencbuf} -body {
set zipfd [open ${ziproot}/def/cp850.enc] ;# FIXME: leave open - see later test
read $zipfd
} -result {# Encoding file: cp850, single-byte
S
003F 0 1
00
0000000100020003000400050006000700080009000A000B000C000D000E000F
0010001100120013001400150016001700180019001A001B001C001D001E001F
0020002100220023002400250026002700280029002A002B002C002D002E002F
0030003100320033003400350036003700380039003A003B003C003D003E003F
0040004100420043004400450046004700480049004A004B004C004D004E004F
0050005100520053005400550056005700580059005A005B005C005D005E005F
0060006100620063006400650066006700680069006A006B006C006D006E006F
0070007100720073007400750076007700780079007A007B007C007D007E007F
00C700FC00E900E200E400E000E500E700EA00EB00E800EF00EE00EC00C400C5
00C900E600C600F400F600F200FB00F900FF00D600DC00F800A300D800D70192
00E100ED00F300FA00F100D100AA00BA00BF00AE00AC00BD00BC00A100AB00BB
2591259225932502252400C100C200C000A9256325512557255D00A200A52510
25142534252C251C2500253C00E300C3255A25542569256625602550256C00A4
00F000D000CA00CB00C8013100CD00CE00CF2518250C2588258400A600CC2580
00D300DF00D400D200F500D500B500FE00DE00DA00DB00D900FD00DD00AF00B4
00AD00B1201700BE00B600A700F700B800B000A800B700B900B300B225A000A0
} ;# FIXME: result depends on content of encodings dir
test zipfs-2.11 {zipfs exists} -constraints {zipfs zipfsencbuf} -body {
zipfs exists /def/cp850.enc
} -result 1
test zipfs-2.12 {zipfs unmount while busy} -constraints {zipfs zipfsencbuf} -body {
zipfs unmount /def
} -returnCodes error -result {filesystem is busy}
test zipfs-2.13 {zipfs unmount} -constraints {zipfs zipfsencbuf} -body {
close $zipfd
zipfs unmount /def
zipfs exists /def/cp850.enc
} -result 0
catch {file delete -force $tmpdir}
test zipfs-3.1 {zipfs in child interpreters} -constraints zipfs -setup {
set interp [interp create]
} -body {
interp eval $interp {
zipfs ?
}
} -returnCodes error -cleanup {
interp delete $interp
} -result {unknown or ambiguous subcommand "?": must be canonical, exists, find, info, list, lmkimg, lmkzip, mkimg, mkkey, mkzip, mount, mount_data, root, or unmount}
test zipfs-3.2 {zipfs in child interpreters} -constraints zipfs -setup {
set interp [interp create]
} -body {
interp eval $interp {
zipfs mkzip
}
} -returnCodes error -cleanup {
interp delete $interp
} -result {wrong # args: should be "zipfs mkzip outfile indir ?strip? ?password?"}
test zipfs-3.3 {zipfs in child interpreters} -constraints zipfs -setup {
set safe [interp create -safe]
} -body {
interp eval $safe {
zipfs ?
}
} -returnCodes error -cleanup {
interp delete $safe
} -result {unknown or ambiguous subcommand "?": must be canonical, exists, find, info, list, lmkimg, lmkzip, mkimg, mkkey, mkzip, mount, mount_data, root, or unmount}
test zipfs-3.4 {zipfs in child interpreters} -constraints zipfs -setup {
set safe [interp create -safe]
} -body {
interp eval $safe {
zipfs mkzip
}
} -returnCodes error -cleanup {
interp delete $safe
} -result {not allowed to invoke subcommand mkzip of zipfs}
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Changes to tools/genStubs.tcl.
| ︙ | ︙ | |||
194 195 196 197 198 199 200 201 202 203 204 205 206 207 |
if {([lindex $platformList 0] eq "deprecated")} {
set stubs($curName,deprecated,$index) [lindex $platformList 1]
set stubs($curName,generic,$index) $decl
if {![info exists stubs($curName,generic,lastNum)] \
|| ($index > $stubs($curName,generic,lastNum))} {
set stubs($curName,generic,lastNum) $index
}
} else {
foreach platform $platformList {
if {$decl ne ""} {
set stubs($curName,$platform,$index) $decl
if {![info exists stubs($curName,$platform,lastNum)] \
|| ($index > $stubs($curName,$platform,lastNum))} {
set stubs($curName,$platform,lastNum) $index
| > > > > > > > | 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 |
if {([lindex $platformList 0] eq "deprecated")} {
set stubs($curName,deprecated,$index) [lindex $platformList 1]
set stubs($curName,generic,$index) $decl
if {![info exists stubs($curName,generic,lastNum)] \
|| ($index > $stubs($curName,generic,lastNum))} {
set stubs($curName,generic,lastNum) $index
}
} elseif {([lindex $platformList 0] eq "nostub")} {
set stubs($curName,nostub,$index) [lindex $platformList 1]
set stubs($curName,generic,$index) $decl
if {![info exists stubs($curName,generic,lastNum)] \
|| ($index > $stubs($curName,generic,lastNum))} {
set stubs($curName,generic,lastNum) $index
}
} else {
foreach platform $platformList {
if {$decl ne ""} {
set stubs($curName,$platform,$index) $decl
if {![info exists stubs($curName,$platform,lastNum)] \
|| ($index > $stubs($curName,$platform,lastNum))} {
set stubs($curName,$platform,lastNum) $index
|
| ︙ | ︙ | |||
512 513 514 515 516 517 518 |
set pad 28
}
append line $next
set sep ", "
}
append line ", ...)"
if {[lindex $args end] eq "{const char *} format"} {
| | | 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 |
set pad 28
}
append line $next
set sep ", "
}
append line ", ...)"
if {[lindex $args end] eq "{const char *} format"} {
append line " TCL_FORMAT_PRINTF(" [expr {[llength $args] - 1}] ", " [llength $args] ")"
}
}
default {
set sep "("
foreach arg $args {
append line $sep
set next {}
|
| ︙ | ︙ | |||
589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 |
set lfname [string tolower [string index $fname 0]]
append lfname [string range $fname 1 end]
set text " "
if {[info exists stubs($name,deprecated,$index)]} {
append text "TCL_DEPRECATED_API(\"$stubs($name,deprecated,$index)\") "
}
if {$args eq ""} {
append text $rtype " *" $lfname "; /* $index */\n"
return $text
}
if {[string range $rtype end-8 end] eq "__stdcall"} {
append text [string trim [string range $rtype 0 end-9]] " (__stdcall *" $lfname ") "
} else {
append text $rtype " (*" $lfname ") "
}
set arg1 [lindex $args 0]
switch -exact $arg1 {
void {
append text "(void)"
}
TCL_VARARGS {
set sep "("
foreach arg [lrange $args 1 end] {
append text $sep [lindex $arg 0]
if {[string index $text end] ne "*"} {
append text " "
}
append text [lindex $arg 1] [lindex $arg 2]
set sep ", "
}
append text ", ...)"
if {[lindex $args end] eq "{const char *} format"} {
| > > > > | | 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 |
set lfname [string tolower [string index $fname 0]]
append lfname [string range $fname 1 end]
set text " "
if {[info exists stubs($name,deprecated,$index)]} {
append text "TCL_DEPRECATED_API(\"$stubs($name,deprecated,$index)\") "
} elseif {[info exists stubs($name,nostub,$index)]} {
append text "TCL_DEPRECATED_API(\"$stubs($name,nostub,$index)\") "
}
if {$args eq ""} {
append text $rtype " *" $lfname "; /* $index */\n"
return $text
}
if {[string range $rtype end-8 end] eq "__stdcall"} {
append text [string trim [string range $rtype 0 end-9]] " (__stdcall *" $lfname ") "
} elseif {[string range $rtype 0 11] eq "TCL_NORETURN"} {
append text "TCL_NORETURN1 " [string trim [string range $rtype 12 end]] " (*" $lfname ") "
} else {
append text $rtype " (*" $lfname ") "
}
set arg1 [lindex $args 0]
switch -exact $arg1 {
void {
append text "(void)"
}
TCL_VARARGS {
set sep "("
foreach arg [lrange $args 1 end] {
append text $sep [lindex $arg 0]
if {[string index $text end] ne "*"} {
append text " "
}
append text [lindex $arg 1] [lindex $arg 2]
set sep ", "
}
append text ", ...)"
if {[lindex $args end] eq "{const char *} format"} {
append text " TCL_FORMAT_PRINTF(" [expr {[llength $args] - 1}] ", " [llength $args] ")"
}
}
default {
set sep "("
foreach arg $args {
append text $sep [lindex $arg 0]
if {[string index $text end] ne "*"} {
|
| ︙ | ︙ | |||
699 700 701 702 703 704 705 706 707 708 709 710 711 712 |
}
for {set i 0} {$i <= $lastNum} {incr i} {
set slots [array names stubs $name,*,$i]
set emit 0
if {[info exists stubs($name,deprecated,$i)]} {
append text [$slotProc $name $stubs($name,generic,$i) $i]
set emit 1
} elseif {[info exists stubs($name,generic,$i)]} {
if {[llength $slots] > 1} {
puts stderr "conflicting generic and platform entries:\
$name $i"
}
append text [$slotProc $name $stubs($name,generic,$i) $i]
set emit 1
| > > > | 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 |
}
for {set i 0} {$i <= $lastNum} {incr i} {
set slots [array names stubs $name,*,$i]
set emit 0
if {[info exists stubs($name,deprecated,$i)]} {
append text [$slotProc $name $stubs($name,generic,$i) $i]
set emit 1
} elseif {[info exists stubs($name,nostub,$i)]} {
append text [$slotProc $name $stubs($name,generic,$i) $i]
set emit 1
} elseif {[info exists stubs($name,generic,$i)]} {
if {[llength $slots] > 1} {
puts stderr "conflicting generic and platform entries:\
$name $i"
}
append text [$slotProc $name $stubs($name,generic,$i) $i]
set emit 1
|
| ︙ | ︙ |
Added tools/installVfs.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 |
#!/bin/sh
#\
exec tclsh "$0" ${1+"$@"}
#----------------------------------------------------------------------
#
# installVfs.tcl --
#
# This file wraps the /library file system around a binary
#
#----------------------------------------------------------------------
#
# Copyright (c) 2018 by Sean Woods. All rights reserved.
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#----------------------------------------------------------------------
proc mapDir {resultvar prefix filepath} {
upvar 1 $resultvar result
if {![info exists result]} {
set result {}
}
set queue [list $prefix $filepath]
while {[llength $queue]} {
set queue [lassign $queue qprefix qpath]
foreach ftail [glob -directory $qpath -nocomplain -tails *] {
set f [file join $qpath $ftail]
if {[file isdirectory $f]} {
if {$ftail eq "CVS"} continue
lappend queue [file join $qprefix $ftail] $f
} elseif {[file isfile $f]} {
if {$ftail eq "pkgIndex.tcl"} continue
if {$ftail eq "manifest.txt"} {
lappend result $f [file join $qprefix pkgIndex.tcl]
} else {
lappend result $f [file join $qprefix $ftail]
}
}
}
}
}
if {[llength $argv]<4} {
error "Usage: [file tail [info script]] IMG_OUTPUT IMG_INPUT PREFIX FILE_SYSTEM ?PREFIX FILE_SYSTEM?..."
}
set paths [lassign $argv DLL_OUTPUT DLL_INPUT]
foreach {prefix fpath} $paths {
mapDir files $prefix [file normalize $fpath]
}
if {$DLL_INPUT != {}} {
zipfs lmkzip $DLL_OUTPUT $files
} else {
zipfs lmkimg $DLL_OUTPUT $files {} $DLL_INPUT
}
|
Added tools/makeHeader.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 |
# makeHeader.tcl --
#
# This script generates embeddable C source (in a .h file) from a .tcl
# script.
#
# Copyright (c) 2018 Donal K. Fellows
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
package require Tcl 8.6
namespace eval makeHeader {
####################################################################
#
# mapSpecial --
# Transform a single line so that it is able to be put in a C string.
#
proc mapSpecial {str} {
# All Tcl metacharacters and key C backslash sequences
set MAP {
\" \\\\\" \\ \\\\\\\\ $ \\$ [ \\[ ] \\] ' \\\\' ? \\\\?
\a \\\\a \b \\\\b \f \\\\f \n \\\\n \r \\\\r \t \\\\t \v \\\\v
}
set XFORM {[format \\\\\\\\u%04x {*}[scan & %c]]}
subst [regsub -all {[^\u0020-\u007e]} [string map $MAP $str] $XFORM]
}
####################################################################
#
# compactLeadingSpaces --
# Converts the leading whitespace on a line into a more compact form.
#
proc compactLeadingSpaces {line} {
set line [string map {\t { }} [string trimright $line]]
if {[regexp {^[ ]+} $line spaces]} {
regsub -all {[ ]{4}} $spaces \t replace
set len [expr {[string length $spaces] - 1}]
set line [string replace $line 0 $len $replace]
}
return $line
}
####################################################################
#
# processScript --
# Transform a whole sequence of lines with [mapSpecial].
#
proc processScript {scriptLines} {
lmap line $scriptLines {
# Skip blank and comment lines; they're there in the original
# sources so we don't need to copy them over.
if {[regexp {^\s*(?:#|$)} $line]} continue
format {"%s"} [mapSpecial [compactLeadingSpaces $line]\n]
}
}
####################################################################
#
# updateTemplate --
# Rewrite a template to contain the content from the input script.
#
proc updateTemplate {dataVar scriptLines} {
set BEGIN "*!BEGIN!: Do not edit below this line.*"
set END "*!END!: Do not edit above this line.*"
upvar 1 $dataVar data
set from [lsearch -glob $data $BEGIN]
set to [lsearch -glob $data $END]
if {$from == -1 || $to == -1 || $from >= $to} {
throw BAD "not a template"
}
set data [lreplace $data $from+1 $to-1 {*}[processScript $scriptLines]]
}
####################################################################
#
# stripSurround --
# Removes the header and footer comments from a (line-split list of
# lines of) Tcl script code.
#
proc stripSurround {lines} {
set RE {^\s*$|^#}
set state 0
set lines [lmap line [lreverse $lines] {
if {!$state && [regexp $RE $line]} continue {
set state 1
set line
}
}]
return [lmap line [lreverse $lines] {
if {$state && [regexp $RE $line]} continue {
set state 0
set line
}
}]
}
####################################################################
#
# updateTemplateFile --
# Rewrites a template file with the lines of the given script.
#
proc updateTemplateFile {headerFile scriptLines} {
set f [open $headerFile "r+"]
try {
set content [split [chan read -nonewline $f] "\n"]
updateTemplate content [stripSurround $scriptLines]
chan seek $f 0
chan puts $f [join $content \n]
chan truncate $f
} trap BAD msg {
# Add the filename to the message
throw BAD "${headerFile}: $msg"
} finally {
chan close $f
}
}
####################################################################
#
# readScript --
# Read a script from a file and return its lines.
#
proc readScript {script} {
set f [open $script]
try {
chan configure $f -encoding utf-8
return [split [string trim [chan read $f]] "\n"]
} finally {
chan close $f
}
}
####################################################################
#
# run --
# The main program of this script.
#
proc run {args} {
try {
if {[llength $args] != 2} {
throw ARGS "inputTclScript templateFile"
}
lassign $args inputTclScript templateFile
puts "Inserting $inputTclScript into $templateFile"
set scriptLines [readScript $inputTclScript]
updateTemplateFile $templateFile $scriptLines
exit 0
} trap ARGS msg {
puts stderr "wrong # args: should be \"[file tail $::argv0] $msg\""
exit 2
} trap BAD msg {
puts stderr $msg
exit 1
} trap POSIX msg {
puts stderr $msg
exit 1
} on error {- opts} {
puts stderr [dict get $opts -errorinfo]
exit 3
}
}
}
########################################################################
#
# Launch the main program
#
if {[info script] eq $::argv0} {
makeHeader::run {*}$::argv
}
# Local-Variables:
# mode: tcl
# fill-column: 78
# End:
|
Changes to tools/man2help2.tcl.
| ︙ | ︙ | |||
823 824 825 826 827 828 829 |
} elseif {$length == 1} {
set indent 5
}
if {$text == {\(bu}} {
set text "\u00b7"
}
| | | 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 |
} elseif {$length == 1} {
set indent 5
}
if {$text == {\(bu}} {
set text "\u00b7"
}
set tab [expr {$indent * 0.1}]i
newPara $tab -$tab
set state(sb) 80
setTabs $tab
formattedText $text
tab
}
|
| ︙ | ︙ |
Changes to tools/man2html2.tcl.
| ︙ | ︙ | |||
110 111 112 113 114 115 116 |
# string - Text to output in the paragraph.
proc text string {
global file textState inDT charCnt inTable
set pos [string first "\t" $string]
if {$pos >= 0} {
| | | | 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 |
# string - Text to output in the paragraph.
proc text string {
global file textState inDT charCnt inTable
set pos [string first "\t" $string]
if {$pos >= 0} {
text [string range $string 0 [expr {$pos-1}]]
tab
text [string range $string [expr {$pos+1}] end]
return
}
if {$inTable} {
if {$inTable == 1} {
puts -nonewline $file <TR>
set inTable 2
}
|
| ︙ | ︙ | |||
467 468 469 470 471 472 473 |
# puts "formattedText: $text"
while {$text ne ""} {
set index [string first \\ $text]
if {$index < 0} {
text $text
return
}
| | | | | | | | | | 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 |
# puts "formattedText: $text"
while {$text ne ""} {
set index [string first \\ $text]
if {$index < 0} {
text $text
return
}
text [string range $text 0 [expr {$index-1}]]
set c [string index $text [expr {$index+1}]]
switch -- $c {
f {
font [string index $text [expr {$index+2}]]
set text [string range $text [expr {$index+3}] end]
}
e {
text \\
set text [string range $text [expr {$index+2}] end]
}
- {
dash
set text [string range $text [expr {$index+2}] end]
}
| {
set text [string range $text [expr {$index+2}] end]
}
default {
puts stderr "Unknown sequence: \\$c"
set text [string range $text [expr {$index+2}] end]
}
}
}
}
##############################################################################
# dash --
|
| ︙ | ︙ | |||
523 524 525 526 527 528 529 |
# Arguments:
# None.
proc tab {} {
global inPRE charCnt tabString file
# ? charCnt
if {$inPRE == 1} {
| | | 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 |
# Arguments:
# None.
proc tab {} {
global inPRE charCnt tabString file
# ? charCnt
if {$inPRE == 1} {
set pos [expr {$charCnt % [string length $tabString]}]
set spaces [string first "1" [string range $tabString $pos end] ]
text [format "%*s" [incr spaces] " "]
} else {
# puts "tab: found tab outside of <PRE> block"
}
}
|
| ︙ | ︙ |
Added tools/mkVfs.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 |
proc cat fname {
set fname [open $fname r]
set data [read $fname]
close $fname
return $data
}
proc pkgIndexDir {root fout d1} {
puts [format {%*sIndexing %s} [expr {4 * [info level]}] {} \
[file tail $d1]]
set idx [string length $root]
foreach ftail [glob -directory $d1 -nocomplain -tails *] {
set f [file join $d1 $ftail]
if {[file isdirectory $f] && [string compare CVS $ftail]} {
pkgIndexDir $root $fout $f
} elseif {[file tail $f] eq "pkgIndex.tcl"} {
puts $fout "set dir \${VFSROOT}[string range $d1 $idx end]"
puts $fout [cat $f]
}
}
}
###
# Script to build the VFS file system
###
proc copyDir {d1 d2} {
puts [format {%*sCreating %s} [expr {4 * [info level]}] {} \
[file tail $d2]]
file delete -force -- $d2
file mkdir $d2
foreach ftail [glob -directory $d1 -nocomplain -tails *] {
set f [file join $d1 $ftail]
if {[file isdirectory $f] && [string compare CVS $ftail]} {
copyDir $f [file join $d2 $ftail]
} elseif {[file isfile $f]} {
file copy -force $f [file join $d2 $ftail]
if {$::tcl_platform(platform) eq {unix}} {
file attributes [file join $d2 $ftail] -permissions 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
}
}
if {[llength $argv] < 3} {
puts "Usage: VFS_ROOT TCLSRC_ROOT PLATFORM"
exit 1
}
set TCL_SCRIPT_DIR [lindex $argv 0]
set TCLSRC_ROOT [lindex $argv 1]
set PLATFORM [lindex $argv 2]
set TKDLL [lindex $argv 3]
set TKVER [lindex $argv 4]
puts "Building [file tail $TCL_SCRIPT_DIR] for $PLATFORM"
copyDir ${TCLSRC_ROOT}/library ${TCL_SCRIPT_DIR}
if {$PLATFORM == "windows"} {
set ddedll [glob -nocomplain ${TCLSRC_ROOT}/win/tcldde*.dll]
puts "DDE DLL $ddedll"
if {$ddedll != {}} {
file copy $ddedll ${TCL_SCRIPT_DIR}/dde
}
set regdll [glob -nocomplain ${TCLSRC_ROOT}/win/tclreg*.dll]
puts "REG DLL $ddedll"
if {$regdll != {}} {
file copy $regdll ${TCL_SCRIPT_DIR}/reg
}
} else {
# Remove the dde and reg package paths
file delete -force ${TCL_SCRIPT_DIR}/dde
file delete -force ${TCL_SCRIPT_DIR}/reg
}
# For the following packages, cat their pkgIndex files to tclIndex
file attributes ${TCL_SCRIPT_DIR}/tclIndex -readonly 0
set fout [open ${TCL_SCRIPT_DIR}/tclIndex a]
puts $fout {#
# MANIFEST OF INCLUDED PACKAGES
#
set VFSROOT $dir
}
if {$TKDLL ne {} && [file exists $TKDLL]} {
file copy $TKDLL ${TCL_SCRIPT_DIR}
puts $fout [list package ifneeded Tk $TKVER "load \$dir $TKDLL"]
}
pkgIndexDir ${TCL_SCRIPT_DIR} $fout ${TCL_SCRIPT_DIR}
close $fout
|
Changes to tools/regexpTestLib.tcl.
| ︙ | ︙ | |||
13 14 15 16 17 18 19 |
set fileId [open $inFileName r]
set i 0
while {[gets $fileId line] >= 0} {
set len [string length $line]
| | | | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 |
set fileId [open $inFileName r]
set i 0
while {[gets $fileId line] >= 0} {
set len [string length $line]
if {($len > 0) && ([string index $line [expr {$len - 1}]] == "\\")} {
if {[info exists lineArray(c$i)] == 0} {
set lineArray(c$i) 1
} else {
incr lineArray(c$i)
}
set line [string range $line 0 [expr {$len - 2}]]
append lineArray($i) $line
continue
}
if {[info exists lineArray(c$i)] == 0} {
set lineArray(c$i) 1
} else {
incr lineArray(c$i)
|
| ︙ | ︙ | |||
200 201 202 203 204 205 206 |
}
set str [lindex $currentLine 2]
}
set flags [removeFlags $flags]
# find the test result
| | | 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 |
}
set str [lindex $currentLine 2]
}
set flags [removeFlags $flags]
# find the test result
set numVars [expr {$len - 3}]
set vars {}
set vals {}
set result 0
set v 0
if {[regsub {\*} "$flags" "" newFlags] == 1} {
# an error is expected
|
| ︙ | ︙ |
Changes to tools/str2c.
| ︙ | ︙ | |||
35 36 37 38 39 40 41 |
} else {
puts "/*
* Multi parts read only string generated by str2c
*/
static const char * const data\[\]= {"
set n 1
for {set i 0} {$i<$lg} {incr i $MAX} {
| | | 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 |
} else {
puts "/*
* Multi parts read only string generated by str2c
*/
static const char * const data\[\]= {"
set n 1
for {set i 0} {$i<$lg} {incr i $MAX} {
set part [string range $r $i [expr {$i+$MAX-1}]]
set len [string length $part];
puts "\t/* Start of part $n ($len characters) */"
puts "\t\"[translate $part]\","
puts "\t/* End of part $n */\n"
incr n
}
puts "\tNULL\t/* End of data marker */\n};"
|
| ︙ | ︙ |
Changes to tools/tcltk-man2html-utils.tcl.
| ︙ | ︙ | |||
145 146 147 148 149 150 151 152 153 154 155 156 157 158 |
{\%} {} \
"\\\n" "\n" \
{\(+-} "±" \
{\(co} "©" \
{\(em} "—" \
{\(en} "–" \
{\(fm} "′" \
{\(mu} "×" \
{\(mi} "−" \
{\(->} "<font size=\"+1\">→</font>" \
{\fP} {\fR} \
{\.} . \
{\(bu} "•" \
]
| > | 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 |
{\%} {} \
"\\\n" "\n" \
{\(+-} "±" \
{\(co} "©" \
{\(em} "—" \
{\(en} "–" \
{\(fm} "′" \
{\(mc} "µ" \
{\(mu} "×" \
{\(mi} "−" \
{\(->} "<font size=\"+1\">→</font>" \
{\fP} {\fR} \
{\.} . \
{\(bu} "•" \
]
|
| ︙ | ︙ | |||
1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 |
#
set manual(toc-$manual(wing-file)-$manual(name)) \
[concat <DL> $manual(section-toc) </DL>]
}
if {!$verbose} {
puts stderr ""
}
#
# make the wing table of contents for the section
#
set width 0
foreach name $manual(wing-toc) {
if {[string length $name] > $width} {
| > > > > | 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 |
#
set manual(toc-$manual(wing-file)-$manual(name)) \
[concat <DL> $manual(section-toc) </DL>]
}
if {!$verbose} {
puts stderr ""
}
if {![llength $manual(wing-toc)]} {
fatal "not table of contents."
}
#
# make the wing table of contents for the section
#
set width 0
foreach name $manual(wing-toc) {
if {[string length $name] > $width} {
|
| ︙ | ︙ |
Changes to tools/tcltk-man2html.tcl.
| ︙ | ︙ | |||
27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 |
##
## Source the utility functions that provide most of the
## implementation of the transformation from nroff to html.
##
source [file join [file dirname [info script]] tcltk-man2html-utils.tcl]
proc parse_command_line {} {
global argv Version
# These variables determine where the man pages come from and where
# the converted pages go to.
global tcltkdir tkdir tcldir webdir build_tcl build_tk verbose
# Set defaults based on original code.
set tcltkdir ../..
set tkdir {}
set tcldir {}
set webdir ../html
set build_tcl 0
set build_tk 0
set verbose 0
# Default search version is a glob pattern
set useversion {{,[8-9].[0-9]{,[.ab][0-9]{,[0-9]}}}}
# Handle arguments a la GNU:
# --version
# --useversion=<version>
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 |
##
## Source the utility functions that provide most of the
## implementation of the transformation from nroff to html.
##
source [file join [file dirname [info script]] tcltk-man2html-utils.tcl]
proc getversion {tclh {name {}}} {
if {[file exists $tclh]} {
set chan [open $tclh]
set data [read $chan]
close $chan
if {$name eq ""} {
set name [string toupper [file root [file tail $tclh]]]
}
# backslash isn't required in front of quote, but it keeps syntax
# highlighting straight in some editors
if {[regexp -lineanchor \
[string map [list @name@ $name] \
{^#define\s+@name@_VERSION\s+\"([^.])+\.([^.\"]+)}] \
$data -> major minor]} {
return [list $major $minor]
}
}
}
proc findversion {top name useversion} {
# Default search version is a glob pattern, switch it for string match:
if {$useversion eq {{,[8-9].[0-9]{,[.ab][0-9]{,[0-9]}}}}} {
set useversion {[8-9].[0-9]}
}
# Search:
set upper [string toupper $name]
foreach top1 [list $top $top/..] sub {{} generic} {
foreach dirname [
glob -nocomplain -tails -type d -directory $top1 *] {
set tclh [join [list $top1 $dirname {*}$sub ${name}.h] /]
set v [getversion $tclh $upper]
if {[llength $v]} {
lassign $v major minor
# to do
# use glob matching instead of string matching or add
# brace handling to [string matcch]
if {$useversion eq {} || [string match $useversion $major.$minor]} {
set top [file dirname [file dirname $tclh]]
set prefix [file dirname $top]
return [list $prefix [file tail $top] $major $minor]
}
}
}
}
}
proc parse_command_line {} {
global argv Version
# These variables determine where the man pages come from and where
# the converted pages go to.
global tcltkdir tkdir tcldir webdir build_tcl build_tk verbose
# Set defaults based on original code.
set tcltkdir ../..
set tkdir {}
set tcldir {}
set webdir ../html
set build_tcl 0
set opt_build_tcl 0
set build_tk 0
set opt_build_tk 0
set verbose 0
# Default search version is a glob pattern
set useversion {{,[8-9].[0-9]{,[.ab][0-9]{,[0-9]}}}}
# Handle arguments a la GNU:
# --version
# --useversion=<version>
|
| ︙ | ︙ | |||
89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 |
--useversion=* {
# length of "--useversion=" is 13
set useversion [string range $option 13 end]
}
--tcl {
set build_tcl 1
}
--tk {
set build_tk 1
}
--verbose=* {
set verbose [string range $option \
[string length --verbose=] end]
}
default {
puts stderr "tcltk-man-html: unrecognized option -- `$option'"
exit 1
}
}
}
if {!$build_tcl && !$build_tk} {
set build_tcl 1;
set build_tk 1
}
if {$build_tcl} {
| > > > > > | | > > > > > > | > | | > > > > > > > > > | > > > | 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 |
--useversion=* {
# length of "--useversion=" is 13
set useversion [string range $option 13 end]
}
--tcl {
set build_tcl 1
set opt_build_tcl 1
}
--tk {
set build_tk 1
set opt_build_tk 1
}
--verbose=* {
set verbose [string range $option \
[string length --verbose=] end]
}
default {
puts stderr "tcltk-man-html: unrecognized option -- `$option'"
exit 1
}
}
}
if {!$build_tcl && !$build_tk} {
set build_tcl 1;
set build_tk 1
}
set major ""
set minor ""
if {$build_tcl} {
# Find Tcl (firstly using glob pattern / backwards compatible way)
set tcldir [lindex [lsort [glob -nocomplain -tails -type d \
-directory $tcltkdir tcl$useversion]] end]
if {$tcldir ne {}} {
# obtain version from generic header if we can:
lassign [getversion [file join $tcltkdir $tcldir generic tcl.h]] major minor
} else {
lassign [findversion $tcltkdir tcl $useversion] tcltkdir tcldir major minor
}
if {$tcldir eq {} && $opt_build_tcl} {
puts stderr "tcltk-man-html: couldn't find Tcl below $tcltkdir"
exit 1
}
puts "using Tcl source directory $tcltkdir $tcldir"
}
if {$build_tk} {
# Find Tk (firstly using glob pattern / backwards compatible way)
set tkdir [lindex [lsort [glob -nocomplain -tails -type d \
-directory $tcltkdir tk$useversion]] end]
if {$tkdir ne {}} {
if {$major eq ""} {
# obtain version from generic header if we can:
lassign [getversion [file join $tcltkdir $tcldir generic tk.h]] major minor
}
} else {
lassign [findversion $tcltkdir tk $useversion] tcltkdir tkdir major minor
}
if {$tkdir eq {} && $opt_build_tk} {
puts stderr "tcltk-man-html: couldn't find Tk below $tcltkdir"
exit 1
}
puts "using Tk source directory $tkdir"
}
puts "verbose messages are [expr {$verbose ? {on} : {off}}]"
# the title for the man pages overall
global overall_title
set overall_title ""
if {$build_tcl} {
if {$major ne ""} {
append overall_title "Tcl $major.$minor"
} else {
append overall_title "Tcl [capitalize $tcldir]"
}
}
if {$build_tcl && $build_tk} {
append overall_title "/"
}
if {$build_tk} {
append overall_title "[capitalize $tkdir]"
}
|
| ︙ | ︙ |
Changes to tools/tsdPerf.c.
1 2 3 4 5 6 7 |
#include <tcl.h>
extern DLLEXPORT Tcl_PackageInitProc Tsdperf_Init;
static Tcl_ThreadDataKey key;
typedef struct {
| | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 |
#include <tcl.h>
extern DLLEXPORT Tcl_PackageInitProc Tsdperf_Init;
static Tcl_ThreadDataKey key;
typedef struct {
Tcl_WideInt value;
} TsdPerf;
static int
tsdPerfSetObjCmd(ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) {
TsdPerf *perf = Tcl_GetThreadData(&key, sizeof(TsdPerf));
Tcl_WideInt i;
if (2 != objc) {
Tcl_WrongNumArgs(interp, 1, objv, "value");
return TCL_ERROR;
}
if (TCL_OK != Tcl_GetWideIntFromObj(interp, objv[1], &i)) {
return TCL_ERROR;
}
perf->value = i;
return TCL_OK;
}
static int
tsdPerfGetObjCmd(ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) {
TsdPerf *perf = Tcl_GetThreadData(&key, sizeof(TsdPerf));
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(perf->value));
return TCL_OK;
}
int
Tsdperf_Init(Tcl_Interp *interp) {
if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) {
|
| ︙ | ︙ |
Changes to tools/uniClass.tcl.
| ︙ | ︙ | |||
16 17 18 19 20 21 22 |
global ranges numranges chars numchars extchars extranges
if {$first < ($last-1)} {
if {!$extranges && ($first) > 0xffff} {
set extranges 1
set numranges 0
set ranges [string trimright $ranges " \n\r\t,"]
| | | | 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 |
global ranges numranges chars numchars extchars extranges
if {$first < ($last-1)} {
if {!$extranges && ($first) > 0xffff} {
set extranges 1
set numranges 0
set ranges [string trimright $ranges " \n\r\t,"]
append ranges "\n#if CHRBITS > 16\n ,"
}
append ranges [format "{0x%x, 0x%x}, " \
$first $last]
if {[incr numranges] % 4 == 0} {
set ranges [string trimright $ranges]
append ranges "\n "
}
} else {
if {!$extchars && ($first) > 0xffff} {
set extchars 1
set numchars 0
set chars [string trimright $chars " \n\r\t,"]
append chars "\n#if CHRBITS > 16\n ,"
}
append chars [format "0x%x, " $first]
incr numchars
if {$numchars % 9 == 0} {
set chars [string trimright $chars]
append chars "\n "
}
|
| ︙ | ︙ | |||
62 63 64 65 66 67 68 |
set numchars 0
set extchars 0
set extranges 0
for {set i 0} {$i <= 0x10ffff} {incr i} {
if {$i == 0xd800} {
# Skip surrogates
| | | 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 |
set numchars 0
set extchars 0
set extranges 0
for {set i 0} {$i <= 0x10ffff} {incr i} {
if {$i == 0xd800} {
# Skip surrogates
set i 0xe000
}
if {[string is $type [format %c $i]]} {
if {$i == ($last + 1)} {
set last $i
} else {
if {$first >= 0} {
emitRange $first $last
|
| ︙ | ︙ |
Changes to tools/uniParse.tcl.
| ︙ | ︙ | |||
208 209 210 211 212 213 214 |
set last [expr {[llength $pMap] - 1}]
for {set i 0} {$i <= $last} {incr i} {
if {$i == [expr {0x10000 >> $shift}]} {
set line [string trimright $line " \t,"]
puts $f $line
set lastpage [expr {[lindex $line end] >> $shift}]
puts stdout "lastpage: $lastpage"
| | | 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 |
set last [expr {[llength $pMap] - 1}]
for {set i 0} {$i <= $last} {incr i} {
if {$i == [expr {0x10000 >> $shift}]} {
set line [string trimright $line " \t,"]
puts $f $line
set lastpage [expr {[lindex $line end] >> $shift}]
puts stdout "lastpage: $lastpage"
puts $f "#if TCL_UTF_MAX > 3 || TCL_MAJOR_VERSION > 8 || TCL_MINOR_VERSION > 6"
set line " ,"
}
append line [lindex $pMap $i]
if {$i != $last} {
append line ", "
}
if {[string length $line] > 70} {
|
| ︙ | ︙ | |||
238 239 240 241 242 243 244 |
set line " "
set lasti [expr {[llength $pages] - 1}]
for {set i 0} {$i <= $lasti} {incr i} {
set page [lindex $pages $i]
set lastj [expr {[llength $page] - 1}]
if {$i == ($lastpage + 1)} {
puts $f [string trimright $line " \t,"]
| | | 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 |
set line " "
set lasti [expr {[llength $pages] - 1}]
for {set i 0} {$i <= $lasti} {incr i} {
set page [lindex $pages $i]
set lastj [expr {[llength $page] - 1}]
if {$i == ($lastpage + 1)} {
puts $f [string trimright $line " \t,"]
puts $f "#if TCL_UTF_MAX > 3 || TCL_MAJOR_VERSION > 8 || TCL_MINOR_VERSION > 6"
set line " ,"
}
for {set j 0} {$j <= $lastj} {incr j} {
append line [lindex $page $j]
if {$j != $lastj || $i != $lasti} {
append line ", "
}
|
| ︙ | ︙ | |||
268 269 270 271 272 273 274 275 276 277 278 279 280 281 |
*
* Bits 5-7 Case delta type: 000 = identity
* 010 = add delta for lower
* 011 = add delta for lower, add 1 for title
* 100 = subtract delta for title/upper
* 101 = sub delta for upper, sub 1 for title
* 110 = sub delta for upper, add delta for lower
*
* Bits 8-31 Case delta: delta for case conversions. This should be the
* highest field so we can easily sign extend.
*/
static const int groups\[\] = {"
set line " "
| > | 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 |
*
* Bits 5-7 Case delta type: 000 = identity
* 010 = add delta for lower
* 011 = add delta for lower, add 1 for title
* 100 = subtract delta for title/upper
* 101 = sub delta for upper, sub 1 for title
* 110 = sub delta for upper, add delta for lower
* 111 = subtract delta for upper
*
* Bits 8-31 Case delta: delta for case conversions. This should be the
* highest field so we can easily sign extend.
*/
static const int groups\[\] = {"
set line " "
|
| ︙ | ︙ | |||
305 306 307 308 309 310 311 |
set case 3
set delta $tolower
if {$totitle != -1} {
error "New case conversion type needed: $toupper $tolower $totitle"
}
}
} elseif {$toupper} {
| > > | | > | > | | 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 |
set case 3
set delta $tolower
if {$totitle != -1} {
error "New case conversion type needed: $toupper $tolower $totitle"
}
}
} elseif {$toupper} {
set delta $toupper
if {$tolower == $toupper} {
# subtract delta for upper, add delta for lower
set case 6
} elseif {!$tolower} {
# subtract delta for upper
set case 7
} else {
error "New case conversion type needed: $toupper $tolower $totitle"
}
} elseif {$tolower} {
# add delta for lower
set case 2
set delta $tolower
} else {
|
| ︙ | ︙ | |||
333 334 335 336 337 338 339 |
puts $f [string trimright $line]
set line " "
}
}
puts $f $line
puts -nonewline $f "};
| | | 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 |
puts $f [string trimright $line]
set line " "
}
}
puts $f $line
puts -nonewline $f "};
#if TCL_UTF_MAX > 3 || TCL_MAJOR_VERSION > 8 || TCL_MINOR_VERSION > 6
# define UNICODE_OUT_OF_RANGE(ch) (((ch) & 0x1fffff) >= [format 0x%x $next])
#else
# define UNICODE_OUT_OF_RANGE(ch) (((ch) & 0x1f0000) != 0)
#endif
/*
* The following constants are used to determine the category of a
|
| ︙ | ︙ | |||
392 393 394 395 396 397 398 | #define GetDelta(info) ((info) >> 8) /* * This macro extracts the information about a character from the * Unicode character tables. */ | | | 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 |
#define GetDelta(info) ((info) >> 8)
/*
* This macro extracts the information about a character from the
* Unicode character tables.
*/
#if TCL_UTF_MAX > 3 || TCL_MAJOR_VERSION > 8 || TCL_MINOR_VERSION > 6
# define GetUniCharInfo(ch) (groups\[groupMap\[pageMap\[((ch) & 0x1fffff) >> OFFSET_BITS\] | ((ch) & ((1 << OFFSET_BITS)-1))\]\])
#else
# define GetUniCharInfo(ch) (groups\[groupMap\[pageMap\[((ch) & 0xffff) >> OFFSET_BITS\] | ((ch) & ((1 << OFFSET_BITS)-1))\]\])
#endif
"
close $f
}
uni::main
return
|
Added tools/valgrind_suppress.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 |
{
TclCreatesocketAddress/getaddrinfo/calloc
Memcheck:Leak
match-leak-kinds: reachable
fun:calloc
...
fun:getaddrinfo
fun:TclCreateSocketAddress
}
{
TclCreatesocketAddress/getaddrinfo/malloc
Memcheck:Leak
match-leak-kinds: reachable
fun:malloc
...
fun:getaddrinfo
fun:TclCreateSocketAddress
}
{
TclpDlopen/load
Memcheck:Leak
match-leak-kinds: reachable
fun:calloc
...
fun:dlopen
fun:TclpDlopen
}
{
TclpDlopen/load
Memcheck:Leak
match-leak-kinds: reachable
fun:malloc
...
fun:dlopen
fun:TclpDlopen
}
{
TclpGetGrNam/__nss_next2/calloc
Memcheck:Leak
match-leak-kinds: reachable
fun:calloc
...
fun:__nss_next2
...
fun:TclpGetGrNam
}
{
TclpGetGrNam/__nss_next2/malloc
Memcheck:Leak
match-leak-kinds: reachable
fun:malloc
...
fun:__nss_next2
...
fun:TclpGetGrNam
}
{
TclpGetGrNam/__nss_systemd_getfrname_r/malloc
Memcheck:Leak
match-leak-kinds: reachable
fun:malloc
...
fun:_nss_systemd_getgrnam_r
...
fun:TclpGetGrNam
}
{
TclpGetPwNam/getpwname_r/__nss_next2/calloc
Memcheck:Leak
match-leak-kinds: reachable
fun:calloc
...
fun:__nss_next2
...
fun:TclpGetPwNam
}
{
TclpGetPwNam/getpwname_r/__nss_next2/malloc
Memcheck:Leak
match-leak-kinds: reachable
fun:malloc
...
fun:__nss_next2
...
fun:TclpGetPwNam
}
{
TclpGetPwNam/getpwname_r/_nss_systemd_getpwnam_r/malloc
Memcheck:Leak
match-leak-kinds: reachable
fun:malloc
...
fun:_nss_systemd_getpwnam_r
...
fun:TclpGetPwNam
}
{
TclpThreadExit/pthread_exit/calloc
Memcheck:Leak
match-leak-kinds: reachable
fun:calloc
...
fun:pthread_exit
fun:TclpThreadExit
}
{
TclpThreadExit/pthread_exit/malloc
Memcheck:Leak
match-leak-kinds: reachable
fun:malloc
...
fun:pthread_exit
fun:TclpThreadExit
}
|
Changes to unix/Makefile.in.
| ︙ | ︙ | |||
79 80 81 82 83 84 85 | # Directory in which to install html documentation: HTML_INSTALL_DIR = $(INSTALL_ROOT)$(HTML_DIR) # Directory in which to install the configuration file tclConfig.sh CONFIG_INSTALL_DIR = $(INSTALL_ROOT)$(libdir) # Directory in which to install bundled packages: | | | 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 | # Directory in which to install html documentation: HTML_INSTALL_DIR = $(INSTALL_ROOT)$(HTML_DIR) # Directory in which to install the configuration file tclConfig.sh CONFIG_INSTALL_DIR = $(INSTALL_ROOT)$(libdir) # Directory in which to install bundled packages: PACKAGE_DIR = @PACKAGE_DIR@ # Package search path. TCL_PACKAGE_PATH = @TCL_PACKAGE_PATH@ # Tcl Module default path roots (TIP189). TCL_MODULE_PATH = @TCL_MODULE_PATH@ |
| ︙ | ︙ | |||
121 122 123 124 125 126 127 | # that Tcl provides these procedures instead of your standard C library. ENV_FLAGS = #ENV_FLAGS = -DTclSetEnv=setenv -DTcl_PutEnv=putenv -DTclUnsetEnv=unsetenv # To enable memory debugging, call configure with --enable-symbols=mem # Warning: if you enable memory debugging, you must do it *everywhere*, | | | | | | | 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 |
# that Tcl provides these procedures instead of your standard C library.
ENV_FLAGS =
#ENV_FLAGS = -DTclSetEnv=setenv -DTcl_PutEnv=putenv -DTclUnsetEnv=unsetenv
# To enable memory debugging, call configure with --enable-symbols=mem
# Warning: if you enable memory debugging, you must do it *everywhere*,
# including all the code that calls Tcl, and you must use Tcl_Alloc and Tcl_Free
# everywhere instead of malloc and free.
TCL_STUB_LIB_FILE = @TCL_STUB_LIB_FILE@
#TCL_STUB_LIB_FILE = libtclstub.a
# Generic stub lib name used in rules that apply to tcl and tk
STUB_LIB_FILE = ${TCL_STUB_LIB_FILE}
TCL_STUB_LIB_FLAG = @TCL_STUB_LIB_FLAG@
#TCL_STUB_LIB_FLAG = -ltclstub
# To compile without backward compatibility and deprecated code uncomment the
# following
NO_DEPRECATED_FLAGS =
#NO_DEPRECATED_FLAGS = -DTCL_NO_DEPRECATED
# Some versions of make, like SGI's, use the following variable to determine
# which shell to use for executing commands:
SHELL = @MAKEFILE_SHELL@
# Tcl used to let the configure script choose which program to use for
# installing, but there are just too many different versions of "install"
# around; better to use the install-sh script that comes with the
# distribution, which is slower but guaranteed to work.
INSTALL_STRIP_PROGRAM = -s
INSTALL_STRIP_LIBRARY = -S -x
INSTALL = $(SHELL) $(UNIX_DIR)/install-sh -c
INSTALL_PROGRAM = ${INSTALL}
INSTALL_LIBRARY = ${INSTALL}
INSTALL_DATA = ${INSTALL} -m 644
INSTALL_DATA_DIR = ${INSTALL} -d -m 755
|
| ︙ | ︙ | |||
238 239 240 241 242 243 244 245 246 247 248 |
# Must be absolute to so the corresponding tcltest's tcl_library is absolute.
TCL_BUILDTIME_LIBRARY = @TCL_SRC_DIR@/library
ZLIB_DIR = ${COMPAT_DIR}/zlib
ZLIB_INCLUDE = @ZLIB_INCLUDE@
CC = @CC@
#CC = purify -best-effort @CC@ -DPURIFY
# Flags to be passed to installManPage to control how the manpages should be
# installed (symlinks, compression, package name suffix).
| > > | > | > > | | > | | 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 |
# Must be absolute to so the corresponding tcltest's tcl_library is absolute.
TCL_BUILDTIME_LIBRARY = @TCL_SRC_DIR@/library
ZLIB_DIR = ${COMPAT_DIR}/zlib
ZLIB_INCLUDE = @ZLIB_INCLUDE@
CC = @CC@
OBJEXT = @OBJEXT@
#CC = purify -best-effort @CC@ -DPURIFY
# Flags to be passed to installManPage to control how the manpages should be
# installed (symlinks, compression, package name suffix).
MAN_FLAGS = @MAN_FLAGS@
# If non-empty, install the timezone files that are included with Tcl,
# otherwise use the ones that ship with the OS.
INSTALL_TZDATA = @INSTALL_TZDATA@
#--------------------------------------------------------------------------
# The information below is usually usable as is. The configure script won't
# modify it and it only exists to make working around selected rare system
# configurations easier.
#--------------------------------------------------------------------------
GDB = gdb
LLDB = lldb
TRACE = strace
TRACE_OPTS =
VALGRIND = valgrind
VALGRINDARGS = --tool=memcheck --num-callers=24 \
--leak-resolution=high --leak-check=yes --show-reachable=yes -v \
--suppressions=$(TOOL_DIR)/valgrind_suppress
#--------------------------------------------------------------------------
# The information below should be usable as is. The configure script won't
# modify it and you shouldn't need to modify it either.
#--------------------------------------------------------------------------
STUB_CC_SWITCHES = ${CFLAGS} ${CFLAGS_WARNING} ${SHLIB_CFLAGS} \
-I"${BUILD_DIR}" -I${UNIX_DIR} -I${GENERIC_DIR} -I${TOMMATH_DIR} \
${AC_FLAGS} ${PROTO_FLAGS} ${ENV_FLAGS} ${EXTRA_CFLAGS} \
@EXTRA_CC_SWITCHES@
CC_SWITCHES = $(STUB_CC_SWITCHES) ${NO_DEPRECATED_FLAGS}
APP_CC_SWITCHES = $(CC_SWITCHES) @EXTRA_APP_CC_SWITCHES@
LIBS = @TCL_LIBS@
DEPEND_SWITCHES = ${CFLAGS} -I${UNIX_DIR} -I${GENERIC_DIR} \
${AC_FLAGS} ${PROTO_FLAGS} ${EXTRA_CFLAGS} @EXTRA_CC_SWITCHES@
TCLSH_OBJS = tclAppInit.o
TCLTEST_OBJS = tclTestInit.o tclTest.o tclTestObj.o tclTestProcBodyObj.o \
tclThreadTest.o tclUnixTest.o
XTTEST_OBJS = xtTestInit.o tclTest.o tclTestObj.o tclTestProcBodyObj.o \
|
| ︙ | ︙ | |||
304 305 306 307 308 309 310 | tclObj.o tclOptimize.o tclPanic.o tclParse.o tclPathObj.o tclPipe.o \ tclPkg.o tclPkgConfig.o tclPosixStr.o \ tclPreserve.o tclProc.o tclProcess.o tclRegexp.o \ tclResolve.o tclResult.o tclScan.o tclStringObj.o \ tclStrToD.o tclThread.o \ tclThreadAlloc.o tclThreadJoin.o tclThreadStorage.o tclStubInit.o \ tclTimer.o tclTrace.o tclUtf.o tclUtil.o tclVar.o tclZlib.o \ | | | | | | > | | | | > | | | 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 |
tclObj.o tclOptimize.o tclPanic.o tclParse.o tclPathObj.o tclPipe.o \
tclPkg.o tclPkgConfig.o tclPosixStr.o \
tclPreserve.o tclProc.o tclProcess.o tclRegexp.o \
tclResolve.o tclResult.o tclScan.o tclStringObj.o \
tclStrToD.o tclThread.o \
tclThreadAlloc.o tclThreadJoin.o tclThreadStorage.o tclStubInit.o \
tclTimer.o tclTrace.o tclUtf.o tclUtil.o tclVar.o tclZlib.o \
tclTomMathInterface.o tclZipfs.o
OO_OBJS = tclOO.o tclOOBasic.o tclOOCall.o tclOODefineCmds.o tclOOInfo.o \
tclOOMethod.o tclOOStubInit.o
TOMMATH_OBJS = bn_reverse.o bn_fast_s_mp_mul_digs.o \
bn_fast_s_mp_sqr.o bn_mp_add.o bn_mp_and.o \
bn_mp_add_d.o bn_mp_clamp.o bn_mp_clear.o bn_mp_clear_multi.o \
bn_mp_cmp.o bn_mp_cmp_d.o bn_mp_cmp_mag.o \
bn_mp_cnt_lsb.o bn_mp_copy.o \
bn_mp_count_bits.o bn_mp_div.o bn_mp_div_d.o bn_mp_div_2.o \
bn_mp_div_2d.o bn_mp_div_3.o bn_mp_exch.o \
bn_mp_expt_d.o bn_mp_expt_d_ex.o bn_s_mp_get_bit.o bn_mp_get_int.o \
bn_mp_get_long.o bn_mp_get_long_long.o bn_mp_grow.o bn_mp_init.o \
bn_mp_init_copy.o bn_mp_init_multi.o bn_mp_init_set.o \
bn_mp_init_set_int.o bn_mp_init_size.o bn_mp_karatsuba_mul.o \
bn_mp_karatsuba_sqr.o \
bn_mp_lshd.o bn_mp_mod.o bn_mp_mod_2d.o bn_mp_mul.o bn_mp_mul_2.o \
bn_mp_mul_2d.o bn_mp_mul_d.o bn_mp_neg.o bn_mp_or.o \
bn_mp_radix_size.o bn_mp_radix_smap.o \
bn_mp_read_radix.o bn_mp_rshd.o bn_mp_set.o bn_mp_set_int.o \
bn_mp_set_long.o bn_mp_set_long_long.o bn_mp_shrink.o \
bn_mp_sqr.o bn_mp_sqrt.o bn_mp_sub.o bn_mp_sub_d.o \
bn_mp_signed_rsh.o \
bn_mp_to_unsigned_bin.o bn_mp_to_unsigned_bin_n.o \
bn_mp_toom_mul.o bn_mp_toom_sqr.o bn_mp_toradix_n.o \
bn_mp_unsigned_bin_size.o bn_mp_xor.o bn_mp_zero.o bn_s_mp_add.o \
bn_s_mp_mul_digs.o bn_s_mp_sqr.o bn_s_mp_sub.o
STUB_LIB_OBJS = tclStubLib.o \
tclTomMathStubLib.o \
${COMPAT_OBJS}
UNIX_OBJS = tclUnixChan.o tclUnixEvent.o tclUnixFCmd.o \
tclUnixFile.o tclUnixPipe.o tclUnixSock.o \
|
| ︙ | ︙ | |||
459 460 461 462 463 464 465 | $(GENERIC_DIR)/tclThreadJoin.c \ $(GENERIC_DIR)/tclThreadStorage.c \ $(GENERIC_DIR)/tclTimer.c \ $(GENERIC_DIR)/tclTrace.c \ $(GENERIC_DIR)/tclUtil.c \ $(GENERIC_DIR)/tclVar.c \ $(GENERIC_DIR)/tclAssembly.c \ | | > < | 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 | $(GENERIC_DIR)/tclThreadJoin.c \ $(GENERIC_DIR)/tclThreadStorage.c \ $(GENERIC_DIR)/tclTimer.c \ $(GENERIC_DIR)/tclTrace.c \ $(GENERIC_DIR)/tclUtil.c \ $(GENERIC_DIR)/tclVar.c \ $(GENERIC_DIR)/tclAssembly.c \ $(GENERIC_DIR)/tclZlib.c \ $(GENERIC_DIR)/tclZipfs.c OO_SRCS = \ $(GENERIC_DIR)/tclOO.c \ $(GENERIC_DIR)/tclOOBasic.c \ $(GENERIC_DIR)/tclOOCall.c \ $(GENERIC_DIR)/tclOODefineCmds.c \ $(GENERIC_DIR)/tclOOInfo.c \ $(GENERIC_DIR)/tclOOMethod.c \ $(GENERIC_DIR)/tclOOStubInit.c STUB_SRCS = \ $(GENERIC_DIR)/tclStubLib.c \ $(GENERIC_DIR)/tclTomMathStubLib.c TOMMATH_SRCS = \ $(TOMMATH_DIR)/bn_reverse.c \ $(TOMMATH_DIR)/bn_fast_s_mp_mul_digs.c \ $(TOMMATH_DIR)/bn_fast_s_mp_sqr.c \ $(TOMMATH_DIR)/bn_mp_add.c \ $(TOMMATH_DIR)/bn_mp_add_d.c \ $(TOMMATH_DIR)/bn_mp_and.c \ $(TOMMATH_DIR)/bn_mp_clamp.c \ |
| ︙ | ︙ | |||
533 534 535 536 537 538 539 540 541 542 543 544 545 546 | $(TOMMATH_DIR)/bn_mp_set_long.c \ $(TOMMATH_DIR)/bn_mp_set_long_long.c \ $(TOMMATH_DIR)/bn_mp_shrink.c \ $(TOMMATH_DIR)/bn_mp_sqr.c \ $(TOMMATH_DIR)/bn_mp_sqrt.c \ $(TOMMATH_DIR)/bn_mp_sub.c \ $(TOMMATH_DIR)/bn_mp_sub_d.c \ $(TOMMATH_DIR)/bn_mp_to_unsigned_bin.c \ $(TOMMATH_DIR)/bn_mp_to_unsigned_bin_n.c \ $(TOMMATH_DIR)/bn_mp_toom_mul.c \ $(TOMMATH_DIR)/bn_mp_toom_sqr.c \ $(TOMMATH_DIR)/bn_mp_toradix_n.c \ $(TOMMATH_DIR)/bn_mp_unsigned_bin_size.c \ $(TOMMATH_DIR)/bn_mp_xor.c \ | > | 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 | $(TOMMATH_DIR)/bn_mp_set_long.c \ $(TOMMATH_DIR)/bn_mp_set_long_long.c \ $(TOMMATH_DIR)/bn_mp_shrink.c \ $(TOMMATH_DIR)/bn_mp_sqr.c \ $(TOMMATH_DIR)/bn_mp_sqrt.c \ $(TOMMATH_DIR)/bn_mp_sub.c \ $(TOMMATH_DIR)/bn_mp_sub_d.c \ $(TOMMATH_DIR)/bn_mp_signed_rsh.c \ $(TOMMATH_DIR)/bn_mp_to_unsigned_bin.c \ $(TOMMATH_DIR)/bn_mp_to_unsigned_bin_n.c \ $(TOMMATH_DIR)/bn_mp_toom_mul.c \ $(TOMMATH_DIR)/bn_mp_toom_sqr.c \ $(TOMMATH_DIR)/bn_mp_toradix_n.c \ $(TOMMATH_DIR)/bn_mp_unsigned_bin_size.c \ $(TOMMATH_DIR)/bn_mp_xor.c \ |
| ︙ | ︙ | |||
611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 |
# Note: don't include DL_SRCS or MAC_OSX_SRCS in SRCS: most of those files
# won't compile on the current machine, and they will cause problems for
# things like "make depend".
SRCS = $(GENERIC_SRCS) $(TOMMATH_SRCS) $(UNIX_SRCS) $(NOTIFY_SRCS) \
$(OO_SRCS) $(STUB_SRCS) @PLAT_SRCS@ @ZLIB_SRCS@
#--------------------------------------------------------------------------
# Start of rules
#--------------------------------------------------------------------------
all: binaries libraries doc packages
binaries: ${LIB_FILE} ${TCL_EXE}
libraries:
doc:
# The following target is configured by autoconf to generate either a shared
# library or non-shared library for Tcl.
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > | | | 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 |
# Note: don't include DL_SRCS or MAC_OSX_SRCS in SRCS: most of those files
# won't compile on the current machine, and they will cause problems for
# things like "make depend".
SRCS = $(GENERIC_SRCS) $(TOMMATH_SRCS) $(UNIX_SRCS) $(NOTIFY_SRCS) \
$(OO_SRCS) $(STUB_SRCS) @PLAT_SRCS@ @ZLIB_SRCS@
###
# Tip 430 - ZipFS Modifications
###
TCL_ZIP_FILE = @TCL_ZIP_FILE@
TCL_VFS_ROOT = libtcl.vfs
TCL_VFS_PATH = ${TCL_VFS_ROOT}/tcl_library
HOST_CC = @CC_FOR_BUILD@
HOST_EXEEXT = @EXEEXT_FOR_BUILD@
HOST_OBJEXT = @OBJEXT_FOR_BUILD@
ZIPFS_BUILD = @ZIPFS_BUILD@
NATIVE_ZIP = @ZIP_PROG@
ZIP_PROG_OPTIONS = @ZIP_PROG_OPTIONS@
ZIP_PROG_VFSSEARCH = @ZIP_PROG_VFSSEARCH@
SHARED_BUILD = @SHARED_BUILD@
INSTALL_LIBRARIES = @INSTALL_LIBRARIES@
INSTALL_MSGS = @INSTALL_MSGS@
# Minizip
MINIZIP_OBJS = \
adler32.$(HOST_OBJEXT) \
compress.$(HOST_OBJEXT) \
crc32.$(HOST_OBJEXT) \
deflate.$(HOST_OBJEXT) \
infback.$(HOST_OBJEXT) \
inffast.$(HOST_OBJEXT) \
inflate.$(HOST_OBJEXT) \
inftrees.$(HOST_OBJEXT) \
ioapi.$(HOST_OBJEXT) \
trees.$(HOST_OBJEXT) \
uncompr.$(HOST_OBJEXT) \
zip.$(HOST_OBJEXT) \
zutil.$(HOST_OBJEXT) \
minizip.$(HOST_OBJEXT)
ZIP_INSTALL_OBJS = @ZIP_INSTALL_OBJS@
#--------------------------------------------------------------------------
# Start of rules
#--------------------------------------------------------------------------
all: binaries libraries doc packages
binaries: ${LIB_FILE} ${TCL_EXE}
libraries:
doc:
tclzipfile: ${TCL_ZIP_FILE}
${TCL_ZIP_FILE}: ${ZIP_INSTALL_OBJS}
@rm -rf ${TCL_VFS_ROOT}
@mkdir -p ${TCL_VFS_PATH}
@echo "creating ${TCL_VFS_PATH} (prepare compression)"
@if \
ln -s $(TOP_DIR)/library/* ${TCL_VFS_PATH}/ && \
ln ${TCL_VFS_PATH}/manifest.txt ${TCL_VFS_PATH}/pkgIndex.tcl; \
then : ; else \
cp -a $(TOP_DIR)/library/* ${TCL_VFS_PATH}; \
cp -a ${TCL_VFS_PATH}/manifest.txt ${TCL_VFS_PATH}/pkgIndex.tcl; \
fi
@find ${TCL_VFS_ROOT} -type d -empty -delete
@echo "creating ${TCL_ZIP_FILE} from ${TCL_VFS_PATH}"
@(zip=`(realpath '${NATIVE_ZIP}' || readlink -m '${NATIVE_ZIP}' || \
echo '${NATIVE_ZIP}' | sed "s?^\./?$$(pwd)/?") 2>/dev/null`; \
echo 'cd ${TCL_VFS_ROOT} &&' $$zip '${ZIP_PROG_OPTIONS} ../${TCL_ZIP_FILE} ${ZIP_PROG_VFSSEARCH}'; \
cd ${TCL_VFS_ROOT} && \
$$zip ${ZIP_PROG_OPTIONS} ../${TCL_ZIP_FILE} ${ZIP_PROG_VFSSEARCH} >/dev/null)
# The following target is configured by autoconf to generate either a shared
# library or non-shared library for Tcl.
${LIB_FILE}: ${STUB_LIB_FILE} ${OBJS} ${TCL_ZIP_FILE}
rm -f $@
@MAKE_LIB@
@if test "${ZIPFS_BUILD}" = "1" ; then \
cat ${TCL_ZIP_FILE} >> ${LIB_FILE}; \
${NATIVE_ZIP} -A ${LIB_FILE} \
|| echo 'ignore zip-error by adjust sfx process (not executable?)'; \
fi
${STUB_LIB_FILE}: ${STUB_LIB_OBJS}
@if [ "x${LIB_FILE}" = "xlibtcl${MAJOR_VERSION}.${MINOR_VERSION}.dll" ] ; then \
( cd ${TOP_DIR}/win; ${MAKE} winextensions ); \
fi
rm -f $@
@MAKE_STUB_LIB@
# Make target which outputs the list of the .o contained in the Tcl lib useful
# to build a single big shared library containing Tcl and other extensions.
# Used for the Tcl Plugin. -- dl
|
| ︙ | ︙ | |||
661 662 663 664 665 666 667 | Makefile: $(UNIX_DIR)/Makefile.in $(DLTEST_DIR)/Makefile.in $(SHELL) config.status #tclConfig.h: $(UNIX_DIR)/tclConfig.h.in # $(SHELL) config.status clean: clean-packages rm -rf *.a *.o libtcl* core errs *~ \#* TAGS *.E a.out \ | | > | | | 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 |
Makefile: $(UNIX_DIR)/Makefile.in $(DLTEST_DIR)/Makefile.in
$(SHELL) config.status
#tclConfig.h: $(UNIX_DIR)/tclConfig.h.in
# $(SHELL) config.status
clean: clean-packages
rm -rf *.a *.o libtcl* core errs *~ \#* TAGS *.E a.out \
errors ${TCL_EXE} ${TCLTEST_EXE} lib.exp Tcl @DTRACE_HDR@ \
minizip${HOST_EXEEXT} *.${HOST_OBJEXT} *.zip *.vfs
(cd dltest ; $(MAKE) clean)
distclean: distclean-packages clean
rm -rf Makefile config.status config.cache config.log tclConfig.sh \
tclConfig.h *.plist Tcl.framework tcl.pc
(cd dltest ; $(MAKE) distclean)
depend:
makedepend -- $(DEPEND_SWITCHES) -- $(SRCS)
#--------------------------------------------------------------------------
# The following target outputs the name of the top-level source directory for
# Tcl (it is used by Tk's configure script, for example). The .NO_PARALLEL
|
| ︙ | ︙ | |||
722 723 724 725 726 727 728 |
$(SHELL_ENV) ./${TCLTEST_EXE} $(TOP_DIR)/tests/all.tcl $(TESTFLAGS)
gdb-test: ${TCLTEST_EXE}
@echo "set env @LD_LIBRARY_PATH_VAR@=`pwd`:$${@LD_LIBRARY_PATH_VAR@}" > gdb.run
@echo "set env TCL_LIBRARY=${TCL_BUILDTIME_LIBRARY}" >> gdb.run
@echo "set args $(TOP_DIR)/tests/all.tcl $(TESTFLAGS) -singleproc 1" >> gdb.run
$(GDB) ./${TCLTEST_EXE} --command=gdb.run
| | > > > > > > > | 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 |
$(SHELL_ENV) ./${TCLTEST_EXE} $(TOP_DIR)/tests/all.tcl $(TESTFLAGS)
gdb-test: ${TCLTEST_EXE}
@echo "set env @LD_LIBRARY_PATH_VAR@=`pwd`:$${@LD_LIBRARY_PATH_VAR@}" > gdb.run
@echo "set env TCL_LIBRARY=${TCL_BUILDTIME_LIBRARY}" >> gdb.run
@echo "set args $(TOP_DIR)/tests/all.tcl $(TESTFLAGS) -singleproc 1" >> gdb.run
$(GDB) ./${TCLTEST_EXE} --command=gdb.run
@rm gdb.run
lldb-test: ${TCLTEST_EXE}
@echo "settings set target.env-vars @LD_LIBRARY_PATH_VAR@=`pwd`:$${@LD_LIBRARY_PATH_VAR@}" > lldb.run
@echo "settings set target.env-vars TCL_LIBRARY=${TCL_BUILDTIME_LIBRARY}" >> lldb.run
$(LLDB) --source lldb.run ./${TCLTEST_EXE} -- $(TOP_DIR)/tests/all.tcl \
$(TESTFLAGS) -singleproc 1
@rm lldb.run
# Useful target to launch a built tcltest with the proper path,...
runtest: ${TCLTEST_EXE}
$(SHELL_ENV) ./${TCLTEST_EXE}
# Useful target for running the test suite with an unwritable current
# directory...
|
| ︙ | ︙ | |||
756 757 758 759 760 761 762 |
$(SHELL_ENV) ./${TCL_EXE} $(SCRIPT)
# This target can be used to run tclsh inside either gdb or insight
gdb: ${TCL_EXE}
$(SHELL_ENV) $(GDB) ./${TCL_EXE}
valgrind: ${TCL_EXE} ${TCLTEST_EXE}
| | > > | | < | < < | | | | > > > | > > > > > > > > > > > > > < | | | < < | | | | < | | | > | | < | | | > | | | | | > | | | | | | | < < | | | 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 |
$(SHELL_ENV) ./${TCL_EXE} $(SCRIPT)
# This target can be used to run tclsh inside either gdb or insight
gdb: ${TCL_EXE}
$(SHELL_ENV) $(GDB) ./${TCL_EXE}
valgrind: ${TCL_EXE} ${TCLTEST_EXE}
$(SHELL_ENV) $(VALGRIND) $(VALGRINDARGS) ./${TCLTEST_EXE} \
$(TOP_DIR)/tests/all.tcl -singleproc 1 -constraints valgrind \
$(TESTFLAGS)
valgrindshell: ${TCL_EXE}
$(SHELL_ENV) $(VALGRIND) $(VALGRINDARGS) ./${TCL_EXE} $(SCRIPT)
trace-shell: ${TCL_EXE}
$(SHELL_ENV) ${TRACE} $(TRACE_OPTS) ./${TCL_EXE} $(SCRIPT)
trace-test: ${TCLTEST_EXE}
$(SHELL_ENV) ${TRACE} $(TRACE_OPTS) ./${TCLTEST_EXE} $(TOP_DIR)/tests/all.tcl -singleproc 1 $(TESTFLAGS)
#--------------------------------------------------------------------------
# Installation rules
#--------------------------------------------------------------------------
INSTALL_BASE_TARGETS = install-binaries $(INSTALL_LIBRARIES) $(INSTALL_MSGS) $(INSTALL_TZDATA)
INSTALL_DOC_TARGETS = install-doc
INSTALL_PACKAGE_TARGETS = install-packages
INSTALL_DEV_TARGETS = install-headers
INSTALL_EXTRA_TARGETS = @EXTRA_INSTALL@
INSTALL_TARGETS = $(INSTALL_BASE_TARGETS) $(INSTALL_DOC_TARGETS) $(INSTALL_DEV_TARGETS) \
$(INSTALL_PACKAGE_TARGETS) $(INSTALL_EXTRA_TARGETS)
install: $(INSTALL_TARGETS)
install-strip:
$(MAKE) $(INSTALL_TARGETS) \
INSTALL_PROGRAM="$(INSTALL_PROGRAM) ${INSTALL_STRIP_PROGRAM}"
install-binaries: binaries
@for i in "$(LIB_INSTALL_DIR)" "$(BIN_INSTALL_DIR)" \
"$(CONFIG_INSTALL_DIR)" ; do \
if [ ! -d "$$i" ] ; then \
echo "Making directory $$i"; \
$(INSTALL_DATA_DIR) "$$i"; \
fi; \
done
@echo "Installing $(LIB_FILE) to $(DLL_INSTALL_DIR)/"
@@INSTALL_LIB@
@chmod 555 "$(DLL_INSTALL_DIR)/$(LIB_FILE)"
@echo "Installing ${TCL_EXE} as $(BIN_INSTALL_DIR)/tclsh$(VERSION)${EXE_SUFFIX}"
@$(INSTALL_PROGRAM) ${TCL_EXE} "$(BIN_INSTALL_DIR)/tclsh$(VERSION)${EXE_SUFFIX}"
@echo "Installing tclConfig.sh to $(CONFIG_INSTALL_DIR)/"
@$(INSTALL_DATA) tclConfig.sh "$(CONFIG_INSTALL_DIR)/tclConfig.sh"
@echo "Installing tclooConfig.sh to $(CONFIG_INSTALL_DIR)/"
@$(INSTALL_DATA) $(UNIX_DIR)/tclooConfig.sh \
"$(CONFIG_INSTALL_DIR)/tclooConfig.sh"
@if test "$(STUB_LIB_FILE)" != "" ; then \
echo "Installing $(STUB_LIB_FILE) to $(LIB_INSTALL_DIR)/"; \
@INSTALL_STUB_LIB@ ; \
fi
@EXTRA_INSTALL_BINARIES@
@echo "Installing pkg-config file to $(LIB_INSTALL_DIR)/pkgconfig/"
@$(INSTALL_DATA_DIR) $(LIB_INSTALL_DIR)/pkgconfig
@$(INSTALL_DATA) tcl.pc $(LIB_INSTALL_DIR)/pkgconfig/tcl.pc
install-libraries-zipfs-shared: libraries
@for i in "$(SCRIPT_INSTALL_DIR)" ; do \
if [ ! -d "$$i" ] ; then \
echo "Making directory $$i"; \
$(INSTALL_DATA_DIR) "$$i"; \
fi; \
done
@echo "Installing library files to $(SCRIPT_INSTALL_DIR)/"
@for i in $(UNIX_DIR)/tclAppInit.c @LDAIX_SRC@ @DTRACE_SRC@ ; do \
$(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"; \
done
install-libraries-zipfs-static: install-libraries-zipfs-shared
$(INSTALL_DATA) ${TCL_ZIP_FILE} "$(LIB_INSTALL_DIR)"
MODULE_INSTALL_DIR=$(SCRIPT_INSTALL_DIR)/..
install-libraries: libraries
@for i in "$(SCRIPT_INSTALL_DIR)" ; do \
if [ ! -d "$$i" ] ; then \
echo "Making directory $$i"; \
$(INSTALL_DATA_DIR) "$$i"; \
fi; \
done
@for i in opt0.4 encoding ../tcl9 ../tcl9/9.0 ../tcl9/9.0/platform ; do \
if [ ! -d "$(SCRIPT_INSTALL_DIR)"/$$i ] ; then \
echo "Making directory $(SCRIPT_INSTALL_DIR)/$$i"; \
$(INSTALL_DATA_DIR) "$(SCRIPT_INSTALL_DIR)"/$$i; \
fi; \
done
@echo "Installing library files to $(SCRIPT_INSTALL_DIR)/"
@for i in $(TOP_DIR)/library/*.tcl $(TOP_DIR)/library/tclIndex \
$(UNIX_DIR)/tclAppInit.c @LDAIX_SRC@ @DTRACE_SRC@ ; do \
$(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"; \
done
@echo "Installing package http 2.9.0 as a Tcl Module"
@$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl \
"$(MODULE_INSTALL_DIR)"/tcl9/9.0/http-2.9.0.tm
@echo "Installing package opt0.4 files to $(SCRIPT_INSTALL_DIR)/opt0.4/"
@for i in $(TOP_DIR)/library/opt/*.tcl ; do \
$(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/opt0.4; \
done
@echo "Installing package msgcat 1.7.0 as a Tcl Module"
@$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl \
"$(MODULE_INSTALL_DIR)"/tcl9/9.0/msgcat-1.7.0.tm
@echo "Installing package tcltest 2.5.0 as a Tcl Module"
@$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl \
"$(MODULE_INSTALL_DIR)"/tcl9/9.0/tcltest-2.5.0.tm
@echo "Installing package platform 1.0.14 as a Tcl Module"
@$(INSTALL_DATA) $(TOP_DIR)/library/platform/platform.tcl \
"$(MODULE_INSTALL_DIR)"/tcl9/9.0/platform-1.0.14.tm
@echo "Installing package platform::shell 1.1.4 as a Tcl Module"
@$(INSTALL_DATA) $(TOP_DIR)/library/platform/shell.tcl \
"$(MODULE_INSTALL_DIR)"/tcl9/9.0/platform/shell-1.1.4.tm
@echo "Installing encoding files to $(SCRIPT_INSTALL_DIR)/encoding/"
@for i in $(TOP_DIR)/library/encoding/*.enc ; do \
$(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/encoding; \
done
@if [ -n "$(TCL_MODULE_PATH)" -a -f $(TOP_DIR)/library/tm.tcl ] ; then \
echo "Customizing tcl module path"; \
echo "if {![interp issafe]} { ::tcl::tm::roots {$(TCL_MODULE_PATH)} }" >> \
"$(SCRIPT_INSTALL_DIR)"/tm.tcl; \
fi
install-tzdata:
@for i in tzdata ; do \
if [ ! -d "$(SCRIPT_INSTALL_DIR)"/$$i ] ; then \
echo "Making directory $(SCRIPT_INSTALL_DIR)/$$i"; \
$(INSTALL_DATA_DIR) "$(SCRIPT_INSTALL_DIR)"/$$i; \
fi; \
done
@echo "Installing time zone files to $(SCRIPT_INSTALL_DIR)/tzdata/"
@for i in $(TOP_DIR)/library/tzdata/* ; do \
if [ -d $$i ] ; then \
ii=`basename $$i`; \
if [ ! -d "$(SCRIPT_INSTALL_DIR)"/tzdata/$$ii ] ; then \
$(INSTALL_DATA_DIR) "$(SCRIPT_INSTALL_DIR)"/tzdata/$$ii; \
fi; \
|
| ︙ | ︙ | |||
897 898 899 900 901 902 903 | else \ $(INSTALL_DATA) $$j "$(SCRIPT_INSTALL_DIR)"/tzdata/$$ii; \ fi; \ done; \ else \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/tzdata; \ fi; \ | | | < < | | | | | < < | | | | < | | < | > > > > > > > > > > > > > | < < | | | < < < < < | | < < | | | < < < < | | | | | | | | | | | | | | | | | | | > > > | 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 |
else \
$(INSTALL_DATA) $$j "$(SCRIPT_INSTALL_DIR)"/tzdata/$$ii; \
fi; \
done; \
else \
$(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/tzdata; \
fi; \
done
install-msgs:
@for i in msgs ; do \
if [ ! -d "$(SCRIPT_INSTALL_DIR)"/$$i ] ; then \
echo "Making directory $(SCRIPT_INSTALL_DIR)/$$i"; \
$(INSTALL_DATA_DIR) "$(SCRIPT_INSTALL_DIR)"/$$i; \
fi; \
done
@echo "Installing message catalog files to $(SCRIPT_INSTALL_DIR)/msgs/"
@for i in $(TOP_DIR)/library/msgs/*.msg ; do \
$(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/msgs; \
done
install-doc: doc
@for i in "$(MAN_INSTALL_DIR)" "$(MAN1_INSTALL_DIR)" "$(MAN3_INSTALL_DIR)" "$(MANN_INSTALL_DIR)" ; do \
if [ ! -d "$$i" ] ; then \
echo "Making directory $$i"; \
$(INSTALL_DATA_DIR) "$$i"; \
fi; \
done
@echo "Installing and cross-linking top-level (.1) docs to $(MAN1_INSTALL_DIR)/"
@for i in $(TOP_DIR)/doc/*.1 ; do \
$(SHELL) $(UNIX_DIR)/installManPage $(MAN_FLAGS) $$i "$(MAN1_INSTALL_DIR)"; \
done
@echo "Installing and cross-linking C API (.3) docs to $(MAN3_INSTALL_DIR)/"
@for i in $(TOP_DIR)/doc/*.3 ; do \
$(SHELL) $(UNIX_DIR)/installManPage $(MAN_FLAGS) $$i "$(MAN3_INSTALL_DIR)"; \
done
@echo "Installing and cross-linking command (.n) docs to $(MANN_INSTALL_DIR)/";
@for i in $(TOP_DIR)/doc/*.n ; do \
$(SHELL) $(UNIX_DIR)/installManPage $(MAN_FLAGS) $$i "$(MANN_INSTALL_DIR)"; \
done
# Public headers that define Tcl's API
TCL_PUBLIC_HEADERS = $(GENERIC_DIR)/tcl.h $(GENERIC_DIR)/tclDecls.h \
$(GENERIC_DIR)/tclOO.h $(GENERIC_DIR)/tclOODecls.h \
$(GENERIC_DIR)/tclPlatDecls.h $(GENERIC_DIR)/tclTomMath.h \
$(GENERIC_DIR)/tclTomMathDecls.h
# Private headers that define Tcl's internal API
TCL_PRIVATE_HEADERS = $(GENERIC_DIR)/tclInt.h $(GENERIC_DIR)/tclIntDecls.h \
$(GENERIC_DIR)/tclIntPlatDecls.h $(GENERIC_DIR)/tclPort.h \
$(GENERIC_DIR)/tclOOInt.h $(GENERIC_DIR)/tclOOIntDecls.h \
$(UNIX_DIR)/tclUnixPort.h
# Any other headers you find in the Tcl sources are purely part of Tcl's
# implementation, and aren't to be installed.
install-headers:
@for i in "$(INCLUDE_INSTALL_DIR)" ; do \
if [ ! -d "$$i" ] ; then \
echo "Making directory $$i"; \
$(INSTALL_DATA_DIR) "$$i"; \
fi; \
done
@echo "Installing header files to $(INCLUDE_INSTALL_DIR)/";
@for i in $(TCL_PUBLIC_HEADERS) ; do \
$(INSTALL_DATA) $$i "$(INCLUDE_INSTALL_DIR)"; \
done
# Optional target to install private headers
install-private-headers:
@for i in "$(PRIVATE_INCLUDE_INSTALL_DIR)" ; do \
if [ ! -d "$$i" ] ; then \
echo "Making directory $$i"; \
$(INSTALL_DATA_DIR) "$$i"; \
fi; \
done
@echo "Installing private header files to $(PRIVATE_INCLUDE_INSTALL_DIR)/";
@for i in $(TCL_PRIVATE_HEADERS) ; do \
$(INSTALL_DATA) $$i "$(PRIVATE_INCLUDE_INSTALL_DIR)"; \
done
@if test -f tclConfig.h ; then \
$(INSTALL_DATA) tclConfig.h "$(PRIVATE_INCLUDE_INSTALL_DIR)"; \
fi
#--------------------------------------------------------------------------
# Rules for how to compile C files
#--------------------------------------------------------------------------
# Test binaries. The rules for tclTestInit.o and xtTestInit.o are complicated
# because they are compiled from tclAppInit.c. Can't use the "-o" option
# because this doesn't work on some strange compilers (e.g. UnixWare).
#
# To enable concurrent parallel make of tclsh and tcltest resp xttest, these
# targets have to depend on tclsh, this ensures that linking of tclsh with
# tclAppInit.o does not execute concurrently with the renaming and recompiling
# of that same object file in the targets below.
tclTestInit.o: $(UNIX_DIR)/tclAppInit.c ${TCL_EXE}
@if test -f tclAppInit.o ; then \
rm -f tclAppInit.sav; \
mv tclAppInit.o tclAppInit.sav; \
fi
$(CC) -c $(APP_CC_SWITCHES) \
-DTCL_BUILDTIME_LIBRARY="\"${TCL_BUILDTIME_LIBRARY}\"" \
-DTCL_TEST $(UNIX_DIR)/tclAppInit.c
@rm -f tclTestInit.o
mv tclAppInit.o tclTestInit.o
@if test -f tclAppInit.sav ; then \
mv tclAppInit.sav tclAppInit.o; \
fi
xtTestInit.o: $(UNIX_DIR)/tclAppInit.c ${TCL_EXE}
@if test -f tclAppInit.o ; then \
rm -f tclAppInit.sav; \
mv tclAppInit.o tclAppInit.sav; \
fi
$(CC) -c $(APP_CC_SWITCHES) \
-DTCL_BUILDTIME_LIBRARY="\"${TCL_BUILDTIME_LIBRARY}\"" \
-DTCL_TEST -DTCL_XT_TEST $(UNIX_DIR)/tclAppInit.c
@rm -f xtTestInit.o
mv tclAppInit.o xtTestInit.o
@if test -f tclAppInit.sav ; then \
mv tclAppInit.sav tclAppInit.o; \
fi
# Object files used on all Unix systems:
REGHDRS = $(GENERIC_DIR)/regex.h $(GENERIC_DIR)/regguts.h \
$(GENERIC_DIR)/regcustom.h
TCLREHDRS = $(GENERIC_DIR)/tclRegexp.h
COMPILEHDR = $(GENERIC_DIR)/tclCompile.h
FSHDR = $(GENERIC_DIR)/tclFileSystem.h
IOHDR = $(GENERIC_DIR)/tclIO.h
MATHHDRS = $(GENERIC_DIR)/tommath.h $(GENERIC_DIR)/tclTomMath.h
PARSEHDR = $(GENERIC_DIR)/tclParse.h
NREHDR = $(GENERIC_DIR)/tclInt.h
TRIMHDR = $(GENERIC_DIR)/tclStringTrim.h
TCL_LOCATIONS = -DTCL_LIBRARY="\"${TCL_LIBRARY}\"" \
-DTCL_PACKAGE_PATH="\"${TCL_PACKAGE_PATH}\""
regcomp.o: $(REGHDRS) $(GENERIC_DIR)/regcomp.c $(GENERIC_DIR)/regc_lex.c \
$(GENERIC_DIR)/regc_color.c $(GENERIC_DIR)/regc_locale.c \
$(GENERIC_DIR)/regc_nfa.c $(GENERIC_DIR)/regc_cvec.c
$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/regcomp.c
regexec.o: $(REGHDRS) $(GENERIC_DIR)/regexec.c $(GENERIC_DIR)/rege_dfa.c
|
| ︙ | ︙ | |||
1214 1215 1216 1217 1218 1219 1220 | tclNamesp.o: $(GENERIC_DIR)/tclNamesp.c $(COMPILEHDR) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclNamesp.c tclNotify.o: $(GENERIC_DIR)/tclNotify.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclNotify.c | | | 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 | tclNamesp.o: $(GENERIC_DIR)/tclNamesp.c $(COMPILEHDR) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclNamesp.c tclNotify.o: $(GENERIC_DIR)/tclNotify.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclNotify.c tclOO.o: $(GENERIC_DIR)/tclOO.c $(GENERIC_DIR)/tclOOScript.h $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclOO.c tclOOBasic.o: $(GENERIC_DIR)/tclOOBasic.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclOOBasic.c tclOOCall.o: $(GENERIC_DIR)/tclOOCall.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclOOCall.c |
| ︙ | ︙ | |||
1259 1260 1261 1262 1263 1264 1265 | # Part of Tcl's configuration information are the paths where it was installed # and where it will look for its libraries (which can be different). We derive # this information from the variables which can be overridden by the user. As # every path can be configured separately we do not remember one general # prefix/exec_prefix but all the different paths individually. tclPkgConfig.o: $(GENERIC_DIR)/tclPkgConfig.c | | < | > | 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 | # Part of Tcl's configuration information are the paths where it was installed # and where it will look for its libraries (which can be different). We derive # this information from the variables which can be overridden by the user. As # every path can be configured separately we do not remember one general # prefix/exec_prefix but all the different paths individually. tclPkgConfig.o: $(GENERIC_DIR)/tclPkgConfig.c $(CC) -c $(CC_SWITCHES) \ -DCFG_INSTALL_LIBDIR="\"$(LIB_INSTALL_DIR)\"" \ -DCFG_INSTALL_BINDIR="\"$(BIN_INSTALL_DIR)\"" \ -DCFG_INSTALL_SCRDIR="\"$(SCRIPT_INSTALL_DIR)\"" \ -DCFG_INSTALL_INCDIR="\"$(INCLUDE_INSTALL_DIR)\"" \ -DCFG_INSTALL_DOCDIR="\"$(MAN_INSTALL_DIR)\"" \ -DCFG_RUNTIME_LIBDIR="\"$(libdir)\"" \ -DCFG_RUNTIME_BINDIR="\"$(bindir)\"" \ -DCFG_RUNTIME_SCRDIR="\"$(TCL_LIBRARY)\"" \ -DCFG_RUNTIME_INCDIR="\"$(includedir)\"" \ -DCFG_RUNTIME_DOCDIR="\"$(mandir)\"" \ -DCFG_RUNTIME_DLLFILE="\"$(TCL_LIB_FILE)\"" \ -DCFG_RUNTIME_ZIPFILE="\"$(TCL_ZIP_FILE)\"" \ $(GENERIC_DIR)/tclPkgConfig.c tclPosixStr.o: $(GENERIC_DIR)/tclPosixStr.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclPosixStr.c tclPreserve.o: $(GENERIC_DIR)/tclPreserve.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclPreserve.c |
| ︙ | ︙ | |||
1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 | $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclUtf.c tclVar.o: $(GENERIC_DIR)/tclVar.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclVar.c tclZlib.o: $(GENERIC_DIR)/tclZlib.c $(CC) -c $(CC_SWITCHES) $(ZLIB_INCLUDE) $(GENERIC_DIR)/tclZlib.c tclTest.o: $(GENERIC_DIR)/tclTest.c $(IOHDR) $(TCLREHDRS) $(CC) -c $(APP_CC_SWITCHES) $(GENERIC_DIR)/tclTest.c tclTestObj.o: $(GENERIC_DIR)/tclTestObj.c $(MATHHDRS) $(CC) -c $(APP_CC_SWITCHES) $(GENERIC_DIR)/tclTestObj.c | > > > > > > > > > | 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 | $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclUtf.c tclVar.o: $(GENERIC_DIR)/tclVar.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclVar.c tclZlib.o: $(GENERIC_DIR)/tclZlib.c $(CC) -c $(CC_SWITCHES) $(ZLIB_INCLUDE) $(GENERIC_DIR)/tclZlib.c tclZipfs.o: $(GENERIC_DIR)/tclZipfs.c $(CC) -c $(CC_SWITCHES) \ -DCFG_RUNTIME_DLLFILE="\"$(TCL_LIB_FILE)\"" \ -DCFG_RUNTIME_ZIPFILE="\"$(TCL_ZIP_FILE)\"" \ -DCFG_RUNTIME_LIBDIR="\"$(libdir)\"" \ -DCFG_RUNTIME_SCRDIR="\"$(TCL_LIBRARY)\"" \ $(ZLIB_INCLUDE) -I$(ZLIB_DIR)/contrib/minizip \ $(GENERIC_DIR)/tclZipfs.c tclTest.o: $(GENERIC_DIR)/tclTest.c $(IOHDR) $(TCLREHDRS) $(CC) -c $(APP_CC_SWITCHES) $(GENERIC_DIR)/tclTest.c tclTestObj.o: $(GENERIC_DIR)/tclTestObj.c $(MATHHDRS) $(CC) -c $(APP_CC_SWITCHES) $(GENERIC_DIR)/tclTestObj.c |
| ︙ | ︙ | |||
1352 1353 1354 1355 1356 1357 1358 | tclThreadTest.o: $(GENERIC_DIR)/tclThreadTest.c $(CC) -c $(APP_CC_SWITCHES) $(GENERIC_DIR)/tclThreadTest.c tclTomMathInterface.o: $(GENERIC_DIR)/tclTomMathInterface.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclTomMathInterface.c | < < < | 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 | tclThreadTest.o: $(GENERIC_DIR)/tclThreadTest.c $(CC) -c $(APP_CC_SWITCHES) $(GENERIC_DIR)/tclThreadTest.c tclTomMathInterface.o: $(GENERIC_DIR)/tclTomMathInterface.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclTomMathInterface.c bn_reverse.o: $(TOMMATH_DIR)/bn_reverse.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_reverse.c bn_fast_s_mp_mul_digs.o: $(TOMMATH_DIR)/bn_fast_s_mp_mul_digs.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_fast_s_mp_mul_digs.c bn_fast_s_mp_sqr.o: $(TOMMATH_DIR)/bn_fast_s_mp_sqr.c $(MATHHDRS) |
| ︙ | ︙ | |||
1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 | $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_exch.c bn_mp_expt_d.o: $(TOMMATH_DIR)/bn_mp_expt_d.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_expt_d.c bn_mp_expt_d_ex.o: $(TOMMATH_DIR)/bn_mp_expt_d_ex.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_expt_d_ex.c bn_mp_get_int.o: $(TOMMATH_DIR)/bn_mp_get_int.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_get_int.c bn_mp_get_long.o: $(TOMMATH_DIR)/bn_mp_get_long.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_get_long.c | > > > | 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 | $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_exch.c bn_mp_expt_d.o: $(TOMMATH_DIR)/bn_mp_expt_d.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_expt_d.c bn_mp_expt_d_ex.o: $(TOMMATH_DIR)/bn_mp_expt_d_ex.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_expt_d_ex.c bn_s_mp_get_bit.o: $(TOMMATH_DIR)/bn_s_mp_get_bit.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_s_mp_get_bit.c bn_mp_get_int.o: $(TOMMATH_DIR)/bn_mp_get_int.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_get_int.c bn_mp_get_long.o: $(TOMMATH_DIR)/bn_mp_get_long.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_get_long.c |
| ︙ | ︙ | |||
1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 | $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_sqrt.c bn_mp_sub.o: $(TOMMATH_DIR)/bn_mp_sub.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_sub.c bn_mp_sub_d.o: $(TOMMATH_DIR)/bn_mp_sub_d.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_sub_d.c bn_mp_to_unsigned_bin.o: $(TOMMATH_DIR)/bn_mp_to_unsigned_bin.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_to_unsigned_bin.c bn_mp_to_unsigned_bin_n.o: $(TOMMATH_DIR)/bn_mp_to_unsigned_bin_n.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_to_unsigned_bin_n.c | > > > | 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 | $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_sqrt.c bn_mp_sub.o: $(TOMMATH_DIR)/bn_mp_sub.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_sub.c bn_mp_sub_d.o: $(TOMMATH_DIR)/bn_mp_sub_d.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_sub_d.c bn_mp_signed_rsh.o: $(TOMMATH_DIR)/bn_mp_signed_rsh.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_signed_rsh.c bn_mp_to_unsigned_bin.o: $(TOMMATH_DIR)/bn_mp_to_unsigned_bin.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_to_unsigned_bin.c bn_mp_to_unsigned_bin_n.o: $(TOMMATH_DIR)/bn_mp_to_unsigned_bin_n.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_to_unsigned_bin_n.c |
| ︙ | ︙ | |||
1598 1599 1600 1601 1602 1603 1604 | tclUnixThrd.o: $(UNIX_DIR)/tclUnixThrd.c $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixThrd.c tclUnixTime.o: $(UNIX_DIR)/tclUnixTime.c $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixTime.c | < | 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 | tclUnixThrd.o: $(UNIX_DIR)/tclUnixThrd.c $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixThrd.c tclUnixTime.o: $(UNIX_DIR)/tclUnixTime.c $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixTime.c tclUnixInit.o: $(UNIX_DIR)/tclUnixInit.c tclConfig.sh $(CC) -c $(CC_SWITCHES) $(TCL_LOCATIONS) $(UNIX_DIR)/tclUnixInit.c tclUnixCompat.o: $(UNIX_DIR)/tclUnixCompat.c $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixCompat.c # The following are Mac OS X only sources: |
| ︙ | ︙ | |||
1655 1656 1657 1658 1659 1660 1661 | #-------------------------------------------------------------------------- # Compat binaries, these must be compiled for use in a shared library even # though they may be placed in a static executable or library. Since they are # included in both the tcl library and the stub library, they need to be # relocatable. #-------------------------------------------------------------------------- | < < < < < < | 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 | #-------------------------------------------------------------------------- # Compat binaries, these must be compiled for use in a shared library even # though they may be placed in a static executable or library. Since they are # included in both the tcl library and the stub library, they need to be # relocatable. #-------------------------------------------------------------------------- opendir.o: $(COMPAT_DIR)/opendir.c $(CC) -c $(STUB_CC_SWITCHES) $(COMPAT_DIR)/opendir.c mkstemp.o: $(COMPAT_DIR)/mkstemp.c $(CC) -c $(STUB_CC_SWITCHES) $(COMPAT_DIR)/mkstemp.c memcmp.o: $(COMPAT_DIR)/memcmp.c $(CC) -c $(STUB_CC_SWITCHES) $(COMPAT_DIR)/memcmp.c strncasecmp.o: $(COMPAT_DIR)/strncasecmp.c $(CC) -c $(STUB_CC_SWITCHES) $(COMPAT_DIR)/strncasecmp.c strstr.o: $(COMPAT_DIR)/strstr.c $(CC) -c $(STUB_CC_SWITCHES) $(COMPAT_DIR)/strstr.c strtol.o: $(COMPAT_DIR)/strtol.c $(CC) -c $(STUB_CC_SWITCHES) $(COMPAT_DIR)/strtol.c strtoul.o: $(COMPAT_DIR)/strtoul.c $(CC) -c $(STUB_CC_SWITCHES) $(COMPAT_DIR)/strtoul.c waitpid.o: $(COMPAT_DIR)/waitpid.c |
| ︙ | ︙ | |||
1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 | $(CC) -c $(STUB_CC_SWITCHES) -DSTATIC_BUILD $(GENERIC_DIR)/tclStubLib.c tclTomMathStubLib.o: $(GENERIC_DIR)/tclTomMathStubLib.c $(CC) -c $(STUB_CC_SWITCHES) $(GENERIC_DIR)/tclTomMathStubLib.c .c.o: $(CC) -c $(CC_SWITCHES) $< #-------------------------------------------------------------------------- # Bundled Package targets #-------------------------------------------------------------------------- # Propagate configure args like --enable-64bit to package configure PKG_CFG_ARGS = @PKG_CFG_ARGS@ # If PKG_DIR is changed to a different relative depth to the build dir, need # to adapt the ../.. relative paths below and at the top of configure.ac (we # cannot use absolute paths due to issues in nested configure when path to # build dir contains spaces). PKG_DIR = ./pkgs configure-packages: | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 |
$(CC) -c $(STUB_CC_SWITCHES) -DSTATIC_BUILD $(GENERIC_DIR)/tclStubLib.c
tclTomMathStubLib.o: $(GENERIC_DIR)/tclTomMathStubLib.c
$(CC) -c $(STUB_CC_SWITCHES) $(GENERIC_DIR)/tclTomMathStubLib.c
.c.o:
$(CC) -c $(CC_SWITCHES) $<
#--------------------------------------------------------------------------
# Minizip implementation
#--------------------------------------------------------------------------
adler32.$(HOST_OBJEXT):
$(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/adler32.c
compress.$(HOST_OBJEXT):
$(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/compress.c
crc32.$(HOST_OBJEXT):
$(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/crc32.c
deflate.$(HOST_OBJEXT):
$(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/deflate.c
ioapi.$(HOST_OBJEXT):
$(HOST_CC) -o $@ -DIOAPI_NO_64 -I$(ZLIB_DIR) -I$(ZLIB_DIR)/contrib/minizip -c \
$(ZLIB_DIR)/contrib/minizip/ioapi.c
infback.$(HOST_OBJEXT):
$(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/infback.c
inffast.$(HOST_OBJEXT):
$(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/inffast.c
inflate.$(HOST_OBJEXT):
$(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/inflate.c
inftrees.$(HOST_OBJEXT):
$(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/inftrees.c
trees.$(HOST_OBJEXT):
$(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/trees.c
uncompr.$(HOST_OBJEXT):
$(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/uncompr.c
zip.$(HOST_OBJEXT):
$(HOST_CC) -o $@ -I$(ZLIB_DIR) -I$(ZLIB_DIR)/contrib/minizip -c \
$(ZLIB_DIR)/contrib/minizip/zip.c
zutil.$(HOST_OBJEXT):
$(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/zutil.c
minizip.$(HOST_OBJEXT):
$(HOST_CC) -o $@ -DIOAPI_NO_64 -I$(ZLIB_DIR) -I$(ZLIB_DIR)/contrib/minizip -c \
$(ZLIB_DIR)/contrib/minizip/minizip.c
minizip${HOST_EXEEXT}: $(MINIZIP_OBJS)
$(HOST_CC) -o $@ $(MINIZIP_OBJS)
#--------------------------------------------------------------------------
# Bundled Package targets
#--------------------------------------------------------------------------
# Propagate configure args like --enable-64bit to package configure
PKG_CFG_ARGS = @PKG_CFG_ARGS@
# If PKG_DIR is changed to a different relative depth to the build dir, need
# to adapt the ../.. relative paths below and at the top of configure.ac (we
# cannot use absolute paths due to issues in nested configure when path to
# build dir contains spaces).
PKG_DIR = ./pkgs
configure-packages:
@for i in $(PKGS_DIR)/* ; do \
if [ -d $$i ] ; then \
if [ -x $$i/configure ] ; then \
pkg=`basename $$i`; \
echo "Configuring package '$$pkg'"; \
mkdir -p $(PKG_DIR)/$$pkg; \
if [ ! -f $(PKG_DIR)/$$pkg/Makefile ] ; then \
( cd $(PKG_DIR)/$$pkg; \
$$i/configure --with-tcl=../.. \
--with-tclinclude=$(GENERIC_DIR) \
$(PKG_CFG_ARGS) --libdir=$(PACKAGE_DIR) \
--enable-shared; ) || exit $$?; \
fi; \
fi; \
fi; \
done
packages: configure-packages ${STUB_LIB_FILE}
@for i in $(PKGS_DIR)/* ; do \
if [ -d $$i ] ; then \
pkg=`basename $$i`; \
if [ -f $(PKG_DIR)/$$pkg/Makefile ] ; then \
echo "Building package '$$pkg'"; \
( cd $(PKG_DIR)/$$pkg; $(MAKE); ) || exit $$?; \
fi; \
fi; \
done
install-packages: packages
@for i in $(PKGS_DIR)/* ; do \
if [ -d $$i ] ; then \
pkg=`basename $$i`; \
if [ -f $(PKG_DIR)/$$pkg/Makefile ] ; then \
echo "Installing package '$$pkg'"; \
( cd $(PKG_DIR)/$$pkg; $(MAKE) install \
"DESTDIR=$(INSTALL_ROOT)"; ) || exit $$?; \
fi; \
fi; \
done
test-packages: ${TCLTEST_EXE} packages
@for i in $(PKGS_DIR)/* ; do \
if [ -d $$i ] ; then \
pkg=`basename $$i`; \
if [ -f $(PKG_DIR)/$$pkg/Makefile ] ; then \
echo "Testing package '$$pkg'"; \
( cd $(PKG_DIR)/$$pkg; $(MAKE) \
"@LD_LIBRARY_PATH_VAR@=../..:$${@LD_LIBRARY_PATH_VAR@}" \
"TCL_LIBRARY=${TCL_BUILDTIME_LIBRARY}" \
"TCLLIBPATH=../../pkgs" test \
"TCLSH_PROG=../../${TCLTEST_EXE}"; ) \
fi; \
fi; \
done
clean-packages:
@for i in $(PKGS_DIR)/* ; do \
if [ -d $$i ] ; then \
pkg=`basename $$i`; \
if [ -f $(PKG_DIR)/$$pkg/Makefile ] ; then \
( cd $(PKG_DIR)/$$pkg; $(MAKE) clean; ) \
fi; \
fi; \
done
distclean-packages:
@for i in $(PKGS_DIR)/* ; do \
if [ -d $$i ] ; then \
pkg=`basename $$i`; \
if [ -f $(PKG_DIR)/$$pkg/Makefile ] ; then \
( cd $(PKG_DIR)/$$pkg; $(MAKE) distclean; ) \
fi; \
rm -rf $(PKG_DIR)/$$pkg; \
fi; \
done; \
rm -rf $(PKG_DIR)
dist-packages: configure-packages
@rm -rf $(DISTROOT)/pkgs; \
mkdir -p $(DISTROOT)/pkgs; \
for i in $(PKGS_DIR)/* ; do \
if [ -d $$i ] ; then \
pkg=`basename $$i`; \
if [ -f $(PKG_DIR)/$$pkg/Makefile ] ; then \
( cd $(PKG_DIR)/$$pkg; $(MAKE) dist \
"DIST_ROOT=$(DISTROOT)/pkgs"; ) || exit $$?; \
fi; \
fi; \
done
#--------------------------------------------------------------------------
# Maintainer-only targets
#--------------------------------------------------------------------------
# The following target generates the file generic/tclDate.c from the yacc
# grammar found in generic/tclGetDate.y. This is only run by hand as yacc is
# not available in all environments. The name of the .c file is different than
# the name of the .y file so that make doesn't try to automatically regenerate
# the .c file.
gendate:
bison --output-file=$(GENERIC_DIR)/tclDate.c \
--no-lines \
--name-prefix=TclDate \
$(GENERIC_DIR)/tclGetDate.y
# yacc -l $(GENERIC_DIR)/tclGetDate.y
# sed -e 's/yy/TclDate/g' -e '/^#include <values.h>/d' \
# -e 's?SCCSID?RCS: @(#) ?' \
# -e '/#ifdef __STDC__/,/#endif/d' -e '/TclDateerrlab:/d' \
# -e '/TclDatenewstate:/d' -e '/#pragma/d' \
# -e '/#include <inttypes.h>/d' \
|
| ︙ | ︙ | |||
1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 |
@echo "This warning can be safely ignored, do not report as a bug!"
$(GENERIC_DIR)/tclOOStubInit.c: $(GENERIC_DIR)/tclOO.decls
@echo "Warning: tclOOStubInit.c may be out of date."
@echo "Developers may want to run \"make genstubs\" to regenerate."
@echo "This warning can be safely ignored, do not report as a bug!"
genstubs:
$(NATIVE_TCLSH) $(TOOL_DIR)/genStubs.tcl $(GENERIC_DIR) \
$(GENERIC_DIR)/tcl.decls $(GENERIC_DIR)/tclInt.decls \
$(GENERIC_DIR)/tclTomMath.decls
$(NATIVE_TCLSH) $(TOOL_DIR)/genStubs.tcl $(GENERIC_DIR) \
$(GENERIC_DIR)/tclOO.decls
#
# Target to check that all exported functions have an entry in the stubs
# tables.
#
checkstubs: $(TCL_LIB_FILE)
-@for i in `nm -p $(TCL_LIB_FILE) \
| awk '$$2 ~ /^[TDBCS]$$/ { sub("^_", "", $$3); print $$3 }' \
| > > > > > > > > > | | | | | | | | > > | | > | | | | | | > > | > | > | | | > | > > > > | > | | | < | | < | | | | | | | | | | < | | | | | | | | < | | | | | | | | | | | | | > | | | | | | | | | > | | | | | | | | | | > > > > > | | | | | | > | | > | 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 |
@echo "This warning can be safely ignored, do not report as a bug!"
$(GENERIC_DIR)/tclOOStubInit.c: $(GENERIC_DIR)/tclOO.decls
@echo "Warning: tclOOStubInit.c may be out of date."
@echo "Developers may want to run \"make genstubs\" to regenerate."
@echo "This warning can be safely ignored, do not report as a bug!"
$(GENERIC_DIR)/tclOOScript.h: $(GENERIC_DIR)/tclOOScript.tcl
@echo "Warning: tclOOScript.h may be out of date."
@echo "Developers may want to run \"make genscript\" to regenerate."
@echo "This warning can be safely ignored, do not report as a bug!"
genstubs:
$(NATIVE_TCLSH) $(TOOL_DIR)/genStubs.tcl $(GENERIC_DIR) \
$(GENERIC_DIR)/tcl.decls $(GENERIC_DIR)/tclInt.decls \
$(GENERIC_DIR)/tclTomMath.decls
$(NATIVE_TCLSH) $(TOOL_DIR)/genStubs.tcl $(GENERIC_DIR) \
$(GENERIC_DIR)/tclOO.decls
genscript:
$(NATIVE_TCLSH) $(TOOL_DIR)/makeHeader.tcl \
$(GENERIC_DIR)/tclOOScript.tcl $(GENERIC_DIR)/tclOOScript.h
#
# Target to check that all exported functions have an entry in the stubs
# tables.
#
checkstubs: $(TCL_LIB_FILE)
-@for i in `nm -p $(TCL_LIB_FILE) \
| awk '$$2 ~ /^[TDBCS]$$/ { sub("^_", "", $$3); print $$3 }' \
| sort -n` ; do \
match=0; \
for j in $(TCL_DECLS) ; do \
if [ `grep -c "$$i *(" $$j` -gt 0 ] ; then \
match=1; \
fi; \
done; \
if [ $$match -eq 0 ] ; then \
echo $$i; \
fi; \
done
#
# Target to check that all public APIs which are not command implementations
# have an entry in section three of the distributed manpages.
#
checkdoc: $(TCL_LIB_FILE)
-@for i in `nm -p $(TCL_LIB_FILE) | awk '$$3 ~ /Tcl_/ { print $$3 }' \
| grep -Fv . | grep -v 'Cmd$$' | sort -n` ; do \
match=0; \
i=`echo $$i | sed 's/^_//'`; \
for j in $(TOP_DIR)/doc/*.3 ; do \
if [ `grep '\-' $$j | grep -c $$i` -gt 0 ] ; then \
match=1; \
fi; \
done; \
if [ $$match -eq 0 ] ; then \
echo $$i; \
fi; \
done
#
# Target to check for proper usage of UCHAR macro.
#
checkuchar:
-@egrep isalnum\|isalpha\|iscntrl\|isdigit\|islower\|isprint\|ispunct\|isspace\|isupper\|isxdigit\|toupper\|tolower $(SRCS) | grep -v UCHAR
#
# Target to make sure that only symbols with "Tcl" prefixes are exported.
#
checkexports: $(TCL_LIB_FILE)
-@nm -p $(TCL_LIB_FILE) \
| awk '$$2 ~ /^[TDBCS]$$/ { sub("^_", "", $$3); print $$3 }' \
| sort -n | grep -E -v '^[Tt]cl' || true
#--------------------------------------------------------------------------
# Distribution building rules
#--------------------------------------------------------------------------
#
# Target to create a Tcl RPM for Linux. Requires that you be on a Linux
# system.
#
RPM_PLATFORMS = i386
rpm: all
-@rm -f THIS.TCL.SPEC
echo "%define _builddir `pwd`" > THIS.TCL.SPEC
echo "%define _rpmdir `pwd`/RPMS" >> THIS.TCL.SPEC
cat tcl.spec >> THIS.TCL.SPEC
for platform in $(RPM_PLATFORMS); do \
mkdir -p RPMS/$$platform && \
rpmbuild -bb THIS.TCL.SPEC && \
mv RPMS/$$platform/*.rpm .; \
done
-rm -rf RPMS THIS.TCL.SPEC
#
# Target to create a proper Tcl distribution from information in the master
# source directory. DISTDIR must be defined to indicate where to put the
# distribution. DISTDIR must be an absolute path name.
#
DISTROOT = /tmp/dist
DISTNAME = tcl${VERSION}${PATCH_LEVEL}
ZIPNAME = tcl${MAJOR_VERSION}${MINOR_VERSION}${PATCH_LEVEL}-src.zip
DISTDIR = $(DISTROOT)/$(DISTNAME)
DIST_INSTALL_DATA = CPPROG='cp -p' $(INSTALL) -m 644
DIST_INSTALL_SCRIPT = CPPROG='cp -p' $(INSTALL) -m 755
BUILTIN_PACKAGE_LIST = http opt msgcat reg dde tcltest platform
$(UNIX_DIR)/configure: $(UNIX_DIR)/configure.ac $(UNIX_DIR)/tcl.m4 \
$(UNIX_DIR)/aclocal.m4
cd $(UNIX_DIR); autoconf
$(MAC_OSX_DIR)/configure: $(MAC_OSX_DIR)/configure.ac $(UNIX_DIR)/configure
cd $(MAC_OSX_DIR); autoconf
$(UNIX_DIR)/tclConfig.h.in: $(MAC_OSX_DIR)/configure
cd $(MAC_OSX_DIR); autoheader; touch $@
dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in $(UNIX_DIR)/tcl.pc.in \
$(MAC_OSX_DIR)/configure genstubs dist-packages ${NATIVE_TCLSH}
rm -rf $(DISTDIR)
$(INSTALL_DATA_DIR) $(DISTDIR)/unix
$(DIST_INSTALL_DATA) $(UNIX_DIR)/*.[ch] $(DISTDIR)/unix
$(DIST_INSTALL_DATA) $(UNIX_DIR)/Makefile.in $(DISTDIR)/unix
$(DIST_INSTALL_DATA) $(UNIX_DIR)/configure.ac \
$(UNIX_DIR)/tcl.m4 $(UNIX_DIR)/aclocal.m4 \
$(UNIX_DIR)/tclConfig.sh.in $(UNIX_DIR)/tclooConfig.sh \
$(UNIX_DIR)/install-sh \
$(UNIX_DIR)/README $(UNIX_DIR)/tcl.spec \
$(UNIX_DIR)/installManPage $(UNIX_DIR)/tclConfig.h.in \
$(UNIX_DIR)/tcl.pc.in $(DISTDIR)/unix
$(DIST_INSTALL_SCRIPT) $(UNIX_DIR)/configure $(UNIX_DIR)/ldAix $(DISTDIR)/unix
$(INSTALL_DATA_DIR) $(DISTDIR)/generic
$(DIST_INSTALL_DATA) $(GENERIC_DIR)/*.[cdh] $(DISTDIR)/generic
$(DIST_INSTALL_DATA) $(GENERIC_DIR)/*.decls $(DISTDIR)/generic
$(DIST_INSTALL_DATA) $(GENERIC_DIR)/README $(DISTDIR)/generic
$(DIST_INSTALL_DATA) $(GENERIC_DIR)/tclGetDate.y $(DISTDIR)/generic
$(DIST_INSTALL_DATA) $(TOP_DIR)/changes $(TOP_DIR)/ChangeLog $(TOP_DIR)/README.md \
$(TOP_DIR)/ChangeLog.[12]??? $(TOP_DIR)/license.terms \
$(DISTDIR)
$(INSTALL_DATA_DIR) $(DISTDIR)/library
$(DIST_INSTALL_DATA) $(TOP_DIR)/license.terms $(TOP_DIR)/library/*.tcl \
$(TOP_DIR)/library/tclIndex $(DISTDIR)/library
@for i in $(BUILTIN_PACKAGE_LIST) ; do \
$(INSTALL_DATA_DIR) $(DISTDIR)/library/$$i;\
$(DIST_INSTALL_DATA) $(TOP_DIR)/library/$$i/*.tcl $(DISTDIR)/library/$$i; \
done
$(INSTALL_DATA_DIR) $(DISTDIR)/library/encoding
$(DIST_INSTALL_DATA) $(TOP_DIR)/library/encoding/*.enc $(DISTDIR)/library/encoding
$(INSTALL_DATA_DIR) $(DISTDIR)/library/msgs
$(DIST_INSTALL_DATA) $(TOP_DIR)/library/msgs/*.msg $(DISTDIR)/library/msgs
@echo cp -r $(TOP_DIR)/library/tzdata $(DISTDIR)/library/tzdata
@( cd $(TOP_DIR); find library/tzdata -type f -print ) \
| ( cd $(TOP_DIR) ; xargs tar cf - ) \
| ( cd $(DISTDIR) ; tar xfp - )
$(INSTALL_DATA_DIR) $(DISTDIR)/doc
$(DIST_INSTALL_DATA) $(TOP_DIR)/license.terms $(TOP_DIR)/doc/*.[13n] \
$(TOP_DIR)/doc/man.macros $(DISTDIR)/doc
$(INSTALL_DATA_DIR) $(DISTDIR)/compat
$(DIST_INSTALL_DATA) $(TOP_DIR)/license.terms $(COMPAT_DIR)/*.[ch] \
$(COMPAT_DIR)/README $(DISTDIR)/compat
$(INSTALL_DATA_DIR) $(DISTDIR)/compat/zlib
@echo cp -r $(COMPAT_DIR)/zlib $(DISTDIR)/compat/zlib
@( cd $(COMPAT_DIR)/zlib; find . -type f -print ) \
| ( cd $(COMPAT_DIR)/zlib ; xargs tar cf - ) \
| ( cd $(DISTDIR)/compat/zlib ; tar xfp - )
$(INSTALL_DATA_DIR) $(DISTDIR)/tests
$(DIST_INSTALL_DATA) $(TOP_DIR)/license.terms $(DISTDIR)/tests
$(DIST_INSTALL_DATA) $(TOP_DIR)/tests/*.test $(TOP_DIR)/tests/README \
$(TOP_DIR)/tests/httpd $(TOP_DIR)/tests/*.tcl \
$(DISTDIR)/tests
$(INSTALL_DATA_DIR) $(DISTDIR)/win
$(DIST_INSTALL_DATA) $(TOP_DIR)/win/Makefile.in $(DISTDIR)/win
$(DIST_INSTALL_DATA) $(TOP_DIR)/win/configure.ac \
$(TOP_DIR)/win/tclConfig.sh.in $(TOP_DIR)/win/tclooConfig.sh \
$(TOP_DIR)/win/tcl.m4 $(TOP_DIR)/win/aclocal.m4 \
$(TOP_DIR)/win/tclsh.exe.manifest.in \
$(DISTDIR)/win
$(DIST_INSTALL_SCRIPT) $(TOP_DIR)/win/configure $(DISTDIR)/win
$(DIST_INSTALL_DATA) $(TOP_DIR)/win/*.[ch] $(TOP_DIR)/win/*.ico $(TOP_DIR)/win/*.rc \
$(DISTDIR)/win
$(DIST_INSTALL_DATA) $(TOP_DIR)/win/*.bat $(DISTDIR)/win
$(DIST_INSTALL_DATA) $(TOP_DIR)/win/*.vc $(DISTDIR)/win
$(DIST_INSTALL_DATA) $(TOP_DIR)/win/tcl.hpj.in $(DISTDIR)/win
$(DIST_INSTALL_DATA) $(TOP_DIR)/win/tcl.ds* $(DISTDIR)/win
$(DIST_INSTALL_DATA) $(TOP_DIR)/win/README $(DISTDIR)/win
$(DIST_INSTALL_DATA) $(TOP_DIR)/license.terms $(DISTDIR)/win
$(INSTALL_DATA_DIR) $(DISTDIR)/macosx
$(DIST_INSTALL_DATA) $(MAC_OSX_DIR)/GNUmakefile $(MAC_OSX_DIR)/README \
$(MAC_OSX_DIR)/*.c $(MAC_OSX_DIR)/*.in \
$(MAC_OSX_DIR)/*.ac $(MAC_OSX_DIR)/*.xcconfig \
$(DISTDIR)/macosx
$(DIST_INSTALL_SCRIPT) $(MAC_OSX_DIR)/configure $(DISTDIR)/macosx
$(DIST_INSTALL_DATA) $(TOP_DIR)/license.terms $(DISTDIR)/macosx
$(INSTALL_DATA_DIR) $(DISTDIR)/macosx/Tcl.xcode
$(DIST_INSTALL_DATA) $(MAC_OSX_DIR)/Tcl.xcode/project.pbxproj \
$(MAC_OSX_DIR)/Tcl.xcode/default.pbxuser \
$(DISTDIR)/macosx/Tcl.xcode
$(INSTALL_DATA_DIR) $(DISTDIR)/macosx/Tcl.xcodeproj
$(DIST_INSTALL_DATA) $(MAC_OSX_DIR)/Tcl.xcodeproj/project.pbxproj \
$(MAC_OSX_DIR)/Tcl.xcodeproj/default.pbxuser \
$(DISTDIR)/macosx/Tcl.xcodeproj
$(INSTALL_DATA_DIR) $(DISTDIR)/unix/dltest
$(DIST_INSTALL_DATA) $(UNIX_DIR)/dltest/*.c $(UNIX_DIR)/dltest/Makefile.in \
$(UNIX_DIR)/dltest/README $(DISTDIR)/unix/dltest
$(INSTALL_DATA_DIR) $(DISTDIR)/tools
$(DIST_INSTALL_DATA) $(TOOL_DIR)/Makefile.in $(TOOL_DIR)/README \
$(TOOL_DIR)/configure $(TOOL_DIR)/configure.ac \
$(TOOL_DIR)/*.tcl $(TOOL_DIR)/man2tcl.c \
$(TOOL_DIR)/*.bmp $(TOOL_DIR)/tcl.hpj.in \
$(DISTDIR)/tools
chmod 755 $(DISTDIR)/tools/checkLibraryDoc.tcl \
$(DISTDIR)/tools/configure $(DISTDIR)/tools/findBadExternals.tcl \
$(DISTDIR)/tools/fix_tommath_h.tcl $(DISTDIR)/tools/loadICU.tcl \
$(DISTDIR)/tools/makeTestCases.tcl $(DISTDIR)/tools/tclZIC.tcl \
$(DISTDIR)/tools/tcltk-man2html.tcl
$(INSTALL_DATA_DIR) $(DISTDIR)/libtommath
$(DIST_INSTALL_DATA) $(TOMMATH_SRCS) $(TOMMATH_DIR)/*.h $(DISTDIR)/libtommath
$(INSTALL_DATA_DIR) $(DISTDIR)/pkgs
$(DIST_INSTALL_DATA) $(TOP_DIR)/pkgs/README $(DISTDIR)/pkgs
$(DIST_INSTALL_DATA) $(TOP_DIR)/pkgs/package.list.txt $(DISTDIR)/pkgs
for i in `ls $(DISTROOT)/pkgs/*.tar.gz 2> /dev/null` ; do \
tar -C $(DISTDIR)/pkgs -xzf "$$i"; \
done
alldist: dist
rm -f $(DISTROOT)/$(DISTNAME)-src.tar.gz $(DISTROOT)/$(ZIPNAME)
( cd $(DISTROOT); \
tar cf $(DISTNAME)-src.tar $(DISTNAME); \
gzip -9 $(DISTNAME)-src.tar; \
zip -qr8 $(ZIPNAME) $(DISTNAME) )
#--------------------------------------------------------------------------
# This target creates the HTML folder for Tcl & Tk and places it in
# DISTDIR/html. It uses the tcltk-man2html.tcl tool from the Tcl group's tool
# workspace. It depends on the Tcl & Tk being in directories called tcl9.* &
# tk8.* up two directories from the TOOL_DIR.
#
|
| ︙ | ︙ | |||
2109 2110 2111 2112 2113 2114 2115 |
$(BUILD_HTML) --tcl
@EXTRA_BUILD_HTML@
html-tk: ${NATIVE_TCLSH}
$(BUILD_HTML) --tk
@EXTRA_BUILD_HTML@
| < < < | | > | 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 |
$(BUILD_HTML) --tcl
@EXTRA_BUILD_HTML@
html-tk: ${NATIVE_TCLSH}
$(BUILD_HTML) --tk
@EXTRA_BUILD_HTML@
BUILD_HTML = \
@${NATIVE_TCLSH} $(TOOL_DIR)/tcltk-man2html.tcl \
--tcl --useversion=$(MAJOR_VERSION).$(MINOR_VERSION) --htmldir="$(HTML_INSTALL_DIR)" \
--srcdir=$(TOP_DIR) $(BUILD_HTML_FLAGS)
#--------------------------------------------------------------------------
# The list of all the targets that do not correspond to real files. This stops
# 'make' from getting confused when someone makes an error in a rule.
#--------------------------------------------------------------------------
.PHONY: all binaries libraries objs doc html html-tcl html-tk test runtest
.PHONY: install install-strip install-binaries install-libraries
.PHONY: install-headers install-private-headers install-doc
.PHONY: clean distclean depend genstubs checkstubs checkexports checkuchar
.PHONY: shell gdb valgrind valgrindshell dist alldist rpm
.PHONY: tclLibObjs tcltest-real test-tcl gdb-test ro-test trace-test xttest
.PHONY: topDirName gendate gentommath_h trace-shell checkdoc
.PHONY: install-tzdata install-msgs
.PHONY: packages configure-packages test-packages clean-packages
.PHONY: dist-packages distclean-packages install-packages
.PHONY: install-libraries-zipfs-shared install-libraries-zipfs-static tclzipfile
#--------------------------------------------------------------------------
# DO NOT DELETE THIS LINE -- make depend depends on it.
|
Changes to unix/README.
| ︙ | ︙ | |||
41 42 43 44 45 46 47 |
(c) Type "./configure". This runs a configuration script created by GNU
autoconf, which configures Tcl for your system and creates a Makefile. The
configure script allows you to customize the Tcl configuration for your
site; for details on how you can do this, type "./configure --help" or
refer to the autoconf documentation (not included here). Tcl's "configure"
supports the following special switches in addition to the standard ones:
| < < | 41 42 43 44 45 46 47 48 49 50 51 52 53 54 |
(c) Type "./configure". This runs a configuration script created by GNU
autoconf, which configures Tcl for your system and creates a Makefile. The
configure script allows you to customize the Tcl configuration for your
site; for details on how you can do this, type "./configure --help" or
refer to the autoconf documentation (not included here). Tcl's "configure"
supports the following special switches in addition to the standard ones:
--disable-load If this switch is specified then Tcl will
configure itself not to allow dynamic loading,
even if your system appears to support it.
Normally you can leave this switch out and Tcl
will build itself for dynamic loading if your
system supports it.
--disable-dll-unloading Disables support for the [unload] command even
|
| ︙ | ︙ |
Changes to unix/configure.
| ︙ | ︙ | |||
660 661 662 663 664 665 666 667 668 669 670 671 672 673 | TCL_LIB_FILE PKG_CFG_ARGS TCL_YEAR TCL_PATCH_LEVEL TCL_MINOR_VERSION TCL_MAJOR_VERSION TCL_VERSION DTRACE LDFLAGS_DEFAULT CFLAGS_DEFAULT INSTALL_STUB_LIB DLL_INSTALL_DIR INSTALL_LIB MAKE_STUB_LIB | > > > > > > > > > > | 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 | TCL_LIB_FILE PKG_CFG_ARGS TCL_YEAR TCL_PATCH_LEVEL TCL_MINOR_VERSION TCL_MAJOR_VERSION TCL_VERSION INSTALL_MSGS INSTALL_LIBRARIES TCL_ZIP_FILE ZIPFS_BUILD ZIP_INSTALL_OBJS ZIP_PROG_VFSSEARCH ZIP_PROG_OPTIONS ZIP_PROG EXEEXT_FOR_BUILD CC_FOR_BUILD DTRACE LDFLAGS_DEFAULT CFLAGS_DEFAULT INSTALL_STUB_LIB DLL_INSTALL_DIR INSTALL_LIB MAKE_STUB_LIB |
| ︙ | ︙ | |||
695 696 697 698 699 700 701 | LIBOBJS AR RANLIB ZLIB_INCLUDE ZLIB_SRCS ZLIB_OBJS TCLSH_PROG | | | 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 | LIBOBJS AR RANLIB ZLIB_INCLUDE ZLIB_SRCS ZLIB_OBJS TCLSH_PROG SHARED_BUILD EGREP GREP CPP OBJEXT EXEEXT ac_ct_CC CPPFLAGS |
| ︙ | ︙ | |||
744 745 746 747 748 749 750 | PACKAGE_URL PACKAGE_BUGREPORT PACKAGE_STRING PACKAGE_VERSION PACKAGE_TARNAME PACKAGE_NAME PATH_SEPARATOR | | > < > | 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 |
PACKAGE_URL
PACKAGE_BUGREPORT
PACKAGE_STRING
PACKAGE_VERSION
PACKAGE_TARNAME
PACKAGE_NAME
PATH_SEPARATOR
SHELL
OBJEXT_FOR_BUILD'
ac_subst_files=''
ac_user_opts='
enable_option_checking
enable_man_symlinks
enable_man_compression
enable_man_suffix
with_encoding
enable_shared
enable_64bit
enable_64bit_vis
enable_rpath
enable_corefoundation
enable_load
enable_symbols
enable_langinfo
enable_dll_unloading
with_tzdata
enable_dtrace
enable_zipfs
enable_framework
'
ac_precious_vars='build_alias
host_alias
target_alias
CC
CFLAGS
|
| ︙ | ︙ | |||
1391 1392 1393 1394 1395 1396 1397 |
--enable-man-symlinks use symlinks for the manpages (default: off)
--enable-man-compression=PROG
compress the manpages with PROG (default: off)
--enable-man-suffix=STRING
use STRING as a suffix to manpage file names
(default: no, tcl if enabled without
specifying STRING)
| < > | 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 |
--enable-man-symlinks use symlinks for the manpages (default: off)
--enable-man-compression=PROG
compress the manpages with PROG (default: off)
--enable-man-suffix=STRING
use STRING as a suffix to manpage file names
(default: no, tcl if enabled without
specifying STRING)
--enable-shared build and link with shared libraries (default: on)
--enable-64bit enable 64bit support (default: off)
--enable-64bit-vis enable 64bit Sparc VIS support (default: off)
--disable-rpath disable rpath support (default: on)
--enable-corefoundation use CoreFoundation API on MacOSX (default: on)
--enable-load allow dynamic loading and "load" command (default:
on)
--enable-symbols build with debugging symbols (default: off)
--enable-langinfo use nl_langinfo if possible to determine encoding at
startup, otherwise use old heuristic (default: on)
--enable-dll-unloading enable the 'unload' command (default: on)
--enable-dtrace build with DTrace support (default: off)
--enable-zipfs build with Zipfs support (default: on)
--enable-framework package shared libraries in MacOSX frameworks
(default: off)
Optional Packages:
--with-PACKAGE[=ARG] use PACKAGE [ARG=yes]
--without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no)
--with-encoding encoding for configuration values (default:
|
| ︙ | ︙ | |||
1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 |
fi
eval ac_res=\$$3
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5
$as_echo "$ac_res" >&6; }
eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno
} # ac_fn_c_check_func
# ac_fn_c_check_type LINENO TYPE VAR INCLUDES
# -------------------------------------------
# Tests whether TYPE exists after having included INCLUDES, setting cache
# variable VAR accordingly.
ac_fn_c_check_type ()
{
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 |
fi
eval ac_res=\$$3
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5
$as_echo "$ac_res" >&6; }
eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno
} # ac_fn_c_check_func
# ac_fn_c_check_decl LINENO SYMBOL VAR INCLUDES
# ---------------------------------------------
# Tests whether SYMBOL is declared in INCLUDES, setting cache variable VAR
# accordingly.
ac_fn_c_check_decl ()
{
as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack
as_decl_name=`echo $2|sed 's/ *(.*//'`
as_decl_use=`echo $2|sed -e 's/(/((/' -e 's/)/) 0&/' -e 's/,/) 0& (/g'`
{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether $as_decl_name is declared" >&5
$as_echo_n "checking whether $as_decl_name is declared... " >&6; }
if eval \${$3+:} false; then :
$as_echo_n "(cached) " >&6
else
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
$4
int
main ()
{
#ifndef $as_decl_name
#ifdef __cplusplus
(void) $as_decl_use;
#else
(void) $as_decl_name;
#endif
#endif
;
return 0;
}
_ACEOF
if ac_fn_c_try_compile "$LINENO"; then :
eval "$3=yes"
else
eval "$3=no"
fi
rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
fi
eval ac_res=\$$3
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5
$as_echo "$ac_res" >&6; }
eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno
} # ac_fn_c_check_decl
# ac_fn_c_check_type LINENO TYPE VAR INCLUDES
# -------------------------------------------
# Tests whether TYPE exists after having included INCLUDES, setting cache
# variable VAR accordingly.
ac_fn_c_check_type ()
{
|
| ︙ | ︙ | |||
3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 |
#ifndef __cplusplus
#define inline $ac_val
#endif
_ACEOF
;;
esac
#--------------------------------------------------------------------
# Supply substitutes for missing POSIX header files. Special notes:
# - stdlib.h doesn't define strtol, strtoul, or
# strtod insome versions of SunOS
# - some versions of string.h don't declare procedures such
# as strstr
| > | 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 |
#ifndef __cplusplus
#define inline $ac_val
#endif
_ACEOF
;;
esac
#--------------------------------------------------------------------
# Supply substitutes for missing POSIX header files. Special notes:
# - stdlib.h doesn't define strtol, strtoul, or
# strtod insome versions of SunOS
# - some versions of string.h don't declare procedures such
# as strstr
|
| ︙ | ︙ | |||
3905 3906 3907 3908 3909 3910 3911 |
fi
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_cc_pipe" >&5
$as_echo "$tcl_cv_cc_pipe" >&6; }
if test $tcl_cv_cc_pipe = yes; then
CFLAGS="$CFLAGS -pipe"
fi
fi
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 3963 3964 3965 3966 3967 3968 3969 3970 3971 3972 3973 3974 3975 3976 |
fi
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_cc_pipe" >&5
$as_echo "$tcl_cv_cc_pipe" >&6; }
if test $tcl_cv_cc_pipe = yes; then
CFLAGS="$CFLAGS -pipe"
fi
fi
#------------------------------------------------------------------------
# Embedded configuration information, encoding to use for the values, TIP #59
#------------------------------------------------------------------------
|
| ︙ | ︙ | |||
4449 4450 4451 4452 4453 4454 4455 4456 4457 4458 4459 4460 4461 4462 |
if test "x$ac_cv_lib_nsl_gethostbyname" = xyes; then :
LIBS="$LIBS -lnsl"
fi
fi
# Add the threads support libraries
LIBS="$LIBS$THREADS_LIBS"
{ $as_echo "$as_me:${as_lineno-$LINENO}: checking how to build libraries" >&5
$as_echo_n "checking how to build libraries... " >&6; }
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 4190 4191 4192 4193 4194 4195 4196 4197 4198 4199 4200 4201 4202 4203 4204 4205 4206 4207 4208 4209 4210 4211 4212 4213 4214 4215 4216 4217 4218 4219 4220 4221 4222 4223 4224 4225 4226 4227 4228 4229 4230 4231 4232 4233 4234 4235 4236 4237 4238 4239 4240 4241 4242 4243 4244 4245 4246 4247 4248 4249 4250 4251 4252 4253 4254 4255 4256 4257 4258 4259 4260 4261 4262 4263 4264 4265 4266 4267 4268 4269 4270 4271 4272 4273 4274 4275 4276 4277 4278 4279 4280 4281 4282 4283 4284 4285 4286 4287 4288 4289 4290 4291 4292 4293 4294 4295 4296 4297 4298 4299 4300 4301 4302 4303 4304 4305 4306 4307 4308 4309 4310 4311 4312 4313 4314 4315 4316 4317 4318 4319 4320 4321 4322 4323 4324 4325 4326 4327 4328 4329 4330 4331 4332 4333 4334 4335 4336 4337 4338 4339 4340 4341 4342 4343 4344 4345 4346 4347 4348 4349 4350 4351 4352 4353 4354 4355 4356 4357 4358 4359 4360 4361 4362 4363 4364 4365 4366 4367 4368 4369 4370 4371 4372 4373 4374 4375 4376 4377 4378 4379 4380 4381 4382 4383 4384 4385 4386 4387 4388 4389 4390 4391 4392 4393 4394 4395 4396 4397 4398 4399 4400 4401 4402 4403 4404 4405 4406 4407 4408 4409 4410 4411 4412 4413 4414 4415 4416 4417 4418 4419 4420 4421 4422 4423 4424 4425 4426 4427 4428 4429 4430 4431 4432 4433 4434 4435 4436 4437 4438 4439 4440 4441 4442 4443 4444 4445 4446 4447 4448 4449 4450 4451 4452 4453 4454 4455 4456 4457 4458 4459 4460 4461 4462 4463 4464 4465 4466 4467 4468 4469 4470 4471 4472 4473 4474 4475 4476 4477 4478 4479 4480 4481 4482 4483 4484 4485 |
if test "x$ac_cv_lib_nsl_gethostbyname" = xyes; then :
LIBS="$LIBS -lnsl"
fi
fi
$as_echo "#define _REENTRANT 1" >>confdefs.h
$as_echo "#define _THREAD_SAFE 1" >>confdefs.h
{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for pthread_mutex_init in -lpthread" >&5
$as_echo_n "checking for pthread_mutex_init in -lpthread... " >&6; }
if ${ac_cv_lib_pthread_pthread_mutex_init+:} false; then :
$as_echo_n "(cached) " >&6
else
ac_check_lib_save_LIBS=$LIBS
LIBS="-lpthread $LIBS"
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
/* Override any GCC internal prototype to avoid an error.
Use char because int might match the return type of a GCC
builtin and then its argument prototype would still apply. */
#ifdef __cplusplus
extern "C"
#endif
char pthread_mutex_init ();
int
main ()
{
return pthread_mutex_init ();
;
return 0;
}
_ACEOF
if ac_fn_c_try_link "$LINENO"; then :
ac_cv_lib_pthread_pthread_mutex_init=yes
else
ac_cv_lib_pthread_pthread_mutex_init=no
fi
rm -f core conftest.err conftest.$ac_objext \
conftest$ac_exeext conftest.$ac_ext
LIBS=$ac_check_lib_save_LIBS
fi
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_pthread_pthread_mutex_init" >&5
$as_echo "$ac_cv_lib_pthread_pthread_mutex_init" >&6; }
if test "x$ac_cv_lib_pthread_pthread_mutex_init" = xyes; then :
tcl_ok=yes
else
tcl_ok=no
fi
if test "$tcl_ok" = "no"; then
# Check a little harder for __pthread_mutex_init in the same
# library, as some systems hide it there until pthread.h is
# defined. We could alternatively do an AC_TRY_COMPILE with
# pthread.h, but that will work with libpthread really doesn't
# exist, like AIX 4.2. [Bug: 4359]
{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for __pthread_mutex_init in -lpthread" >&5
$as_echo_n "checking for __pthread_mutex_init in -lpthread... " >&6; }
if ${ac_cv_lib_pthread___pthread_mutex_init+:} false; then :
$as_echo_n "(cached) " >&6
else
ac_check_lib_save_LIBS=$LIBS
LIBS="-lpthread $LIBS"
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
/* Override any GCC internal prototype to avoid an error.
Use char because int might match the return type of a GCC
builtin and then its argument prototype would still apply. */
#ifdef __cplusplus
extern "C"
#endif
char __pthread_mutex_init ();
int
main ()
{
return __pthread_mutex_init ();
;
return 0;
}
_ACEOF
if ac_fn_c_try_link "$LINENO"; then :
ac_cv_lib_pthread___pthread_mutex_init=yes
else
ac_cv_lib_pthread___pthread_mutex_init=no
fi
rm -f core conftest.err conftest.$ac_objext \
conftest$ac_exeext conftest.$ac_ext
LIBS=$ac_check_lib_save_LIBS
fi
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_pthread___pthread_mutex_init" >&5
$as_echo "$ac_cv_lib_pthread___pthread_mutex_init" >&6; }
if test "x$ac_cv_lib_pthread___pthread_mutex_init" = xyes; then :
tcl_ok=yes
else
tcl_ok=no
fi
fi
if test "$tcl_ok" = "yes"; then
# The space is needed
THREADS_LIBS=" -lpthread"
else
{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for pthread_mutex_init in -lpthreads" >&5
$as_echo_n "checking for pthread_mutex_init in -lpthreads... " >&6; }
if ${ac_cv_lib_pthreads_pthread_mutex_init+:} false; then :
$as_echo_n "(cached) " >&6
else
ac_check_lib_save_LIBS=$LIBS
LIBS="-lpthreads $LIBS"
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
/* Override any GCC internal prototype to avoid an error.
Use char because int might match the return type of a GCC
builtin and then its argument prototype would still apply. */
#ifdef __cplusplus
extern "C"
#endif
char pthread_mutex_init ();
int
main ()
{
return pthread_mutex_init ();
;
return 0;
}
_ACEOF
if ac_fn_c_try_link "$LINENO"; then :
ac_cv_lib_pthreads_pthread_mutex_init=yes
else
ac_cv_lib_pthreads_pthread_mutex_init=no
fi
rm -f core conftest.err conftest.$ac_objext \
conftest$ac_exeext conftest.$ac_ext
LIBS=$ac_check_lib_save_LIBS
fi
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_pthreads_pthread_mutex_init" >&5
$as_echo "$ac_cv_lib_pthreads_pthread_mutex_init" >&6; }
if test "x$ac_cv_lib_pthreads_pthread_mutex_init" = xyes; then :
_ok=yes
else
tcl_ok=no
fi
if test "$tcl_ok" = "yes"; then
# The space is needed
THREADS_LIBS=" -lpthreads"
else
{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for pthread_mutex_init in -lc" >&5
$as_echo_n "checking for pthread_mutex_init in -lc... " >&6; }
if ${ac_cv_lib_c_pthread_mutex_init+:} false; then :
$as_echo_n "(cached) " >&6
else
ac_check_lib_save_LIBS=$LIBS
LIBS="-lc $LIBS"
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
/* Override any GCC internal prototype to avoid an error.
Use char because int might match the return type of a GCC
builtin and then its argument prototype would still apply. */
#ifdef __cplusplus
extern "C"
#endif
char pthread_mutex_init ();
int
main ()
{
return pthread_mutex_init ();
;
return 0;
}
_ACEOF
if ac_fn_c_try_link "$LINENO"; then :
ac_cv_lib_c_pthread_mutex_init=yes
else
ac_cv_lib_c_pthread_mutex_init=no
fi
rm -f core conftest.err conftest.$ac_objext \
conftest$ac_exeext conftest.$ac_ext
LIBS=$ac_check_lib_save_LIBS
fi
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_c_pthread_mutex_init" >&5
$as_echo "$ac_cv_lib_c_pthread_mutex_init" >&6; }
if test "x$ac_cv_lib_c_pthread_mutex_init" = xyes; then :
tcl_ok=yes
else
tcl_ok=no
fi
if test "$tcl_ok" = "no"; then
{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for pthread_mutex_init in -lc_r" >&5
$as_echo_n "checking for pthread_mutex_init in -lc_r... " >&6; }
if ${ac_cv_lib_c_r_pthread_mutex_init+:} false; then :
$as_echo_n "(cached) " >&6
else
ac_check_lib_save_LIBS=$LIBS
LIBS="-lc_r $LIBS"
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
/* Override any GCC internal prototype to avoid an error.
Use char because int might match the return type of a GCC
builtin and then its argument prototype would still apply. */
#ifdef __cplusplus
extern "C"
#endif
char pthread_mutex_init ();
int
main ()
{
return pthread_mutex_init ();
;
return 0;
}
_ACEOF
if ac_fn_c_try_link "$LINENO"; then :
ac_cv_lib_c_r_pthread_mutex_init=yes
else
ac_cv_lib_c_r_pthread_mutex_init=no
fi
rm -f core conftest.err conftest.$ac_objext \
conftest$ac_exeext conftest.$ac_ext
LIBS=$ac_check_lib_save_LIBS
fi
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_c_r_pthread_mutex_init" >&5
$as_echo "$ac_cv_lib_c_r_pthread_mutex_init" >&6; }
if test "x$ac_cv_lib_c_r_pthread_mutex_init" = xyes; then :
tcl_ok=yes
else
tcl_ok=no
fi
if test "$tcl_ok" = "yes"; then
# The space is needed
THREADS_LIBS=" -pthread"
else
{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: Don't know how to find pthread lib on your system - you must edit the LIBS in the Makefile..." >&5
$as_echo "$as_me: WARNING: Don't know how to find pthread lib on your system - you must edit the LIBS in the Makefile..." >&2;}
fi
fi
fi
fi
# Does the pthread-implementation provide
# 'pthread_attr_setstacksize' ?
ac_saved_libs=$LIBS
LIBS="$LIBS $THREADS_LIBS"
for ac_func in pthread_attr_setstacksize pthread_atfork
do :
as_ac_var=`$as_echo "ac_cv_func_$ac_func" | $as_tr_sh`
ac_fn_c_check_func "$LINENO" "$ac_func" "$as_ac_var"
if eval test \"x\$"$as_ac_var"\" = x"yes"; then :
cat >>confdefs.h <<_ACEOF
#define `$as_echo "HAVE_$ac_func" | $as_tr_cpp` 1
_ACEOF
fi
done
LIBS=$ac_saved_libs
# TIP #509
ac_fn_c_check_decl "$LINENO" "PTHREAD_MUTEX_RECURSIVE" "ac_cv_have_decl_PTHREAD_MUTEX_RECURSIVE" "#include <pthread.h>
"
if test "x$ac_cv_have_decl_PTHREAD_MUTEX_RECURSIVE" = xyes; then :
ac_have_decl=1
else
ac_have_decl=0
fi
cat >>confdefs.h <<_ACEOF
#define HAVE_DECL_PTHREAD_MUTEX_RECURSIVE $ac_have_decl
_ACEOF
if test $ac_have_decl = 1; then :
tcl_ok=yes
else
tcl_ok=no
fi
# Add the threads support libraries
LIBS="$LIBS$THREADS_LIBS"
{ $as_echo "$as_me:${as_lineno-$LINENO}: checking how to build libraries" >&5
$as_echo_n "checking how to build libraries... " >&6; }
|
| ︙ | ︙ | |||
4483 4484 4485 4486 4487 4488 4489 4490 4491 4492 4493 4494 4495 4496 |
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: static" >&5
$as_echo "static" >&6; }
SHARED_BUILD=0
$as_echo "#define STATIC_BUILD 1" >>confdefs.h
fi
#--------------------------------------------------------------------
# Look for a native installed tclsh binary (if available)
# If one cannot be found then use the binary we build (fails for
# cross compiling). This is used for NATIVE_TCLSH in Makefile.
#--------------------------------------------------------------------
| > | 4506 4507 4508 4509 4510 4511 4512 4513 4514 4515 4516 4517 4518 4519 4520 |
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: static" >&5
$as_echo "static" >&6; }
SHARED_BUILD=0
$as_echo "#define STATIC_BUILD 1" >>confdefs.h
fi
#--------------------------------------------------------------------
# Look for a native installed tclsh binary (if available)
# If one cannot be found then use the binary we build (fails for
# cross compiling). This is used for NATIVE_TCLSH in Makefile.
#--------------------------------------------------------------------
|
| ︙ | ︙ | |||
4919 4920 4921 4922 4923 4924 4925 |
TCL_TRIM_DOTS='`echo ${VERSION} | tr -d .`'
ECHO_VERSION='`echo ${VERSION}`'
TCL_LIB_VERSIONS_OK=ok
CFLAGS_DEBUG=-g
if test "$GCC" = yes; then :
CFLAGS_OPTIMIZE=-O2
| | | 4943 4944 4945 4946 4947 4948 4949 4950 4951 4952 4953 4954 4955 4956 4957 |
TCL_TRIM_DOTS='`echo ${VERSION} | tr -d .`'
ECHO_VERSION='`echo ${VERSION}`'
TCL_LIB_VERSIONS_OK=ok
CFLAGS_DEBUG=-g
if test "$GCC" = yes; then :
CFLAGS_OPTIMIZE=-O2
CFLAGS_WARNING="-Wall -Wwrite-strings -Wsign-compare -Wdeclaration-after-statement -Wpointer-arith"
else
CFLAGS_OPTIMIZE=-O
CFLAGS_WARNING=""
fi
|
| ︙ | ︙ | |||
5029 5030 5031 5032 5033 5034 5035 |
PLAT_SRCS=""
LDAIX_SRC=""
if test "x${SHLIB_VERSION}" = x; then :
SHLIB_VERSION="1.0"
fi
case $system in
AIX-*)
| | | 5053 5054 5055 5056 5057 5058 5059 5060 5061 5062 5063 5064 5065 5066 5067 |
PLAT_SRCS=""
LDAIX_SRC=""
if test "x${SHLIB_VERSION}" = x; then :
SHLIB_VERSION="1.0"
fi
case $system in
AIX-*)
if test "$GCC" != "yes"; then :
# AIX requires the _r compiler when gcc isn't being used
case "${CC}" in
*_r|*_r\ *)
# ok ...
;;
*)
|
| ︙ | ︙ | |||
5185 5186 5187 5188 5189 5190 5191 | SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" LDFLAGS="$LDFLAGS -export-dynamic" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; | | | 5209 5210 5211 5212 5213 5214 5215 5216 5217 5218 5219 5220 5221 5222 5223 |
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS="-ldl"
LDFLAGS="$LDFLAGS -export-dynamic"
CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
;;
CYGWIN_*)
SHLIB_CFLAGS=""
SHLIB_LD='${CC} -shared'
SHLIB_SUFFIX=".dll"
DL_OBJS="tclLoadDl.o"
PLAT_OBJS='${CYGWIN_OBJS}'
PLAT_SRCS='${CYGWIN_SRCS}'
DL_LIBS="-ldl"
|
| ︙ | ︙ | |||
5231 5232 5233 5234 5235 5236 5237 |
fi
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_cygwin" >&5
$as_echo "$ac_cv_cygwin" >&6; }
if test "$ac_cv_cygwin" = "no"; then
as_fn_error $? "${CC} is not a cygwin compiler." "$LINENO" 5
fi
| < < < | 5255 5256 5257 5258 5259 5260 5261 5262 5263 5264 5265 5266 5267 5268 |
fi
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_cygwin" >&5
$as_echo "$ac_cv_cygwin" >&6; }
if test "$ac_cv_cygwin" = "no"; then
as_fn_error $? "${CC} is not a cygwin compiler." "$LINENO" 5
fi
do64bit_ok=yes
if test "x${SHARED_BUILD}" = "x1"; then
echo "running cd ../win; ${CONFIG_SHELL-/bin/sh} ./configure $ac_configure_args"
# The eval makes quoting arguments work.
if cd ../win; eval ${CONFIG_SHELL-/bin/sh} ./configure $ac_configure_args; cd ../unix
then :
else
|
| ︙ | ︙ | |||
5680 5681 5682 5683 5684 5685 5686 |
CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
fi
LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so.${SHLIB_VERSION}'
LDFLAGS="-Wl,-export-dynamic"
CFLAGS_OPTIMIZE="-O2"
| < < | | | | < < < < | | | | < < | < < | | | | < | 5701 5702 5703 5704 5705 5706 5707 5708 5709 5710 5711 5712 5713 5714 5715 5716 5717 5718 5719 5720 5721 5722 5723 5724 5725 5726 5727 5728 5729 5730 5731 5732 5733 5734 5735 5736 5737 5738 5739 5740 5741 5742 5743 5744 5745 5746 5747 5748 5749 5750 5751 5752 5753 5754 5755 5756 5757 5758 |
CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
fi
LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so.${SHLIB_VERSION}'
LDFLAGS="-Wl,-export-dynamic"
CFLAGS_OPTIMIZE="-O2"
# On OpenBSD: Compile with -pthread
# Don't link with -lpthread
LIBS=`echo $LIBS | sed s/-lpthread//`
CFLAGS="$CFLAGS -pthread"
# OpenBSD doesn't do version numbers with dots.
UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.a'
TCL_LIB_VERSIONS_OK=nodots
;;
NetBSD-*)
# NetBSD has ELF and can use 'cc -shared' to build shared libs
SHLIB_CFLAGS="-fPIC"
SHLIB_LD='${CC} ${SHLIB_CFLAGS} -shared'
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
LDFLAGS="$LDFLAGS -export-dynamic"
if test $doRpath = yes; then :
CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
fi
LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
# The -pthread needs to go in the CFLAGS, not LIBS
LIBS=`echo $LIBS | sed s/-pthread//`
CFLAGS="$CFLAGS -pthread"
LDFLAGS="$LDFLAGS -pthread"
;;
DragonFly-*|FreeBSD-*)
# This configuration from FreeBSD Ports.
SHLIB_CFLAGS="-fPIC"
SHLIB_LD="${CC} -shared"
SHLIB_LD_LIBS="${SHLIB_LD_LIBS} -Wl,-soname,\$@"
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
LDFLAGS=""
if test $doRpath = yes; then :
CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
fi
# The -pthread needs to go in the LDFLAGS, not LIBS
LIBS=`echo $LIBS | sed s/-pthread//`
CFLAGS="$CFLAGS $PTHREAD_CFLAGS"
LDFLAGS="$LDFLAGS $PTHREAD_LIBS"
case $system in
FreeBSD-3.*)
# Version numbers are dot-stripped by system policy.
TCL_TRIM_DOTS=`echo ${VERSION} | tr -d .`
UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.a'
SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so'
TCL_LIB_VERSIONS_OK=nodots
|
| ︙ | ︙ | |||
5888 5889 5890 5891 5892 5893 5894 |
SHLIB_LD="${SHLIB_LD} -Wl,-single_module"
fi
SHLIB_SUFFIX=".dylib"
DL_OBJS="tclLoadDyld.o"
DL_LIBS=""
| < < < < < < | 5898 5899 5900 5901 5902 5903 5904 5905 5906 5907 5908 5909 5910 5911 |
SHLIB_LD="${SHLIB_LD} -Wl,-single_module"
fi
SHLIB_SUFFIX=".dylib"
DL_OBJS="tclLoadDyld.o"
DL_LIBS=""
LDFLAGS="$LDFLAGS -headerpad_max_install_names"
{ $as_echo "$as_me:${as_lineno-$LINENO}: checking if ld accepts -search_paths_first flag" >&5
$as_echo_n "checking if ld accepts -search_paths_first flag... " >&6; }
if ${tcl_cv_ld_search_paths_first+:} false; then :
$as_echo_n "(cached) " >&6
else
|
| ︙ | ︙ | |||
6096 6097 6098 6099 6100 6101 6102 | if test "$GCC" = yes; then : CFLAGS="$CFLAGS -mieee" else CFLAGS="$CFLAGS -DHAVE_TZSET -std1 -ieee" fi # see pthread_intro(3) for pthread support on osf1, k.furukawa | < < | | | | | | | < < | 6100 6101 6102 6103 6104 6105 6106 6107 6108 6109 6110 6111 6112 6113 6114 6115 6116 6117 6118 6119 6120 6121 6122 6123 6124 | if test "$GCC" = yes; then : CFLAGS="$CFLAGS -mieee" else CFLAGS="$CFLAGS -DHAVE_TZSET -std1 -ieee" fi # see pthread_intro(3) for pthread support on osf1, k.furukawa CFLAGS="$CFLAGS -DHAVE_PTHREAD_ATTR_SETSTACKSIZE" CFLAGS="$CFLAGS -DTCL_THREAD_STACK_MIN=PTHREAD_STACK_MIN*64" LIBS=`echo $LIBS | sed s/-lpthreads//` if test "$GCC" = yes; then : LIBS="$LIBS -lpthread -lmach -lexc" else CFLAGS="$CFLAGS -pthread" LDFLAGS="$LDFLAGS -pthread" fi ;; QNX-6*) # QNX RTP # This may work for all QNX, but it was only reported for v6. SHLIB_CFLAGS="-fPIC" |
| ︙ | ︙ | |||
6460 6461 6462 6463 6464 6465 6466 |
# standard manufacturer compiler.
if test "$DL_OBJS" != "tclLoadNone.o" -a "$GCC" = yes; then :
case $system in
AIX-*) ;;
BSD/OS*) ;;
| | | | 6460 6461 6462 6463 6464 6465 6466 6467 6468 6469 6470 6471 6472 6473 6474 6475 6476 |
# standard manufacturer compiler.
if test "$DL_OBJS" != "tclLoadNone.o" -a "$GCC" = yes; then :
case $system in
AIX-*) ;;
BSD/OS*) ;;
CYGWIN_*) ;;
IRIX*) ;;
NetBSD-*|DragonFly-*|FreeBSD-*|OpenBSD-*) ;;
Darwin-*) ;;
SCO_SV-3.2*) ;;
*) SHLIB_CFLAGS="-fPIC" ;;
esac
fi
if test "$tcl_cv_cc_visibility_hidden" != yes; then :
|
| ︙ | ︙ | |||
6938 6939 6940 6941 6942 6943 6944 6945 6946 6947 6948 6949 6950 6951 |
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_struct_dirent64" >&5
$as_echo "$tcl_cv_struct_dirent64" >&6; }
if test "x${tcl_cv_struct_dirent64}" = "xyes" ; then
$as_echo "#define HAVE_STRUCT_DIRENT64 1" >>confdefs.h
fi
{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for struct stat64" >&5
$as_echo_n "checking for struct stat64... " >&6; }
if ${tcl_cv_struct_stat64+:} false; then :
$as_echo_n "(cached) " >&6
else
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 6938 6939 6940 6941 6942 6943 6944 6945 6946 6947 6948 6949 6950 6951 6952 6953 6954 6955 6956 6957 6958 6959 6960 6961 6962 6963 6964 6965 6966 6967 6968 6969 6970 6971 6972 6973 6974 6975 6976 6977 6978 6979 6980 6981 6982 6983 6984 6985 |
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_struct_dirent64" >&5
$as_echo "$tcl_cv_struct_dirent64" >&6; }
if test "x${tcl_cv_struct_dirent64}" = "xyes" ; then
$as_echo "#define HAVE_STRUCT_DIRENT64 1" >>confdefs.h
fi
{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for DIR64" >&5
$as_echo_n "checking for DIR64... " >&6; }
if ${tcl_cv_DIR64+:} false; then :
$as_echo_n "(cached) " >&6
else
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <sys/types.h>
#include <dirent.h>
int
main ()
{
struct dirent64 *p; DIR64 d = opendir64(".");
p = readdir64(d); rewinddir64(d); closedir64(d);
;
return 0;
}
_ACEOF
if ac_fn_c_try_compile "$LINENO"; then :
tcl_cv_DIR64=yes
else
tcl_cv_DIR64=no
fi
rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
fi
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_DIR64" >&5
$as_echo "$tcl_cv_DIR64" >&6; }
if test "x${tcl_cv_DIR64}" = "xyes" ; then
$as_echo "#define HAVE_DIR64 1" >>confdefs.h
fi
{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for struct stat64" >&5
$as_echo_n "checking for struct stat64... " >&6; }
if ${tcl_cv_struct_stat64+:} false; then :
$as_echo_n "(cached) " >&6
else
|
| ︙ | ︙ | |||
7369 7370 7371 7372 7373 7374 7375 | else $as_echo "#define NO_UNAME 1" >>confdefs.h fi | | | 7403 7404 7405 7406 7407 7408 7409 7410 7411 7412 7413 7414 7415 7416 7417 |
else
$as_echo "#define NO_UNAME 1" >>confdefs.h
fi
if test "`uname -s`" = "Darwin" && \
test "`uname -r | awk -F. '{print $1}'`" -lt 7; then
# prior to Darwin 7, realpath is not threadsafe, so don't
# use it when threads are enabled, c.f. bug # 711232
ac_cv_func_realpath=no
fi
ac_fn_c_check_func "$LINENO" "realpath" "ac_cv_func_realpath"
if test "x$ac_cv_func_realpath" = xyes; then :
|
| ︙ | ︙ | |||
7492 7493 7494 7495 7496 7497 7498 | fi #-------------------------------------------------------------------- # Look for thread-safe variants of some library functions. #-------------------------------------------------------------------- | < | | 7526 7527 7528 7529 7530 7531 7532 7533 7534 7535 7536 7537 7538 7539 7540 |
fi
#--------------------------------------------------------------------
# Look for thread-safe variants of some library functions.
#--------------------------------------------------------------------
ac_fn_c_check_func "$LINENO" "getpwuid_r" "ac_cv_func_getpwuid_r"
if test "x$ac_cv_func_getpwuid_r" = xyes; then :
{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for getpwuid_r with 5 args" >&5
$as_echo_n "checking for getpwuid_r with 5 args... " >&6; }
if ${tcl_cv_api_getpwuid_r_5+:} false; then :
$as_echo_n "(cached) " >&6
else
|
| ︙ | ︙ | |||
7589 7590 7591 7592 7593 7594 7595 |
$as_echo "#define HAVE_GETPWUID_R 1" >>confdefs.h
fi
fi
| | | 7622 7623 7624 7625 7626 7627 7628 7629 7630 7631 7632 7633 7634 7635 7636 |
$as_echo "#define HAVE_GETPWUID_R 1" >>confdefs.h
fi
fi
ac_fn_c_check_func "$LINENO" "getpwnam_r" "ac_cv_func_getpwnam_r"
if test "x$ac_cv_func_getpwnam_r" = xyes; then :
{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for getpwnam_r with 5 args" >&5
$as_echo_n "checking for getpwnam_r with 5 args... " >&6; }
if ${tcl_cv_api_getpwnam_r_5+:} false; then :
$as_echo_n "(cached) " >&6
else
|
| ︙ | ︙ | |||
7685 7686 7687 7688 7689 7690 7691 |
$as_echo "#define HAVE_GETPWNAM_R 1" >>confdefs.h
fi
fi
| | | 7718 7719 7720 7721 7722 7723 7724 7725 7726 7727 7728 7729 7730 7731 7732 |
$as_echo "#define HAVE_GETPWNAM_R 1" >>confdefs.h
fi
fi
ac_fn_c_check_func "$LINENO" "getgrgid_r" "ac_cv_func_getgrgid_r"
if test "x$ac_cv_func_getgrgid_r" = xyes; then :
{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for getgrgid_r with 5 args" >&5
$as_echo_n "checking for getgrgid_r with 5 args... " >&6; }
if ${tcl_cv_api_getgrgid_r_5+:} false; then :
$as_echo_n "(cached) " >&6
else
|
| ︙ | ︙ | |||
7781 7782 7783 7784 7785 7786 7787 |
$as_echo "#define HAVE_GETGRGID_R 1" >>confdefs.h
fi
fi
| | | 7814 7815 7816 7817 7818 7819 7820 7821 7822 7823 7824 7825 7826 7827 7828 |
$as_echo "#define HAVE_GETGRGID_R 1" >>confdefs.h
fi
fi
ac_fn_c_check_func "$LINENO" "getgrnam_r" "ac_cv_func_getgrnam_r"
if test "x$ac_cv_func_getgrnam_r" = xyes; then :
{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for getgrnam_r with 5 args" >&5
$as_echo_n "checking for getgrnam_r with 5 args... " >&6; }
if ${tcl_cv_api_getgrnam_r_5+:} false; then :
$as_echo_n "(cached) " >&6
else
|
| ︙ | ︙ | |||
7877 7878 7879 7880 7881 7882 7883 |
$as_echo "#define HAVE_GETGRNAM_R 1" >>confdefs.h
fi
fi
| | | | | | | | | | | | | | 7910 7911 7912 7913 7914 7915 7916 7917 7918 7919 7920 7921 7922 7923 7924 7925 7926 7927 7928 7929 7930 7931 7932 7933 7934 7935 7936 7937 7938 7939 7940 7941 7942 7943 7944 7945 7946 7947 7948 7949 |
$as_echo "#define HAVE_GETGRNAM_R 1" >>confdefs.h
fi
fi
if test "`uname -s`" = "Darwin" && \
test "`uname -r | awk -F. '{print $1}'`" -gt 5; then
# Starting with Darwin 6 (Mac OSX 10.2), gethostbyX
# are actually MT-safe as they always return pointers
# from TSD instead of static storage.
$as_echo "#define HAVE_MTSAFE_GETHOSTBYNAME 1" >>confdefs.h
$as_echo "#define HAVE_MTSAFE_GETHOSTBYADDR 1" >>confdefs.h
elif test "`uname -s`" = "HP-UX" && \
test "`uname -r|sed -e 's|B\.||' -e 's|\..*$||'`" -gt 10; then
# Starting with HPUX 11.00 (we believe), gethostbyX
# are actually MT-safe as they always return pointers
# from TSD instead of static storage.
$as_echo "#define HAVE_MTSAFE_GETHOSTBYNAME 1" >>confdefs.h
$as_echo "#define HAVE_MTSAFE_GETHOSTBYADDR 1" >>confdefs.h
else
ac_fn_c_check_func "$LINENO" "gethostbyname_r" "ac_cv_func_gethostbyname_r"
if test "x$ac_cv_func_gethostbyname_r" = xyes; then :
{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for gethostbyname_r with 6 args" >&5
$as_echo_n "checking for gethostbyname_r with 6 args... " >&6; }
if ${tcl_cv_api_gethostbyname_r_6+:} false; then :
$as_echo_n "(cached) " >&6
else
|
| ︙ | ︙ | |||
8039 8040 8041 8042 8043 8044 8045 |
$as_echo "#define HAVE_GETHOSTBYNAME_R 1" >>confdefs.h
fi
fi
| | | 8072 8073 8074 8075 8076 8077 8078 8079 8080 8081 8082 8083 8084 8085 8086 |
$as_echo "#define HAVE_GETHOSTBYNAME_R 1" >>confdefs.h
fi
fi
ac_fn_c_check_func "$LINENO" "gethostbyaddr_r" "ac_cv_func_gethostbyaddr_r"
if test "x$ac_cv_func_gethostbyaddr_r" = xyes; then :
{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for gethostbyaddr_r with 7 args" >&5
$as_echo_n "checking for gethostbyaddr_r with 7 args... " >&6; }
if ${tcl_cv_api_gethostbyaddr_r_7+:} false; then :
$as_echo_n "(cached) " >&6
else
|
| ︙ | ︙ | |||
8141 8142 8143 8144 8145 8146 8147 |
$as_echo "#define HAVE_GETHOSTBYADDR_R 1" >>confdefs.h
fi
fi
| < | 8174 8175 8176 8177 8178 8179 8180 8181 8182 8183 8184 8185 8186 8187 |
$as_echo "#define HAVE_GETHOSTBYADDR_R 1" >>confdefs.h
fi
fi
fi
#---------------------------------------------------------------------------
# Check for serial port interface.
#
# termios.h is present on all POSIX systems.
# sys/ioctl.h is almost always present, though what it contains
|
| ︙ | ︙ | |||
8333 8334 8335 8336 8337 8338 8339 |
fi;;
xDarwin)
# Assume that we've got CoreFoundation present (checked elsewhere because
# of wider impact).
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: OSX" >&5
$as_echo "OSX" >&6; };;
*)
| < < < < | 8365 8366 8367 8368 8369 8370 8371 8372 8373 8374 8375 8376 8377 8378 |
fi;;
xDarwin)
# Assume that we've got CoreFoundation present (checked elsewhere because
# of wider impact).
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: OSX" >&5
$as_echo "OSX" >&6; };;
*)
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: none" >&5
$as_echo "none" >&6; };;
esac
#------------------------------------------------------------------------------
# Find out all about time handling differences.
#------------------------------------------------------------------------------
|
| ︙ | ︙ | |||
8797 8798 8799 8800 8801 8802 8803 | case " $LIBOBJS " in *" strtoul.$ac_objext "* ) ;; *) LIBOBJS="$LIBOBJS strtoul.$ac_objext" ;; esac USE_COMPAT=1 | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 8825 8826 8827 8828 8829 8830 8831 8832 8833 8834 8835 8836 8837 8838 |
case " $LIBOBJS " in
*" strtoul.$ac_objext "* ) ;;
*) LIBOBJS="$LIBOBJS strtoul.$ac_objext"
;;
esac
USE_COMPAT=1
fi
#--------------------------------------------------------------------
# Check for various typedefs and provide substitutes if
# they don't exist.
#--------------------------------------------------------------------
|
| ︙ | ︙ | |||
9557 9558 9559 9560 9561 9562 9563 |
else
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $langinfo_ok" >&5
$as_echo "$langinfo_ok" >&6; }
fi
#--------------------------------------------------------------------
| | | | 9451 9452 9453 9454 9455 9456 9457 9458 9459 9460 9461 9462 9463 9464 9465 9466 9467 9468 |
else
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $langinfo_ok" >&5
$as_echo "$langinfo_ok" >&6; }
fi
#--------------------------------------------------------------------
# Check for support of cfmakeraw, chflags and mkstemps functions
#--------------------------------------------------------------------
for ac_func in cfmakeraw chflags mkstemps
do :
as_ac_var=`$as_echo "ac_cv_func_$ac_func" | $as_tr_sh`
ac_fn_c_check_func "$LINENO" "$ac_func" "$as_ac_var"
if eval test \"x\$"$as_ac_var"\" = x"yes"; then :
cat >>confdefs.h <<_ACEOF
#define `$as_echo "HAVE_$ac_func" | $as_tr_cpp` 1
_ACEOF
|
| ︙ | ︙ | |||
10089 10090 10091 10092 10093 10094 10095 10096 10097 10098 10099 10100 10101 10102 |
AR='/usr/ccs/bin/ar'
RANLIB='/usr/ccs/bin/ranlib'
fi
fi
fi
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_ok" >&5
$as_echo "$tcl_ok" >&6; }
#--------------------------------------------------------------------
# The check below checks whether the cpuid instruction is usable.
#--------------------------------------------------------------------
{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether the cpuid instruction is usable" >&5
$as_echo_n "checking whether the cpuid instruction is usable... " >&6; }
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 9983 9984 9985 9986 9987 9988 9989 9990 9991 9992 9993 9994 9995 9996 9997 9998 9999 10000 10001 10002 10003 10004 10005 10006 10007 10008 10009 10010 10011 10012 10013 10014 10015 10016 10017 10018 10019 10020 10021 10022 10023 10024 10025 10026 10027 10028 10029 10030 10031 10032 10033 10034 10035 10036 10037 10038 10039 10040 10041 10042 10043 10044 10045 10046 10047 10048 10049 10050 10051 10052 10053 10054 10055 10056 10057 10058 10059 10060 10061 10062 10063 10064 10065 10066 10067 10068 10069 10070 10071 10072 10073 10074 10075 10076 10077 10078 10079 10080 10081 10082 10083 10084 10085 10086 10087 10088 10089 10090 10091 10092 10093 10094 10095 10096 10097 10098 10099 10100 10101 10102 10103 10104 10105 10106 10107 10108 10109 10110 10111 10112 10113 10114 10115 10116 10117 10118 10119 10120 10121 10122 10123 10124 10125 10126 10127 10128 10129 10130 10131 10132 10133 10134 10135 10136 10137 10138 10139 10140 10141 10142 10143 10144 10145 10146 10147 10148 10149 10150 10151 10152 10153 10154 10155 10156 10157 10158 10159 10160 10161 |
AR='/usr/ccs/bin/ar'
RANLIB='/usr/ccs/bin/ranlib'
fi
fi
fi
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_ok" >&5
$as_echo "$tcl_ok" >&6; }
#--------------------------------------------------------------------
# Zipfs support - Tip 430
#--------------------------------------------------------------------
# Check whether --enable-zipfs was given.
if test "${enable_zipfs+set}" = set; then :
enableval=$enable_zipfs; tcl_ok=$enableval
else
tcl_ok=yes
fi
if test "$tcl_ok" = "yes" ; then
#
# Find a native compiler
#
# Put a plausible default for CC_FOR_BUILD in Makefile.
if test -z "$CC_FOR_BUILD"; then
if test "x$cross_compiling" = "xno"; then
CC_FOR_BUILD='$(CC)'
else
{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for gcc" >&5
$as_echo_n "checking for gcc... " >&6; }
if ${ac_cv_path_cc+:} false; then :
$as_echo_n "(cached) " >&6
else
search_path=`echo ${PATH} | sed -e 's/:/ /g'`
for dir in $search_path ; do
for j in `ls -r $dir/gcc 2> /dev/null` \
`ls -r $dir/gcc 2> /dev/null` ; do
if test x"$ac_cv_path_cc" = x ; then
if test -f "$j" ; then
ac_cv_path_cc=$j
break
fi
fi
done
done
fi
fi
fi
# Also set EXEEXT_FOR_BUILD.
if test "x$cross_compiling" = "xno"; then
EXEEXT_FOR_BUILD='$(EXEEXT)'
OBJEXT_FOR_BUILD='$(OBJEXT)'
else
OBJEXT_FOR_BUILD='.no'
{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for build system executable suffix" >&5
$as_echo_n "checking for build system executable suffix... " >&6; }
if ${bfd_cv_build_exeext+:} false; then :
$as_echo_n "(cached) " >&6
else
rm -f conftest*
echo 'int main () { return 0; }' > conftest.c
bfd_cv_build_exeext=
${CC_FOR_BUILD} -o conftest conftest.c 1>&5 2>&5
for file in conftest.*; do
case $file in
*.c | *.o | *.obj | *.ilk | *.pdb) ;;
*) bfd_cv_build_exeext=`echo $file | sed -e s/conftest//` ;;
esac
done
rm -f conftest*
test x"${bfd_cv_build_exeext}" = x && bfd_cv_build_exeext=no
fi
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $bfd_cv_build_exeext" >&5
$as_echo "$bfd_cv_build_exeext" >&6; }
EXEEXT_FOR_BUILD=""
test x"${bfd_cv_build_exeext}" != xno && EXEEXT_FOR_BUILD=${bfd_cv_build_exeext}
fi
#
# Find a native zip implementation
#
ZIP_PROG=""
ZIP_PROG_OPTIONS=""
ZIP_PROG_VFSSEARCH=""
ZIP_INSTALL_OBJS=""
{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for zip" >&5
$as_echo_n "checking for zip... " >&6; }
if ${ac_cv_path_zip+:} false; then :
$as_echo_n "(cached) " >&6
else
search_path=`echo ${PATH} | sed -e 's/:/ /g'`
for dir in $search_path ; do
for j in `ls -r $dir/zip 2> /dev/null` \
`ls -r $dir/zip 2> /dev/null` ; do
if test x"$ac_cv_path_zip" = x ; then
if test -f "$j" ; then
ac_cv_path_zip=$j
break
fi
fi
done
done
fi
if test -f "$ac_cv_path_zip" ; then
ZIP_PROG="$ac_cv_path_zip"
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ZIP_PROG" >&5
$as_echo "$ZIP_PROG" >&6; }
ZIP_PROG_OPTIONS="-rq"
ZIP_PROG_VFSSEARCH="*"
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: Found INFO Zip in environment" >&5
$as_echo "Found INFO Zip in environment" >&6; }
# Use standard arguments for zip
else
# It is not an error if an installed version of Zip can't be located.
# We can use the locally distributed minizip instead
ZIP_PROG="./minizip${EXEEXT_FOR_BUILD}"
ZIP_PROG_OPTIONS="-o -r"
ZIP_PROG_VFSSEARCH="*"
ZIP_INSTALL_OBJS="minizip${EXEEXT_FOR_BUILD}"
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: No zip found on PATH. Building minizip" >&5
$as_echo "No zip found on PATH. Building minizip" >&6; }
fi
ZIPFS_BUILD=1
TCL_ZIP_FILE=libtcl_${TCL_MAJOR_VERSION}_${TCL_MINOR_VERSION}_${TCL_PATCH_LEVEL}.zip
else
ZIPFS_BUILD=0
TCL_ZIP_FILE=
fi
# Do checking message here to not mess up interleaved configure output
{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for building with zipfs" >&5
$as_echo_n "checking for building with zipfs... " >&6; }
if test "${ZIPFS_BUILD}" = 1; then
if test "${SHARED_BUILD}" = 0; then
ZIPFS_BUILD=2;
$as_echo "#define ZIPFS_BUILD 2" >>confdefs.h
INSTALL_LIBRARIES=install-libraries-zipfs-static
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5
$as_echo "yes" >&6; }
else
$as_echo "#define ZIPFS_BUILD 1" >>confdefs.h
\
INSTALL_LIBRARIES=install-libraries-zipfs-shared
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5
$as_echo "yes" >&6; }
fi
else
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
$as_echo "no" >&6; }
INSTALL_LIBRARIES=install-libraries
INSTALL_MSGS=install-msgs
fi
#--------------------------------------------------------------------
# The check below checks whether the cpuid instruction is usable.
#--------------------------------------------------------------------
{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether the cpuid instruction is usable" >&5
$as_echo_n "checking whether the cpuid instruction is usable... " >&6; }
|
| ︙ | ︙ | |||
10315 10316 10317 10318 10319 10320 10321 10322 10323 10324 10325 10326 10327 10328 |
eval "TCL_INCLUDE_SPEC=\"-I${includedir}\""
#------------------------------------------------------------------------
# tclConfig.sh refers to this by a different name
#------------------------------------------------------------------------
TCL_SHARED_BUILD=${SHARED_BUILD}
| > | 10374 10375 10376 10377 10378 10379 10380 10381 10382 10383 10384 10385 10386 10387 10388 |
eval "TCL_INCLUDE_SPEC=\"-I${includedir}\""
#------------------------------------------------------------------------
# tclConfig.sh refers to this by a different name
#------------------------------------------------------------------------
TCL_SHARED_BUILD=${SHARED_BUILD}
|
| ︙ | ︙ |
Changes to unix/configure.ac.
| ︙ | ︙ | |||
81 82 83 84 85 86 87 88 89 90 91 92 93 94 |
# the AC_PROG_CC macro from adding "-g -O2".
if test "${CFLAGS+set}" != "set" ; then
CFLAGS=""
fi
AC_PROG_CC
AC_C_INLINE
#--------------------------------------------------------------------
# Supply substitutes for missing POSIX header files. Special notes:
# - stdlib.h doesn't define strtol, strtoul, or
# strtod insome versions of SunOS
# - some versions of string.h don't declare procedures such
# as strstr
| > | 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 |
# the AC_PROG_CC macro from adding "-g -O2".
if test "${CFLAGS+set}" != "set" ; then
CFLAGS=""
fi
AC_PROG_CC
AC_C_INLINE
#--------------------------------------------------------------------
# Supply substitutes for missing POSIX header files. Special notes:
# - stdlib.h doesn't define strtol, strtoul, or
# strtod insome versions of SunOS
# - some versions of string.h don't declare procedures such
# as strstr
|
| ︙ | ︙ | |||
115 116 117 118 119 120 121 |
AC_TRY_COMPILE(,, tcl_cv_cc_pipe=yes, tcl_cv_cc_pipe=no)
CFLAGS=$hold_cflags])
if test $tcl_cv_cc_pipe = yes; then
CFLAGS="$CFLAGS -pipe"
fi
fi
| < < < < < < | 116 117 118 119 120 121 122 123 124 125 126 127 128 129 |
AC_TRY_COMPILE(,, tcl_cv_cc_pipe=yes, tcl_cv_cc_pipe=no)
CFLAGS=$hold_cflags])
if test $tcl_cv_cc_pipe = yes; then
CFLAGS="$CFLAGS -pipe"
fi
fi
#------------------------------------------------------------------------
# Embedded configuration information, encoding to use for the values, TIP #59
#------------------------------------------------------------------------
SC_TCL_CFG_ENCODING
#--------------------------------------------------------------------
|
| ︙ | ︙ | |||
211 212 213 214 215 216 217 | AC_REPLACE_FUNCS(mkstemp opendir strtol waitpid) AC_CHECK_FUNC(strerror, , [AC_DEFINE(NO_STRERROR, 1, [Do we have strerror()])]) AC_CHECK_FUNC(getwd, , [AC_DEFINE(NO_GETWD, 1, [Do we have getwd()])]) AC_CHECK_FUNC(wait3, , [AC_DEFINE(NO_WAIT3, 1, [Do we have wait3()])]) AC_CHECK_FUNC(uname, , [AC_DEFINE(NO_UNAME, 1, [Do we have uname()])]) | | < | | | | | | | | | | | | | | | | | | | | | | | | | < | 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 |
AC_REPLACE_FUNCS(mkstemp opendir strtol waitpid)
AC_CHECK_FUNC(strerror, , [AC_DEFINE(NO_STRERROR, 1, [Do we have strerror()])])
AC_CHECK_FUNC(getwd, , [AC_DEFINE(NO_GETWD, 1, [Do we have getwd()])])
AC_CHECK_FUNC(wait3, , [AC_DEFINE(NO_WAIT3, 1, [Do we have wait3()])])
AC_CHECK_FUNC(uname, , [AC_DEFINE(NO_UNAME, 1, [Do we have uname()])])
if test "`uname -s`" = "Darwin" && \
test "`uname -r | awk -F. '{print [$]1}'`" -lt 7; then
# prior to Darwin 7, realpath is not threadsafe, so don't
# use it when threads are enabled, c.f. bug # 711232
ac_cv_func_realpath=no
fi
AC_CHECK_FUNC(realpath, , [AC_DEFINE(NO_REALPATH, 1, [Do we have realpath()])])
SC_TCL_IPV6
#--------------------------------------------------------------------
# Look for thread-safe variants of some library functions.
#--------------------------------------------------------------------
SC_TCL_GETPWUID_R
SC_TCL_GETPWNAM_R
SC_TCL_GETGRGID_R
SC_TCL_GETGRNAM_R
if test "`uname -s`" = "Darwin" && \
test "`uname -r | awk -F. '{print [$]1}'`" -gt 5; then
# Starting with Darwin 6 (Mac OSX 10.2), gethostbyX
# are actually MT-safe as they always return pointers
# from TSD instead of static storage.
AC_DEFINE(HAVE_MTSAFE_GETHOSTBYNAME, 1,
[Do we have MT-safe gethostbyname() ?])
AC_DEFINE(HAVE_MTSAFE_GETHOSTBYADDR, 1,
[Do we have MT-safe gethostbyaddr() ?])
elif test "`uname -s`" = "HP-UX" && \
test "`uname -r|sed -e 's|B\.||' -e 's|\..*$||'`" -gt 10; then
# Starting with HPUX 11.00 (we believe), gethostbyX
# are actually MT-safe as they always return pointers
# from TSD instead of static storage.
AC_DEFINE(HAVE_MTSAFE_GETHOSTBYNAME, 1,
[Do we have MT-safe gethostbyname() ?])
AC_DEFINE(HAVE_MTSAFE_GETHOSTBYADDR, 1,
[Do we have MT-safe gethostbyaddr() ?])
else
SC_TCL_GETHOSTBYNAME_R
SC_TCL_GETHOSTBYADDR_R
fi
#---------------------------------------------------------------------------
# Check for serial port interface.
#
# termios.h is present on all POSIX systems.
# sys/ioctl.h is almost always present, though what it contains
|
| ︙ | ︙ | |||
323 324 325 326 327 328 329 | AS_IF([test $tcl_kqueue_headers = xyyy], [ AC_DEFINE(NOTIFIER_KQUEUE, [1], [Is kqueue(2) supported?])]);; xDarwin) # Assume that we've got CoreFoundation present (checked elsewhere because # of wider impact). AC_MSG_RESULT([OSX]);; *) | < | 316 317 318 319 320 321 322 323 324 325 326 327 328 329 | AS_IF([test $tcl_kqueue_headers = xyyy], [ AC_DEFINE(NOTIFIER_KQUEUE, [1], [Is kqueue(2) supported?])]);; xDarwin) # Assume that we've got CoreFoundation present (checked elsewhere because # of wider impact). AC_MSG_RESULT([OSX]);; *) AC_MSG_RESULT([none]);; esac #------------------------------------------------------------------------------ # Find out all about time handling differences. #------------------------------------------------------------------------------ |
| ︙ | ︙ | |||
384 385 386 387 388 389 390 |
SC_TCL_CHECK_BROKEN_FUNC(strtoul, [
extern int strtoul();
char *term, *string = "0";
exit(strtoul(string,&term,0) != 0 || term != string+1);
])
| < < < < < < < < < < < < < < < < < < < < | 376 377 378 379 380 381 382 383 384 385 386 387 388 389 |
SC_TCL_CHECK_BROKEN_FUNC(strtoul, [
extern int strtoul();
char *term, *string = "0";
exit(strtoul(string,&term,0) != 0 || term != string+1);
])
#--------------------------------------------------------------------
# Check for various typedefs and provide substitutes if
# they don't exist.
#--------------------------------------------------------------------
AC_TYPE_MODE_T
AC_TYPE_PID_T
|
| ︙ | ︙ | |||
577 578 579 580 581 582 583 | #-------------------------------------------------------------------- # Check for support of nl_langinfo function #-------------------------------------------------------------------- SC_ENABLE_LANGINFO #-------------------------------------------------------------------- | | | | 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 |
#--------------------------------------------------------------------
# Check for support of nl_langinfo function
#--------------------------------------------------------------------
SC_ENABLE_LANGINFO
#--------------------------------------------------------------------
# Check for support of cfmakeraw, chflags and mkstemps functions
#--------------------------------------------------------------------
AC_CHECK_FUNCS(cfmakeraw chflags mkstemps)
#--------------------------------------------------------------------
# Check for support of isnan() function or macro
#--------------------------------------------------------------------
AC_CACHE_CHECK([isnan], tcl_cv_isnan, [
AC_TRY_LINK([#include <math.h>], [
|
| ︙ | ︙ | |||
785 786 787 788 789 790 791 792 793 794 795 796 797 798 |
# tclDTrace.o and the combined object file above.
AR='/usr/ccs/bin/ar'
RANLIB='/usr/ccs/bin/ranlib'
fi
fi
fi
AC_MSG_RESULT([$tcl_ok])
#--------------------------------------------------------------------
# The check below checks whether the cpuid instruction is usable.
#--------------------------------------------------------------------
AC_CACHE_CHECK([whether the cpuid instruction is usable], tcl_cv_cpuid, [
AC_TRY_LINK(, [
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 |
# tclDTrace.o and the combined object file above.
AR='/usr/ccs/bin/ar'
RANLIB='/usr/ccs/bin/ranlib'
fi
fi
fi
AC_MSG_RESULT([$tcl_ok])
#--------------------------------------------------------------------
# Zipfs support - Tip 430
#--------------------------------------------------------------------
AC_ARG_ENABLE(zipfs,
AC_HELP_STRING([--enable-zipfs],
[build with Zipfs support (default: on)]),
[tcl_ok=$enableval], [tcl_ok=yes])
if test "$tcl_ok" = "yes" ; then
#
# Find a native compiler
#
AX_CC_FOR_BUILD
#
# Find a native zip implementation
#
SC_ZIPFS_SUPPORT
ZIPFS_BUILD=1
TCL_ZIP_FILE=libtcl_${TCL_MAJOR_VERSION}_${TCL_MINOR_VERSION}_${TCL_PATCH_LEVEL}.zip
else
ZIPFS_BUILD=0
TCL_ZIP_FILE=
fi
# Do checking message here to not mess up interleaved configure output
AC_MSG_CHECKING([for building with zipfs])
if test "${ZIPFS_BUILD}" = 1; then
if test "${SHARED_BUILD}" = 0; then
ZIPFS_BUILD=2;
AC_DEFINE(ZIPFS_BUILD, 2, [Are we building with zipfs enabled?])
INSTALL_LIBRARIES=install-libraries-zipfs-static
AC_MSG_RESULT([yes])
else
AC_DEFINE(ZIPFS_BUILD, 1, [Are we building with zipfs enabled?])\
INSTALL_LIBRARIES=install-libraries-zipfs-shared
AC_MSG_RESULT([yes])
fi
else
AC_MSG_RESULT([no])
INSTALL_LIBRARIES=install-libraries
INSTALL_MSGS=install-msgs
fi
AC_SUBST(ZIPFS_BUILD)
AC_SUBST(TCL_ZIP_FILE)
AC_SUBST(INSTALL_LIBRARIES)
AC_SUBST(INSTALL_MSGS)
#--------------------------------------------------------------------
# The check below checks whether the cpuid instruction is usable.
#--------------------------------------------------------------------
AC_CACHE_CHECK([whether the cpuid instruction is usable], tcl_cv_cpuid, [
AC_TRY_LINK(, [
|
| ︙ | ︙ | |||
956 957 958 959 960 961 962 963 964 965 966 967 968 969 | AC_SUBST(TCL_VERSION) AC_SUBST(TCL_MAJOR_VERSION) AC_SUBST(TCL_MINOR_VERSION) AC_SUBST(TCL_PATCH_LEVEL) AC_SUBST(TCL_YEAR) AC_SUBST(PKG_CFG_ARGS) AC_SUBST(TCL_LIB_FILE) AC_SUBST(TCL_LIB_FLAG) AC_SUBST(TCL_LIB_SPEC) AC_SUBST(TCL_STUB_LIB_FILE) AC_SUBST(TCL_STUB_LIB_FLAG) AC_SUBST(TCL_STUB_LIB_SPEC) AC_SUBST(TCL_STUB_LIB_PATH) | > | 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 | AC_SUBST(TCL_VERSION) AC_SUBST(TCL_MAJOR_VERSION) AC_SUBST(TCL_MINOR_VERSION) AC_SUBST(TCL_PATCH_LEVEL) AC_SUBST(TCL_YEAR) AC_SUBST(PKG_CFG_ARGS) AC_SUBST(TCL_ZIP_FILE) AC_SUBST(TCL_LIB_FILE) AC_SUBST(TCL_LIB_FLAG) AC_SUBST(TCL_LIB_SPEC) AC_SUBST(TCL_STUB_LIB_FILE) AC_SUBST(TCL_STUB_LIB_FLAG) AC_SUBST(TCL_STUB_LIB_SPEC) AC_SUBST(TCL_STUB_LIB_PATH) |
| ︙ | ︙ |
Changes to unix/dltest/Makefile.in.
| ︙ | ︙ | |||
13 14 15 16 17 18 19 | DLTEST_SUFFIX = @DLTEST_SUFFIX@ SRC_DIR = @TCL_SRC_DIR@/unix/dltest BUILD_DIR = @builddir@ TCL_VERSION= @TCL_VERSION@ CFLAGS_DEBUG = @CFLAGS_DEBUG@ CFLAGS_OPTIMIZE = @CFLAGS_OPTIMIZE@ | | | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
DLTEST_SUFFIX = @DLTEST_SUFFIX@
SRC_DIR = @TCL_SRC_DIR@/unix/dltest
BUILD_DIR = @builddir@
TCL_VERSION= @TCL_VERSION@
CFLAGS_DEBUG = @CFLAGS_DEBUG@
CFLAGS_OPTIMIZE = @CFLAGS_OPTIMIZE@
CFLAGS = @CFLAGS_DEFAULT@ @CFLAGS@ -DTCL_NO_DEPRECATED=1
LDFLAGS_DEBUG = @LDFLAGS_DEBUG@
LDFLAGS_OPTIMIZE = @LDFLAGS_OPTIMIZE@
LDFLAGS = @LDFLAGS_DEFAULT@ @LDFLAGS@
CC_SWITCHES = $(CFLAGS) -I${SRC_DIR}/../../generic -DTCL_MEM_DEBUG \
${SHLIB_CFLAGS} -DUSE_TCL_STUBS ${AC_FLAGS}
|
| ︙ | ︙ |
Changes to unix/dltest/pkga.c.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | /* * pkga.c -- * * This file contains a simple Tcl package "pkga" that is intended for * testing the Tcl dynamic loading facilities. * * 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 "tcl.h" /* * Prototypes for procedures defined later in this file: */ static int Pkga_EqObjCmd(ClientData clientData, | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | /* * pkga.c -- * * This file contains a simple Tcl package "pkga" that is intended for * testing the Tcl dynamic loading facilities. * * 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. */ #undef STATIC_BUILD #include "tcl.h" /* * Prototypes for procedures defined later in this file: */ static int Pkga_EqObjCmd(ClientData clientData, |
| ︙ | ︙ | |||
58 59 60 61 62 63 64 |
str1 = Tcl_GetStringFromObj(objv[1], &len1);
str2 = Tcl_GetStringFromObj(objv[2], &len2);
if (len1 == len2) {
result = (Tcl_UtfNcmp(str1, str2, len1) == 0);
} else {
result = 0;
}
| | | 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 |
str1 = Tcl_GetStringFromObj(objv[1], &len1);
str2 = Tcl_GetStringFromObj(objv[2], &len2);
if (len1 == len2) {
result = (Tcl_UtfNcmp(str1, str2, len1) == 0);
} else {
result = 0;
}
Tcl_SetObjResult(interp, Tcl_NewIntObj(result));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Pkga_QuoteObjCmd --
|
| ︙ | ︙ | |||
121 122 123 124 125 126 127 |
* made available. */
{
int code;
if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) {
return TCL_ERROR;
}
| | | 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 |
* made available. */
{
int code;
if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) {
return TCL_ERROR;
}
code = Tcl_PkgProvide(interp, "Pkga", "1.0");
if (code != TCL_OK) {
return code;
}
Tcl_CreateObjCommand(interp, "pkga_eq", Pkga_EqObjCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "pkga_quote", Pkga_QuoteObjCmd, NULL,
NULL);
return TCL_OK;
}
|
Changes to unix/dltest/pkgb.c.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | /* * pkgb.c -- * * This file contains a simple Tcl package "pkgb" that is intended for * testing the Tcl dynamic loading facilities. It can be used in both * safe and unsafe interpreters. * * Copyright (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 "tcl.h" /* * Prototypes for procedures defined later in this file: */ static int Pkgb_SubObjCmd(ClientData clientData, | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | /* * pkgb.c -- * * This file contains a simple Tcl package "pkgb" that is intended for * testing the Tcl dynamic loading facilities. It can be used in both * safe and unsafe interpreters. * * Copyright (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. */ #undef STATIC_BUILD #include "tcl.h" /* * Prototypes for procedures defined later in this file: */ static int Pkgb_SubObjCmd(ClientData clientData, |
| ︙ | ︙ | |||
61 62 63 64 65 66 67 |
if ((Tcl_GetIntFromObj(interp, objv[1], &first) != TCL_OK)
|| (Tcl_GetIntFromObj(interp, objv[2], &second) != TCL_OK)) {
char buf[TCL_INTEGER_SPACE];
sprintf(buf, "%d", Tcl_GetErrorLine(interp));
Tcl_AppendResult(interp, " in line: ", buf, NULL);
return TCL_ERROR;
}
| | | 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 |
if ((Tcl_GetIntFromObj(interp, objv[1], &first) != TCL_OK)
|| (Tcl_GetIntFromObj(interp, objv[2], &second) != TCL_OK)) {
char buf[TCL_INTEGER_SPACE];
sprintf(buf, "%d", Tcl_GetErrorLine(interp));
Tcl_AppendResult(interp, " in line: ", buf, NULL);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewIntObj(first - second));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Pkgb_UnsafeObjCmd --
|
| ︙ | ︙ |
Changes to unix/dltest/pkgc.c.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | /* * pkgc.c -- * * This file contains a simple Tcl package "pkgc" that is intended for * testing the Tcl dynamic loading facilities. It can be used in both * safe and unsafe interpreters. * * Copyright (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 "tcl.h" /* * Prototypes for procedures defined later in this file: */ static int Pkgc_SubObjCmd(ClientData clientData, | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | /* * pkgc.c -- * * This file contains a simple Tcl package "pkgc" that is intended for * testing the Tcl dynamic loading facilities. It can be used in both * safe and unsafe interpreters. * * Copyright (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. */ #undef STATIC_BUILD #include "tcl.h" /* * Prototypes for procedures defined later in this file: */ static int Pkgc_SubObjCmd(ClientData clientData, |
| ︙ | ︙ | |||
52 53 54 55 56 57 58 |
Tcl_WrongNumArgs(interp, 1, objv, "num num");
return TCL_ERROR;
}
if ((Tcl_GetIntFromObj(interp, objv[1], &first) != TCL_OK)
|| (Tcl_GetIntFromObj(interp, objv[2], &second) != TCL_OK)) {
return TCL_ERROR;
}
| | | 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 |
Tcl_WrongNumArgs(interp, 1, objv, "num num");
return TCL_ERROR;
}
if ((Tcl_GetIntFromObj(interp, objv[1], &first) != TCL_OK)
|| (Tcl_GetIntFromObj(interp, objv[2], &second) != TCL_OK)) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewIntObj(first - second));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Pkgc_UnsafeCmd --
|
| ︙ | ︙ | |||
111 112 113 114 115 116 117 |
* made available. */
{
int code;
if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) {
return TCL_ERROR;
}
| | | 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 |
* made available. */
{
int code;
if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) {
return TCL_ERROR;
}
code = Tcl_PkgProvide(interp, "Pkgc", "1.7.2");
if (code != TCL_OK) {
return code;
}
Tcl_CreateObjCommand(interp, "pkgc_sub", Pkgc_SubObjCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "pkgc_unsafe", Pkgc_UnsafeObjCmd, NULL,
NULL);
return TCL_OK;
|
| ︙ | ︙ | |||
148 149 150 151 152 153 154 |
* made available. */
{
int code;
if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) {
return TCL_ERROR;
}
| | | 149 150 151 152 153 154 155 156 157 158 159 160 161 162 |
* made available. */
{
int code;
if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) {
return TCL_ERROR;
}
code = Tcl_PkgProvide(interp, "Pkgc", "1.7.2");
if (code != TCL_OK) {
return code;
}
Tcl_CreateObjCommand(interp, "pkgc_sub", Pkgc_SubObjCmd, NULL, NULL);
return TCL_OK;
}
|
Changes to unix/dltest/pkgd.c.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | /* * pkgd.c -- * * This file contains a simple Tcl package "pkgd" that is intended for * testing the Tcl dynamic loading facilities. It can be used in both * safe and unsafe interpreters. * * Copyright (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 "tcl.h" /* * Prototypes for procedures defined later in this file: */ static int Pkgd_SubObjCmd(ClientData clientData, | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | /* * pkgd.c -- * * This file contains a simple Tcl package "pkgd" that is intended for * testing the Tcl dynamic loading facilities. It can be used in both * safe and unsafe interpreters. * * Copyright (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. */ #undef STATIC_BUILD #include "tcl.h" /* * Prototypes for procedures defined later in this file: */ static int Pkgd_SubObjCmd(ClientData clientData, |
| ︙ | ︙ | |||
52 53 54 55 56 57 58 |
Tcl_WrongNumArgs(interp, 1, objv, "num num");
return TCL_ERROR;
}
if ((Tcl_GetIntFromObj(interp, objv[1], &first) != TCL_OK)
|| (Tcl_GetIntFromObj(interp, objv[2], &second) != TCL_OK)) {
return TCL_ERROR;
}
| | | 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 |
Tcl_WrongNumArgs(interp, 1, objv, "num num");
return TCL_ERROR;
}
if ((Tcl_GetIntFromObj(interp, objv[1], &first) != TCL_OK)
|| (Tcl_GetIntFromObj(interp, objv[2], &second) != TCL_OK)) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewIntObj(first - second));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Pkgd_UnsafeCmd --
|
| ︙ | ︙ | |||
111 112 113 114 115 116 117 |
* made available. */
{
int code;
if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) {
return TCL_ERROR;
}
| | | 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 |
* made available. */
{
int code;
if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) {
return TCL_ERROR;
}
code = Tcl_PkgProvide(interp, "Pkgd", "7.3");
if (code != TCL_OK) {
return code;
}
Tcl_CreateObjCommand(interp, "pkgd_sub", Pkgd_SubObjCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "pkgd_unsafe", Pkgd_UnsafeObjCmd, NULL,
NULL);
return TCL_OK;
|
| ︙ | ︙ | |||
148 149 150 151 152 153 154 |
* made available. */
{
int code;
if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) {
return TCL_ERROR;
}
| | | 149 150 151 152 153 154 155 156 157 158 159 160 161 162 |
* made available. */
{
int code;
if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) {
return TCL_ERROR;
}
code = Tcl_PkgProvide(interp, "Pkgd", "7.3");
if (code != TCL_OK) {
return code;
}
Tcl_CreateObjCommand(interp, "pkgd_sub", Pkgd_SubObjCmd, NULL, NULL);
return TCL_OK;
}
|
Changes to unix/dltest/pkge.c.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 | /* * pkge.c -- * * This file contains a simple Tcl package "pkge" that is intended for * testing the Tcl dynamic loading facilities. Its Init procedure returns * an error in order to test how this is handled. * * Copyright (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 "tcl.h" | > < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | /* * pkge.c -- * * This file contains a simple Tcl package "pkge" that is intended for * testing the Tcl dynamic loading facilities. Its Init procedure returns * an error in order to test how this is handled. * * Copyright (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. */ #undef STATIC_BUILD #include "tcl.h" /* *---------------------------------------------------------------------- * * Pkge_Init -- * * This is a package initialization procedure, which is called by Tcl |
| ︙ | ︙ |
Changes to unix/dltest/pkgooa.c.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | /* * pkgooa.c -- * * This file contains a simple Tcl package "pkgooa" that is intended for * testing the Tcl dynamic loading facilities. * * 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 "tclOO.h" #include <string.h> /* *---------------------------------------------------------------------- * * Pkgooa_StubsOKObjCmd -- | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | /* * pkgooa.c -- * * This file contains a simple Tcl package "pkgooa" that is intended for * testing the Tcl dynamic loading facilities. * * 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. */ #undef STATIC_BUILD #include "tclOO.h" #include <string.h> /* *---------------------------------------------------------------------- * * Pkgooa_StubsOKObjCmd -- |
| ︙ | ︙ |
Changes to unix/dltest/pkgua.c.
| ︙ | ︙ | |||
134 135 136 137 138 139 140 |
str1 = Tcl_GetStringFromObj(objv[1], &len1);
str2 = Tcl_GetStringFromObj(objv[2], &len2);
if (len1 == len2) {
result = (Tcl_UtfNcmp(str1, str2, len1) == 0);
} else {
result = 0;
}
| | | 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 |
str1 = Tcl_GetStringFromObj(objv[1], &len1);
str2 = Tcl_GetStringFromObj(objv[2], &len2);
if (len1 == len2) {
result = (Tcl_UtfNcmp(str1, str2, len1) == 0);
} else {
result = 0;
}
Tcl_SetObjResult(interp, Tcl_NewIntObj(result));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* PkguaQuoteObjCmd --
|
| ︙ | ︙ | |||
206 207 208 209 210 211 212 |
/*
* Initialise our Hash table, where we store the registered command tokens
* for each interpreter.
*/
PkguaInitTokensHashTable();
| | | 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 |
/*
* Initialise our Hash table, where we store the registered command tokens
* for each interpreter.
*/
PkguaInitTokensHashTable();
code = Tcl_PkgProvide(interp, "Pkgua", "1.0");
if (code != TCL_OK) {
return code;
}
Tcl_SetVar2(interp, "::pkgua_loaded", NULL, ".", TCL_APPEND_VALUE);
cmdTokens = PkguaInterpToTokens(interp);
|
| ︙ | ︙ |
Changes to unix/installManPage.
| ︙ | ︙ | |||
56 57 58 59 60 61 62 | # A sed script to parse the alternative names out of a man page. # # Backslashes are trippled in the sed script, because it is in # backticks which doesn't pass backslashes literally. # Names=`sed -n ' # Look for a line that starts with .SH NAME | | | | > > | | > | | > > | | > > > > > | | | > > > > > > | < | 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 |
# A sed script to parse the alternative names out of a man page.
#
# Backslashes are trippled in the sed script, because it is in
# backticks which doesn't pass backslashes literally.
#
Names=`sed -n '
# Look for a line that starts with .SH NAME
/^\.SH NAME/,/^\./{
/^\./!{
# Remove all commas...
s/,//g
# ... and backslash-escaped spaces.
s/\\\ //g
/\\\-.*/{
# Delete from \- to the end of line
s/ \\\-.*//
h
s/.*/./
x
}
# Convert all non-space non-alphanum sequences
# to single underscores.
s/[^ A-Za-z0-9][^ A-Za-z0-9]*/_/g
p
g
/^\./{
q
}
}
}' $ManPage`
if test -z "$Names" ; then
echo "warning: no target names found in $ManPage"
fi
########################################################################
|
| ︙ | ︙ |
Changes to unix/tcl.m4.
| ︙ | ︙ | |||
87 88 89 90 91 92 93 |
fi
# check in a few common install locations
if test x"${ac_cv_c_tclconfig}" = x ; then
for i in `ls -d ${libdir} 2>/dev/null` \
`ls -d ${exec_prefix}/lib 2>/dev/null` \
`ls -d ${prefix}/lib 2>/dev/null` \
| < > > > | 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 |
fi
# check in a few common install locations
if test x"${ac_cv_c_tclconfig}" = x ; then
for i in `ls -d ${libdir} 2>/dev/null` \
`ls -d ${exec_prefix}/lib 2>/dev/null` \
`ls -d ${prefix}/lib 2>/dev/null` \
`ls -d /usr/local/lib 2>/dev/null` \
`ls -d /usr/contrib/lib 2>/dev/null` \
`ls -d /usr/pkg/lib 2>/dev/null` \
`ls -d /usr/lib 2>/dev/null` \
`ls -d /usr/lib64 2>/dev/null` \
`ls -d /usr/local/lib/tcl9.0 2>/dev/null` \
`ls -d /usr/local/lib/tcl/tcl9.0 2>/dev/null` \
; do
if test -f "$i/tclConfig.sh" ; then
ac_cv_c_tclconfig="`(cd $i; pwd)`"
break
fi
done
fi
|
| ︙ | ︙ | |||
220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 |
# check in a few common install locations
if test x"${ac_cv_c_tkconfig}" = x ; then
for i in `ls -d ${libdir} 2>/dev/null` \
`ls -d ${exec_prefix}/lib 2>/dev/null` \
`ls -d ${prefix}/lib 2>/dev/null` \
`ls -d /usr/local/lib 2>/dev/null` \
`ls -d /usr/contrib/lib 2>/dev/null` \
`ls -d /usr/lib 2>/dev/null` \
`ls -d /usr/lib64 2>/dev/null` \
; do
if test -f "$i/tkConfig.sh" ; then
ac_cv_c_tkconfig="`(cd $i; pwd)`"
break
fi
done
fi
| > > > | 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 |
# check in a few common install locations
if test x"${ac_cv_c_tkconfig}" = x ; then
for i in `ls -d ${libdir} 2>/dev/null` \
`ls -d ${exec_prefix}/lib 2>/dev/null` \
`ls -d ${prefix}/lib 2>/dev/null` \
`ls -d /usr/local/lib 2>/dev/null` \
`ls -d /usr/contrib/lib 2>/dev/null` \
`ls -d /usr/pkg/lib 2>/dev/null` \
`ls -d /usr/lib 2>/dev/null` \
`ls -d /usr/lib64 2>/dev/null` \
`ls -d /usr/local/lib/tk9.0 2>/dev/null` \
`ls -d /usr/local/lib/tcl/tk9.0 2>/dev/null` \
; do
if test -f "$i/tkConfig.sh" ; then
ac_cv_c_tkconfig="`(cd $i; pwd)`"
break
fi
done
fi
|
| ︙ | ︙ | |||
538 539 540 541 542 543 544 545 546 547 548 549 550 551 |
AC_MSG_RESULT([shared])
SHARED_BUILD=1
else
AC_MSG_RESULT([static])
SHARED_BUILD=0
AC_DEFINE(STATIC_BUILD, 1, [Is this a static build?])
fi
])
#------------------------------------------------------------------------
# SC_ENABLE_FRAMEWORK --
#
# Allows the building of shared libraries into frameworks
#
| > | 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 |
AC_MSG_RESULT([shared])
SHARED_BUILD=1
else
AC_MSG_RESULT([static])
SHARED_BUILD=0
AC_DEFINE(STATIC_BUILD, 1, [Is this a static build?])
fi
AC_SUBST(SHARED_BUILD)
])
#------------------------------------------------------------------------
# SC_ENABLE_FRAMEWORK --
#
# Allows the building of shared libraries into frameworks
#
|
| ︙ | ︙ | |||
588 589 590 591 592 593 594 |
AC_MSG_RESULT([static library])
fi
FRAMEWORK_BUILD=0
fi
fi
])
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 594 595 596 597 598 599 600 601 602 603 604 605 606 607 |
AC_MSG_RESULT([static library])
fi
FRAMEWORK_BUILD=0
fi
fi
])
#------------------------------------------------------------------------
# SC_ENABLE_SYMBOLS --
#
# Specify if debugging symbols should be used.
# Memory (TCL_MEM_DEBUG) and compile (TCL_COMPILE_DEBUG) debugging
# can also be enabled.
#
|
| ︙ | ︙ | |||
1083 1084 1085 1086 1087 1088 1089 |
UNSHARED_LIB_SUFFIX=""
TCL_TRIM_DOTS='`echo ${VERSION} | tr -d .`'
ECHO_VERSION='`echo ${VERSION}`'
TCL_LIB_VERSIONS_OK=ok
CFLAGS_DEBUG=-g
AS_IF([test "$GCC" = yes], [
CFLAGS_OPTIMIZE=-O2
| | | | 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 |
UNSHARED_LIB_SUFFIX=""
TCL_TRIM_DOTS='`echo ${VERSION} | tr -d .`'
ECHO_VERSION='`echo ${VERSION}`'
TCL_LIB_VERSIONS_OK=ok
CFLAGS_DEBUG=-g
AS_IF([test "$GCC" = yes], [
CFLAGS_OPTIMIZE=-O2
CFLAGS_WARNING="-Wall -Wwrite-strings -Wsign-compare -Wdeclaration-after-statement -Wpointer-arith"
], [
CFLAGS_OPTIMIZE=-O
CFLAGS_WARNING=""
])
AC_CHECK_TOOL(AR, ar)
STLIB_LD='${AR} cr'
LD_LIBRARY_PATH_VAR="LD_LIBRARY_PATH"
PLAT_OBJS=""
PLAT_SRCS=""
LDAIX_SRC=""
AS_IF([test "x${SHLIB_VERSION}" = x], [SHLIB_VERSION="1.0"])
case $system in
AIX-*)
AS_IF([test "$GCC" != "yes"], [
# AIX requires the _r compiler when gcc isn't being used
case "${CC}" in
*_r|*_r\ *)
# ok ...
;;
*)
# Make sure only first arg gets _r
|
| ︙ | ︙ | |||
1192 1193 1194 1195 1196 1197 1198 | SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" LDFLAGS="$LDFLAGS -export-dynamic" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; | | | 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 |
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS="-ldl"
LDFLAGS="$LDFLAGS -export-dynamic"
CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
;;
CYGWIN_*)
SHLIB_CFLAGS=""
SHLIB_LD='${CC} -shared'
SHLIB_SUFFIX=".dll"
DL_OBJS="tclLoadDl.o"
PLAT_OBJS='${CYGWIN_OBJS}'
PLAT_SRCS='${CYGWIN_SRCS}'
DL_LIBS="-ldl"
|
| ︙ | ︙ | |||
1218 1219 1220 1221 1222 1223 1224 |
], [],
ac_cv_cygwin=no,
ac_cv_cygwin=yes)
)
if test "$ac_cv_cygwin" = "no"; then
AC_MSG_ERROR([${CC} is not a cygwin compiler.])
fi
| < < < | 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 |
], [],
ac_cv_cygwin=no,
ac_cv_cygwin=yes)
)
if test "$ac_cv_cygwin" = "no"; then
AC_MSG_ERROR([${CC} is not a cygwin compiler.])
fi
do64bit_ok=yes
if test "x${SHARED_BUILD}" = "x1"; then
echo "running cd ../win; ${CONFIG_SHELL-/bin/sh} ./configure $ac_configure_args"
# The eval makes quoting arguments work.
if cd ../win; eval ${CONFIG_SHELL-/bin/sh} ./configure $ac_configure_args; cd ../unix
then :
else
|
| ︙ | ︙ | |||
1450 1451 1452 1453 1454 1455 1456 |
DL_LIBS=""
AS_IF([test $doRpath = yes], [
CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'])
LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so.${SHLIB_VERSION}'
LDFLAGS="-Wl,-export-dynamic"
CFLAGS_OPTIMIZE="-O2"
| < | | | | < < | | | | < | < | | | | | 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 |
DL_LIBS=""
AS_IF([test $doRpath = yes], [
CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'])
LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so.${SHLIB_VERSION}'
LDFLAGS="-Wl,-export-dynamic"
CFLAGS_OPTIMIZE="-O2"
# On OpenBSD: Compile with -pthread
# Don't link with -lpthread
LIBS=`echo $LIBS | sed s/-lpthread//`
CFLAGS="$CFLAGS -pthread"
# OpenBSD doesn't do version numbers with dots.
UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.a'
TCL_LIB_VERSIONS_OK=nodots
;;
NetBSD-*)
# NetBSD has ELF and can use 'cc -shared' to build shared libs
SHLIB_CFLAGS="-fPIC"
SHLIB_LD='${CC} ${SHLIB_CFLAGS} -shared'
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
LDFLAGS="$LDFLAGS -export-dynamic"
AS_IF([test $doRpath = yes], [
CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'])
LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
# The -pthread needs to go in the CFLAGS, not LIBS
LIBS=`echo $LIBS | sed s/-pthread//`
CFLAGS="$CFLAGS -pthread"
LDFLAGS="$LDFLAGS -pthread"
;;
DragonFly-*|FreeBSD-*)
# This configuration from FreeBSD Ports.
SHLIB_CFLAGS="-fPIC"
SHLIB_LD="${CC} -shared"
SHLIB_LD_LIBS="${SHLIB_LD_LIBS} -Wl,-soname,\$[@]"
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
LDFLAGS=""
AS_IF([test $doRpath = yes], [
CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'])
# The -pthread needs to go in the LDFLAGS, not LIBS
LIBS=`echo $LIBS | sed s/-pthread//`
CFLAGS="$CFLAGS $PTHREAD_CFLAGS"
LDFLAGS="$LDFLAGS $PTHREAD_LIBS"
case $system in
FreeBSD-3.*)
# Version numbers are dot-stripped by system policy.
TCL_TRIM_DOTS=`echo ${VERSION} | tr -d .`
UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.a'
SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so'
TCL_LIB_VERSIONS_OK=nodots
|
| ︙ | ︙ | |||
1564 1565 1566 1567 1568 1569 1570 |
LDFLAGS=$hold_ldflags])
AS_IF([test $tcl_cv_ld_single_module = yes], [
SHLIB_LD="${SHLIB_LD} -Wl,-single_module"
])
SHLIB_SUFFIX=".dylib"
DL_OBJS="tclLoadDyld.o"
DL_LIBS=""
| < < < < | 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 |
LDFLAGS=$hold_ldflags])
AS_IF([test $tcl_cv_ld_single_module = yes], [
SHLIB_LD="${SHLIB_LD} -Wl,-single_module"
])
SHLIB_SUFFIX=".dylib"
DL_OBJS="tclLoadDyld.o"
DL_LIBS=""
LDFLAGS="$LDFLAGS -headerpad_max_install_names"
AC_CACHE_CHECK([if ld accepts -search_paths_first flag],
tcl_cv_ld_search_paths_first, [
hold_ldflags=$LDFLAGS
LDFLAGS="$LDFLAGS -Wl,-search_paths_first"
AC_TRY_LINK(, [int i;], tcl_cv_ld_search_paths_first=yes,
tcl_cv_ld_search_paths_first=no)
|
| ︙ | ︙ | |||
1666 1667 1668 1669 1670 1671 1672 |
DL_LIBS=""
AS_IF([test $doRpath = yes], [
CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}'])
AS_IF([test "$GCC" = yes], [CFLAGS="$CFLAGS -mieee"], [
CFLAGS="$CFLAGS -DHAVE_TZSET -std1 -ieee"])
# see pthread_intro(3) for pthread support on osf1, k.furukawa
| < | | | | | | | | < | 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 |
DL_LIBS=""
AS_IF([test $doRpath = yes], [
CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}'])
AS_IF([test "$GCC" = yes], [CFLAGS="$CFLAGS -mieee"], [
CFLAGS="$CFLAGS -DHAVE_TZSET -std1 -ieee"])
# see pthread_intro(3) for pthread support on osf1, k.furukawa
CFLAGS="$CFLAGS -DHAVE_PTHREAD_ATTR_SETSTACKSIZE"
CFLAGS="$CFLAGS -DTCL_THREAD_STACK_MIN=PTHREAD_STACK_MIN*64"
LIBS=`echo $LIBS | sed s/-lpthreads//`
AS_IF([test "$GCC" = yes], [
LIBS="$LIBS -lpthread -lmach -lexc"
], [
CFLAGS="$CFLAGS -pthread"
LDFLAGS="$LDFLAGS -pthread"
])
;;
QNX-6*)
# QNX RTP
# This may work for all QNX, but it was only reported for v6.
SHLIB_CFLAGS="-fPIC"
SHLIB_LD="ld -Bshareable -x"
|
| ︙ | ︙ | |||
1908 1909 1910 1911 1912 1913 1914 |
# libraries to the right flags for gcc, instead of those for the
# standard manufacturer compiler.
AS_IF([test "$DL_OBJS" != "tclLoadNone.o" -a "$GCC" = yes], [
case $system in
AIX-*) ;;
BSD/OS*) ;;
| | | | 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 |
# libraries to the right flags for gcc, instead of those for the
# standard manufacturer compiler.
AS_IF([test "$DL_OBJS" != "tclLoadNone.o" -a "$GCC" = yes], [
case $system in
AIX-*) ;;
BSD/OS*) ;;
CYGWIN_*) ;;
IRIX*) ;;
NetBSD-*|DragonFly-*|FreeBSD-*|OpenBSD-*) ;;
Darwin-*) ;;
SCO_SV-3.2*) ;;
*) SHLIB_CFLAGS="-fPIC" ;;
esac])
AS_IF([test "$tcl_cv_cc_visibility_hidden" != yes], [
AC_DEFINE(MODULE_SCOPE, [extern],
|
| ︙ | ︙ | |||
2288 2289 2290 2291 2292 2293 2294 2295 |
tcl_cv_timezone_time=yes, tcl_cv_timezone_time=no)])
if test $tcl_cv_timezone_time = yes ; then
AC_DEFINE(HAVE_TIMEZONE_VAR, 1, [Should we use the global timezone variable?])
fi
fi
])
#--------------------------------------------------------------------
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | > > > > > > > | 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 |
tcl_cv_timezone_time=yes, tcl_cv_timezone_time=no)])
if test $tcl_cv_timezone_time = yes ; then
AC_DEFINE(HAVE_TIMEZONE_VAR, 1, [Should we use the global timezone variable?])
fi
fi
])
#--------------------------------------------------------------------
# SC_TCL_LINK_LIBS
#
# Search for the libraries needed to link the Tcl shell.
# Things like the math library (-lm) and socket stuff (-lsocket vs.
# -lnsl) or thread library (-lpthread) are dealt with here.
#
# Arguments:
# None.
#
# Results:
#
# Sets the following vars:
# THREADS_LIBS Thread library(s)
#
# Defines the following vars:
# _REENTRANT
# _THREAD_SAFE
#
# Might append to the following vars:
# LIBS
# MATH_LIBS
#
# Might define the following vars:
# HAVE_NET_ERRNO_H
|
| ︙ | ︙ | |||
2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 |
if test "$tcl_checkBoth" = 1; then
tk_oldLibs=$LIBS
LIBS="$LIBS -lsocket -lnsl"
AC_CHECK_FUNC(accept, tcl_checkNsl=0, [LIBS=$tk_oldLibs])
fi
AC_CHECK_FUNC(gethostbyname, , [AC_CHECK_LIB(nsl, gethostbyname,
[LIBS="$LIBS -lnsl"])])
])
#--------------------------------------------------------------------
# SC_TCL_EARLY_FLAGS
#
# Check for what flags are needed to be passed so the correct OS
# features are available.
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 |
if test "$tcl_checkBoth" = 1; then
tk_oldLibs=$LIBS
LIBS="$LIBS -lsocket -lnsl"
AC_CHECK_FUNC(accept, tcl_checkNsl=0, [LIBS=$tk_oldLibs])
fi
AC_CHECK_FUNC(gethostbyname, , [AC_CHECK_LIB(nsl, gethostbyname,
[LIBS="$LIBS -lnsl"])])
AC_DEFINE(_REENTRANT, 1, [Do we want the reentrant OS API?])
AC_DEFINE(_THREAD_SAFE, 1, [Do we want the thread-safe OS API?])
AC_CHECK_LIB(pthread,pthread_mutex_init,tcl_ok=yes,tcl_ok=no)
if test "$tcl_ok" = "no"; then
# Check a little harder for __pthread_mutex_init in the same
# library, as some systems hide it there until pthread.h is
# defined. We could alternatively do an AC_TRY_COMPILE with
# pthread.h, but that will work with libpthread really doesn't
# exist, like AIX 4.2. [Bug: 4359]
AC_CHECK_LIB(pthread, __pthread_mutex_init,
tcl_ok=yes, tcl_ok=no)
fi
if test "$tcl_ok" = "yes"; then
# The space is needed
THREADS_LIBS=" -lpthread"
else
AC_CHECK_LIB(pthreads, pthread_mutex_init,
_ok=yes, tcl_ok=no)
if test "$tcl_ok" = "yes"; then
# The space is needed
THREADS_LIBS=" -lpthreads"
else
AC_CHECK_LIB(c, pthread_mutex_init,
tcl_ok=yes, tcl_ok=no)
if test "$tcl_ok" = "no"; then
AC_CHECK_LIB(c_r, pthread_mutex_init,
tcl_ok=yes, tcl_ok=no)
if test "$tcl_ok" = "yes"; then
# The space is needed
THREADS_LIBS=" -pthread"
else
AC_MSG_WARN([Don't know how to find pthread lib on your system - you must edit the LIBS in the Makefile...])
fi
fi
fi
fi
# Does the pthread-implementation provide
# 'pthread_attr_setstacksize' ?
ac_saved_libs=$LIBS
LIBS="$LIBS $THREADS_LIBS"
AC_CHECK_FUNCS(pthread_attr_setstacksize pthread_atfork)
LIBS=$ac_saved_libs
# TIP #509
AC_CHECK_DECLS([PTHREAD_MUTEX_RECURSIVE],tcl_ok=yes,tcl_ok=no, [[#include <pthread.h>]])
])
#--------------------------------------------------------------------
# SC_TCL_EARLY_FLAGS
#
# Check for what flags are needed to be passed so the correct OS
# features are available.
|
| ︙ | ︙ | |||
2472 2473 2474 2475 2476 2477 2478 | # None # # Results: # # Might define the following vars: # TCL_WIDE_INT_IS_LONG # TCL_WIDE_INT_TYPE | | | 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 |
# None
#
# Results:
#
# Might define the following vars:
# TCL_WIDE_INT_IS_LONG
# TCL_WIDE_INT_TYPE
# HAVE_STRUCT_DIRENT64, HAVE_DIR64
# HAVE_STRUCT_STAT64
# HAVE_TYPE_OFF64_T
#
#--------------------------------------------------------------------
AC_DEFUN([SC_TCL_64BIT_FLAGS], [
AC_MSG_CHECKING([for 64-bit integer type])
|
| ︙ | ︙ | |||
2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 |
AC_CACHE_CHECK([for struct dirent64], tcl_cv_struct_dirent64,[
AC_TRY_COMPILE([#include <sys/types.h>
#include <dirent.h>],[struct dirent64 p;],
tcl_cv_struct_dirent64=yes,tcl_cv_struct_dirent64=no)])
if test "x${tcl_cv_struct_dirent64}" = "xyes" ; then
AC_DEFINE(HAVE_STRUCT_DIRENT64, 1, [Is 'struct dirent64' in <sys/types.h>?])
fi
AC_CACHE_CHECK([for struct stat64], tcl_cv_struct_stat64,[
AC_TRY_COMPILE([#include <sys/stat.h>],[struct stat64 p;
],
tcl_cv_struct_stat64=yes,tcl_cv_struct_stat64=no)])
if test "x${tcl_cv_struct_stat64}" = "xyes" ; then
AC_DEFINE(HAVE_STRUCT_STAT64, 1, [Is 'struct stat64' in <sys/stat.h>?])
| > > > > > > > > > | 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 |
AC_CACHE_CHECK([for struct dirent64], tcl_cv_struct_dirent64,[
AC_TRY_COMPILE([#include <sys/types.h>
#include <dirent.h>],[struct dirent64 p;],
tcl_cv_struct_dirent64=yes,tcl_cv_struct_dirent64=no)])
if test "x${tcl_cv_struct_dirent64}" = "xyes" ; then
AC_DEFINE(HAVE_STRUCT_DIRENT64, 1, [Is 'struct dirent64' in <sys/types.h>?])
fi
AC_CACHE_CHECK([for DIR64], tcl_cv_DIR64,[
AC_TRY_COMPILE([#include <sys/types.h>
#include <dirent.h>],[struct dirent64 *p; DIR64 d = opendir64(".");
p = readdir64(d); rewinddir64(d); closedir64(d);],
tcl_cv_DIR64=yes,tcl_cv_DIR64=no)])
if test "x${tcl_cv_DIR64}" = "xyes" ; then
AC_DEFINE(HAVE_DIR64, 1, [Is 'DIR64' in <sys/types.h>?])
fi
AC_CACHE_CHECK([for struct stat64], tcl_cv_struct_stat64,[
AC_TRY_COMPILE([#include <sys/stat.h>],[struct stat64 p;
],
tcl_cv_struct_stat64=yes,tcl_cv_struct_stat64=no)])
if test "x${tcl_cv_struct_stat64}" = "xyes" ; then
AC_DEFINE(HAVE_STRUCT_STAT64, 1, [Is 'struct stat64' in <sys/stat.h>?])
|
| ︙ | ︙ | |||
3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 |
if test "x$NEED_FAKE_RFC2553" = "x1"; then
AC_DEFINE([NEED_FAKE_RFC2553], 1,
[Use compat implementation of getaddrinfo() and friends])
AC_LIBOBJ([fake-rfc2553])
AC_CHECK_FUNC(strlcpy)
fi
])
# Local Variables:
# mode: autoconf
# End:
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 |
if test "x$NEED_FAKE_RFC2553" = "x1"; then
AC_DEFINE([NEED_FAKE_RFC2553], 1,
[Use compat implementation of getaddrinfo() and friends])
AC_LIBOBJ([fake-rfc2553])
AC_CHECK_FUNC(strlcpy)
fi
])
#------------------------------------------------------------------------
# SC_CC_FOR_BUILD
# For cross compiles, locate a C compiler that can generate native binaries.
#
# Arguments:
# none
#
# Results:
# Substitutes the following vars:
# CC_FOR_BUILD
# EXEEXT_FOR_BUILD
#------------------------------------------------------------------------
dnl Get a default for CC_FOR_BUILD to put into Makefile.
AC_DEFUN([AX_CC_FOR_BUILD],[# Put a plausible default for CC_FOR_BUILD in Makefile.
if test -z "$CC_FOR_BUILD"; then
if test "x$cross_compiling" = "xno"; then
CC_FOR_BUILD='$(CC)'
else
AC_MSG_CHECKING([for gcc])
AC_CACHE_VAL(ac_cv_path_cc, [
search_path=`echo ${PATH} | sed -e 's/:/ /g'`
for dir in $search_path ; do
for j in `ls -r $dir/gcc 2> /dev/null` \
`ls -r $dir/gcc 2> /dev/null` ; do
if test x"$ac_cv_path_cc" = x ; then
if test -f "$j" ; then
ac_cv_path_cc=$j
break
fi
fi
done
done
])
fi
fi
AC_SUBST(CC_FOR_BUILD)
# Also set EXEEXT_FOR_BUILD.
if test "x$cross_compiling" = "xno"; then
EXEEXT_FOR_BUILD='$(EXEEXT)'
OBJEXT_FOR_BUILD='$(OBJEXT)'
else
OBJEXT_FOR_BUILD='.no'
AC_CACHE_CHECK([for build system executable suffix], bfd_cv_build_exeext,
[rm -f conftest*
echo 'int main () { return 0; }' > conftest.c
bfd_cv_build_exeext=
${CC_FOR_BUILD} -o conftest conftest.c 1>&5 2>&5
for file in conftest.*; do
case $file in
*.c | *.o | *.obj | *.ilk | *.pdb) ;;
*) bfd_cv_build_exeext=`echo $file | sed -e s/conftest//` ;;
esac
done
rm -f conftest*
test x"${bfd_cv_build_exeext}" = x && bfd_cv_build_exeext=no])
EXEEXT_FOR_BUILD=""
test x"${bfd_cv_build_exeext}" != xno && EXEEXT_FOR_BUILD=${bfd_cv_build_exeext}
fi
AC_SUBST(EXEEXT_FOR_BUILD)])dnl
AC_SUBST(OBJEXT_FOR_BUILD)])dnl
])
#------------------------------------------------------------------------
# SC_ZIPFS_SUPPORT
# Locate a zip encoder installed on the system path, or none.
#
# Arguments:
# none
#
# Results:
# Substitutes the following vars:
# ZIP_PROG
# ZIP_PROG_OPTIONS
# ZIP_PROG_VFSSEARCH
# ZIP_INSTALL_OBJS
#------------------------------------------------------------------------
AC_DEFUN([SC_ZIPFS_SUPPORT], [
ZIP_PROG=""
ZIP_PROG_OPTIONS=""
ZIP_PROG_VFSSEARCH=""
ZIP_INSTALL_OBJS=""
AC_MSG_CHECKING([for zip])
AC_CACHE_VAL(ac_cv_path_zip, [
search_path=`echo ${PATH} | sed -e 's/:/ /g'`
for dir in $search_path ; do
for j in `ls -r $dir/zip 2> /dev/null` \
`ls -r $dir/zip 2> /dev/null` ; do
if test x"$ac_cv_path_zip" = x ; then
if test -f "$j" ; then
ac_cv_path_zip=$j
break
fi
fi
done
done
])
if test -f "$ac_cv_path_zip" ; then
ZIP_PROG="$ac_cv_path_zip"
AC_MSG_RESULT([$ZIP_PROG])
ZIP_PROG_OPTIONS="-rq"
ZIP_PROG_VFSSEARCH="*"
AC_MSG_RESULT([Found INFO Zip in environment])
# Use standard arguments for zip
else
# It is not an error if an installed version of Zip can't be located.
# We can use the locally distributed minizip instead
ZIP_PROG="./minizip${EXEEXT_FOR_BUILD}"
ZIP_PROG_OPTIONS="-o -r"
ZIP_PROG_VFSSEARCH="*"
ZIP_INSTALL_OBJS="minizip${EXEEXT_FOR_BUILD}"
AC_MSG_RESULT([No zip found on PATH. Building minizip])
fi
AC_SUBST(ZIP_PROG)
AC_SUBST(ZIP_PROG_OPTIONS)
AC_SUBST(ZIP_PROG_VFSSEARCH)
AC_SUBST(ZIP_INSTALL_OBJS)
])
# Local Variables:
# mode: autoconf
# End:
|
Changes to unix/tcl.pc.in.
1 2 3 4 5 6 7 8 9 10 11 12 13 |
# tcl pkg-config source file
prefix=@prefix@
exec_prefix=@exec_prefix@
libdir=@libdir@
includedir=@includedir@
Name: Tool Command Language
Description: Tcl is a powerful, easy-to-learn dynamic programming language, suitable for a wide range of uses.
URL: http://www.tcl.tk/
Version: @TCL_VERSION@@TCL_PATCH_LEVEL@
Requires.private: zlib >= 1.2.3
Libs: -L${libdir} @TCL_LIB_FLAG@ @TCL_STUB_LIB_FLAG@
| > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 |
# tcl pkg-config source file
prefix=@prefix@
exec_prefix=@exec_prefix@
libdir=@libdir@
includedir=@includedir@
libfile=@TCL_LIB_FILE@
zipfile=@TCL_ZIP_FILE@
Name: Tool Command Language
Description: Tcl is a powerful, easy-to-learn dynamic programming language, suitable for a wide range of uses.
URL: http://www.tcl.tk/
Version: @TCL_VERSION@@TCL_PATCH_LEVEL@
Requires.private: zlib >= 1.2.3
Libs: -L${libdir} @TCL_LIB_FLAG@ @TCL_STUB_LIB_FLAG@
|
| ︙ | ︙ |
Changes to unix/tclAppInit.c.
| ︙ | ︙ | |||
75 76 77 78 79 80 81 82 83 84 85 86 87 88 |
{
#ifdef TCL_XT_TEST
XtToolkitInitialize();
#endif
#ifdef TCL_LOCAL_MAIN_HOOK
TCL_LOCAL_MAIN_HOOK(&argc, &argv);
#endif
Tcl_Main(argc, argv, TCL_LOCAL_APPINIT);
return 0; /* Needed only to prevent compiler warning. */
}
/*
| > > | 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 |
{
#ifdef TCL_XT_TEST
XtToolkitInitialize();
#endif
#ifdef TCL_LOCAL_MAIN_HOOK
TCL_LOCAL_MAIN_HOOK(&argc, &argv);
#else
TclZipfs_AppHook(&argc, &argv);
#endif
Tcl_Main(argc, argv, TCL_LOCAL_APPINIT);
return 0; /* Needed only to prevent compiler warning. */
}
/*
|
| ︙ | ︙ |
Changes to unix/tclConfig.h.in.
| ︙ | ︙ | |||
26 27 28 29 30 31 32 33 34 35 36 37 38 39 | #undef HAVE_COPYFILE_H /* Do we have access to Darwin CoreFoundation.framework? */ #undef HAVE_COREFOUNDATION /* Is the cpuid instruction usable? */ #undef HAVE_CPUID /* Define to 1 if you have the `freeaddrinfo' function. */ #undef HAVE_FREEADDRINFO /* Do we have fts functions? */ #undef HAVE_FTS | > > > | 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 | #undef HAVE_COPYFILE_H /* Do we have access to Darwin CoreFoundation.framework? */ #undef HAVE_COREFOUNDATION /* Is the cpuid instruction usable? */ #undef HAVE_CPUID /* Is 'DIR64' in <sys/types.h>? */ #undef HAVE_DIR64 /* Define to 1 if you have the `freeaddrinfo' function. */ #undef HAVE_FREEADDRINFO /* Do we have fts functions? */ #undef HAVE_FTS |
| ︙ | ︙ | |||
381 382 383 384 385 386 387 | /* Is memory debugging enabled? */ #undef TCL_MEM_DEBUG /* What is the default extension for shared libraries? */ #undef TCL_SHLIB_EXT | < < < | 384 385 386 387 388 389 390 391 392 393 394 395 396 397 | /* Is memory debugging enabled? */ #undef TCL_MEM_DEBUG /* What is the default extension for shared libraries? */ #undef TCL_SHLIB_EXT /* Do we allow unloading of shared libraries? */ #undef TCL_UNLOAD_DLLS /* Does this platform have wide high-resolution clicks? */ #undef TCL_WIDE_CLICKS /* Do Tcl_WideInt, 'long' and 'long long' all have the same size (64-bit) ? */ |
| ︙ | ︙ | |||
480 481 482 483 484 485 486 | /* Define to `unsigned' if <sys/types.h> does not define. */ #undef size_t /* Define as int if socklen_t is not available */ #undef socklen_t | < < < | 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 |
/* Define to `unsigned' if <sys/types.h> does not define. */
#undef size_t
/* Define as int if socklen_t is not available */
#undef socklen_t
/* Define to `int' if <sys/types.h> doesn't define. */
#undef uid_t
/* Unsigned integer type wide enough to hold a pointer. */
#undef uintptr_t
/* Undef unused package specific autoheader defines so that we can
* include both tclConfig.h and tkConfig.h at the same time: */
/* override */ #undef PACKAGE_NAME
/* override */ #undef PACKAGE_STRING
/* override */ #undef PACKAGE_TARNAME
#endif /* _TCLCONFIG */
|
Changes to unix/tclConfig.sh.in.
| ︙ | ︙ | |||
34 35 36 37 38 39 40 41 42 43 44 45 46 47 | TCL_LDFLAGS_OPTIMIZE='@LDFLAGS_OPTIMIZE@' # Flag, 1: we built a shared lib, 0 we didn't TCL_SHARED_BUILD=@TCL_SHARED_BUILD@ # The name of the Tcl library (may be either a .a file or a shared library): TCL_LIB_FILE='@TCL_LIB_FILE@' # Additional libraries to use when linking Tcl. TCL_LIBS='@TCL_LIBS@' # Top-level directory in which Tcl's platform-independent files are # installed. TCL_PREFIX='@prefix@' | > > > | 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 | TCL_LDFLAGS_OPTIMIZE='@LDFLAGS_OPTIMIZE@' # Flag, 1: we built a shared lib, 0 we didn't TCL_SHARED_BUILD=@TCL_SHARED_BUILD@ # The name of the Tcl library (may be either a .a file or a shared library): TCL_LIB_FILE='@TCL_LIB_FILE@' # The name of a zip containing the /library and /encodings (may be either a .zip file or a shared library): TCL_ZIP_FILE='@TCL_ZIP_FILE@' # Additional libraries to use when linking Tcl. TCL_LIBS='@TCL_LIBS@' # Top-level directory in which Tcl's platform-independent files are # installed. TCL_PREFIX='@prefix@' |
| ︙ | ︙ | |||
160 161 162 163 164 165 166 | TCL_STUB_LIB_SPEC='@TCL_STUB_LIB_SPEC@' # Path to the Tcl stub library in the build directory. TCL_BUILD_STUB_LIB_PATH='@TCL_BUILD_STUB_LIB_PATH@' # Path to the Tcl stub library in the install directory. TCL_STUB_LIB_PATH='@TCL_STUB_LIB_PATH@' | < < < | 163 164 165 166 167 168 169 | TCL_STUB_LIB_SPEC='@TCL_STUB_LIB_SPEC@' # Path to the Tcl stub library in the build directory. TCL_BUILD_STUB_LIB_PATH='@TCL_BUILD_STUB_LIB_PATH@' # Path to the Tcl stub library in the install directory. TCL_STUB_LIB_PATH='@TCL_STUB_LIB_PATH@' |
Changes to unix/tclEpollNotfy.c.
1 2 3 4 | /* * tclEpollNotfy.c -- * * This file contains the implementation of the epoll()-based | | | < < < > > < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 | /* * tclEpollNotfy.c -- * * This file contains the implementation of the epoll()-based * Linux-specific notifier, which is the lowest-level part of the Tcl * event loop. This file works together with generic/tclNotify.c. * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * Copyright (c) 2016 Lucio Andrés Illanes Albornoz <l.illanes@gmx.de> * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #ifndef HAVE_COREFOUNDATION /* Darwin/Mac OS X CoreFoundation notifier is * in tclMacOSXNotify.c */ #if defined(NOTIFIER_EPOLL) && TCL_THREADS #define _GNU_SOURCE /* For pipe2(2) */ #include <fcntl.h> #include <signal.h> #include <sys/epoll.h> #ifdef HAVE_EVENTFD #include <sys/eventfd.h> #endif /* HAVE_EVENTFD */ #include <sys/queue.h> /* * This structure is used to keep track of the notifier info for a registered * file. */ struct PlatformEventData; |
| ︙ | ︙ | |||
50 51 52 53 54 55 56 |
* ready for I/O. */
struct PlatformEventData *pedPtr;
/* Pointer to PlatformEventData associating this
* FileHandler with epoll(7) events. */
} FileHandler;
/*
| | | | | 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 |
* ready for I/O. */
struct PlatformEventData *pedPtr;
/* Pointer to PlatformEventData associating this
* FileHandler with epoll(7) events. */
} FileHandler;
/*
* The following structure associates a FileHandler and the thread that owns
* it with the file descriptors of interest and their event masks passed to
* epoll_ctl(2) and their corresponding event(s) returned by epoll_wait(2).
*/
struct ThreadSpecificData;
struct PlatformEventData {
FileHandler *filePtr;
struct ThreadSpecificData *tsdPtr;
};
|
| ︙ | ︙ | |||
84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 |
* The following static structure contains the state information for the
* epoll based implementation of the Tcl notifier. One of these structures is
* created for each thread that is using the notifier.
*/
LIST_HEAD(PlatformReadyFileHandlerList, FileHandler);
typedef struct ThreadSpecificData {
FileHandler *firstFileHandlerPtr;
/* Pointer to head of file handler list. */
struct PlatformReadyFileHandlerList firstReadyFileHandlerPtr;
/* Pointer to head of list of FileHandlers
* associated with regular files (S_IFREG)
* that are ready for I/O. */
pthread_mutex_t notifierMutex;
/* Mutex protecting notifier termination in
* PlatformEventsFinalize. */
#ifdef HAVE_EVENTFD
int triggerEventFd; /* eventfd(2) used by other threads to wake
* up this thread for inter-thread IPC. */
#else
int triggerPipe[2]; /* pipe(2) used by other threads to wake
* up this thread for inter-thread IPC. */
#endif /* HAVE_EVENTFD */
| > | > | > > > > > | | | | > | | > > > > | 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 |
* The following static structure contains the state information for the
* epoll based implementation of the Tcl notifier. One of these structures is
* created for each thread that is using the notifier.
*/
LIST_HEAD(PlatformReadyFileHandlerList, FileHandler);
typedef struct ThreadSpecificData {
FileHandler *triggerFilePtr;
FileHandler *firstFileHandlerPtr;
/* Pointer to head of file handler list. */
struct PlatformReadyFileHandlerList firstReadyFileHandlerPtr;
/* Pointer to head of list of FileHandlers
* associated with regular files (S_IFREG)
* that are ready for I/O. */
pthread_mutex_t notifierMutex;
/* Mutex protecting notifier termination in
* PlatformEventsFinalize. */
#ifdef HAVE_EVENTFD
int triggerEventFd; /* eventfd(2) used by other threads to wake
* up this thread for inter-thread IPC. */
#else
int triggerPipe[2]; /* pipe(2) used by other threads to wake
* up this thread for inter-thread IPC. */
#endif /* HAVE_EVENTFD */
int eventsFd; /* epoll(7) file descriptor used to wait for
* fds */
struct epoll_event *readyEvents;
/* Pointer to at most maxReadyEvents events
* returned by epoll_wait(2). */
size_t maxReadyEvents; /* Count of epoll_events in readyEvents. */
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
/*
* Forward declarations.
*/
static void PlatformEventsControl(FileHandler *filePtr,
ThreadSpecificData *tsdPtr, int op, int isNew);
static void PlatformEventsFinalize(void);
static void PlatformEventsInit(void);
static int PlatformEventsTranslate(struct epoll_event *event);
static int PlatformEventsWait(struct epoll_event *events,
size_t numEvents, struct timeval *timePtr);
/*
* Incorporate the base notifier API.
*/
#include "tclUnixNotfy.c"
/*
*----------------------------------------------------------------------
*
* Tcl_InitNotifier --
*
|
| ︙ | ︙ | |||
185 186 187 188 189 190 191 | *---------------------------------------------------------------------- * * PlatformEventsControl -- * * This function registers interest for the file descriptor and the mask * of TCL_* bits associated with filePtr on the epoll file descriptor * associated with tsdPtr. | > | | | | | | | | | | | | | | | | | | | | > | | | | | | | > > | | 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 |
*----------------------------------------------------------------------
*
* PlatformEventsControl --
*
* This function registers interest for the file descriptor and the mask
* of TCL_* bits associated with filePtr on the epoll file descriptor
* associated with tsdPtr.
*
* Future calls to epoll_wait will return filePtr and tsdPtr alongside
* with the event registered here via the PlatformEventData struct.
*
* Results:
* None.
*
* Side effects:
* - If adding a new file descriptor, a PlatformEventData struct will be
* allocated and associated with filePtr.
* - fstat is called on the file descriptor; if it is associated with a
* regular file (S_IFREG,) filePtr is considered to be ready for I/O
* and added to or deleted from the corresponding list in tsdPtr.
* - If it is not associated with a regular file, the file descriptor is
* added, modified concerning its mask of events of interest, or
* deleted from the epoll file descriptor of the calling thread.
*
*----------------------------------------------------------------------
*/
void
PlatformEventsControl(
FileHandler *filePtr,
ThreadSpecificData *tsdPtr,
int op,
int isNew)
{
struct epoll_event newEvent;
struct PlatformEventData *newPedPtr;
struct stat fdStat;
newEvent.events = 0;
if (filePtr->mask & (TCL_READABLE | TCL_EXCEPTION)) {
newEvent.events |= EPOLLIN;
}
if (filePtr->mask & TCL_WRITABLE) {
newEvent.events |= EPOLLOUT;
}
if (isNew) {
newPedPtr = Tcl_Alloc(sizeof(*newPedPtr));
newPedPtr->filePtr = filePtr;
newPedPtr->tsdPtr = tsdPtr;
filePtr->pedPtr = newPedPtr;
}
newEvent.data.ptr = filePtr->pedPtr;
/*
* N.B. As discussed in Tcl_WaitForEvent(), epoll(7) does not support
* regular files (S_IFREG.) Therefore, filePtr is in these cases simply
* added or deleted from the list of FileHandlers associated with regular
* files belonging to tsdPtr.
*/
if (fstat(filePtr->fd, &fdStat) == -1) {
Tcl_Panic("fstat: %s", strerror(errno));
} else if ((fdStat.st_mode & S_IFMT) == S_IFREG) {
switch (op) {
case EPOLL_CTL_ADD:
if (isNew) {
LIST_INSERT_HEAD(&tsdPtr->firstReadyFileHandlerPtr, filePtr,
readyNode);
}
break;
case EPOLL_CTL_DEL:
LIST_REMOVE(filePtr, readyNode);
break;
}
return;
} else if (epoll_ctl(tsdPtr->eventsFd, op, filePtr->fd, &newEvent) == -1) {
Tcl_Panic("epoll_ctl: %s", strerror(errno));
}
}
/*
*----------------------------------------------------------------------
*
* PlatformEventsFinalize --
*
* This function closes the eventfd and the epoll file descriptor and
* frees the epoll_event structs owned by the thread of the caller. The
* above operations are protected by tsdPtr->notifierMutex, which is
* destroyed thereafter.
*
* Results:
* None.
*
* Side effects:
* While tsdPtr->notifierMutex is held:
* - The per-thread eventfd(2) is closed, if non-zero, and set to -1.
* - The per-thread epoll(7) fd is closed, if non-zero, and set to 0.
* - The per-thread epoll_event structs are freed, if any, and set to 0.
*
* tsdPtr->notifierMutex is destroyed.
*
*----------------------------------------------------------------------
*/
void
PlatformEventsFinalize(
void)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
pthread_mutex_lock(&tsdPtr->notifierMutex);
#ifdef HAVE_EVENTFD
if (tsdPtr->triggerEventFd) {
close(tsdPtr->triggerEventFd);
tsdPtr->triggerEventFd = -1;
}
#else /* !HAVE_EVENTFD */
if (tsdPtr->triggerPipe[0]) {
close(tsdPtr->triggerPipe[0]);
tsdPtr->triggerPipe[0] = -1;
}
if (tsdPtr->triggerPipe[1]) {
close(tsdPtr->triggerPipe[1]);
tsdPtr->triggerPipe[1] = -1;
}
#endif /* HAVE_EVENTFD */
Tcl_Free(tsdPtr->triggerFilePtr->pedPtr);
Tcl_Free(tsdPtr->triggerFilePtr);
if (tsdPtr->eventsFd > 0) {
close(tsdPtr->eventsFd);
tsdPtr->eventsFd = 0;
}
if (tsdPtr->readyEvents) {
Tcl_Free(tsdPtr->readyEvents);
tsdPtr->maxReadyEvents = 0;
}
pthread_mutex_unlock(&tsdPtr->notifierMutex);
if ((errno = pthread_mutex_destroy(&tsdPtr->notifierMutex))) {
Tcl_Panic("pthread_mutex_destroy: %s", strerror(errno));
}
}
|
| ︙ | ︙ | |||
330 331 332 333 334 335 336 | * tsdPtr for the thread of the caller. * * Results: * None. * * Side effects: * The following per-thread entities are initialised: | | | | | | | | > | < | | > | | > | | | | | | 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 |
* tsdPtr for the thread of the caller.
*
* Results:
* None.
*
* Side effects:
* The following per-thread entities are initialised:
* - notifierMutex is initialised.
* - The eventfd(2) is created w/ EFD_CLOEXEC and EFD_NONBLOCK.
* - The epoll(7) fd is created w/ EPOLL_CLOEXEC.
* - A FileHandler struct is allocated and initialised for the
* eventfd(2), registering interest for TCL_READABLE on it via
* PlatformEventsControl().
* - readyEvents and maxReadyEvents are initialised with 512
* epoll_events.
*
*----------------------------------------------------------------------
*/
void
PlatformEventsInit(void)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
FileHandler *filePtr;
errno = pthread_mutex_init(&tsdPtr->notifierMutex, NULL);
if (errno) {
Tcl_Panic("Tcl_InitNotifier: %s", "could not create mutex");
}
filePtr = Tcl_Alloc(sizeof(*filePtr));
#ifdef HAVE_EVENTFD
tsdPtr->triggerEventFd = eventfd(0, EFD_CLOEXEC | EFD_NONBLOCK);
if (tsdPtr->triggerEventFd <= 0) {
Tcl_Panic("Tcl_InitNotifier: %s", "could not create trigger eventfd");
}
filePtr->fd = tsdPtr->triggerEventFd;
#else /* !HAVE_EVENTFD */
if (pipe2(tsdPtr->triggerPipe, O_CLOEXEC | O_NONBLOCK) != 0) {
Tcl_Panic("Tcl_InitNotifier: %s", "could not create trigger pipe");
}
filePtr->fd = tsdPtr->triggerPipe[0];
#endif /* HAVE_EVENTFD */
tsdPtr->triggerFilePtr = filePtr;
if ((tsdPtr->eventsFd = epoll_create1(EPOLL_CLOEXEC)) == -1) {
Tcl_Panic("epoll_create1: %s", strerror(errno));
}
filePtr->mask = TCL_READABLE;
PlatformEventsControl(filePtr, tsdPtr, EPOLL_CTL_ADD, 1);
if (!tsdPtr->readyEvents) {
tsdPtr->maxReadyEvents = 512;
tsdPtr->readyEvents = Tcl_Alloc(
tsdPtr->maxReadyEvents * sizeof(tsdPtr->readyEvents[0]));
}
LIST_INIT(&tsdPtr->firstReadyFileHandlerPtr);
}
/*
*----------------------------------------------------------------------
*
* PlatformEventsTranslate --
*
* This function translates the platform-specific mask of returned events
* in eventPtr to a mask of TCL_* bits.
*
* Results:
* Returns the translated mask.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
PlatformEventsTranslate(
struct epoll_event *eventPtr)
{
int mask;
mask = 0;
if (eventPtr->events & (EPOLLIN | EPOLLHUP)) {
mask |= TCL_READABLE;
}
|
| ︙ | ︙ | |||
421 422 423 424 425 426 427 | *---------------------------------------------------------------------- * * PlatformEventsWait -- * * This function abstracts waiting for I/O events via epoll_wait. * * Results: | | | | | | | | | | | | | | | | | | | | 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 |
*----------------------------------------------------------------------
*
* PlatformEventsWait --
*
* This function abstracts waiting for I/O events via epoll_wait.
*
* Results:
* Returns -1 if epoll_wait failed. Returns 0 if polling and if no events
* became available whilst polling. Returns a pointer to and the count of
* all returned events in all other cases.
*
* Side effects:
* gettimeofday(2), epoll_wait(2), and gettimeofday(2) are called, in the
* specified order.
* If timePtr specifies a positive value, it is updated to reflect the
* amount of time that has passed; if its value would {under, over}flow,
* it is set to zero.
*
*----------------------------------------------------------------------
*/
int
PlatformEventsWait(
struct epoll_event *events,
size_t numEvents,
struct timeval *timePtr)
{
int numFound;
struct timeval tv0, tv1, tv_delta;
int timeout;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
/*
* If timePtr is NULL, epoll_wait(2) will wait indefinitely. If it
* specifies a timeout of {0,0}, epoll_wait(2) will poll. Otherwise, the
* timeout will simply be converted to milliseconds.
*/
if (!timePtr) {
timeout = -1;
} else if (!timePtr->tv_sec && !timePtr->tv_usec) {
timeout = 0;
} else {
timeout = (int)timePtr->tv_sec * 1000;
if (timePtr->tv_usec) {
timeout += (int)timePtr->tv_usec / 1000;
}
}
/*
* Call (and possibly block on) epoll_wait(2) and substract the delta of
* gettimeofday(2) before and after the call from timePtr if the latter is
* not NULL. Return the number of events returned by epoll_wait(2).
*/
gettimeofday(&tv0, NULL);
numFound = epoll_wait(tsdPtr->eventsFd, events, (int)numEvents, timeout);
gettimeofday(&tv1, NULL);
if (timePtr && (timePtr->tv_sec && timePtr->tv_usec)) {
timersub(&tv1, &tv0, &tv_delta);
if (!timercmp(&tv_delta, timePtr, >)) {
timersub(timePtr, &tv_delta, timePtr);
} else {
timePtr->tv_sec = 0;
timePtr->tv_usec = 0;
}
}
return numFound;
}
/*
*----------------------------------------------------------------------
*
* Tcl_CreateFileHandler --
*
* This function registers a file handler with the epoll notifier of the
* thread of the caller.
*
* Results:
* None.
*
* Side effects:
* Creates a new file handler structure.
* PlatformEventsControl() is called for the new file handler structure.
|
| ︙ | ︙ | |||
530 531 532 533 534 535 536 |
for (filePtr = tsdPtr->firstFileHandlerPtr; filePtr != NULL;
filePtr = filePtr->nextPtr) {
if (filePtr->fd == fd) {
break;
}
}
if (filePtr == NULL) {
| | | | | | | 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 |
for (filePtr = tsdPtr->firstFileHandlerPtr; filePtr != NULL;
filePtr = filePtr->nextPtr) {
if (filePtr->fd == fd) {
break;
}
}
if (filePtr == NULL) {
filePtr = Tcl_Alloc(sizeof(FileHandler));
filePtr->fd = fd;
filePtr->readyMask = 0;
filePtr->nextPtr = tsdPtr->firstFileHandlerPtr;
tsdPtr->firstFileHandlerPtr = filePtr;
isNew = 1;
} else {
isNew = 0;
}
filePtr->proc = proc;
filePtr->clientData = clientData;
filePtr->mask = mask;
PlatformEventsControl(filePtr, tsdPtr,
isNew ? EPOLL_CTL_ADD : EPOLL_CTL_MOD, isNew);
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_DeleteFileHandler --
*
* Cancel a previously-arranged callback arrangement for a file on the
* epoll file descriptor of the thread of the caller.
*
* Results:
* None.
*
* Side effects:
* If a callback was previously registered on file, remove it.
* PlatformEventsControl() is called for the file handler structure.
|
| ︙ | ︙ | |||
600 601 602 603 604 605 606 |
/*
* Update the check masks for this file.
*/
PlatformEventsControl(filePtr, tsdPtr, EPOLL_CTL_DEL, 0);
if (filePtr->pedPtr) {
| | | > | | 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 |
/*
* Update the check masks for this file.
*/
PlatformEventsControl(filePtr, tsdPtr, EPOLL_CTL_DEL, 0);
if (filePtr->pedPtr) {
Tcl_Free(filePtr->pedPtr);
}
/*
* Clean up information in the callback record.
*/
if (prevPtr == NULL) {
tsdPtr->firstFileHandlerPtr = filePtr->nextPtr;
} else {
prevPtr->nextPtr = filePtr->nextPtr;
}
Tcl_Free(filePtr);
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_WaitForEvent --
*
* This function is called by Tcl_DoOneEvent to wait for new events on
* the message queue. If the block time is 0, then Tcl_WaitForEvent just
* polls without blocking.
*
* The waiting logic is implemented in PlatformEventsWait.
*
* Results:
* Returns -1 if PlatformEventsWait() would block forever, otherwise
* returns 0.
*
* Side effects:
* Queues file events that are detected by PlatformEventsWait().
*
*----------------------------------------------------------------------
*/
int
Tcl_WaitForEvent(
const Tcl_Time *timePtr) /* Maximum block time, or NULL. */
{
if (tclNotifierHooks.waitForEventProc) {
return tclNotifierHooks.waitForEventProc(timePtr);
} else {
FileHandler *filePtr;
int mask;
Tcl_Time vTime;
|
| ︙ | ︙ | |||
688 689 690 691 692 693 694 695 696 |
timeoutPtr = NULL;
}
/*
* Walk the list of FileHandlers associated with regular files
* (S_IFREG) belonging to tsdPtr, queue Tcl events for them, and
* update their mask of events of interest.
* As epoll(7) does not support regular files, the behaviour of
* {select,poll}(2) is simply simulated here: fds associated with
| > | | | | | | | > | > | > > > > > > > | | > < | | | < > | | < > | > < < | 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 |
timeoutPtr = NULL;
}
/*
* Walk the list of FileHandlers associated with regular files
* (S_IFREG) belonging to tsdPtr, queue Tcl events for them, and
* update their mask of events of interest.
*
* As epoll(7) does not support regular files, the behaviour of
* {select,poll}(2) is simply simulated here: fds associated with
* regular files are added to this list by PlatformEventsControl() and
* processed here before calling (and possibly blocking) on
* PlatformEventsWait().
*/
numQueued = 0;
LIST_FOREACH(filePtr, &tsdPtr->firstReadyFileHandlerPtr, readyNode) {
mask = 0;
if (filePtr->mask & TCL_READABLE) {
mask |= TCL_READABLE;
}
if (filePtr->mask & TCL_WRITABLE) {
mask |= TCL_WRITABLE;
}
/*
* Don't bother to queue an event if the mask was previously
* non-zero since an event must still be on the queue.
*/
if (filePtr->readyMask == 0) {
FileHandlerEvent *fileEvPtr =
Tcl_Alloc(sizeof(FileHandlerEvent));
fileEvPtr->header.proc = FileHandlerEventProc;
fileEvPtr->fd = filePtr->fd;
Tcl_QueueEvent((Tcl_Event *) fileEvPtr, TCL_QUEUE_TAIL);
numQueued++;
}
filePtr->readyMask = mask;
}
/*
* If any events were queued in the above loop, force
* PlatformEventsWait() to poll as there already are events that need
* to be processed at this point.
*/
if (numQueued) {
timeout.tv_sec = 0;
timeout.tv_usec = 0;
timeoutPtr = &timeout;
}
/*
* Wait or poll for new events, queue Tcl events for the FileHandlers
* corresponding to them, and update the FileHandlers' mask of events
* of interest registered by the last call to Tcl_CreateFileHandler().
*
* Events for the eventfd(2)/trigger pipe are processed here in order
* to facilitate inter-thread IPC. If another thread intends to wake
* up this thread whilst it's blocking on PlatformEventsWait(), it
* write(2)s to the eventfd(2)/trigger pipe (see Tcl_AlertNotifier(),)
* which in turn will cause PlatformEventsWait() to return
* immediately.
*/
numFound = PlatformEventsWait(tsdPtr->readyEvents,
tsdPtr->maxReadyEvents, timeoutPtr);
for (numEvent = 0; numEvent < numFound; numEvent++) {
pedPtr = tsdPtr->readyEvents[numEvent].data.ptr;
filePtr = pedPtr->filePtr;
mask = PlatformEventsTranslate(&tsdPtr->readyEvents[numEvent]);
#ifdef HAVE_EVENTFD
if (filePtr->fd == tsdPtr->triggerEventFd) {
uint64_t eventFdVal;
i = read(tsdPtr->triggerEventFd, &eventFdVal,
sizeof(eventFdVal));
if ((i != sizeof(eventFdVal)) && (errno != EAGAIN)) {
Tcl_Panic(
"Tcl_WaitForEvent: read from %p->triggerEventFd: %s",
(void *) tsdPtr, strerror(errno));
}
continue;
}
#else /* !HAVE_EVENTFD */
if (filePtr->fd == tsdPtr->triggerPipe[0]) {
char triggerPipeVal;
i = read(tsdPtr->triggerPipe[0], &triggerPipeVal,
sizeof(triggerPipeVal));
if ((i != sizeof(triggerPipeVal)) && (errno != EAGAIN)) {
Tcl_Panic(
"Tcl_WaitForEvent: read from %p->triggerPipe[0]: %s",
(void *) tsdPtr, strerror(errno));
}
continue;
}
#endif /* HAVE_EVENTFD */
if (!mask) {
continue;
}
/*
* Don't bother to queue an event if the mask was previously
* non-zero since an event must still be on the queue.
*/
if (filePtr->readyMask == 0) {
FileHandlerEvent *fileEvPtr =
Tcl_Alloc(sizeof(FileHandlerEvent));
fileEvPtr->header.proc = FileHandlerEventProc;
fileEvPtr->fd = filePtr->fd;
Tcl_QueueEvent((Tcl_Event *) fileEvPtr, TCL_QUEUE_TAIL);
}
filePtr->readyMask = mask;
}
return 0;
}
}
#endif /* NOTIFIER_EPOLL && TCL_THREADS */
#endif /* !HAVE_COREFOUNDATION */
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to unix/tclKqueueNotfy.c.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 | * Copyright (c) 1995-1997 Sun Microsystems, Inc. * Copyright (c) 2016 Lucio Andrés Illanes Albornoz <l.illanes@gmx.de> * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ | < < > > | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 | * Copyright (c) 1995-1997 Sun Microsystems, Inc. * Copyright (c) 2016 Lucio Andrés Illanes Albornoz <l.illanes@gmx.de> * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #ifndef HAVE_COREFOUNDATION /* Darwin/Mac OS X CoreFoundation notifier is * in tclMacOSXNotify.c */ #if defined(NOTIFIER_KQUEUE) && TCL_THREADS #include <signal.h> #include <sys/types.h> #include <sys/event.h> #include <sys/queue.h> #include <sys/time.h> /* |
| ︙ | ︙ | |||
47 48 49 50 51 52 53 |
* ready for I/O. */
struct PlatformEventData *pedPtr;
/* Pointer to PlatformEventData associating this
* FileHandler with kevent(2) events. */
} FileHandler;
/*
| | | | | 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 |
* ready for I/O. */
struct PlatformEventData *pedPtr;
/* Pointer to PlatformEventData associating this
* FileHandler with kevent(2) events. */
} FileHandler;
/*
* The following structure associates a FileHandler and the thread that owns
* it with the file descriptors of interest and their event masks passed to
* kevent(2) and their corresponding event(s) returned by kevent(2).
*/
struct ThreadSpecificData;
struct PlatformEventData {
FileHandler *filePtr;
struct ThreadSpecificData *tsdPtr;
};
|
| ︙ | ︙ | |||
92 93 94 95 96 97 98 |
* associated with regular files (S_IFREG)
* that are ready for I/O. */
pthread_mutex_t notifierMutex;
/* Mutex protecting notifier termination in
* PlatformEventsFinalize. */
int triggerPipe[2]; /* pipe(2) used by other threads to wake
* up this thread for inter-thread IPC. */
| | > | > > > > > | | | | > | | | 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 |
* associated with regular files (S_IFREG)
* that are ready for I/O. */
pthread_mutex_t notifierMutex;
/* Mutex protecting notifier termination in
* PlatformEventsFinalize. */
int triggerPipe[2]; /* pipe(2) used by other threads to wake
* up this thread for inter-thread IPC. */
int eventsFd; /* kqueue(2) file descriptor used to wait for
* fds. */
struct kevent *readyEvents; /* Pointer to at most maxReadyEvents events
* returned by kevent(2). */
size_t maxReadyEvents; /* Count of kevents in readyEvents. */
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
/*
* Forward declarations of internal functions.
*/
static void PlatformEventsControl(FileHandler *filePtr,
ThreadSpecificData *tsdPtr, int op, int isNew);
static void PlatformEventsFinalize(void);
static void PlatformEventsInit(void);
static int PlatformEventsTranslate(struct kevent *eventPtr);
static int PlatformEventsWait(struct kevent *events,
size_t numEvents, struct timeval *timePtr);
#include "tclUnixNotfy.c"
/*
*----------------------------------------------------------------------
*
* Tcl_InitNotifier --
*
|
| ︙ | ︙ | |||
176 177 178 179 180 181 182 183 184 185 186 187 188 189 | *---------------------------------------------------------------------- * * PlatformEventsControl -- * * This function registers interest for the file descriptor and the mask * of TCL_* bits associated with filePtr on the kqueue file descriptor * associated with tsdPtr. * Future calls to kevent will return filePtr and tsdPtr alongside with * the event registered here via the PlatformEventData struct. * * Results: * None. * * Side effects: | > | | | | | | | | | | | | | | | | | | | | | > | | | | | > | | | | | < > | | | > | > | | | | | | | | | | | | | | | | | | | | < | 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 |
*----------------------------------------------------------------------
*
* PlatformEventsControl --
*
* This function registers interest for the file descriptor and the mask
* of TCL_* bits associated with filePtr on the kqueue file descriptor
* associated with tsdPtr.
*
* Future calls to kevent will return filePtr and tsdPtr alongside with
* the event registered here via the PlatformEventData struct.
*
* Results:
* None.
*
* Side effects:
* - If adding a new file descriptor, a PlatformEventData struct will be
* allocated and associated with filePtr.
* - fstat is called on the file descriptor; if it is associated with
* a regular file (S_IFREG,) filePtr is considered to be ready for I/O
* and added to or deleted from the corresponding list in tsdPtr.
* - If it is not associated with a regular file, the file descriptor is
* added, modified concerning its mask of events of interest, or
* deleted from the epoll file descriptor of the calling thread.
* - If deleting a file descriptor, kevent(2) is called twice specifying
* EVFILT_READ first and then EVFILT_WRITE (see note below.)
*
*----------------------------------------------------------------------
*/
void
PlatformEventsControl(
FileHandler *filePtr,
ThreadSpecificData *tsdPtr,
int op,
int isNew)
{
int numChanges;
struct kevent changeList[2];
struct PlatformEventData *newPedPtr;
struct stat fdStat;
if (isNew) {
newPedPtr = Tcl_Alloc(sizeof(*newPedPtr));
newPedPtr->filePtr = filePtr;
newPedPtr->tsdPtr = tsdPtr;
filePtr->pedPtr = newPedPtr;
}
/*
* N.B. As discussed in Tcl_WaitForEvent(), kqueue(2) does not reproduce
* the `always ready' {select,poll}(2) behaviour for regular files
* (S_IFREG) prior to FreeBSD 11.0-RELEASE. Therefore, filePtr is in these
* cases simply added or deleted from the list of FileHandlers associated
* with regular files belonging to tsdPtr.
*/
if (fstat(filePtr->fd, &fdStat) == -1) {
Tcl_Panic("fstat: %s", strerror(errno));
} else if ((fdStat.st_mode & S_IFMT) == S_IFREG) {
switch (op) {
case EV_ADD:
if (isNew) {
LIST_INSERT_HEAD(&tsdPtr->firstReadyFileHandlerPtr, filePtr,
readyNode);
}
break;
case EV_DELETE:
LIST_REMOVE(filePtr, readyNode);
break;
}
return;
}
numChanges = 0;
switch (op) {
case EV_ADD:
if (filePtr->mask & (TCL_READABLE | TCL_EXCEPTION)) {
EV_SET(&changeList[numChanges], (uintptr_t)filePtr->fd,
EVFILT_READ, op, 0, 0, filePtr->pedPtr);
numChanges++;
}
if (filePtr->mask & TCL_WRITABLE) {
EV_SET(&changeList[numChanges], (uintptr_t)filePtr->fd,
EVFILT_WRITE, op, 0, 0, filePtr->pedPtr);
numChanges++;
}
if (numChanges) {
if (kevent(tsdPtr->eventsFd, changeList, numChanges, NULL, 0,
NULL) == -1) {
Tcl_Panic("kevent: %s", strerror(errno));
}
}
break;
case EV_DELETE:
/*
* N.B. kqueue(2) has separate filters for readability and writability
* fd events. We therefore need to ensure that fds are ompletely
* removed from the kqueue(2) fd when deleting. This is exacerbated
* by changes to filePtr->mask w/o calls to PlatforEventsControl()
* after e.g. an exec(3) in a child process.
*
* As one of these calls can fail, two separate kevent(2) calls are
* made for EVFILT_{READ,WRITE}.
*/
EV_SET(&changeList[0], (uintptr_t)filePtr->fd, EVFILT_READ, op, 0, 0,
NULL);
if ((kevent(tsdPtr->eventsFd, changeList, 1, NULL, 0, NULL) == -1)
&& (errno != ENOENT)) {
Tcl_Panic("kevent: %s", strerror(errno));
}
EV_SET(&changeList[0], (uintptr_t)filePtr->fd, EVFILT_WRITE, op, 0, 0,
NULL);
if ((kevent(tsdPtr->eventsFd, changeList, 1, NULL, 0, NULL) == -1)
&& (errno != ENOENT)) {
Tcl_Panic("kevent: %s", strerror(errno));
}
break;
}
}
/*
*----------------------------------------------------------------------
*
* PlatformEventsFinalize --
*
* This function closes the pipe and the kqueue file descriptors and
* frees the kevent structs owned by the thread of the caller. The above
* operations are protected by tsdPtr->notifierMutex, which is destroyed
* thereafter.
*
* Results:
* None.
*
* Side effects:
* While tsdPtr->notifierMutex is held:
* The per-thread pipe(2) fds are closed, if non-zero, and set to -1.
* The per-thread kqueue(2) fd is closed, if non-zero, and set to 0.
* The per-thread kevent structs are freed, if any, and set to 0.
*
* tsdPtr->notifierMutex is destroyed.
*
*----------------------------------------------------------------------
*/
void
PlatformEventsFinalize(
void)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
pthread_mutex_lock(&tsdPtr->notifierMutex);
if (tsdPtr->triggerPipe[0]) {
close(tsdPtr->triggerPipe[0]);
tsdPtr->triggerPipe[0] = -1;
}
if (tsdPtr->triggerPipe[1]) {
close(tsdPtr->triggerPipe[1]);
tsdPtr->triggerPipe[1] = -1;
}
if (tsdPtr->eventsFd > 0) {
close(tsdPtr->eventsFd);
tsdPtr->eventsFd = 0;
}
if (tsdPtr->readyEvents) {
Tcl_Free(tsdPtr->readyEvents);
tsdPtr->maxReadyEvents = 0;
}
pthread_mutex_unlock(&tsdPtr->notifierMutex);
if ((errno = pthread_mutex_destroy(&tsdPtr->notifierMutex))) {
Tcl_Panic("pthread_mutex_destroy: %s", strerror(errno));
}
}
/*
*----------------------------------------------------------------------
*
* PlatformEventsInit --
*
* This function abstracts creating a kqueue fd via the kqueue system
* call and allocating memory for the kevents structs in tsdPtr for the
* thread of the caller.
*
* Results:
* None.
*
* Side effects:
* The following per-thread entities are initialised:
* - notifierMutex is initialised.
* - The pipe(2) is created; fcntl(2) is called on both fds to set
* FD_CLOEXEC and O_NONBLOCK.
* - The kqueue(2) fd is created; fcntl(2) is called on it to set
* FD_CLOEXEC.
* - A FileHandler struct is allocated and initialised for the event-
* fd(2), registering interest for TCL_READABLE on it via Platform-
* EventsControl().
* - readyEvents and maxReadyEvents are initialised with 512 kevents.
*
*----------------------------------------------------------------------
*/
void
PlatformEventsInit(void)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
int i, fdFl;
FileHandler *filePtr;
errno = pthread_mutex_init(&tsdPtr->notifierMutex, NULL);
if (errno) {
|
| ︙ | ︙ | |||
394 395 396 397 398 399 400 |
}
}
if ((tsdPtr->eventsFd = kqueue()) == -1) {
Tcl_Panic("kqueue: %s", strerror(errno));
} else if (fcntl(tsdPtr->eventsFd, F_SETFD, FD_CLOEXEC) == -1) {
Tcl_Panic("fcntl: %s", strerror(errno));
}
| | | | | 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 |
}
}
if ((tsdPtr->eventsFd = kqueue()) == -1) {
Tcl_Panic("kqueue: %s", strerror(errno));
} else if (fcntl(tsdPtr->eventsFd, F_SETFD, FD_CLOEXEC) == -1) {
Tcl_Panic("fcntl: %s", strerror(errno));
}
filePtr = Tcl_Alloc(sizeof(*filePtr));
filePtr->fd = tsdPtr->triggerPipe[0];
filePtr->mask = TCL_READABLE;
PlatformEventsControl(filePtr, tsdPtr, EV_ADD, 1);
if (!tsdPtr->readyEvents) {
tsdPtr->maxReadyEvents = 512;
tsdPtr->readyEvents = Tcl_Alloc(
tsdPtr->maxReadyEvents * sizeof(tsdPtr->readyEvents[0]));
}
LIST_INIT(&tsdPtr->firstReadyFileHandlerPtr);
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
425 426 427 428 429 430 431 | * None. * *---------------------------------------------------------------------- */ int PlatformEventsTranslate( | | | 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 |
* None.
*
*----------------------------------------------------------------------
*/
int
PlatformEventsTranslate(
struct kevent *eventPtr)
{
int mask;
mask = 0;
if (eventPtr->filter == EVFILT_READ) {
mask |= TCL_READABLE;
if (eventPtr->flags & EV_ERROR) {
|
| ︙ | ︙ | |||
450 451 452 453 454 455 456 | } /* *---------------------------------------------------------------------- * * PlatformEventsWait -- * | | | | | | | | | | | | | | | | > | | | | 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 |
}
/*
*----------------------------------------------------------------------
*
* PlatformEventsWait --
*
* This function abstracts waiting for I/O events via the kevent system
* call.
*
* Results:
* Returns -1 if kevent failed. Returns 0 if polling and if no events
* became available whilst polling. Returns a pointer to and the count of
* all returned events in all other cases.
*
* Side effects:
* gettimeofday(2), kevent(2), and gettimeofday(2) are called, in the
* specified order.
* If timePtr specifies a positive value, it is updated to reflect the
* amount of time that has passed; if its value would {under, over}flow,
* it is set to zero.
*
*----------------------------------------------------------------------
*/
int
PlatformEventsWait(
struct kevent *events,
size_t numEvents,
struct timeval *timePtr)
{
int numFound;
struct timeval tv0, tv1, tv_delta;
struct timespec timeout, *timeoutPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
/*
* If timePtr is NULL, kevent(2) will wait indefinitely. If it specifies a
* timeout of {0,0}, kevent(2) will poll. Otherwise, the timeout will
* simply be converted to a timespec.
*/
if (!timePtr) {
timeoutPtr = NULL;
} else if (!timePtr->tv_sec && !timePtr->tv_usec) {
timeout.tv_sec = 0;
timeout.tv_nsec = 0;
timeoutPtr = &timeout;
} else {
timeout.tv_sec = timePtr->tv_sec;
timeout.tv_nsec = timePtr->tv_usec * 1000;
timeoutPtr = &timeout;
}
/*
* Call (and possibly block on) kevent(2) and substract the delta of
* gettimeofday(2) before and after the call from timePtr if the latter is
* not NULL. Return the number of events returned by kevent(2).
*/
gettimeofday(&tv0, NULL);
numFound = kevent(tsdPtr->eventsFd, NULL, 0, events, (int) numEvents,
timeoutPtr);
gettimeofday(&tv1, NULL);
if (timePtr && (timePtr->tv_sec && timePtr->tv_usec)) {
timersub(&tv1, &tv0, &tv_delta);
if (!timercmp(&tv_delta, timePtr, >)) {
timersub(timePtr, &tv_delta, timePtr);
} else {
timePtr->tv_sec = 0;
timePtr->tv_usec = 0;
}
}
return numFound;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
564 565 566 567 568 569 570 |
for (filePtr = tsdPtr->firstFileHandlerPtr; filePtr != NULL;
filePtr = filePtr->nextPtr) {
if (filePtr->fd == fd) {
break;
}
}
if (filePtr == NULL) {
| | | 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 |
for (filePtr = tsdPtr->firstFileHandlerPtr; filePtr != NULL;
filePtr = filePtr->nextPtr) {
if (filePtr->fd == fd) {
break;
}
}
if (filePtr == NULL) {
filePtr = Tcl_Alloc(sizeof(FileHandler));
filePtr->fd = fd;
filePtr->readyMask = 0;
filePtr->nextPtr = tsdPtr->firstFileHandlerPtr;
tsdPtr->firstFileHandlerPtr = filePtr;
isNew = 1;
} else {
isNew = 0;
|
| ︙ | ︙ | |||
586 587 588 589 590 591 592 | } /* *---------------------------------------------------------------------- * * Tcl_DeleteFileHandler -- * | | | | 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 | } /* *---------------------------------------------------------------------- * * Tcl_DeleteFileHandler -- * * Cancel a previously-arranged callback arrangement for a file on the * kqueue of the thread of the caller. * * Results: * None. * * Side effects: * If a callback was previously registered on file, remove it. * PlatformEventsControl() is called for the file handler structure. |
| ︙ | ︙ | |||
633 634 635 636 637 638 639 |
/*
* Update the check masks for this file.
*/
PlatformEventsControl(filePtr, tsdPtr, EV_DELETE, 0);
if (filePtr->pedPtr) {
| | | > | 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 |
/*
* Update the check masks for this file.
*/
PlatformEventsControl(filePtr, tsdPtr, EV_DELETE, 0);
if (filePtr->pedPtr) {
Tcl_Free(filePtr->pedPtr);
}
/*
* Clean up information in the callback record.
*/
if (prevPtr == NULL) {
tsdPtr->firstFileHandlerPtr = filePtr->nextPtr;
} else {
prevPtr->nextPtr = filePtr->nextPtr;
}
Tcl_Free(filePtr);
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_WaitForEvent --
*
* This function is called by Tcl_DoOneEvent to wait for new events on
* the message queue. If the block time is 0, then Tcl_WaitForEvent just
* polls without blocking.
*
* The waiting logic is implemented in PlatformEventsWait.
*
* Results:
* Returns -1 if PlatformEventsWait() would block forever, otherwise
* returns 0.
*
* Side effects:
|
| ︙ | ︙ | |||
722 723 724 725 726 727 728 729 | timeoutPtr = NULL; } /* * Walk the list of FileHandlers associated with regular files * (S_IFREG) belonging to tsdPtr, queue Tcl events for them, and * update their mask of events of interest. * kqueue(2), unlike epoll(7), does support regular files, but | > | | | | > | 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 |
timeoutPtr = NULL;
}
/*
* Walk the list of FileHandlers associated with regular files
* (S_IFREG) belonging to tsdPtr, queue Tcl events for them, and
* update their mask of events of interest.
*
* kqueue(2), unlike epoll(7), does support regular files, but
* EVFILT_READ only `[r]eturns when the file pointer is not at the end
* of file' as opposed to unconditionally. While FreeBSD 11.0-RELEASE
* adds support for this mode (NOTE_FILE_POLL,) this is not used for
* reasons of compatibility.
*
* Therefore, the behaviour of {select,poll}(2) is simply simulated
* here: fds associated with regular files are added to this list by
* PlatformEventsControl() and processed here before calling (and
* possibly blocking) on PlatformEventsWait().
*/
numQueued = 0;
|
| ︙ | ︙ | |||
750 751 752 753 754 755 756 |
/*
* Don't bother to queue an event if the mask was previously
* non-zero since an event must still be on the queue.
*/
if (filePtr->readyMask == 0) {
FileHandlerEvent *fileEvPtr =
| | | 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 |
/*
* Don't bother to queue an event if the mask was previously
* non-zero since an event must still be on the queue.
*/
if (filePtr->readyMask == 0) {
FileHandlerEvent *fileEvPtr =
Tcl_Alloc(sizeof(FileHandlerEvent));
fileEvPtr->header.proc = FileHandlerEventProc;
fileEvPtr->fd = filePtr->fd;
Tcl_QueueEvent((Tcl_Event *) fileEvPtr, TCL_QUEUE_TAIL);
numQueued++;
}
filePtr->readyMask = mask;
|
| ︙ | ︙ | |||
784 785 786 787 788 789 790 | * Events for the trigger pipe are processed here in order to facilitate * inter-thread IPC. If another thread intends to wake up this thread * whilst it's blocking on PlatformEventsWait(), it write(2)s to the * other end of the pipe (see Tcl_AlertNotifier(),) which in turn will * cause PlatformEventsWait() to return immediately. */ | | > | > < | | | < | < < | < | > < < | 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 |
* Events for the trigger pipe are processed here in order to facilitate
* inter-thread IPC. If another thread intends to wake up this thread
* whilst it's blocking on PlatformEventsWait(), it write(2)s to the
* other end of the pipe (see Tcl_AlertNotifier(),) which in turn will
* cause PlatformEventsWait() to return immediately.
*/
numFound = PlatformEventsWait(tsdPtr->readyEvents,
tsdPtr->maxReadyEvents, timeoutPtr);
for (numEvent = 0; numEvent < numFound; numEvent++) {
pedPtr = (struct PlatformEventData *)
tsdPtr->readyEvents[numEvent].udata;
filePtr = pedPtr->filePtr;
mask = PlatformEventsTranslate(&tsdPtr->readyEvents[numEvent]);
if (filePtr->fd == tsdPtr->triggerPipe[0]) {
i = read(tsdPtr->triggerPipe[0], buf, 1);
if ((i == -1) && (errno != EAGAIN)) {
Tcl_Panic("Tcl_WaitForEvent: read from %p->triggerPipe: %s",
(void *) tsdPtr, strerror(errno));
}
continue;
}
if (!mask) {
continue;
}
/*
* Don't bother to queue an event if the mask was previously
* non-zero since an event must still be on the queue.
*/
if (filePtr->readyMask == 0) {
FileHandlerEvent *fileEvPtr =
Tcl_Alloc(sizeof(FileHandlerEvent));
fileEvPtr->header.proc = FileHandlerEventProc;
fileEvPtr->fd = filePtr->fd;
Tcl_QueueEvent((Tcl_Event *) fileEvPtr, TCL_QUEUE_TAIL);
}
filePtr->readyMask |= mask;
}
return 0;
}
}
#endif /* NOTIFIER_KQUEUE && TCL_THREADS */
#endif /* !HAVE_COREFOUNDATION */
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to unix/tclLoadAix.c.
| ︙ | ︙ | |||
130 131 132 133 134 135 136 |
if (mp == NULL) {
errvalid++;
strcpy(errbuf, "calloc: ");
strcat(errbuf, strerror(errno));
return NULL;
}
| | | 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 |
if (mp == NULL) {
errvalid++;
strcpy(errbuf, "calloc: ");
strcat(errbuf, strerror(errno));
return NULL;
}
mp->name = malloc(strlen(path) + 1);
strcpy(mp->name, path);
/*
* load should be declared load(const char *...). Thus we cast the path to
* a normal char *. Ugly.
*/
|
| ︙ | ︙ | |||
537 538 539 540 541 542 543 | * end. */ strncpy(tmpsym, ls->l_name, SYMNMLEN); tmpsym[SYMNMLEN] = '\0'; symname = tmpsym; } | | | 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 |
* end.
*/
strncpy(tmpsym, ls->l_name, SYMNMLEN);
tmpsym[SYMNMLEN] = '\0';
symname = tmpsym;
}
ep->name = malloc(strlen(symname) + 1);
strcpy(ep->name, symname);
ep->addr = (void *)((unsigned long)
mp->entry + ls->l_value - shdata.s_vaddr);
ep++;
}
free(ldbuf);
while (ldclose(ldp) == FAILURE) {
|
| ︙ | ︙ |
Changes to unix/tclLoadDl.c.
| ︙ | ︙ | |||
102 103 104 105 106 107 108 | /* * Let the OS loader examine the binary search path for whatever * string the user gave us which hopefully refers to a file on the * binary path. */ Tcl_DString ds; | | | | | 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 |
/*
* Let the OS loader examine the binary search path for whatever
* string the user gave us which hopefully refers to a file on the
* binary path.
*/
Tcl_DString ds;
const char *fileName = TclGetString(pathPtr);
native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds);
/*
* Use (RTLD_NOW|RTLD_LOCAL) as default, see [Bug #3216070]
*/
handle = dlopen(native, dlopenflags);
Tcl_DStringFree(&ds);
}
if (handle == NULL) {
/*
* Write the string to a variable first to work around a compiler bug
* in the Sun Forte 6 compiler. [Bug 1503729]
*/
const char *errorStr = dlerror();
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't load file \"%s\": %s",
TclGetString(pathPtr), errorStr));
}
return TCL_ERROR;
}
newHandle = Tcl_Alloc(sizeof(*newHandle));
newHandle->clientData = handle;
newHandle->findSymbolProcPtr = &FindSymbol;
newHandle->unloadFileProcPtr = &UnloadFile;
*unloadProcPtr = &UnloadFile;
*loadHandle = newHandle;
return TCL_OK;
|
| ︙ | ︙ | |||
228 229 230 231 232 233 234 |
Tcl_LoadHandle loadHandle) /* loadHandle returned by a previous call to
* TclpDlopen(). The loadHandle is a token
* that represents the loaded file. */
{
void *handle = loadHandle->clientData;
dlclose(handle);
| | | 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 |
Tcl_LoadHandle loadHandle) /* loadHandle returned by a previous call to
* TclpDlopen(). The loadHandle is a token
* that represents the loaded file. */
{
void *handle = loadHandle->clientData;
dlclose(handle);
Tcl_Free(loadHandle);
}
/*
*----------------------------------------------------------------------
*
* TclGuessPackageName --
*
|
| ︙ | ︙ |
Changes to unix/tclLoadDyld.c.
| ︙ | ︙ | |||
180 181 182 183 184 185 186 |
/*
* First try the full path the user gave us. This is particularly
* important if the cwd is inside a vfs, and we are trying to load using a
* relative path.
*/
nativePath = Tcl_FSGetNativePath(pathPtr);
| | | 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 |
/*
* First try the full path the user gave us. This is particularly
* important if the cwd is inside a vfs, and we are trying to load using a
* relative path.
*/
nativePath = Tcl_FSGetNativePath(pathPtr);
nativeFileName = Tcl_UtfToExternalDString(NULL, TclGetString(pathPtr),
-1, &ds);
#if TCL_DYLD_USE_DLFCN
/*
* Use (RTLD_NOW|RTLD_LOCAL) as default, see [Bug #3216070]
*/
|
| ︙ | ︙ | |||
254 255 256 257 258 259 260 |
if (err == NSObjectFileImageSuccess && dyldObjFileImage) {
int nsflags = NSLINKMODULE_OPTION_RETURN_ON_ERROR;
if (!(flags & 1)) nsflags |= NSLINKMODULE_OPTION_PRIVATE;
if (!(flags & 2)) nsflags |= NSLINKMODULE_OPTION_BINDNOW;
module = NSLinkModule(dyldObjFileImage, nativePath, nsflags);
NSDestroyObjectFileImage(dyldObjFileImage);
if (module) {
| | | | | 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 |
if (err == NSObjectFileImageSuccess && dyldObjFileImage) {
int nsflags = NSLINKMODULE_OPTION_RETURN_ON_ERROR;
if (!(flags & 1)) nsflags |= NSLINKMODULE_OPTION_PRIVATE;
if (!(flags & 2)) nsflags |= NSLINKMODULE_OPTION_BINDNOW;
module = NSLinkModule(dyldObjFileImage, nativePath, nsflags);
NSDestroyObjectFileImage(dyldObjFileImage);
if (module) {
modulePtr = Tcl_Alloc(sizeof(Tcl_DyldModuleHandle));
modulePtr->module = module;
modulePtr->nextPtr = NULL;
} else {
NSLinkEditError(&editError, &errorNumber, &errorName,
&errMsg);
}
} else {
objFileImageErrMsg = DyldOFIErrorMsg(err);
}
}
}
#endif /* TCL_DYLD_USE_NSMODULE */
}
if (dlHandle
#if TCL_DYLD_USE_NSMODULE
|| dyldLibHeader || modulePtr
#endif /* TCL_DYLD_USE_NSMODULE */
) {
dyldLoadHandle = Tcl_Alloc(sizeof(Tcl_DyldLoadHandle));
dyldLoadHandle->dlHandle = dlHandle;
#if TCL_DYLD_USE_NSMODULE || defined(TCL_LOAD_FROM_MEMORY)
dyldLoadHandle->dyldLibHeader = dyldLibHeader;
dyldLoadHandle->modulePtr = modulePtr;
#endif /* TCL_DYLD_USE_NSMODULE || TCL_LOAD_FROM_MEMORY */
newHandle = Tcl_Alloc(sizeof(*newHandle));
newHandle->clientData = dyldLoadHandle;
newHandle->findSymbolProcPtr = &FindSymbol;
newHandle->unloadFileProcPtr = &UnloadFile;
*unloadProcPtr = &UnloadFile;
*loadHandle = newHandle;
result = TCL_OK;
} else {
|
| ︙ | ︙ | |||
377 378 379 380 381 382 383 |
while (modulePtr != NULL) {
if (module == modulePtr->module) {
break;
}
modulePtr = modulePtr->nextPtr;
}
if (modulePtr == NULL) {
| | | 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 |
while (modulePtr != NULL) {
if (module == modulePtr->module) {
break;
}
modulePtr = modulePtr->nextPtr;
}
if (modulePtr == NULL) {
modulePtr = Tcl_Alloc(sizeof(Tcl_DyldModuleHandle));
modulePtr->module = module;
modulePtr->nextPtr = dyldLoadHandle->modulePtr;
dyldLoadHandle->modulePtr = modulePtr;
}
#endif /* DYLD_SUPPORTS_DYLIB_UNLOADING */
} else {
NSLinkEditErrors editError;
|
| ︙ | ︙ | |||
452 453 454 455 456 457 458 |
while (modulePtr != NULL) {
void *ptr = modulePtr;
(void) NSUnLinkModule(modulePtr->module,
NSUNLINKMODULE_OPTION_RESET_LAZY_REFERENCES);
modulePtr = modulePtr->nextPtr;
| | | | | 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 |
while (modulePtr != NULL) {
void *ptr = modulePtr;
(void) NSUnLinkModule(modulePtr->module,
NSUNLINKMODULE_OPTION_RESET_LAZY_REFERENCES);
modulePtr = modulePtr->nextPtr;
Tcl_Free(ptr);
}
#endif /* TCL_DYLD_USE_NSMODULE */
}
Tcl_Free(dyldLoadHandle);
Tcl_Free(loadHandle);
}
/*
*----------------------------------------------------------------------
*
* TclGuessPackageName --
*
|
| ︙ | ︙ | |||
689 690 691 692 693 694 695 |
return TCL_ERROR;
}
/*
* Stash the module reference within the load handle we create and return.
*/
| | | | | 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 |
return TCL_ERROR;
}
/*
* Stash the module reference within the load handle we create and return.
*/
modulePtr = Tcl_Alloc(sizeof(Tcl_DyldModuleHandle));
modulePtr->module = module;
modulePtr->nextPtr = NULL;
dyldLoadHandle = Tcl_Alloc(sizeof(Tcl_DyldLoadHandle));
dyldLoadHandle->dlHandle = NULL;
dyldLoadHandle->dyldLibHeader = NULL;
dyldLoadHandle->modulePtr = modulePtr;
newHandle = Tcl_Alloc(sizeof(*newHandle));
newHandle->clientData = dyldLoadHandle;
newHandle->findSymbolProcPtr = &FindSymbol;
newHandle->unloadFileProcPtr = &UnloadFile;
*loadHandle = newHandle;
*unloadProcPtr = &UnloadFile;
return TCL_OK;
}
|
| ︙ | ︙ |
Changes to unix/tclLoadNext.c.
| ︙ | ︙ | |||
57 58 59 60 61 62 63 |
char *fileName;
char *files[2];
const char *native;
int result = 1;
NXStream *errorStream = NXOpenMemory(0,0,NX_READWRITE);
| | | 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 |
char *fileName;
char *files[2];
const char *native;
int result = 1;
NXStream *errorStream = NXOpenMemory(0,0,NX_READWRITE);
fileName = TclGetString(pathPtr);
/*
* First try the full path the user gave us. This is particularly
* important if the cwd is inside a vfs, and we are trying to load using a
* relative path.
*/
|
| ︙ | ︙ | |||
97 98 99 100 101 102 103 |
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't load file \"%s\": %s", fileName, data));
NXCloseMemory(errorStream, NX_FREEBUFFER);
return TCL_ERROR;
}
NXCloseMemory(errorStream, NX_FREEBUFFER);
| | | 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 |
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't load file \"%s\": %s", fileName, data));
NXCloseMemory(errorStream, NX_FREEBUFFER);
return TCL_ERROR;
}
NXCloseMemory(errorStream, NX_FREEBUFFER);
newHandle = Tcl_Alloc(sizeof(Tcl_LoadHandle));
newHandle->clientData = INT2PTR(1);
newHandle->findSymbolProcPtr = &FindSymbol;
newHandle->unloadFileProcPtr = &UnloadFile;
*loadHandle = newHandle;
*unloadProcPtr = &UnloadFile;
return TCL_OK;
|
| ︙ | ︙ | |||
171 172 173 174 175 176 177 |
void
UnloadFile(
Tcl_LoadHandle loadHandle) /* loadHandle returned by a previous call to
* TclpDlopen(). The loadHandle is a token
* that represents the loaded file. */
{
| | | 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 |
void
UnloadFile(
Tcl_LoadHandle loadHandle) /* loadHandle returned by a previous call to
* TclpDlopen(). The loadHandle is a token
* that represents the loaded file. */
{
Tcl_Free(loadHandle);
}
/*
*----------------------------------------------------------------------
*
* TclGuessPackageName --
*
|
| ︙ | ︙ |
Changes to unix/tclLoadOSF.c.
| ︙ | ︙ | |||
75 76 77 78 79 80 81 |
* function which should be used for this
* file. */
int flags)
{
Tcl_LoadHandle newHandle;
ldr_module_t lm;
char *pkg;
| | | 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 |
* function which should be used for this
* file. */
int flags)
{
Tcl_LoadHandle newHandle;
ldr_module_t lm;
char *pkg;
char *fileName = TclGetString(pathPtr);
const char *native;
/*
* First try the full path the user gave us. This is particularly
* important if the cwd is inside a vfs, and we are trying to load using a
* relative path.
*/
|
| ︙ | ︙ | |||
124 125 126 127 128 129 130 |
*/
if ((pkg = strrchr(fileName, '/')) == NULL) {
pkg = fileName;
} else {
pkg++;
}
| | | 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 |
*/
if ((pkg = strrchr(fileName, '/')) == NULL) {
pkg = fileName;
} else {
pkg++;
}
newHandle = Tcl_Alloc(sizeof(*newHandle));
newHandle->clientData = pkg;
newHandle->findSymbolProcPtr = &FindSymbol;
newHandle->unloadFileProcPtr = &UnloadFile;
*loadHandle = newHandle;
*unloadProcPtr = &UnloadFile;
return TCL_OK;
}
|
| ︙ | ︙ | |||
189 190 191 192 193 194 195 |
static void
UnloadFile(
Tcl_LoadHandle loadHandle) /* loadHandle returned by a previous call to
* TclpDlopen(). The loadHandle is a token
* that represents the loaded file. */
{
| | | 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 |
static void
UnloadFile(
Tcl_LoadHandle loadHandle) /* loadHandle returned by a previous call to
* TclpDlopen(). The loadHandle is a token
* that represents the loaded file. */
{
Tcl_Free(loadHandle);
}
/*
*----------------------------------------------------------------------
*
* TclGuessPackageName --
*
|
| ︙ | ︙ |
Changes to unix/tclLoadShl.c.
| ︙ | ︙ | |||
53 54 55 56 57 58 59 |
* function which should be used for this
* file. */
int flags)
{
shl_t handle;
Tcl_LoadHandle newHandle;
const char *native;
| | | 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 |
* function which should be used for this
* file. */
int flags)
{
shl_t handle;
Tcl_LoadHandle newHandle;
const char *native;
char *fileName = TclGetString(pathPtr);
/*
* The flags below used to be BIND_IMMEDIATE; they were changed at the
* suggestion of Wolfgang Kechel (wolfgang@prs.de): "This enables
* verbosity for missing symbols when loading a shared lib and allows to
* load libtk8.0.sl into tclsh8.0 without problems. In general, this
* delays resolving symbols until they are actually needed. Shared libs
|
| ︙ | ︙ | |||
93 94 95 96 97 98 99 |
if (handle == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't load file \"%s\": %s",
fileName, Tcl_PosixError(interp)));
return TCL_ERROR;
}
| | | 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 |
if (handle == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't load file \"%s\": %s",
fileName, Tcl_PosixError(interp)));
return TCL_ERROR;
}
newHandle = Tcl_Alloc(sizeof(*newHandle));
newHandle->clientData = handle;
newHandle->findSymbolProcPtr = &FindSymbol;
newHandle->unloadFileProcPtr = *unloadProcPtr = &UnloadFile;
*loadHandle = newHandle;
return TCL_OK;
}
|
| ︙ | ︙ | |||
178 179 180 181 182 183 184 |
Tcl_LoadHandle loadHandle) /* loadHandle returned by a previous call to
* TclpDlopen(). The loadHandle is a token
* that represents the loaded file. */
{
shl_t handle = (shl_t) loadHandle->clientData;
shl_unload(handle);
| | | 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 |
Tcl_LoadHandle loadHandle) /* loadHandle returned by a previous call to
* TclpDlopen(). The loadHandle is a token
* that represents the loaded file. */
{
shl_t handle = (shl_t) loadHandle->clientData;
shl_unload(handle);
Tcl_Free(loadHandle);
}
/*
*----------------------------------------------------------------------
*
* TclGuessPackageName --
*
|
| ︙ | ︙ |
Changes to unix/tclSelectNotfy.c.
1 2 3 | /* * tclSelectNotfy.c -- * | | | | < < > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 | /* * tclSelectNotfy.c -- * * This file contains the implementation of the select()-based generic * Unix notifier, which is the lowest-level part of the Tcl event loop. * This file works together with generic/tclNotify.c. * * Copyright (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" #ifndef HAVE_COREFOUNDATION /* Darwin/Mac OS X CoreFoundation notifier is * in tclMacOSXNotify.c */ #if (!defined(NOTIFIER_EPOLL) && !defined(NOTIFIER_KQUEUE)) || !TCL_THREADS #include <signal.h> /* * This structure is used to keep track of the notifier info for a registered * file. */ |
| ︙ | ︙ | |||
77 78 79 80 81 82 83 |
* to Tcl_CreateFileHandler. */
SelectMasks readyMasks; /* This array reflects the readable/writable
* conditions that were found to exist by the
* last call to select. */
int numFdBits; /* Number of valid bits in checkMasks (one
* more than highest fd for which
* Tcl_WatchFile has been called). */
| | | | | | > | | 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 |
* to Tcl_CreateFileHandler. */
SelectMasks readyMasks; /* This array reflects the readable/writable
* conditions that were found to exist by the
* last call to select. */
int numFdBits; /* Number of valid bits in checkMasks (one
* more than highest fd for which
* Tcl_WatchFile has been called). */
#if TCL_THREADS
int onList; /* True if it is in this list */
unsigned int pollState; /* pollState is used to implement a polling
* handshake between each thread and the
* notifier thread. Bits defined below. */
struct ThreadSpecificData *nextPtr, *prevPtr;
/* All threads that are currently waiting on
* an event have their ThreadSpecificData
* structure on a doubly-linked listed formed
* from these pointers. You must hold the
* notifierMutex lock before accessing these
* fields. */
#ifdef __CYGWIN__
void *event; /* Any other thread alerts a notifier that an
* event is ready to be processed by sending
* this event. */
void *hwnd; /* Messaging window. */
#else /* !__CYGWIN__ */
pthread_cond_t waitCV; /* Any other thread alerts a notifier that an
* event is ready to be processed by signaling
* this condition variable. */
#endif /* __CYGWIN__ */
int waitCVinitialized; /* Variable to flag initialization of the
* structure. */
int eventReady; /* True if an event is ready to be processed.
* Used as condition flag together with waitCV
* above. */
#endif /* TCL_THREADS */
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
#if TCL_THREADS
/*
* The following static indicates the number of threads that have initialized
* notifiers.
*
* You must hold the notifierMutex lock before accessing this variable.
*/
|
| ︙ | ︙ | |||
167 168 169 170 171 172 173 | * initializing the triggerPipe and right before the notifier thread * terminates. */ static pthread_cond_t notifierCV = PTHREAD_COND_INITIALIZER; /* | | > | | > | | | | | | | | | | | | | | | | | > | 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 |
* initializing the triggerPipe and right before the notifier thread
* terminates.
*/
static pthread_cond_t notifierCV = PTHREAD_COND_INITIALIZER;
/*
* The pollState bits:
*
* POLL_WANT is set by each thread before it waits on its condition variable.
* It is checked by the notifier before it does select.
*
* POLL_DONE is set by the notifier if it goes into select after seeing
* POLL_WANT. The idea is to ensure it tries a select with the same bits
* the initial thread had set.
*/
#define POLL_WANT 0x1
#define POLL_DONE 0x2
/*
* This is the thread ID of the notifier thread that does select.
*/
static Tcl_ThreadId notifierThread;
#endif /* TCL_THREADS */
/*
* Static routines defined in this file.
*/
#if TCL_THREADS
static TCL_NORETURN void NotifierThreadProc(ClientData clientData);
#if defined(HAVE_PTHREAD_ATFORK)
static int atForkInit = 0;
static void AtForkChild(void);
#endif /* HAVE_PTHREAD_ATFORK */
#endif /* TCL_THREADS */
static int FileHandlerEventProc(Tcl_Event *evPtr, int flags);
/*
* Import of critical bits of Windows API when building threaded with Cygwin.
*/
#if defined(__CYGWIN__)
typedef struct {
void *hwnd; /* Messaging window. */
unsigned int *message; /* Message payload. */
int wParam; /* Event-specific "word" parameter. */
int lParam; /* Event-specific "long" parameter. */
int time; /* Event timestamp. */
int x; /* Event location (where meaningful). */
int y;
} MSG;
typedef struct {
unsigned int style;
void *lpfnWndProc;
int cbClsExtra;
int cbWndExtra;
void *hInstance;
void *hIcon;
void *hCursor;
void *hbrBackground;
void *lpszMenuName;
const void *lpszClassName;
} WNDCLASS;
extern void __stdcall CloseHandle(void *);
extern void *__stdcall CreateEventW(void *, unsigned char, unsigned char,
void *);
extern void *__stdcall CreateWindowExW(void *, const void *, const void *,
DWORD, int, int, int, int, void *, void *, void *,
void *);
extern DWORD __stdcall DefWindowProcW(void *, int, void *, void *);
extern unsigned char __stdcall DestroyWindow(void *);
extern int __stdcall DispatchMessageW(const MSG *);
extern unsigned char __stdcall GetMessageW(MSG *, void *, int, int);
extern void __stdcall MsgWaitForMultipleObjects(DWORD, void *,
unsigned char, DWORD, DWORD);
extern unsigned char __stdcall PeekMessageW(MSG *, void *, int, int, int);
|
| ︙ | ︙ | |||
281 282 283 284 285 286 287 |
Tcl_InitNotifier(void)
{
if (tclNotifierHooks.initNotifierProc) {
return tclNotifierHooks.initNotifierProc();
} else {
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
| | | 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 |
Tcl_InitNotifier(void)
{
if (tclNotifierHooks.initNotifierProc) {
return tclNotifierHooks.initNotifierProc();
} else {
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
#if TCL_THREADS
tsdPtr->eventReady = 0;
/*
* Initialize thread specific condition variable for this thread.
*/
if (tsdPtr->waitCVinitialized == 0) {
#ifdef __CYGWIN__
|
| ︙ | ︙ | |||
332 333 334 335 336 337 338 |
Tcl_Panic("Tcl_InitNotifier: pthread_atfork failed");
}
atForkInit = 1;
}
#endif /* HAVE_PTHREAD_ATFORK */
notifierCount++;
| < | 336 337 338 339 340 341 342 343 344 345 346 347 348 349 |
Tcl_Panic("Tcl_InitNotifier: pthread_atfork failed");
}
atForkInit = 1;
}
#endif /* HAVE_PTHREAD_ATFORK */
notifierCount++;
pthread_mutex_unlock(¬ifierInitMutex);
#endif /* TCL_THREADS */
return tsdPtr;
}
}
|
| ︙ | ︙ | |||
366 367 368 369 370 371 372 |
Tcl_FinalizeNotifier(
ClientData clientData) /* Not used. */
{
if (tclNotifierHooks.finalizeNotifierProc) {
tclNotifierHooks.finalizeNotifierProc(clientData);
return;
} else {
| | | < < | | | | | | | | | | | | | | | | | < | 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 |
Tcl_FinalizeNotifier(
ClientData clientData) /* Not used. */
{
if (tclNotifierHooks.finalizeNotifierProc) {
tclNotifierHooks.finalizeNotifierProc(clientData);
return;
} else {
#if TCL_THREADS
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
pthread_mutex_lock(¬ifierInitMutex);
notifierCount--;
/*
* If this is the last thread to use the notifier, close the notifier
* pipe and wait for the background thread to terminate.
*/
if (notifierCount == 0 && triggerPipe != -1) {
if (write(triggerPipe, "q", 1) != 1) {
Tcl_Panic("Tcl_FinalizeNotifier: %s",
"unable to write 'q' to triggerPipe");
}
close(triggerPipe);
pthread_mutex_lock(¬ifierMutex);
while(triggerPipe != -1) {
pthread_cond_wait(¬ifierCV, ¬ifierMutex);
}
pthread_mutex_unlock(¬ifierMutex);
if (notifierThreadRunning) {
int result = pthread_join((pthread_t) notifierThread, NULL);
if (result) {
Tcl_Panic("Tcl_FinalizeNotifier: %s",
"unable to join notifier thread");
}
notifierThreadRunning = 0;
}
}
/*
* Clean up any synchronization objects in the thread local storage.
*/
|
| ︙ | ︙ | |||
460 461 462 463 464 465 466 |
for (filePtr = tsdPtr->firstFileHandlerPtr; filePtr != NULL;
filePtr = filePtr->nextPtr) {
if (filePtr->fd == fd) {
break;
}
}
if (filePtr == NULL) {
| | | 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 |
for (filePtr = tsdPtr->firstFileHandlerPtr; filePtr != NULL;
filePtr = filePtr->nextPtr) {
if (filePtr->fd == fd) {
break;
}
}
if (filePtr == NULL) {
filePtr = Tcl_Alloc(sizeof(FileHandler));
filePtr->fd = fd;
filePtr->readyMask = 0;
filePtr->nextPtr = tsdPtr->firstFileHandlerPtr;
tsdPtr->firstFileHandlerPtr = filePtr;
}
filePtr->proc = proc;
filePtr->clientData = clientData;
|
| ︙ | ︙ | |||
579 580 581 582 583 584 585 |
*/
if (prevPtr == NULL) {
tsdPtr->firstFileHandlerPtr = filePtr->nextPtr;
} else {
prevPtr->nextPtr = filePtr->nextPtr;
}
| | | | 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 |
*/
if (prevPtr == NULL) {
tsdPtr->firstFileHandlerPtr = filePtr->nextPtr;
} else {
prevPtr->nextPtr = filePtr->nextPtr;
}
Tcl_Free(filePtr);
}
}
#if defined(__CYGWIN__)
static DWORD __stdcall
NotifierProc(
void *hwnd,
unsigned int message,
void *wParam,
void *lParam)
|
| ︙ | ︙ | |||
636 637 638 639 640 641 642 |
{
if (tclNotifierHooks.waitForEventProc) {
return tclNotifierHooks.waitForEventProc(timePtr);
} else {
FileHandler *filePtr;
int mask;
Tcl_Time vTime;
| | | | 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 |
{
if (tclNotifierHooks.waitForEventProc) {
return tclNotifierHooks.waitForEventProc(timePtr);
} else {
FileHandler *filePtr;
int mask;
Tcl_Time vTime;
#if TCL_THREADS
int waitForFiles;
# ifdef __CYGWIN__
MSG msg;
# endif /* __CYGWIN__ */
#else /* !TCL_THREADS */
/*
* Impl. notes: timeout & timeoutPtr are used if, and only if threads
* are not enabled. They are the arguments for the regular select()
* used when the core is not thread-enabled.
*/
struct timeval timeout, *timeoutPtr;
|
| ︙ | ︙ | |||
671 672 673 674 675 676 677 |
*/
if (timePtr->sec != 0 || timePtr->usec != 0) {
vTime = *timePtr;
tclScaleTimeProcPtr(&vTime, tclTimeClientData);
timePtr = &vTime;
}
| | | | 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 |
*/
if (timePtr->sec != 0 || timePtr->usec != 0) {
vTime = *timePtr;
tclScaleTimeProcPtr(&vTime, tclTimeClientData);
timePtr = &vTime;
}
#if !TCL_THREADS
timeout.tv_sec = timePtr->sec;
timeout.tv_usec = timePtr->usec;
timeoutPtr = &timeout;
} else if (tsdPtr->numFdBits == 0) {
/*
* If there are no threads, no timeout, and no fds registered,
* then there are no events possible and we must avoid deadlock.
* Note that this is not entirely correct because there might be a
* signal that could interrupt the select call, but we don't
* handle that case if we aren't using threads.
*/
return -1;
} else {
timeoutPtr = NULL;
#endif /* !TCL_THREADS */
}
#if TCL_THREADS
/*
* Start notifier thread and place this thread on the list of
* interested threads, signal the notifier thread, and wait for a
* response or a timeout.
*/
StartNotifierThread("Tcl_WaitForEvent");
|
| ︙ | ︙ | |||
767 768 769 770 771 772 773 |
} else {
timeout = 0xFFFFFFFF;
}
pthread_mutex_unlock(¬ifierMutex);
MsgWaitForMultipleObjects(1, &tsdPtr->event, 0, timeout, 1279);
pthread_mutex_lock(¬ifierMutex);
}
| | | | | | > | | | | 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 |
} else {
timeout = 0xFFFFFFFF;
}
pthread_mutex_unlock(¬ifierMutex);
MsgWaitForMultipleObjects(1, &tsdPtr->event, 0, timeout, 1279);
pthread_mutex_lock(¬ifierMutex);
}
#else /* !__CYGWIN__ */
if (timePtr != NULL) {
Tcl_Time now;
struct timespec ptime;
Tcl_GetTime(&now);
ptime.tv_sec = timePtr->sec + now.sec +
(timePtr->usec + now.usec) / 1000000;
ptime.tv_nsec = 1000 * ((timePtr->usec + now.usec) % 1000000);
pthread_cond_timedwait(&tsdPtr->waitCV, ¬ifierMutex, &ptime);
} else {
pthread_cond_wait(&tsdPtr->waitCV, ¬ifierMutex);
}
#endif /* __CYGWIN__ */
}
tsdPtr->eventReady = 0;
#ifdef __CYGWIN__
while (PeekMessageW(&msg, NULL, 0, 0, 0)) {
|
| ︙ | ︙ | |||
826 827 828 829 830 831 832 |
tsdPtr->nextPtr = tsdPtr->prevPtr = NULL;
tsdPtr->onList = 0;
if ((write(triggerPipe, "", 1) == -1) && (errno != EAGAIN)) {
Tcl_Panic("Tcl_WaitForEvent: %s",
"unable to write to triggerPipe");
}
}
| < | | 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 |
tsdPtr->nextPtr = tsdPtr->prevPtr = NULL;
tsdPtr->onList = 0;
if ((write(triggerPipe, "", 1) == -1) && (errno != EAGAIN)) {
Tcl_Panic("Tcl_WaitForEvent: %s",
"unable to write to triggerPipe");
}
}
#else /* !TCL_THREADS */
tsdPtr->readyMasks = tsdPtr->checkMasks;
numFound = select(tsdPtr->numFdBits, &tsdPtr->readyMasks.readable,
&tsdPtr->readyMasks.writable, &tsdPtr->readyMasks.exception,
timeoutPtr);
/*
* Some systems don't clear the masks after an error, so we have to do
|
| ︙ | ︙ | |||
873 874 875 876 877 878 879 |
/*
* Don't bother to queue an event if the mask was previously
* non-zero since an event must still be on the queue.
*/
if (filePtr->readyMask == 0) {
FileHandlerEvent *fileEvPtr =
| | | < < | 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 |
/*
* Don't bother to queue an event if the mask was previously
* non-zero since an event must still be on the queue.
*/
if (filePtr->readyMask == 0) {
FileHandlerEvent *fileEvPtr =
Tcl_Alloc(sizeof(FileHandlerEvent));
fileEvPtr->header.proc = FileHandlerEventProc;
fileEvPtr->fd = filePtr->fd;
Tcl_QueueEvent((Tcl_Event *) fileEvPtr, TCL_QUEUE_TAIL);
}
filePtr->readyMask = mask;
}
#if TCL_THREADS
pthread_mutex_unlock(¬ifierMutex);
#endif /* TCL_THREADS */
return 0;
}
}
/*
*----------------------------------------------------------------------
*
* NotifierThreadProc --
*
* This routine is the initial (and only) function executed by the
* special notifier thread. Its job is to wait for file descriptors to
|
| ︙ | ︙ | |||
914 915 916 917 918 919 920 921 922 923 924 925 926 927 |
* Side effects:
* The trigger pipe used to signal the notifier thread is created when
* the notifier thread first starts.
*
*----------------------------------------------------------------------
*/
static TCL_NORETURN void
NotifierThreadProc(
ClientData clientData) /* Not used. */
{
ThreadSpecificData *tsdPtr;
fd_set readableMask;
fd_set writableMask;
| > | 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 |
* Side effects:
* The trigger pipe used to signal the notifier thread is created when
* the notifier thread first starts.
*
*----------------------------------------------------------------------
*/
#if TCL_THREADS
static TCL_NORETURN void
NotifierThreadProc(
ClientData clientData) /* Not used. */
{
ThreadSpecificData *tsdPtr;
fd_set readableMask;
fd_set writableMask;
|
| ︙ | ︙ | |||
1097 1098 1099 1100 1101 1102 1103 |
pthread_mutex_lock(¬ifierMutex);
triggerPipe = -1;
pthread_cond_broadcast(¬ifierCV);
pthread_mutex_unlock(¬ifierMutex);
TclpThreadExit(0);
}
| < | > < < | 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 |
pthread_mutex_lock(¬ifierMutex);
triggerPipe = -1;
pthread_cond_broadcast(¬ifierCV);
pthread_mutex_unlock(¬ifierMutex);
TclpThreadExit(0);
}
#endif /* TCL_THREADS */
#endif /* (!NOTIFIER_EPOLL && !NOTIFIER_KQUEUE) || !TCL_THREADS */
#endif /* !HAVE_COREFOUNDATION */
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to unix/tclUnixChan.c.
| ︙ | ︙ | |||
44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 | # endif /* !CRTSCTS&CNEW_RTSCTS */ # if !defined(PAREXT) && defined(CMSPAR) # define PAREXT CMSPAR # endif /* !PAREXT&&CMSPAR */ #endif /* HAVE_TERMIOS_H */ /* * Helper macros to make parts of this file clearer. The macros do exactly * what they say on the tin. :-) They also only ever refer to their arguments * once, and so can be used without regard to side effects. */ #define SET_BITS(var, bits) ((var) |= (bits)) #define CLEAR_BITS(var, bits) ((var) &= ~(bits)) /* | > > > > > > > > > > | > > > > > > > > > > > > > | | 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 |
# endif /* !CRTSCTS&CNEW_RTSCTS */
# if !defined(PAREXT) && defined(CMSPAR)
# define PAREXT CMSPAR
# endif /* !PAREXT&&CMSPAR */
#endif /* HAVE_TERMIOS_H */
/*
* The bits supported for describing the closeMode field of TtyState.
*/
enum CloseModeBits {
CLOSE_DEFAULT,
CLOSE_DRAIN,
CLOSE_DISCARD
};
/*
* Helper macros to make parts of this file clearer. The macros do exactly
* what they say on the tin. :-) They also only ever refer to their arguments
* once, and so can be used without regard to side effects.
*/
#define SET_BITS(var, bits) ((var) |= (bits))
#define CLEAR_BITS(var, bits) ((var) &= ~(bits))
/*
* These structures describe per-instance state of file-based and serial-based
* channels.
*/
typedef struct {
Tcl_Channel channel; /* Channel associated with this file. */
int fd; /* File handle. */
int validMask; /* OR'ed combination of TCL_READABLE,
* TCL_WRITABLE, or TCL_EXCEPTION: indicates
* which operations are valid on the file. */
} FileState;
typedef struct {
FileState fileState;
#ifdef SUPPORTS_TTY
int closeMode; /* One of CLOSE_DEFAULT, CLOSE_DRAIN or
* CLOSE_DISCARD. */
int doReset; /* Whether we should do a terminal reset on
* close. */
struct termios initState; /* The state of the terminal when it was
* opened. */
#endif /* SUPPORTS_TTY */
} TtyState;
#ifdef SUPPORTS_TTY
/*
* The following structure is used to set or get the serial port attributes in
* a platform-independant manner.
*/
typedef struct {
int baud;
int parity;
int data;
int stop;
} TtyAttrs;
#endif /* SUPPORTS_TTY */
#define UNSUPPORTED_OPTION(detail) \
if (interp) { \
Tcl_SetObjResult(interp, Tcl_ObjPrintf( \
"%s not supported for this platform", (detail))); \
Tcl_SetErrorCode(interp, "TCL", "UNSUPPORTED", NULL); \
}
|
| ︙ | ︙ | |||
109 110 111 112 113 114 115 116 117 118 119 120 121 122 | int mode, int *errorCode); static int FileTruncateProc(ClientData instanceData, Tcl_WideInt length); static Tcl_WideInt FileWideSeekProc(ClientData instanceData, Tcl_WideInt offset, int mode, int *errorCode); static void FileWatchProc(ClientData instanceData, int mask); #ifdef SUPPORTS_TTY static void TtyGetAttributes(int fd, TtyAttrs *ttyPtr); static int TtyGetOptionProc(ClientData instanceData, Tcl_Interp *interp, const char *optionName, Tcl_DString *dsPtr); static int TtyGetBaud(speed_t speed); static speed_t TtyGetSpeed(int baud); static void TtyInit(int fd); | > > | 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 | int mode, int *errorCode); static int FileTruncateProc(ClientData instanceData, Tcl_WideInt length); static Tcl_WideInt FileWideSeekProc(ClientData instanceData, Tcl_WideInt offset, int mode, int *errorCode); static void FileWatchProc(ClientData instanceData, int mask); #ifdef SUPPORTS_TTY static int TtyCloseProc(ClientData instanceData, Tcl_Interp *interp); static void TtyGetAttributes(int fd, TtyAttrs *ttyPtr); static int TtyGetOptionProc(ClientData instanceData, Tcl_Interp *interp, const char *optionName, Tcl_DString *dsPtr); static int TtyGetBaud(speed_t speed); static speed_t TtyGetSpeed(int baud); static void TtyInit(int fd); |
| ︙ | ︙ | |||
158 159 160 161 162 163 164 |
* This structure describes the channel type structure for serial IO.
* Note that this type is a subclass of the "file" type.
*/
static const Tcl_ChannelType ttyChannelType = {
"tty", /* Type name. */
TCL_CHANNEL_VERSION_5, /* v5 channel */
| | | 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 |
* This structure describes the channel type structure for serial IO.
* Note that this type is a subclass of the "file" type.
*/
static const Tcl_ChannelType ttyChannelType = {
"tty", /* Type name. */
TCL_CHANNEL_VERSION_5, /* v5 channel */
TtyCloseProc, /* Close proc. */
FileInputProc, /* Input proc. */
FileOutputProc, /* Output proc. */
NULL, /* Seek proc. */
TtySetOptionProc, /* Set option proc. */
TtyGetOptionProc, /* Get option proc. */
FileWatchProc, /* Initialize notifier. */
FileGetHandleProc, /* Get OS handles out of channel. */
|
| ︙ | ︙ | |||
248 249 250 251 252 253 254 |
/*
* Assume there is always enough input available. This will block
* appropriately, and read will unblock as soon as a short read is
* possible, if the channel is in blocking mode. If the channel is
* nonblocking, the read will never block.
*/
| | | 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 |
/*
* Assume there is always enough input available. This will block
* appropriately, and read will unblock as soon as a short read is
* possible, if the channel is in blocking mode. If the channel is
* nonblocking, the read will never block.
*/
bytesRead = read(fsPtr->fd, buf, toRead);
if (bytesRead > -1) {
return bytesRead;
}
*errorCodePtr = errno;
return -1;
}
|
| ︙ | ︙ | |||
295 296 297 298 299 300 301 |
* SF Tcl Bug 465765. Do not try to write nothing into a file. STREAM
* based implementations will considers this as EOF (if there is a
* pipe behind the file).
*/
return 0;
}
| | | | | > | 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 |
* SF Tcl Bug 465765. Do not try to write nothing into a file. STREAM
* based implementations will considers this as EOF (if there is a
* pipe behind the file).
*/
return 0;
}
written = write(fsPtr->fd, buf, toWrite);
if (written > -1) {
return written;
}
*errorCodePtr = errno;
return -1;
}
/*
*----------------------------------------------------------------------
*
* FileCloseProc, TtyCloseProc --
*
* These functions are called from the generic IO level to perform
* channel-type-specific cleanup when a file- or tty-based channel is
* closed.
*
* Results:
* 0 if successful, errno if failed.
*
* Side effects:
* Closes the device of the channel.
*
|
| ︙ | ︙ | |||
340 341 342 343 344 345 346 |
if (!TclInThreadExit()
|| ((fsPtr->fd != 0) && (fsPtr->fd != 1) && (fsPtr->fd != 2))) {
if (close(fsPtr->fd) < 0) {
errorCode = errno;
}
}
| | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 |
if (!TclInThreadExit()
|| ((fsPtr->fd != 0) && (fsPtr->fd != 1) && (fsPtr->fd != 2))) {
if (close(fsPtr->fd) < 0) {
errorCode = errno;
}
}
Tcl_Free(fsPtr);
return errorCode;
}
#ifdef SUPPORTS_TTY
static int
TtyCloseProc(
ClientData instanceData,
Tcl_Interp *interp)
{
TtyState *ttyPtr = instanceData;
/*
* If we've been asked by the user to drain or flush, do so now.
*/
switch (ttyPtr->closeMode) {
case CLOSE_DRAIN:
tcdrain(ttyPtr->fileState.fd);
break;
case CLOSE_DISCARD:
tcflush(ttyPtr->fileState.fd, TCIOFLUSH);
break;
default:
/* Do nothing */
break;
}
/*
* If we've had our state changed from the default, reset now.
*/
if (ttyPtr->doReset) {
tcsetattr(ttyPtr->fileState.fd, TCSANOW, &ttyPtr->initState);
}
/*
* Delegate to close for files.
*/
return FileCloseProc(instanceData, interp);
}
#endif /* SUPPORTS_TTY */
/*
*----------------------------------------------------------------------
*
* FileSeekProc --
*
* This function is called by the generic IO level to move the access
|
| ︙ | ︙ | |||
379 380 381 382 383 384 385 |
Tcl_WideInt oldLoc, newLoc;
/*
* Save our current place in case we need to roll-back the seek.
*/
oldLoc = TclOSseek(fsPtr->fd, (Tcl_SeekOffset) 0, SEEK_CUR);
| | | | | | 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 |
Tcl_WideInt oldLoc, newLoc;
/*
* Save our current place in case we need to roll-back the seek.
*/
oldLoc = TclOSseek(fsPtr->fd, (Tcl_SeekOffset) 0, SEEK_CUR);
if (oldLoc == -1) {
/*
* Bad things are happening. Error out...
*/
*errorCodePtr = errno;
return -1;
}
newLoc = TclOSseek(fsPtr->fd, (Tcl_SeekOffset) offset, mode);
/*
* Check for expressability in our return type, and roll-back otherwise.
*/
if (newLoc > INT_MAX) {
*errorCodePtr = EOVERFLOW;
TclOSseek(fsPtr->fd, (Tcl_SeekOffset) oldLoc, SEEK_SET);
return -1;
} else {
*errorCodePtr = (newLoc == -1) ? errno : 0;
}
return (int) newLoc;
}
/*
*----------------------------------------------------------------------
*
* FileWideSeekProc --
*
|
| ︙ | ︙ | |||
574 575 576 577 578 579 580 |
static int
TtySetOptionProc(
ClientData instanceData, /* File state. */
Tcl_Interp *interp, /* For error reporting - can be NULL. */
const char *optionName, /* Which option to set? */
const char *value) /* New value for option. */
{
| | | | 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 |
static int
TtySetOptionProc(
ClientData instanceData, /* File state. */
Tcl_Interp *interp, /* For error reporting - can be NULL. */
const char *optionName, /* Which option to set? */
const char *value) /* New value for option. */
{
TtyState *fsPtr = instanceData;
size_t len, vlen;
TtyAttrs tty;
int argc;
const char **argv;
struct termios iostate;
len = strlen(optionName);
vlen = strlen(value);
|
| ︙ | ︙ | |||
597 598 599 600 601 602 603 | return TCL_ERROR; } /* * system calls results should be checked there. - dl */ | | | | 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 |
return TCL_ERROR;
}
/*
* system calls results should be checked there. - dl
*/
TtySetAttributes(fsPtr->fileState.fd, &tty);
return TCL_OK;
}
/*
* Option -handshake none|xonxoff|rtscts|dtrdsr
*/
if ((len > 1) && (strncmp(optionName, "-handshake", len) == 0)) {
/*
* Reset all handshake options. DTR and RTS are ON by default.
*/
tcgetattr(fsPtr->fileState.fd, &iostate);
CLEAR_BITS(iostate.c_iflag, IXON | IXOFF | IXANY);
#ifdef CRTSCTS
CLEAR_BITS(iostate.c_cflag, CRTSCTS);
#endif /* CRTSCTS */
if (Tcl_UtfNcasecmp(value, "NONE", vlen) == 0) {
/*
* Leave all handshake options disabled.
|
| ︙ | ︙ | |||
641 642 643 644 645 646 647 | "bad value for -handshake: must be one of" " xonxoff, rtscts, dtrdsr or none", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE", "VALUE", NULL); } return TCL_ERROR; } | | < < > | | < | | < | > > > > | > > > | > | > > > | < > | | | | | 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 |
"bad value for -handshake: must be one of"
" xonxoff, rtscts, dtrdsr or none", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE",
"VALUE", NULL);
}
return TCL_ERROR;
}
tcsetattr(fsPtr->fileState.fd, TCSADRAIN, &iostate);
return TCL_OK;
}
/*
* Option -xchar {\x11 \x13}
*/
if ((len > 1) && (strncmp(optionName, "-xchar", len) == 0)) {
if (Tcl_SplitList(interp, value, &argc, &argv) == TCL_ERROR) {
return TCL_ERROR;
} else if (argc != 2) {
badXchar:
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad value for -xchar: should be a list of"
" two elements with each a single 8-bit character", -1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "XCHAR", NULL);
}
Tcl_Free(argv);
return TCL_ERROR;
}
tcgetattr(fsPtr->fileState.fd, &iostate);
iostate.c_cc[VSTART] = argv[0][0];
iostate.c_cc[VSTOP] = argv[1][0];
if (argv[0][0] & 0x80 || argv[1][0] & 0x80) {
Tcl_UniChar character = 0;
int charLen;
charLen = Tcl_UtfToUniChar(argv[0], &character);
if ((character > 0xFF) || argv[0][charLen]) {
goto badXchar;
}
iostate.c_cc[VSTART] = character;
charLen = Tcl_UtfToUniChar(argv[1], &character);
if ((character > 0xFF) || argv[1][charLen]) {
goto badXchar;
}
iostate.c_cc[VSTOP] = character;
}
Tcl_Free(argv);
tcsetattr(fsPtr->fileState.fd, TCSADRAIN, &iostate);
return TCL_OK;
}
/*
* Option -timeout msec
*/
if ((len > 2) && (strncmp(optionName, "-timeout", len) == 0)) {
int msec;
tcgetattr(fsPtr->fileState.fd, &iostate);
if (Tcl_GetInt(interp, value, &msec) != TCL_OK) {
return TCL_ERROR;
}
iostate.c_cc[VMIN] = 0;
iostate.c_cc[VTIME] = (msec==0) ? 0 : (msec<100) ? 1 : (msec+50)/100;
tcsetattr(fsPtr->fileState.fd, TCSADRAIN, &iostate);
return TCL_OK;
}
/*
* Option -ttycontrol {DTR 1 RTS 0 BREAK 0}
*/
|
| ︙ | ︙ | |||
717 718 719 720 721 722 723 |
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad value for -ttycontrol: should be a list of"
" signal,value pairs", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE",
"VALUE", NULL);
}
| | | | | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 |
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad value for -ttycontrol: should be a list of"
" signal,value pairs", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE",
"VALUE", NULL);
}
Tcl_Free(argv);
return TCL_ERROR;
}
ioctl(fsPtr->fileState.fd, TIOCMGET, &control);
for (i = 0; i < argc-1; i += 2) {
if (Tcl_GetBoolean(interp, argv[i+1], &flag) == TCL_ERROR) {
Tcl_Free(argv);
return TCL_ERROR;
}
if (Tcl_UtfNcasecmp(argv[i], "DTR", strlen(argv[i])) == 0) {
if (flag) {
SET_BITS(control, TIOCM_DTR);
} else {
CLEAR_BITS(control, TIOCM_DTR);
}
} else if (Tcl_UtfNcasecmp(argv[i], "RTS", strlen(argv[i])) == 0) {
if (flag) {
SET_BITS(control, TIOCM_RTS);
} else {
CLEAR_BITS(control, TIOCM_RTS);
}
} else if (Tcl_UtfNcasecmp(argv[i], "BREAK", strlen(argv[i])) == 0) {
#if defined(TIOCSBRK) && defined(TIOCCBRK)
if (flag) {
ioctl(fsPtr->fileState.fd, TIOCSBRK, NULL);
} else {
ioctl(fsPtr->fileState.fd, TIOCCBRK, NULL);
}
#else /* TIOCSBRK & TIOCCBRK */
UNSUPPORTED_OPTION("-ttycontrol BREAK");
Tcl_Free(argv);
return TCL_ERROR;
#endif /* TIOCSBRK & TIOCCBRK */
} else {
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad signal \"%s\" for -ttycontrol: must be"
" DTR, RTS or BREAK", argv[i]));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE",
"VALUE", NULL);
}
Tcl_Free(argv);
return TCL_ERROR;
}
} /* -ttycontrol options loop */
ioctl(fsPtr->fileState.fd, TIOCMSET, &control);
Tcl_Free(argv);
return TCL_OK;
#else /* TIOCMGET&TIOCMSET */
UNSUPPORTED_OPTION("-ttycontrol");
#endif /* TIOCMGET&TIOCMSET */
}
/*
* Option -closemode drain|discard
*/
if ((len > 2) && (strncmp(optionName, "-closemode", len) == 0)) {
if (Tcl_UtfNcasecmp(value, "DEFAULT", vlen) == 0) {
fsPtr->closeMode = CLOSE_DEFAULT;
} else if (Tcl_UtfNcasecmp(value, "DRAIN", vlen) == 0) {
fsPtr->closeMode = CLOSE_DRAIN;
} else if (Tcl_UtfNcasecmp(value, "DISCARD", vlen) == 0) {
fsPtr->closeMode = CLOSE_DISCARD;
} else {
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad mode \"%s\" for -closemode: must be"
" default, discard, or drain", value));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE",
"VALUE", NULL);
}
return TCL_ERROR;
}
return TCL_OK;
}
/*
* Option -inputmode normal|password|raw
*/
if ((len > 2) && (strncmp(optionName, "-inputmode", len) == 0)) {
if (tcgetattr(fsPtr->fileState.fd, &iostate) < 0) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't read serial terminal control state: %s",
Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
if (Tcl_UtfNcasecmp(value, "NORMAL", vlen) == 0) {
SET_BITS(iostate.c_iflag, BRKINT | IGNPAR | ISTRIP | ICRNL | IXON);
SET_BITS(iostate.c_oflag, OPOST);
SET_BITS(iostate.c_lflag, ECHO | ECHONL | ICANON | ISIG);
} else if (Tcl_UtfNcasecmp(value, "PASSWORD", vlen) == 0) {
SET_BITS(iostate.c_iflag, BRKINT | IGNPAR | ISTRIP | ICRNL | IXON);
SET_BITS(iostate.c_oflag, OPOST);
CLEAR_BITS(iostate.c_lflag, ECHO);
/*
* Note: password input turns out to be best if you echo the
* newline that the user types. Theoretically we could get users
* to do the processing of this in their scripts, but it always
* feels highly unnatural to do so in practice.
*/
SET_BITS(iostate.c_lflag, ECHONL | ICANON | ISIG);
} else if (Tcl_UtfNcasecmp(value, "RAW", vlen) == 0) {
#ifdef HAVE_CFMAKERAW
cfmakeraw(&iostate);
#else /* !HAVE_CFMAKERAW */
CLEAR_BITS(iostate.c_iflag, IGNBRK | BRKINT | PARMRK | ISTRIP
| INLCR | IGNCR | ICRNL | IXON);
CLEAR_BITS(iostate.c_oflag, OPOST);
CLEAR_BITS(iostate.c_lflag, ECHO | ECHONL | ICANON | ISIG | IEXTEN);
CLEAR_BITS(iostate.c_cflag, CSIZE | PARENB);
SET_BITS(iostate.c_cflag, CS8);
#endif /* HAVE_CFMAKERAW */
} else if (Tcl_UtfNcasecmp(value, "RESET", vlen) == 0) {
/*
* Reset to the initial state, whatever that is.
*/
memcpy(&iostate, &fsPtr->initState, sizeof(struct termios));
} else {
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad mode \"%s\" for -inputmode: must be"
" normal, password, raw, or reset", value));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE",
"VALUE", NULL);
}
return TCL_ERROR;
}
if (tcsetattr(fsPtr->fileState.fd, TCSADRAIN, &iostate) < 0) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't update serial terminal control state: %s",
Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
/*
* If we've changed the state from default, schedule a reset later.
* Note that this specifically does not detect changes made by calling
* an external stty program; that is deliberate, as it maintains
* compatibility with existing code!
*
* This mechanism in Tcl is not intended to be a full replacement for
* what stty does; it just handles a few common cases and tries not to
* leave things in a broken state.
*/
fsPtr->doReset = (memcmp(&iostate, &fsPtr->initState,
sizeof(struct termios)) != 0);
return TCL_OK;
}
return Tcl_BadChannelOption(interp, optionName,
"closemode inputmode mode handshake timeout ttycontrol xchar");
}
/*
*----------------------------------------------------------------------
*
* TtyGetOptionProc --
*
|
| ︙ | ︙ | |||
801 802 803 804 805 806 807 |
static int
TtyGetOptionProc(
ClientData instanceData, /* File state. */
Tcl_Interp *interp, /* For error reporting - can be NULL. */
const char *optionName, /* Option to get. */
Tcl_DString *dsPtr) /* Where to store value(s). */
{
| | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | < | | 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 |
static int
TtyGetOptionProc(
ClientData instanceData, /* File state. */
Tcl_Interp *interp, /* For error reporting - can be NULL. */
const char *optionName, /* Option to get. */
Tcl_DString *dsPtr) /* Where to store value(s). */
{
TtyState *fsPtr = instanceData;
size_t len;
char buf[3*TCL_INTEGER_SPACE + 16];
int valid = 0; /* Flag if valid option parsed. */
struct termios iostate;
if (optionName == NULL) {
len = 0;
} else {
len = strlen(optionName);
}
/*
* Get option -closemode
*/
if (len == 0) {
Tcl_DStringAppendElement(dsPtr, "-closemode");
}
if (len==0 || (len>1 && strncmp(optionName, "-closemode", len)==0)) {
switch (fsPtr->closeMode) {
case CLOSE_DRAIN:
Tcl_DStringAppendElement(dsPtr, "drain");
break;
case CLOSE_DISCARD:
Tcl_DStringAppendElement(dsPtr, "discard");
break;
default:
Tcl_DStringAppendElement(dsPtr, "default");
break;
}
}
/*
* Get option -inputmode
*
* This is a great simplification of the underlying reality, but actually
* represents what almost all scripts really want to know.
*/
if (len == 0) {
Tcl_DStringAppendElement(dsPtr, "-inputmode");
}
if (len==0 || (len>1 && strncmp(optionName, "-inputmode", len)==0)) {
valid = 1;
if (tcgetattr(fsPtr->fileState.fd, &iostate) < 0) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't read serial terminal control state: %s",
Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
if (iostate.c_lflag & ICANON) {
if (iostate.c_lflag & ECHO) {
Tcl_DStringAppendElement(dsPtr, "normal");
} else {
Tcl_DStringAppendElement(dsPtr, "password");
}
} else {
Tcl_DStringAppendElement(dsPtr, "raw");
}
}
/*
* Get option -mode
*/
if (len == 0) {
Tcl_DStringAppendElement(dsPtr, "-mode");
}
if (len==0 || (len>2 && strncmp(optionName, "-mode", len)==0)) {
TtyAttrs tty;
valid = 1;
TtyGetAttributes(fsPtr->fileState.fd, &tty);
sprintf(buf, "%d,%c,%d,%d", tty.baud, tty.parity, tty.data, tty.stop);
Tcl_DStringAppendElement(dsPtr, buf);
}
/*
* Get option -xchar
*/
if (len == 0) {
Tcl_DStringAppendElement(dsPtr, "-xchar");
Tcl_DStringStartSublist(dsPtr);
}
if (len==0 || (len>1 && strncmp(optionName, "-xchar", len)==0)) {
Tcl_DString ds;
valid = 1;
tcgetattr(fsPtr->fileState.fd, &iostate);
Tcl_DStringInit(&ds);
Tcl_ExternalToUtfDString(NULL, (char *) &iostate.c_cc[VSTART], 1, &ds);
Tcl_DStringAppendElement(dsPtr, Tcl_DStringValue(&ds));
TclDStringClear(&ds);
Tcl_ExternalToUtfDString(NULL, (char *) &iostate.c_cc[VSTOP], 1, &ds);
|
| ︙ | ︙ | |||
861 862 863 864 865 866 867 |
* returned by unnamed [fconfigure chan].
*/
if ((len > 1) && (strncmp(optionName, "-queue", len) == 0)) {
int inQueue=0, outQueue=0, inBuffered, outBuffered;
valid = 1;
| | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > | | 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 |
* returned by unnamed [fconfigure chan].
*/
if ((len > 1) && (strncmp(optionName, "-queue", len) == 0)) {
int inQueue=0, outQueue=0, inBuffered, outBuffered;
valid = 1;
GETREADQUEUE(fsPtr->fileState.fd, inQueue);
GETWRITEQUEUE(fsPtr->fileState.fd, outQueue);
inBuffered = Tcl_InputBuffered(fsPtr->fileState.channel);
outBuffered = Tcl_OutputBuffered(fsPtr->fileState.channel);
sprintf(buf, "%d", inBuffered+inQueue);
Tcl_DStringAppendElement(dsPtr, buf);
sprintf(buf, "%d", outBuffered+outQueue);
Tcl_DStringAppendElement(dsPtr, buf);
}
#if defined(TIOCMGET)
/*
* Get option -ttystatus
* Option is readonly and returned by [fconfigure chan -ttystatus] but not
* returned by unnamed [fconfigure chan].
*/
if ((len > 4) && (strncmp(optionName, "-ttystatus", len) == 0)) {
int status;
valid = 1;
ioctl(fsPtr->fileState.fd, TIOCMGET, &status);
TtyModemStatusStr(status, dsPtr);
}
#endif /* TIOCMGET */
#if defined(TIOCGWINSZ)
/*
* Get option -winsize
* Option is readonly and returned by [fconfigure chan -winsize] but not
* returned by [fconfigure chan] without explicit option name.
*/
if ((len > 1) && (strncmp(optionName, "-winsize", len) == 0)) {
struct winsize ws;
valid = 1;
if (ioctl(fsPtr->fileState.fd, TIOCGWINSZ, &ws) < 0) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't read terminal size: %s",
Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
sprintf(buf, "%d", ws.ws_col);
Tcl_DStringAppendElement(dsPtr, buf);
sprintf(buf, "%d", ws.ws_row);
Tcl_DStringAppendElement(dsPtr, buf);
}
#endif /* TIOCGWINSZ */
if (valid) {
return TCL_OK;
}
return Tcl_BadChannelOption(interp, optionName,
"closemode inputmode mode queue ttystatus winsize xchar");
}
static const struct {int baud; speed_t speed;} speeds[] = {
#ifdef B0
{0, B0},
#endif
#ifdef B50
|
| ︙ | ︙ | |||
1363 1364 1365 1366 1367 1368 1369 |
* NULL. */
Tcl_Obj *pathPtr, /* Name of file to open. */
int mode, /* POSIX open mode. */
int permissions) /* If the open involves creating a file, with
* what modes to create it? */
{
int fd, channelPermissions;
| | | 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 |
* NULL. */
Tcl_Obj *pathPtr, /* Name of file to open. */
int mode, /* POSIX open mode. */
int permissions) /* If the open involves creating a file, with
* what modes to create it? */
{
int fd, channelPermissions;
TtyState *fsPtr;
const char *native, *translation;
char channelName[16 + TCL_INTEGER_SPACE];
const Tcl_ChannelType *channelTypePtr;
switch (mode & (O_RDONLY | O_WRONLY | O_RDWR)) {
case O_RDONLY:
channelPermissions = TCL_READABLE;
|
| ︙ | ︙ | |||
1419 1420 1421 1422 1423 1424 1425 |
/*
* Set close-on-exec flag on the fd so that child processes will not
* inherit this fd.
*/
fcntl(fd, F_SETFD, FD_CLOEXEC);
| < < > > | | | > > > > > | > > | | | | | | 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 |
/*
* Set close-on-exec flag on the fd so that child processes will not
* inherit this fd.
*/
fcntl(fd, F_SETFD, FD_CLOEXEC);
#ifdef SUPPORTS_TTY
if (strcmp(native, "/dev/tty") != 0 && isatty(fd)) {
/*
* Initialize the serial port to a set of sane parameters. Especially
* important if the remote device is set to echo and the serial port
* driver was also set to echo -- as soon as a char were sent to the
* serial port, the remote device would echo it, then the serial
* driver would echo it back to the device, etc.
*
* Note that we do not do this if we're dealing with /dev/tty itself,
* as that tends to cause Bad Things To Happen when you're working
* interactively. Strictly a better check would be to see if the FD
* being set up is a device and has the same major/minor as the
* initial std FDs (beware reopening!) but that's nearly as messy.
*/
translation = "auto crlf";
channelTypePtr = &ttyChannelType;
TtyInit(fd);
sprintf(channelName, "serial%d", fd);
} else
#endif /* SUPPORTS_TTY */
{
translation = NULL;
channelTypePtr = &fileChannelType;
sprintf(channelName, "file%d", fd);
}
fsPtr = Tcl_Alloc(sizeof(TtyState));
fsPtr->fileState.validMask = channelPermissions | TCL_EXCEPTION;
fsPtr->fileState.fd = fd;
#ifdef SUPPORTS_TTY
if (channelTypePtr == &ttyChannelType) {
fsPtr->closeMode = CLOSE_DEFAULT;
fsPtr->doReset = 0;
tcgetattr(fsPtr->fileState.fd, &fsPtr->initState);
}
#endif /* SUPPORTS_TTY */
fsPtr->fileState.channel = Tcl_CreateChannel(channelTypePtr, channelName,
fsPtr, channelPermissions);
if (translation != NULL) {
/*
* Gotcha. Most modems need a "\r" at the end of the command sequence.
* If you just send "at\n", the modem will not respond with "OK"
* because it never got a "\r" to actually invoke the command. So, by
* default, newlines are translated to "\r\n" on output to avoid "bug"
* reports that the serial port isn't working.
*/
if (Tcl_SetChannelOption(interp, fsPtr->fileState.channel,
"-translation", translation) != TCL_OK) {
Tcl_Close(NULL, fsPtr->fileState.channel);
return NULL;
}
}
return fsPtr->fileState.channel;
}
/*
*----------------------------------------------------------------------
*
* Tcl_MakeFileChannel --
*
|
| ︙ | ︙ | |||
1495 1496 1497 1498 1499 1500 1501 |
Tcl_Channel
Tcl_MakeFileChannel(
ClientData handle, /* OS level handle. */
int mode) /* ORed combination of TCL_READABLE and
* TCL_WRITABLE to indicate file mode. */
{
| | | < < < > > > > > | | | > | > > > | | | | > > > > > | > > | | 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 |
Tcl_Channel
Tcl_MakeFileChannel(
ClientData handle, /* OS level handle. */
int mode) /* ORed combination of TCL_READABLE and
* TCL_WRITABLE to indicate file mode. */
{
TtyState *fsPtr;
char channelName[16 + TCL_INTEGER_SPACE];
int fd = PTR2INT(handle);
const Tcl_ChannelType *channelTypePtr;
struct stat buf;
if (mode == 0) {
return NULL;
}
#ifdef SUPPORTS_TTY
if (isatty(fd)) {
channelTypePtr = &ttyChannelType;
sprintf(channelName, "serial%d", fd);
} else
#endif /* SUPPORTS_TTY */
if (fstat(fd, &buf) == 0 && S_ISSOCK(buf.st_mode)) {
struct sockaddr sockaddr;
socklen_t sockaddrLen = sizeof(sockaddr);
sockaddr.sa_family = AF_UNSPEC;
if ((getsockname(fd, (struct sockaddr *)&sockaddr, &sockaddrLen) == 0)
&& (sockaddrLen > 0)
&& (sockaddr.sa_family == AF_INET
|| sockaddr.sa_family == AF_INET6)) {
return TclpMakeTcpClientChannelMode(INT2PTR(fd), mode);
}
goto normalChannelAfterAll;
} else {
normalChannelAfterAll:
channelTypePtr = &fileChannelType;
sprintf(channelName, "file%d", fd);
}
fsPtr = Tcl_Alloc(sizeof(TtyState));
fsPtr->fileState.fd = fd;
fsPtr->fileState.validMask = mode | TCL_EXCEPTION;
fsPtr->fileState.channel = Tcl_CreateChannel(channelTypePtr, channelName,
fsPtr, mode);
#ifdef SUPPORTS_TTY
if (channelTypePtr == &ttyChannelType) {
fsPtr->closeMode = CLOSE_DEFAULT;
fsPtr->doReset = 0;
tcgetattr(fsPtr->fileState.fd, &fsPtr->initState);
}
#endif /* SUPPORTS_TTY */
return fsPtr->fileState.channel;
}
/*
*----------------------------------------------------------------------
*
* TclpGetDefaultStdChannel --
*
|
| ︙ | ︙ |
Changes to unix/tclUnixCompat.c.
| ︙ | ︙ | |||
41 42 43 44 45 46 47 |
}
/*
* Per-thread private storage used to store values returned from MT-unsafe
* library calls.
*/
| | | 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 |
}
/*
* Per-thread private storage used to store values returned from MT-unsafe
* library calls.
*/
#if TCL_THREADS
typedef struct {
struct passwd pwd;
#if defined(HAVE_GETPWNAM_R_5) || defined(HAVE_GETPWUID_R_5)
#define NEED_PW_CLEANER 1
char *pbuf;
int pbuflen;
|
| ︙ | ︙ | |||
176 177 178 179 180 181 182 |
*---------------------------------------------------------------------------
*/
struct passwd *
TclpGetPwNam(
const char *name)
{
| | | | | 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 |
*---------------------------------------------------------------------------
*/
struct passwd *
TclpGetPwNam(
const char *name)
{
#if !TCL_THREADS
return getpwnam(name);
#else
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
#if defined(HAVE_GETPWNAM_R_5)
struct passwd *pwPtr = NULL;
/*
* How to allocate a buffer of the right initial size. If you want the
* gory detail, see http://www.opengroup.org/austin/docs/austin_328.txt
* and weep.
*/
if (tsdPtr->pbuf == NULL) {
tsdPtr->pbuflen = (int) sysconf(_SC_GETPW_R_SIZE_MAX);
if (tsdPtr->pbuflen < 1) {
tsdPtr->pbuflen = 1024;
}
tsdPtr->pbuf = Tcl_Alloc(tsdPtr->pbuflen);
Tcl_CreateThreadExitHandler(FreePwBuf, NULL);
}
while (1) {
int e = getpwnam_r(name, &tsdPtr->pwd, tsdPtr->pbuf, tsdPtr->pbuflen,
&pwPtr);
if (e == 0) {
break;
} else if (e != ERANGE) {
return NULL;
}
tsdPtr->pbuflen *= 2;
tsdPtr->pbuf = Tcl_Realloc(tsdPtr->pbuf, tsdPtr->pbuflen);
}
return (pwPtr != NULL ? &tsdPtr->pwd : NULL);
#elif defined(HAVE_GETPWNAM_R_4)
return getpwnam_r(name, &tsdPtr->pwd, tsdPtr->pbuf, sizeof(tsdPtr->pbuf));
#else
|
| ︙ | ︙ | |||
256 257 258 259 260 261 262 |
*---------------------------------------------------------------------------
*/
struct passwd *
TclpGetPwUid(
uid_t uid)
{
| | | | | 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 |
*---------------------------------------------------------------------------
*/
struct passwd *
TclpGetPwUid(
uid_t uid)
{
#if !TCL_THREADS
return getpwuid(uid);
#else
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
#if defined(HAVE_GETPWUID_R_5)
struct passwd *pwPtr = NULL;
/*
* How to allocate a buffer of the right initial size. If you want the
* gory detail, see http://www.opengroup.org/austin/docs/austin_328.txt
* and weep.
*/
if (tsdPtr->pbuf == NULL) {
tsdPtr->pbuflen = (int) sysconf(_SC_GETPW_R_SIZE_MAX);
if (tsdPtr->pbuflen < 1) {
tsdPtr->pbuflen = 1024;
}
tsdPtr->pbuf = Tcl_Alloc(tsdPtr->pbuflen);
Tcl_CreateThreadExitHandler(FreePwBuf, NULL);
}
while (1) {
int e = getpwuid_r(uid, &tsdPtr->pwd, tsdPtr->pbuf, tsdPtr->pbuflen,
&pwPtr);
if (e == 0) {
break;
} else if (e != ERANGE) {
return NULL;
}
tsdPtr->pbuflen *= 2;
tsdPtr->pbuf = Tcl_Realloc(tsdPtr->pbuf, tsdPtr->pbuflen);
}
return (pwPtr != NULL ? &tsdPtr->pwd : NULL);
#elif defined(HAVE_GETPWUID_R_4)
return getpwuid_r(uid, &tsdPtr->pwd, tsdPtr->pbuf, sizeof(tsdPtr->pbuf));
#else
|
| ︙ | ︙ | |||
334 335 336 337 338 339 340 |
#ifdef NEED_PW_CLEANER
static void
FreePwBuf(
ClientData ignored)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
| | | 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 |
#ifdef NEED_PW_CLEANER
static void
FreePwBuf(
ClientData ignored)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
Tcl_Free(tsdPtr->pbuf);
}
#endif /* NEED_PW_CLEANER */
/*
*---------------------------------------------------------------------------
*
* TclpGetGrNam --
|
| ︙ | ︙ | |||
359 360 361 362 363 364 365 |
*---------------------------------------------------------------------------
*/
struct group *
TclpGetGrNam(
const char *name)
{
| | | | | 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 |
*---------------------------------------------------------------------------
*/
struct group *
TclpGetGrNam(
const char *name)
{
#if !TCL_THREADS
return getgrnam(name);
#else
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
#if defined(HAVE_GETGRNAM_R_5)
struct group *grPtr = NULL;
/*
* How to allocate a buffer of the right initial size. If you want the
* gory detail, see http://www.opengroup.org/austin/docs/austin_328.txt
* and weep.
*/
if (tsdPtr->gbuf == NULL) {
tsdPtr->gbuflen = (int) sysconf(_SC_GETGR_R_SIZE_MAX);
if (tsdPtr->gbuflen < 1) {
tsdPtr->gbuflen = 1024;
}
tsdPtr->gbuf = Tcl_Alloc(tsdPtr->gbuflen);
Tcl_CreateThreadExitHandler(FreeGrBuf, NULL);
}
while (1) {
int e = getgrnam_r(name, &tsdPtr->grp, tsdPtr->gbuf, tsdPtr->gbuflen,
&grPtr);
if (e == 0) {
break;
} else if (e != ERANGE) {
return NULL;
}
tsdPtr->gbuflen *= 2;
tsdPtr->gbuf = Tcl_Realloc(tsdPtr->gbuf, tsdPtr->gbuflen);
}
return (grPtr != NULL ? &tsdPtr->grp : NULL);
#elif defined(HAVE_GETGRNAM_R_4)
return getgrnam_r(name, &tsdPtr->grp, tsdPtr->gbuf, sizeof(tsdPtr->gbuf));
#else
|
| ︙ | ︙ | |||
439 440 441 442 443 444 445 |
*---------------------------------------------------------------------------
*/
struct group *
TclpGetGrGid(
gid_t gid)
{
| | | | | 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 |
*---------------------------------------------------------------------------
*/
struct group *
TclpGetGrGid(
gid_t gid)
{
#if !TCL_THREADS
return getgrgid(gid);
#else
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
#if defined(HAVE_GETGRGID_R_5)
struct group *grPtr = NULL;
/*
* How to allocate a buffer of the right initial size. If you want the
* gory detail, see http://www.opengroup.org/austin/docs/austin_328.txt
* and weep.
*/
if (tsdPtr->gbuf == NULL) {
tsdPtr->gbuflen = (int) sysconf(_SC_GETGR_R_SIZE_MAX);
if (tsdPtr->gbuflen < 1) {
tsdPtr->gbuflen = 1024;
}
tsdPtr->gbuf = Tcl_Alloc(tsdPtr->gbuflen);
Tcl_CreateThreadExitHandler(FreeGrBuf, NULL);
}
while (1) {
int e = getgrgid_r(gid, &tsdPtr->grp, tsdPtr->gbuf, tsdPtr->gbuflen,
&grPtr);
if (e == 0) {
break;
} else if (e != ERANGE) {
return NULL;
}
tsdPtr->gbuflen *= 2;
tsdPtr->gbuf = Tcl_Realloc(tsdPtr->gbuf, tsdPtr->gbuflen);
}
return (grPtr != NULL ? &tsdPtr->grp : NULL);
#elif defined(HAVE_GETGRGID_R_4)
return getgrgid_r(gid, &tsdPtr->grp, tsdPtr->gbuf, sizeof(tsdPtr->gbuf));
#else
|
| ︙ | ︙ | |||
517 518 519 520 521 522 523 |
#ifdef NEED_GR_CLEANER
static void
FreeGrBuf(
ClientData ignored)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
| | | 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 |
#ifdef NEED_GR_CLEANER
static void
FreeGrBuf(
ClientData ignored)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
Tcl_Free(tsdPtr->gbuf);
}
#endif /* NEED_GR_CLEANER */
/*
*---------------------------------------------------------------------------
*
* TclpGetHostByName --
|
| ︙ | ︙ | |||
542 543 544 545 546 547 548 |
*---------------------------------------------------------------------------
*/
struct hostent *
TclpGetHostByName(
const char *name)
{
| | | 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 |
*---------------------------------------------------------------------------
*/
struct hostent *
TclpGetHostByName(
const char *name)
{
#if !TCL_THREADS || defined(HAVE_MTSAFE_GETHOSTBYNAME)
return gethostbyname(name);
#else
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
#if defined(HAVE_GETHOSTBYNAME_R_5)
int h_errno;
|
| ︙ | ︙ | |||
612 613 614 615 616 617 618 |
struct hostent *
TclpGetHostByAddr(
const char *addr,
int length,
int type)
{
| | | 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 |
struct hostent *
TclpGetHostByAddr(
const char *addr,
int length,
int type)
{
#if !TCL_THREADS || defined(HAVE_MTSAFE_GETHOSTBYADDR)
return gethostbyaddr(addr, length, type);
#else
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
#if defined(HAVE_GETHOSTBYADDR_R_7)
int h_errno;
|
| ︙ | ︙ |
Changes to unix/tclUnixFCmd.c.
| ︙ | ︙ | |||
250 251 252 253 254 255 256 |
return realpath(path, resolved);
}
#else
# define Realpath realpath
#endif /* PURIFY */
#ifndef NO_REALPATH
| | | 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 |
return realpath(path, resolved);
}
#else
# define Realpath realpath
#endif /* PURIFY */
#ifndef NO_REALPATH
#if defined(__APPLE__) && TCL_THREADS && \
defined(MAC_OS_X_VERSION_MIN_REQUIRED) && \
MAC_OS_X_VERSION_MIN_REQUIRED < 1030
/*
* Prior to Darwin 7, realpath is not thread-safe, c.f. Bug 711232; if we
* might potentially be running on pre-10.3 OSX, check Darwin release at
* runtime before using realpath.
*/
|
| ︙ | ︙ | |||
363 364 365 366 367 368 369 |
* as EINVAL instead of EEXIST (first rule out the correct EINVAL result
* code for moving a directory into itself). Must be conditionally
* compiled because realpath() not defined on all systems.
*/
if (errno == EINVAL && haveRealpath) {
char srcPath[MAXPATHLEN], dstPath[MAXPATHLEN];
| | | | | | 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 |
* as EINVAL instead of EEXIST (first rule out the correct EINVAL result
* code for moving a directory into itself). Must be conditionally
* compiled because realpath() not defined on all systems.
*/
if (errno == EINVAL && haveRealpath) {
char srcPath[MAXPATHLEN], dstPath[MAXPATHLEN];
TclDIR *dirPtr;
Tcl_DirEntry *dirEntPtr;
if ((Realpath((char *) src, srcPath) != NULL) /* INTL: Native. */
&& (Realpath((char *) dst, dstPath) != NULL) /* INTL: Native */
&& (strncmp(srcPath, dstPath, strlen(srcPath)) != 0)) {
dirPtr = TclOSopendir(dst); /* INTL: Native. */
if (dirPtr != NULL) {
while (1) {
dirEntPtr = TclOSreaddir(dirPtr); /* INTL: Native. */
if (dirEntPtr == NULL) {
break;
}
if ((strcmp(dirEntPtr->d_name, ".") != 0) &&
(strcmp(dirEntPtr->d_name, "..") != 0)) {
errno = EEXIST;
TclOSclosedir(dirPtr);
return TCL_ERROR;
}
}
TclOSclosedir(dirPtr);
}
}
errno = EINVAL;
}
#endif /* !NO_REALPATH */
if (strcmp(src, "/") == 0) {
|
| ︙ | ︙ | |||
548 549 550 551 552 553 554 |
const char *dst, /* Pathname of file to create/overwrite
* (native). */
const Tcl_StatBuf *statBufPtr,
/* Used to determine mode and blocksize. */
int dontCopyAtts) /* If flag set, don't copy attributes. */
{
int srcFd, dstFd;
| | | 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 |
const char *dst, /* Pathname of file to create/overwrite
* (native). */
const Tcl_StatBuf *statBufPtr,
/* Used to determine mode and blocksize. */
int dontCopyAtts) /* If flag set, don't copy attributes. */
{
int srcFd, dstFd;
size_t blockSize; /* Optimal I/O blocksize for filesystem */
char *buffer; /* Data buffer for copy */
size_t nread;
#ifdef DJGPP
#define BINMODE |O_BINARY
#else
#define BINMODE
|
| ︙ | ︙ | |||
604 605 606 607 608 609 610 |
* detecting such a situation we now simply fall back to a hardwired
* default size.
*/
if (blockSize <= 0) {
blockSize = DEFAULT_COPY_BLOCK_SIZE;
}
| | | | | | | | 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 |
* detecting such a situation we now simply fall back to a hardwired
* default size.
*/
if (blockSize <= 0) {
blockSize = DEFAULT_COPY_BLOCK_SIZE;
}
buffer = Tcl_Alloc(blockSize);
while (1) {
nread = read(srcFd, buffer, blockSize);
if ((nread == TCL_IO_FAILURE) || (nread == 0)) {
break;
}
if ((size_t) write(dstFd, buffer, nread) != nread) {
nread = TCL_IO_FAILURE;
break;
}
}
Tcl_Free(buffer);
close(srcFd);
if ((close(dstFd) != 0) || (nread == TCL_IO_FAILURE)) {
unlink(dst); /* INTL: Native. */
return TCL_ERROR;
}
if (!dontCopyAtts && CopyFileAtts(src, dst, statBufPtr) == TCL_ERROR) {
/*
* The copy succeeded, but setting the permissions failed, so be in a
* consistent state, we remove the file that was created by the copy.
|
| ︙ | ︙ | |||
954 955 956 957 958 959 960 |
* traverseProc has returned TCL_OK; this is
* required when traverseProc modifies the
* source hierarchy, e.g. by deleting
* files. */
{
Tcl_StatBuf statBuf;
const char *source, *errfile;
| | | | | 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 |
* traverseProc has returned TCL_OK; this is
* required when traverseProc modifies the
* source hierarchy, e.g. by deleting
* files. */
{
Tcl_StatBuf statBuf;
const char *source, *errfile;
int result;
size_t targetLen, sourceLen;
#ifndef HAVE_FTS
int numProcessed = 0;
Tcl_DirEntry *dirEntPtr;
TclDIR *dirPtr;
#else
const char *paths[2] = {NULL, NULL};
FTS *fts = NULL;
FTSENT *ent;
#endif
errfile = NULL;
|
| ︙ | ︙ | |||
984 985 986 987 988 989 990 |
* Process the regular file
*/
return traverseProc(sourcePtr, targetPtr, &statBuf, DOTREE_F,
errorPtr);
}
#ifndef HAVE_FTS
| | | | 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 |
* Process the regular file
*/
return traverseProc(sourcePtr, targetPtr, &statBuf, DOTREE_F,
errorPtr);
}
#ifndef HAVE_FTS
dirPtr = TclOSopendir(source); /* INTL: Native. */
if (dirPtr == NULL) {
/*
* Can't read directory
*/
errfile = source;
goto end;
}
result = traverseProc(sourcePtr, targetPtr, &statBuf, DOTREE_PRED,
errorPtr);
if (result != TCL_OK) {
TclOSclosedir(dirPtr);
return result;
}
TclDStringAppendLiteral(sourcePtr, "/");
sourceLen = Tcl_DStringLength(sourcePtr);
if (targetPtr != NULL) {
|
| ︙ | ︙ | |||
1046 1047 1048 1049 1050 1051 1052 |
if (doRewind && (numProcessed > MAX_READDIR_UNLINK_THRESHOLD)) {
/*
* Call rewinddir if we've called unlink or rmdir so many times
* (since the opendir or the previous rewinddir), to avoid a
* NULL-return that may a symptom of a buggy readdir.
*/
| | | | 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 |
if (doRewind && (numProcessed > MAX_READDIR_UNLINK_THRESHOLD)) {
/*
* Call rewinddir if we've called unlink or rmdir so many times
* (since the opendir or the previous rewinddir), to avoid a
* NULL-return that may a symptom of a buggy readdir.
*/
TclOSrewinddir(dirPtr);
numProcessed = 0;
}
}
TclOSclosedir(dirPtr);
/*
* Strip off the trailing slash we added
*/
Tcl_DStringSetLength(sourcePtr, sourceLen - 1);
if (targetPtr != NULL) {
|
| ︙ | ︙ | |||
1363 1364 1365 1366 1367 1368 1369 |
}
return TCL_ERROR;
}
groupPtr = TclpGetGrGid(statBuf.st_gid);
if (groupPtr == NULL) {
| | | 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 |
}
return TCL_ERROR;
}
groupPtr = TclpGetGrGid(statBuf.st_gid);
if (groupPtr == NULL) {
*attributePtrPtr = Tcl_NewWideIntObj(statBuf.st_gid);
} else {
Tcl_DString ds;
const char *utf;
utf = Tcl_ExternalToUtfDString(NULL, groupPtr->gr_name, -1, &ds);
*attributePtrPtr = Tcl_NewStringObj(utf, -1);
Tcl_DStringFree(&ds);
|
| ︙ | ︙ | |||
1417 1418 1419 1420 1421 1422 1423 |
}
return TCL_ERROR;
}
pwPtr = TclpGetPwUid(statBuf.st_uid);
if (pwPtr == NULL) {
| | | 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 |
}
return TCL_ERROR;
}
pwPtr = TclpGetPwUid(statBuf.st_uid);
if (pwPtr == NULL) {
*attributePtrPtr = Tcl_NewWideIntObj(statBuf.st_uid);
} else {
Tcl_DString ds;
(void) Tcl_ExternalToUtfDString(NULL, pwPtr->pw_name, -1, &ds);
*attributePtrPtr = TclDStringToObj(&ds);
}
return TCL_OK;
|
| ︙ | ︙ | |||
1493 1494 1495 1496 1497 1498 1499 |
static int
SetGroupAttribute(
Tcl_Interp *interp, /* The interp for error reporting. */
int objIndex, /* The index of the attribute. */
Tcl_Obj *fileName, /* The name of the file (UTF-8). */
Tcl_Obj *attributePtr) /* New group for file. */
{
| | | > | | | 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 |
static int
SetGroupAttribute(
Tcl_Interp *interp, /* The interp for error reporting. */
int objIndex, /* The index of the attribute. */
Tcl_Obj *fileName, /* The name of the file (UTF-8). */
Tcl_Obj *attributePtr) /* New group for file. */
{
Tcl_WideInt gid;
int result;
const char *native;
if (Tcl_GetWideIntFromObj(NULL, attributePtr, &gid) != TCL_OK) {
Tcl_DString ds;
struct group *groupPtr = NULL;
const char *string;
size_t length;
string = TclGetStringFromObj(attributePtr, &length);
native = Tcl_UtfToExternalDString(NULL, string, length, &ds);
groupPtr = TclpGetGrNam(native); /* INTL: Native. */
Tcl_DStringFree(&ds);
if (groupPtr == NULL) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not set group for file \"%s\":"
|
| ︙ | ︙ | |||
1559 1560 1561 1562 1563 1564 1565 |
static int
SetOwnerAttribute(
Tcl_Interp *interp, /* The interp for error reporting. */
int objIndex, /* The index of the attribute. */
Tcl_Obj *fileName, /* The name of the file (UTF-8). */
Tcl_Obj *attributePtr) /* New owner for file. */
{
| | | > | | | 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 |
static int
SetOwnerAttribute(
Tcl_Interp *interp, /* The interp for error reporting. */
int objIndex, /* The index of the attribute. */
Tcl_Obj *fileName, /* The name of the file (UTF-8). */
Tcl_Obj *attributePtr) /* New owner for file. */
{
Tcl_WideInt uid;
int result;
const char *native;
if (Tcl_GetWideIntFromObj(NULL, attributePtr, &uid) != TCL_OK) {
Tcl_DString ds;
struct passwd *pwPtr = NULL;
const char *string;
size_t length;
string = TclGetStringFromObj(attributePtr, &length);
native = Tcl_UtfToExternalDString(NULL, string, length, &ds);
pwPtr = TclpGetPwNam(native); /* INTL: Native. */
Tcl_DStringFree(&ds);
if (pwPtr == NULL) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not set owner for file \"%s\":"
|
| ︙ | ︙ | |||
1625 1626 1627 1628 1629 1630 1631 |
static int
SetPermissionsAttribute(
Tcl_Interp *interp, /* The interp we are using for errors. */
int objIndex, /* The index of the attribute. */
Tcl_Obj *fileName, /* The name of the file (UTF-8). */
Tcl_Obj *attributePtr) /* The attribute to set. */
{
| | | | | 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 |
static int
SetPermissionsAttribute(
Tcl_Interp *interp, /* The interp we are using for errors. */
int objIndex, /* The index of the attribute. */
Tcl_Obj *fileName, /* The name of the file (UTF-8). */
Tcl_Obj *attributePtr) /* The attribute to set. */
{
Tcl_WideInt mode;
mode_t newMode;
int result = TCL_ERROR;
const char *native;
const char *modeStringPtr = TclGetString(attributePtr);
int scanned = TclParseAllWhiteSpace(modeStringPtr, -1);
/*
* First supply support for octal number format
*/
if ((modeStringPtr[scanned] == '0')
&& (modeStringPtr[scanned+1] >= '0')
&& (modeStringPtr[scanned+1] <= '7')) {
/* Leading zero - attempt octal interpretation */
Tcl_Obj *modeObj;
TclNewLiteralStringObj(modeObj, "0o");
Tcl_AppendToObj(modeObj, modeStringPtr+scanned+1, -1);
result = Tcl_GetWideIntFromObj(NULL, modeObj, &mode);
Tcl_DecrRefCount(modeObj);
}
if (result == TCL_OK
|| Tcl_GetWideIntFromObj(NULL, attributePtr, &mode) == TCL_OK) {
newMode = (mode_t) (mode & 0x00007FFF);
} else {
Tcl_StatBuf buf;
/*
* Try the forms "rwxrwxrwx" and "ugo=rwx"
*
|
| ︙ | ︙ | |||
1939 1940 1941 1942 1943 1944 1945 |
TclpObjNormalizePath(
Tcl_Interp *interp,
Tcl_Obj *pathPtr,
int nextCheckpoint)
{
const char *currentPathEndPosition;
char cur;
| > | < | 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 |
TclpObjNormalizePath(
Tcl_Interp *interp,
Tcl_Obj *pathPtr,
int nextCheckpoint)
{
const char *currentPathEndPosition;
char cur;
size_t pathLen;
const char *path = TclGetStringFromObj(pathPtr, &pathLen);
Tcl_DString ds;
const char *nativePath;
#ifndef NO_REALPATH
char normPath[MAXPATHLEN];
#endif
/*
|
| ︙ | ︙ | |||
2048 2049 2050 2051 2052 2053 2054 |
if (nextCheckpoint == 0) {
return 0;
}
nativePath = Tcl_UtfToExternalDString(NULL, path,nextCheckpoint, &ds);
if (Realpath(nativePath, normPath) != NULL) {
| | | 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 |
if (nextCheckpoint == 0) {
return 0;
}
nativePath = Tcl_UtfToExternalDString(NULL, path,nextCheckpoint, &ds);
if (Realpath(nativePath, normPath) != NULL) {
size_t newNormLen;
wholeStringOk:
newNormLen = strlen(normPath);
if ((newNormLen == Tcl_DStringLength(&ds))
&& (strcmp(normPath, nativePath) == 0)) {
/*
* String is unchanged.
|
| ︙ | ︙ | |||
2082 2083 2084 2085 2086 2087 2088 | /* * Free up the native path and put in its place the converted, * normalized path. */ Tcl_DStringFree(&ds); | | | 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 |
/*
* Free up the native path and put in its place the converted,
* normalized path.
*/
Tcl_DStringFree(&ds);
Tcl_ExternalToUtfDString(NULL, normPath, newNormLen, &ds);
if (path[nextCheckpoint] != '\0') {
/*
* Not at end, append remaining path.
*/
int normLen = Tcl_DStringLength(&ds);
|
| ︙ | ︙ | |||
2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 |
Tcl_Obj *basenameObj,
Tcl_Obj *extensionObj,
Tcl_Obj *resultingNameObj)
{
Tcl_DString template, tmp;
const char *string;
int fd;
/*
* We should also check against making more then TMP_MAX of these.
*/
if (dirObj) {
| > | | | | | | | 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 |
Tcl_Obj *basenameObj,
Tcl_Obj *extensionObj,
Tcl_Obj *resultingNameObj)
{
Tcl_DString template, tmp;
const char *string;
int fd;
size_t length;
/*
* We should also check against making more then TMP_MAX of these.
*/
if (dirObj) {
string = TclGetStringFromObj(dirObj, &length);
Tcl_UtfToExternalDString(NULL, string, length, &template);
} else {
Tcl_DStringInit(&template);
Tcl_DStringAppend(&template, DefaultTempDir(), -1); /* INTL: native */
}
TclDStringAppendLiteral(&template, "/");
if (basenameObj) {
string = TclGetStringFromObj(basenameObj, &length);
Tcl_UtfToExternalDString(NULL, string, length, &tmp);
TclDStringAppendDString(&template, &tmp);
Tcl_DStringFree(&tmp);
} else {
TclDStringAppendLiteral(&template, "tcl");
}
TclDStringAppendLiteral(&template, "_XXXXXX");
#ifdef HAVE_MKSTEMPS
if (extensionObj) {
string = TclGetStringFromObj(extensionObj, &length);
Tcl_UtfToExternalDString(NULL, string, length, &tmp);
TclDStringAppendDString(&template, &tmp);
fd = mkstemps(Tcl_DStringValue(&template), Tcl_DStringLength(&tmp));
Tcl_DStringFree(&tmp);
} else
#endif
{
fd = mkstemp(Tcl_DStringValue(&template));
|
| ︙ | ︙ | |||
2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 |
* Assume that the default location ("/tmp" if not overridden) is always
* an existing writable directory; we've no recovery mechanism if it
* isn't.
*/
return TCL_TEMPORARY_FILE_DIRECTORY;
}
#if defined(__CYGWIN__)
static void
StatError(
Tcl_Interp *interp, /* The interp that has the error */
Tcl_Obj *fileName) /* The name of the file which caused the
* error. */
{
TclWinConvertError(GetLastError());
Tcl_SetObjResult(interp, Tcl_ObjPrintf("could not read \"%s\": %s",
TclGetString(fileName), Tcl_PosixError(interp)));
}
static WCHAR *
winPathFromObj(
Tcl_Obj *fileName)
{
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | > | 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 |
* Assume that the default location ("/tmp" if not overridden) is always
* an existing writable directory; we've no recovery mechanism if it
* isn't.
*/
return TCL_TEMPORARY_FILE_DIRECTORY;
}
/*
*----------------------------------------------------------------------
*
* TclpCreateTemporaryDirectory --
*
* Creates a temporary directory, possibly based on the supplied bits and
* pieces of template supplied in the arguments.
*
* Results:
* An object (refcount 0) containing the name of the newly-created
* directory, or NULL on failure.
*
* Side effects:
* Accesses the native filesystem. Makes a directory.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclpCreateTemporaryDirectory(
Tcl_Obj *dirObj,
Tcl_Obj *basenameObj)
{
Tcl_DString template, tmp;
const char *string;
#define DEFAULT_TEMP_DIR_PREFIX "tcl"
/*
* Build the template in writable memory from the user-supplied pieces and
* some defaults.
*/
if (dirObj) {
string = TclGetString(dirObj);
Tcl_UtfToExternalDString(NULL, string, dirObj->length, &template);
} else {
Tcl_DStringInit(&template);
Tcl_DStringAppend(&template, DefaultTempDir(), -1); /* INTL: native */
}
if (Tcl_DStringValue(&template)[Tcl_DStringLength(&template) - 1] != '/') {
TclDStringAppendLiteral(&template, "/");
}
if (basenameObj) {
string = TclGetString(basenameObj);
if (basenameObj->length) {
Tcl_UtfToExternalDString(NULL, string, basenameObj->length, &tmp);
TclDStringAppendDString(&template, &tmp);
Tcl_DStringFree(&tmp);
} else {
TclDStringAppendLiteral(&template, DEFAULT_TEMP_DIR_PREFIX);
}
} else {
TclDStringAppendLiteral(&template, DEFAULT_TEMP_DIR_PREFIX);
}
TclDStringAppendLiteral(&template, "_XXXXXX");
/*
* Make the temporary directory.
*/
if (mkdtemp(Tcl_DStringValue(&template)) == NULL) {
Tcl_DStringFree(&template);
return NULL;
}
/*
* The template has been updated. Tell the caller what it was.
*/
Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(&template),
Tcl_DStringLength(&template), &tmp);
Tcl_DStringFree(&template);
return TclDStringToObj(&tmp);
}
#if defined(__CYGWIN__)
static void
StatError(
Tcl_Interp *interp, /* The interp that has the error */
Tcl_Obj *fileName) /* The name of the file which caused the
* error. */
{
TclWinConvertError(GetLastError());
Tcl_SetObjResult(interp, Tcl_ObjPrintf("could not read \"%s\": %s",
TclGetString(fileName), Tcl_PosixError(interp)));
}
static WCHAR *
winPathFromObj(
Tcl_Obj *fileName)
{
size_t size;
const char *native = Tcl_FSGetNativePath(fileName);
WCHAR *winPath;
size = cygwin_conv_path(1, native, NULL, 0);
winPath = Tcl_Alloc(size);
cygwin_conv_path(1, native, winPath, size);
return winPath;
}
static const int attributeArray[] = {
0x20, 0, 2, 0, 0, 1, 4
};
/*
*----------------------------------------------------------------------
*
* GetUnixFileAttributes
*
* Gets the readonly attribute of a file.
|
| ︙ | ︙ | |||
2326 2327 2328 2329 2330 2331 2332 |
Tcl_Obj *fileName, /* The name of the file (UTF-8). */
Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */
{
int fileAttributes;
WCHAR *winPath = winPathFromObj(fileName);
fileAttributes = GetFileAttributesW(winPath);
| | | | | 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 |
Tcl_Obj *fileName, /* The name of the file (UTF-8). */
Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */
{
int fileAttributes;
WCHAR *winPath = winPathFromObj(fileName);
fileAttributes = GetFileAttributesW(winPath);
Tcl_Free(winPath);
if (fileAttributes == -1) {
StatError(interp, fileName);
return TCL_ERROR;
}
*attributePtrPtr = Tcl_NewWideIntObj(
(fileAttributes & attributeArray[objIndex]) != 0);
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
* SetUnixFileAttributes
|
| ︙ | ︙ | |||
2373 2374 2375 2376 2377 2378 2379 |
}
winPath = winPathFromObj(fileName);
fileAttributes = old = GetFileAttributesW(winPath);
if (fileAttributes == -1) {
| | | | | 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 |
}
winPath = winPathFromObj(fileName);
fileAttributes = old = GetFileAttributesW(winPath);
if (fileAttributes == -1) {
Tcl_Free(winPath);
StatError(interp, fileName);
return TCL_ERROR;
}
if (yesNo) {
fileAttributes |= attributeArray[objIndex];
} else {
fileAttributes &= ~attributeArray[objIndex];
}
if ((fileAttributes != old)
&& !SetFileAttributesW(winPath, fileAttributes)) {
Tcl_Free(winPath);
StatError(interp, fileName);
return TCL_ERROR;
}
Tcl_Free(winPath);
return TCL_OK;
}
#elif defined(HAVE_CHFLAGS) && defined(UF_IMMUTABLE)
/*
*----------------------------------------------------------------------
*
* GetUnixFileAttributes
|
| ︙ | ︙ | |||
2433 2434 2435 2436 2437 2438 2439 |
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not read \"%s\": %s",
TclGetString(fileName), Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
| | < | 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 |
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not read \"%s\": %s",
TclGetString(fileName), Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
*attributePtrPtr = Tcl_NewWideIntObj((statBuf.st_flags & UF_IMMUTABLE) != 0);
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
* SetUnixFileAttributes
|
| ︙ | ︙ |
Changes to unix/tclUnixFile.c.
| ︙ | ︙ | |||
37 38 39 40 41 42 43 |
void
TclpFindExecutable(
const char *argv0) /* The value of the application's argv[0]
* (native). */
{
Tcl_Encoding encoding;
#ifdef __CYGWIN__
| | | 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 |
void
TclpFindExecutable(
const char *argv0) /* The value of the application's argv[0]
* (native). */
{
Tcl_Encoding encoding;
#ifdef __CYGWIN__
size_t length;
char buf[PATH_MAX * 2];
char name[PATH_MAX * TCL_UTF_MAX + 1];
GetModuleFileNameW(NULL, buf, PATH_MAX);
cygwin_conv_path(3, buf, name, PATH_MAX);
length = strlen(name);
if ((length > 4) && !strcasecmp(name + length - 4, ".exe")) {
/* Strip '.exe' part. */
|
| ︙ | ︙ | |||
255 256 257 258 259 260 261 |
matchResult = NativeMatchType(interp, native, nativeTail, types);
if (matchResult == 1) {
Tcl_ListObjAppendElement(interp, resultPtr, pathPtr);
}
Tcl_DecrRefCount(tailPtr);
Tcl_DecrRefCount(fileNamePtr);
} else {
| | | < | 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 |
matchResult = NativeMatchType(interp, native, nativeTail, types);
if (matchResult == 1) {
Tcl_ListObjAppendElement(interp, resultPtr, pathPtr);
}
Tcl_DecrRefCount(tailPtr);
Tcl_DecrRefCount(fileNamePtr);
} else {
TclDIR *d;
Tcl_DirEntry *entryPtr;
const char *dirName;
size_t dirLength, nativeDirLen;
int matchHidden, matchHiddenPat;
Tcl_StatBuf statBuf;
Tcl_DString ds; /* native encoding of dir */
Tcl_DString dsOrig; /* utf-8 encoding of dir */
Tcl_DStringInit(&dsOrig);
dirName = TclGetStringFromObj(fileNamePtr, &dirLength);
Tcl_DStringAppend(&dsOrig, dirName, dirLength);
/*
* Make sure that the directory part of the name really is a
* directory. If the directory name is "", use the name "." instead,
* because some UNIX systems don't treat "" like "." automatically.
* Keep the "" for use in generating file names, otherwise "glob
|
| ︙ | ︙ | |||
306 307 308 309 310 311 312 |
|| !S_ISDIR(statBuf.st_mode)) {
Tcl_DStringFree(&dsOrig);
Tcl_DStringFree(&ds);
Tcl_DecrRefCount(fileNamePtr);
return TCL_OK;
}
| | | 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 |
|| !S_ISDIR(statBuf.st_mode)) {
Tcl_DStringFree(&dsOrig);
Tcl_DStringFree(&ds);
Tcl_DecrRefCount(fileNamePtr);
return TCL_OK;
}
d = TclOSopendir(native); /* INTL: Native. */
if (d == NULL) {
Tcl_DStringFree(&ds);
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't read directory \"%s\": %s",
Tcl_DStringValue(&dsOrig), Tcl_PosixError(interp)));
}
|
| ︙ | ︙ | |||
384 385 386 387 388 389 390 |
}
Tcl_DStringFree(&utfDs);
if (matchResult < 0) {
break;
}
}
| | | 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 |
}
Tcl_DStringFree(&utfDs);
if (matchResult < 0) {
break;
}
}
TclOSclosedir(d);
Tcl_DStringFree(&ds);
Tcl_DStringFree(&dsOrig);
Tcl_DecrRefCount(fileNamePtr);
}
if (matchResult < 0) {
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
716 717 718 719 720 721 722 |
#else
if (getcwd(buffer, MAXPATHLEN+1) == NULL) { /* INTL: Native. */
return NULL;
}
#endif /* USEGETWD */
if ((clientData == NULL) || strcmp(buffer, (const char *) clientData)) {
| | | 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 |
#else
if (getcwd(buffer, MAXPATHLEN+1) == NULL) { /* INTL: Native. */
return NULL;
}
#endif /* USEGETWD */
if ((clientData == NULL) || strcmp(buffer, (const char *) clientData)) {
char *newCd = Tcl_Alloc(strlen(buffer) + 1);
strcpy(newCd, buffer);
return newCd;
}
/*
* No change to pwd.
|
| ︙ | ︙ | |||
936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 |
/*
* Check symbolic link flag first, since we prefer to create these.
*/
if (linkAction & TCL_CREATE_SYMBOLIC_LINK) {
Tcl_DString ds;
Tcl_Obj *transPtr;
/*
* Now we don't want to link to the absolute, normalized path.
* Relative links are quite acceptable (but links to ~user are not
* -- these must be expanded first).
*/
transPtr = Tcl_FSGetTranslatedPath(NULL, toPtr);
if (transPtr == NULL) {
return NULL;
}
| > | | | 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 |
/*
* Check symbolic link flag first, since we prefer to create these.
*/
if (linkAction & TCL_CREATE_SYMBOLIC_LINK) {
Tcl_DString ds;
Tcl_Obj *transPtr;
size_t length;
/*
* Now we don't want to link to the absolute, normalized path.
* Relative links are quite acceptable (but links to ~user are not
* -- these must be expanded first).
*/
transPtr = Tcl_FSGetTranslatedPath(NULL, toPtr);
if (transPtr == NULL) {
return NULL;
}
target = TclGetStringFromObj(transPtr, &length);
target = Tcl_UtfToExternalDString(NULL, target, length, &ds);
Tcl_DecrRefCount(transPtr);
if (symlink(target, src) != 0) {
toPtr = NULL;
}
Tcl_DStringFree(&ds);
} else if (linkAction & TCL_CREATE_HARD_LINK) {
|
| ︙ | ︙ | |||
1101 1102 1103 1104 1105 1106 1107 |
validPathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
if (validPathPtr == NULL) {
return NULL;
}
Tcl_IncrRefCount(validPathPtr);
}
| | < | | | 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 |
validPathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
if (validPathPtr == NULL) {
return NULL;
}
Tcl_IncrRefCount(validPathPtr);
}
str = TclGetStringFromObj(validPathPtr, &len);
Tcl_UtfToExternalDString(NULL, str, len, &ds);
len = Tcl_DStringLength(&ds) + sizeof(char);
if (strlen(Tcl_DStringValue(&ds)) < len - sizeof(char)) {
/* See bug [3118489]: NUL in filenames */
Tcl_DecrRefCount(validPathPtr);
Tcl_DStringFree(&ds);
return NULL;
}
Tcl_DecrRefCount(validPathPtr);
nativePathPtr = Tcl_Alloc(len);
memcpy(nativePathPtr, Tcl_DStringValue(&ds), len);
Tcl_DStringFree(&ds);
return nativePathPtr;
}
/*
*---------------------------------------------------------------------------
|
| ︙ | ︙ | |||
1153 1154 1155 1156 1157 1158 1159 |
/*
* ASCII representation when running on Unix.
*/
len = (strlen((const char*) clientData) + 1) * sizeof(char);
| | | 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 |
/*
* ASCII representation when running on Unix.
*/
len = (strlen((const char*) clientData) + 1) * sizeof(char);
copy = Tcl_Alloc(len);
memcpy(copy, clientData, len);
return copy;
}
/*
*---------------------------------------------------------------------------
*
|
| ︙ | ︙ |
Changes to unix/tclUnixInit.c.
| ︙ | ︙ | |||
312 313 314 315 316 317 318 | #ifdef HAVE_COREFOUNDATION static int MacOSXGetLibraryPath(Tcl_Interp *interp, int maxPathLen, char *tclLibPath); #endif /* HAVE_COREFOUNDATION */ #if defined(__APPLE__) && (defined(TCL_LOAD_FROM_MEMORY) || ( \ defined(MAC_OS_X_VERSION_MIN_REQUIRED) && ( \ | | | 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 | #ifdef HAVE_COREFOUNDATION static int MacOSXGetLibraryPath(Tcl_Interp *interp, int maxPathLen, char *tclLibPath); #endif /* HAVE_COREFOUNDATION */ #if defined(__APPLE__) && (defined(TCL_LOAD_FROM_MEMORY) || ( \ defined(MAC_OS_X_VERSION_MIN_REQUIRED) && ( \ (TCL_THREADS && MAC_OS_X_VERSION_MIN_REQUIRED < 1030) || \ (defined(__LP64__) && MAC_OS_X_VERSION_MIN_REQUIRED < 1050) || \ (defined(HAVE_COREFOUNDATION) && MAC_OS_X_VERSION_MIN_REQUIRED < 1050)\ ))) /* * Need to check Darwin release at runtime in tclUnixFCmd.c and tclLoadDyld.c: * initialize release global at startup from uname(). */ |
| ︙ | ︙ | |||
501 502 503 504 505 506 507 | * string. */ pathv[pathc - 1] = installLib + 4; str = Tcl_JoinPath(pathc, pathv, &ds); Tcl_ListObjAppendElement(NULL, pathPtr, TclDStringToObj(&ds)); } | | | 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 |
* string.
*/
pathv[pathc - 1] = installLib + 4;
str = Tcl_JoinPath(pathc, pathv, &ds);
Tcl_ListObjAppendElement(NULL, pathPtr, TclDStringToObj(&ds));
}
Tcl_Free(pathv);
}
/*
* Finally, look for the library relative to the compiled-in path. This is
* needed when users install Tcl with an exec-prefix that is different
* from the prefix.
*/
|
| ︙ | ︙ | |||
533 534 535 536 537 538 539 |
objPtr = Tcl_NewStringObj(str, -1);
Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
}
}
Tcl_DStringFree(&buffer);
*encodingPtr = Tcl_GetEncoding(NULL, NULL);
| | < | | 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 |
objPtr = Tcl_NewStringObj(str, -1);
Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
}
}
Tcl_DStringFree(&buffer);
*encodingPtr = Tcl_GetEncoding(NULL, NULL);
str = TclGetStringFromObj(pathPtr, lengthPtr);
*valuePtr = Tcl_Alloc(*lengthPtr + 1);
memcpy(*valuePtr, str, *lengthPtr + 1);
Tcl_DecrRefCount(pathPtr);
}
/*
*---------------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
977 978 979 980 981 982 983 | * TclpFindVariable -- * * Locate the entry in environ for a given name. On Unix this routine is * case sensetive, on Windows this matches mixed case. * * Results: * The return value is the index in environ of an entry with the name | | | | | | 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 |
* TclpFindVariable --
*
* Locate the entry in environ for a given name. On Unix this routine is
* case sensetive, on Windows this matches mixed case.
*
* Results:
* The return value is the index in environ of an entry with the name
* "name", or TCL_IO_FAILURE if there is no such entry. The integer at *lengthPtr is
* filled in with the length of name (if a matching entry is found) or
* the length of the environ array (if no matching entry is found).
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
size_t
TclpFindVariable(
const char *name, /* Name of desired environment variable
* (native). */
size_t *lengthPtr) /* Used to return length of name (for
* successful searches) or number of non-NULL
* entries in environ (for unsuccessful
* searches). */
{
size_t i, result = TCL_IO_FAILURE;
register const char *env, *p1, *p2;
Tcl_DString envString;
Tcl_DStringInit(&envString);
for (i = 0, env = environ[i]; env != NULL; i++, env = environ[i]) {
p1 = Tcl_ExternalToUtfDString(NULL, env, -1, &envString);
p2 = name;
|
| ︙ | ︙ |
Changes to unix/tclUnixNotfy.c.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 15 16 17 18 19 | * Copyright (c) 2016 Lucio Andrés Illanes Albornoz <l.illanes@gmx.de> * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include <poll.h> /* * Static routines defined in this file. */ | > > > | | > > > | | | < < < < < | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 | * Copyright (c) 2016 Lucio Andrés Illanes Albornoz <l.illanes@gmx.de> * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include <poll.h> #include "tclInt.h" /* * Static routines defined in this file. */ static int FileHandlerEventProc(Tcl_Event *evPtr, int flags); #if !TCL_THREADS # undef NOTIFIER_EPOLL # undef NOTIFIER_KQUEUE # define NOTIFIER_SELECT #elif !defined(NOTIFIER_EPOLL) && !defined(NOTIFIER_KQUEUE) # define NOTIFIER_SELECT static TCL_NORETURN void NotifierThreadProc(ClientData clientData); # if defined(HAVE_PTHREAD_ATFORK) static void AtForkChild(void); # endif /* HAVE_PTHREAD_ATFORK */ /* *---------------------------------------------------------------------- * * StartNotifierThread -- * * Start a notifier thread and wait for the notifier pipe to be created. * * Results: * None. * * Side effects: * Running Thread. * |
| ︙ | ︙ | |||
66 67 68 69 70 71 72 |
pthread_mutex_unlock(¬ifierMutex);
notifierThreadRunning = 1;
}
pthread_mutex_unlock(¬ifierInitMutex);
}
}
| < | 67 68 69 70 71 72 73 74 75 76 77 78 79 80 |
pthread_mutex_unlock(¬ifierMutex);
notifierThreadRunning = 1;
}
pthread_mutex_unlock(¬ifierInitMutex);
}
}
#endif /* NOTIFIER_SELECT */
/*
*----------------------------------------------------------------------
*
* Tcl_AlertNotifier --
*
|
| ︙ | ︙ | |||
103 104 105 106 107 108 109 |
ClientData clientData)
{
if (tclNotifierHooks.alertNotifierProc) {
tclNotifierHooks.alertNotifierProc(clientData);
return;
} else {
#ifdef NOTIFIER_SELECT
| | | > < > | 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 |
ClientData clientData)
{
if (tclNotifierHooks.alertNotifierProc) {
tclNotifierHooks.alertNotifierProc(clientData);
return;
} else {
#ifdef NOTIFIER_SELECT
#if TCL_THREADS
ThreadSpecificData *tsdPtr = clientData;
pthread_mutex_lock(¬ifierMutex);
tsdPtr->eventReady = 1;
# ifdef __CYGWIN__
PostMessageW(tsdPtr->hwnd, 1024, 0, 0);
# else
pthread_cond_broadcast(&tsdPtr->waitCV);
# endif /* __CYGWIN__ */
pthread_mutex_unlock(¬ifierMutex);
#endif /* TCL_THREADS */
#else /* !NOTIFIER_SELECT */
ThreadSpecificData *tsdPtr = clientData;
#if defined(NOTIFIER_EPOLL) && defined(HAVE_EVENTFD)
uint64_t eventFdVal = 1;
if (write(tsdPtr->triggerEventFd, &eventFdVal,
sizeof(eventFdVal)) != sizeof(eventFdVal)) {
Tcl_Panic("Tcl_AlertNotifier: unable to write to %p->triggerEventFd",
(void *)tsdPtr);
}
#else
if (write(tsdPtr->triggerPipe[1], "", 1) != 1) {
Tcl_Panic("Tcl_AlertNotifier: unable to write to %p->triggerPipe",
(void *)tsdPtr);
}
#endif /* NOTIFIER_EPOLL && HAVE_EVENTFD */
#endif /* NOTIFIER_SELECT */
}
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
276 277 278 279 280 281 282 |
}
break;
}
return 1;
}
#ifdef NOTIFIER_SELECT
| | | | | | | | | 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 |
}
break;
}
return 1;
}
#ifdef NOTIFIER_SELECT
#if TCL_THREADS
/*
*----------------------------------------------------------------------
*
* AlertSingleThread --
*
* Notify a single thread that is waiting on a file descriptor to become
* readable or writable or to have an exception condition.
* notifierMutex must be held.
*
* Result:
* None.
*
* Side effects:
* The condition variable associated with the thread is broadcasted.
*
*----------------------------------------------------------------------
*/
static void
AlertSingleThread(
ThreadSpecificData *tsdPtr)
{
tsdPtr->eventReady = 1;
if (tsdPtr->onList) {
/*
* Remove the ThreadSpecificData structure of this thread from the
* waiting list. This prevents us from continuously spinning on
* epoll_wait until the other threads runs and services the file
* event.
*/
if (tsdPtr->prevPtr) {
tsdPtr->prevPtr->nextPtr = tsdPtr->nextPtr;
} else {
waitingListPtr = tsdPtr->nextPtr;
}
if (tsdPtr->nextPtr) {
tsdPtr->nextPtr->prevPtr = tsdPtr->prevPtr;
}
tsdPtr->nextPtr = tsdPtr->prevPtr = NULL;
tsdPtr->onList = 0;
tsdPtr->pollState = 0;
}
#ifdef __CYGWIN__
PostMessageW(tsdPtr->hwnd, 1024, 0, 0);
#else /* !__CYGWIN__ */
pthread_cond_broadcast(&tsdPtr->waitCV);
#endif /* __CYGWIN__ */
}
#if defined(HAVE_PTHREAD_ATFORK)
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
355 356 357 358 359 360 361 |
pthread_cond_destroy(¬ifierCV);
}
pthread_mutex_init(¬ifierInitMutex, NULL);
pthread_mutex_init(¬ifierMutex, NULL);
pthread_cond_init(¬ifierCV, NULL);
/*
| | > | | | | | | 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 |
pthread_cond_destroy(¬ifierCV);
}
pthread_mutex_init(¬ifierInitMutex, NULL);
pthread_mutex_init(¬ifierMutex, NULL);
pthread_cond_init(¬ifierCV, NULL);
/*
* notifierThreadRunning == 1: thread is running, (there might be data in
* notifier lists)
* atForkInit == 0: InitNotifier was never called
* notifierCount != 0: unbalanced InitNotifier() / FinalizeNotifier calls
* waitingListPtr != 0: there are threads currently waiting for events.
*/
if (atForkInit == 1) {
notifierCount = 0;
if (notifierThreadRunning == 1) {
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
notifierThreadRunning = 0;
close(triggerPipe);
triggerPipe = -1;
/*
* The waitingListPtr might contain event info from multiple
* threads, which are invalid here, so setting it to NULL is not
* unreasonable.
*/
waitingListPtr = NULL;
/*
* The tsdPtr from before the fork is copied as well. But since we
* are paranoic, we don't trust its condvar and reset it.
*/
#ifdef __CYGWIN__
DestroyWindow(tsdPtr->hwnd);
tsdPtr->hwnd = CreateWindowExW(NULL, className,
className, 0, 0, 0, 0, 0, NULL, NULL,
TclWinGetTclInstance(), NULL);
ResetEvent(tsdPtr->event);
#else /* !__CYGWIN__ */
pthread_cond_destroy(&tsdPtr->waitCV);
pthread_cond_init(&tsdPtr->waitCV, NULL);
#endif /* __CYGWIN__ */
/*
* In case, we had multiple threads running before the fork,
* make sure, we don't try to reach out to their thread local data.
*/
tsdPtr->nextPtr = tsdPtr->prevPtr = NULL;
|
| ︙ | ︙ | |||
461 462 463 464 465 466 467 |
/*
* If there is a non-zero finite timeout, compute the time when we give
* up.
*/
if (timeout > 0) {
Tcl_GetTime(&now);
| | | | 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 |
/*
* If there is a non-zero finite timeout, compute the time when we give
* up.
*/
if (timeout > 0) {
Tcl_GetTime(&now);
abortTime.sec = now.sec + timeout / 1000;
abortTime.usec = now.usec + (timeout % 1000) * 1000;
if (abortTime.usec >= 1000000) {
abortTime.usec -= 1000000;
abortTime.sec += 1;
}
timeoutPtr = &blockTime;
} else if (timeout == 0) {
timeoutPtr = &blockTime;
|
| ︙ | ︙ | |||
497 498 499 500 501 502 503 |
}
/*
* Loop in a mini-event loop of our own, waiting for either the file to
* become ready or a timeout to occur.
*/
| | | 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 |
}
/*
* Loop in a mini-event loop of our own, waiting for either the file to
* become ready or a timeout to occur.
*/
do {
if (timeout > 0) {
blockTime.tv_sec = abortTime.sec - now.sec;
blockTime.tv_usec = abortTime.usec - now.usec;
if (blockTime.tv_usec < 0) {
blockTime.tv_sec -= 1;
blockTime.tv_usec += 1000000;
}
|
| ︙ | ︙ | |||
520 521 522 523 524 525 526 |
*/
if (!timeoutPtr) {
pollTimeout = -1;
} else if (!timeoutPtr->tv_sec && !timeoutPtr->tv_usec) {
pollTimeout = 0;
} else {
| | | | 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 |
*/
if (!timeoutPtr) {
pollTimeout = -1;
} else if (!timeoutPtr->tv_sec && !timeoutPtr->tv_usec) {
pollTimeout = 0;
} else {
pollTimeout = (int) timeoutPtr->tv_sec * 1000;
if (timeoutPtr->tv_usec) {
pollTimeout += (int) timeoutPtr->tv_usec / 1000;
}
}
numFound = poll(pollFds, 1, pollTimeout);
if (numFound == 1) {
result = 0;
if (pollFds[0].revents & (POLLIN | POLLHUP)) {
result |= TCL_READABLE;
|
| ︙ | ︙ | |||
553 554 555 556 557 558 559 | } /* * The select returned early, so we need to recompute the timeout. */ Tcl_GetTime(&now); | | | | | | < < | 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 |
}
/*
* The select returned early, so we need to recompute the timeout.
*/
Tcl_GetTime(&now);
} while ((abortTime.sec > now.sec)
|| (abortTime.sec == now.sec && abortTime.usec > now.usec));
return result;
}
#endif /* !HAVE_COREFOUNDATION */
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to unix/tclUnixPipe.c.
| ︙ | ︙ | |||
520 521 522 523 524 525 526 |
* an error message.
*/
TclpCloseFile(errPipeOut);
errPipeOut = NULL;
fd = GetFd(errPipeIn);
| | | 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 |
* an error message.
*/
TclpCloseFile(errPipeOut);
errPipeOut = NULL;
fd = GetFd(errPipeIn);
count = read(fd, errSpace, sizeof(errSpace) - 1);
if (count > 0) {
char *end;
errSpace[count] = 0;
errno = strtol(errSpace, &end, 10);
Tcl_SetObjResult(interp, Tcl_ObjPrintf("%s: %s",
end, Tcl_PosixError(interp)));
|
| ︙ | ︙ | |||
740 741 742 743 744 745 746 |
Tcl_Pid *pidPtr) /* An array of process identifiers. Allocated
* by the caller, freed when the channel is
* closed or the processes are detached (in a
* background exec). */
{
char channelName[16 + TCL_INTEGER_SPACE];
int channelId;
| | | 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 |
Tcl_Pid *pidPtr) /* An array of process identifiers. Allocated
* by the caller, freed when the channel is
* closed or the processes are detached (in a
* background exec). */
{
char channelName[16 + TCL_INTEGER_SPACE];
int channelId;
PipeState *statePtr = Tcl_Alloc(sizeof(PipeState));
int mode;
statePtr->inFile = readFile;
statePtr->outFile = writeFile;
statePtr->errorFile = errorFile;
statePtr->numPids = numPids;
statePtr->pidPtr = pidPtr;
|
| ︙ | ︙ | |||
868 869 870 871 872 873 874 |
if (chanTypePtr != &pipeChannelType) {
return;
}
pipePtr = Tcl_GetChannelInstanceData(chan);
TclNewObj(pidsObj);
for (i = 0; i < pipePtr->numPids; i++) {
| | | | 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 |
if (chanTypePtr != &pipeChannelType) {
return;
}
pipePtr = Tcl_GetChannelInstanceData(chan);
TclNewObj(pidsObj);
for (i = 0; i < pipePtr->numPids; i++) {
Tcl_ListObjAppendElement(NULL, pidsObj, Tcl_NewWideIntObj(
PTR2INT(pipePtr->pidPtr[i])));
Tcl_DetachPids(1, &pipePtr->pidPtr[i]);
}
Tcl_SetObjResult(interp, pidsObj);
if (pipePtr->numPids > 0) {
Tcl_Free(pipePtr->pidPtr);
pipePtr->numPids = 0;
}
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1005 1006 1007 1008 1009 1010 1011 |
errChan = NULL;
}
result = TclCleanupChildren(interp, pipePtr->numPids, pipePtr->pidPtr,
errChan);
}
if (pipePtr->numPids != 0) {
| | | | 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 |
errChan = NULL;
}
result = TclCleanupChildren(interp, pipePtr->numPids, pipePtr->pidPtr,
errChan);
}
if (pipePtr->numPids != 0) {
Tcl_Free(pipePtr->pidPtr);
}
Tcl_Free(pipePtr);
if (errorCode == 0) {
return result;
}
return errorCode;
}
/*
|
| ︙ | ︙ | |||
1055 1056 1057 1058 1059 1060 1061 |
* appropriately, and read will unblock as soon as a short read is
* possible, if the channel is in blocking mode. If the channel is
* nonblocking, the read will never block. Some OSes can throw an
* interrupt error, for which we should immediately retry. [Bug #415131]
*/
do {
| | | 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 |
* appropriately, and read will unblock as soon as a short read is
* possible, if the channel is in blocking mode. If the channel is
* nonblocking, the read will never block. Some OSes can throw an
* interrupt error, for which we should immediately retry. [Bug #415131]
*/
do {
bytesRead = read(GetFd(psPtr->inFile), buf, toRead);
} while ((bytesRead < 0) && (errno == EINTR));
if (bytesRead < 0) {
*errorCodePtr = errno;
return -1;
}
return bytesRead;
|
| ︙ | ︙ | |||
1101 1102 1103 1104 1105 1106 1107 |
/*
* Some OSes can throw an interrupt error, for which we should immediately
* retry. [Bug #415131]
*/
do {
| | | 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 |
/*
* Some OSes can throw an interrupt error, for which we should immediately
* retry. [Bug #415131]
*/
do {
written = write(GetFd(psPtr->outFile), buf, toWrite);
} while ((written < 0) && (errno == EINTR));
if (written < 0) {
*errorCodePtr = errno;
return -1;
}
return written;
|
| ︙ | ︙ | |||
1264 1265 1266 1267 1268 1269 1270 |
if (objc > 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?channelId?");
return TCL_ERROR;
}
if (objc == 1) {
| | | | | 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 |
if (objc > 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?channelId?");
return TCL_ERROR;
}
if (objc == 1) {
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(getpid()));
} else {
/*
* Get the channel and make sure that it refers to a pipe.
*/
chan = Tcl_GetChannel(interp, TclGetString(objv[1]), NULL);
if (chan == NULL) {
return TCL_ERROR;
}
if (Tcl_GetChannelType(chan) != &pipeChannelType) {
return TCL_OK;
}
/*
* Extract the process IDs from the pipe structure.
*/
pipePtr = Tcl_GetChannelInstanceData(chan);
resultPtr = Tcl_NewObj();
for (i = 0; i < pipePtr->numPids; i++) {
Tcl_ListObjAppendElement(NULL, resultPtr,
Tcl_NewWideIntObj(PTR2INT(TclpGetPid(pipePtr->pidPtr[i]))));
}
Tcl_SetObjResult(interp, resultPtr);
}
return TCL_OK;
}
/*
|
| ︙ | ︙ |
Changes to unix/tclUnixPort.h.
| ︙ | ︙ | |||
53 54 55 56 57 58 59 | /* *--------------------------------------------------------------------------- * Parameterize for 64-bit filesystem support. *--------------------------------------------------------------------------- */ #ifdef HAVE_STRUCT_DIRENT64 | | | > > > > > > > > > > > | 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 | /* *--------------------------------------------------------------------------- * Parameterize for 64-bit filesystem support. *--------------------------------------------------------------------------- */ #ifdef HAVE_STRUCT_DIRENT64 typedef struct dirent64 Tcl_DirEntry; # define TclOSreaddir readdir64 #else typedef struct dirent Tcl_DirEntry; # define TclOSreaddir readdir #endif #ifdef HAVE_DIR64 typedef DIR64 TclDIR; # define TclOSopendir opendir64 # define TclOSrewinddir rewinddir64 # define TclOSclosedir closedir64 #else typedef DIR TclDIR; # define TclOSopendir opendir # define TclOSrewinddir rewinddir # define TclOSclosedir closedir #endif #ifdef HAVE_TYPE_OFF64_T typedef off64_t Tcl_SeekOffset; # define TclOSseek lseek64 # define TclOSopen open64 #else typedef off_t Tcl_SeekOffset; |
| ︙ | ︙ | |||
141 142 143 144 145 146 147 | #ifdef HAVE_INTTYPES_H # include <inttypes.h> #endif #include <limits.h> #ifdef HAVE_STDINT_H # include <stdint.h> #endif | < | < < < | | 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 | #ifdef HAVE_INTTYPES_H # include <inttypes.h> #endif #include <limits.h> #ifdef HAVE_STDINT_H # include <stdint.h> #endif #include <unistd.h> MODULE_SCOPE int TclUnixSetBlockingMode(int fd, int mode); #include <utime.h> /* *--------------------------------------------------------------------------- * Socket support stuff: This likely needs more work to parameterize for each * system. |
| ︙ | ︙ | |||
598 599 600 601 602 603 604 | # endif # if MAC_OS_X_VERSION_MAX_ALLOWED < 1040 # undef HAVE_OSSPINLOCKLOCK # undef HAVE_PTHREAD_ATFORK # undef HAVE_COPYFILE # endif # if MAC_OS_X_VERSION_MAX_ALLOWED < 1030 | < | | < | 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 | # endif # if MAC_OS_X_VERSION_MAX_ALLOWED < 1040 # undef HAVE_OSSPINLOCKLOCK # undef HAVE_PTHREAD_ATFORK # undef HAVE_COPYFILE # endif # if MAC_OS_X_VERSION_MAX_ALLOWED < 1030 /* prior to 10.3, realpath is not threadsafe, c.f. bug 711232 */ # define NO_REALPATH 1 # undef HAVE_LANGINFO # endif # endif /* MAC_OS_X_VERSION_MAX_ALLOWED */ # if defined(HAVE_COREFOUNDATION) && defined(__LP64__) && \ defined(HAVE_WEAK_IMPORT) && MAC_OS_X_VERSION_MIN_REQUIRED < 1050 # warning "Weak import of 64-bit CoreFoundation is not supported, will not run on Mac OS X < 10.5." # endif |
| ︙ | ︙ | |||
663 664 665 666 667 668 669 | /* *--------------------------------------------------------------------------- * The following defines wrap the system memory allocation routines. *--------------------------------------------------------------------------- */ #define TclpSysAlloc(size) malloc(size) | | | | | | | | | | | 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 | /* *--------------------------------------------------------------------------- * The following defines wrap the system memory allocation routines. *--------------------------------------------------------------------------- */ #define TclpSysAlloc(size) malloc(size) #define TclpSysFree(ptr) free(ptr) #define TclpSysRealloc(ptr, size) realloc(ptr, size) /* *--------------------------------------------------------------------------- * The following macros and declaration wrap the C runtime library functions. *--------------------------------------------------------------------------- */ #define TclpExit exit #if !defined(TCL_THREADS) || TCL_THREADS # include <pthread.h> #endif /* TCL_THREADS */ /* FIXME - Hyper-enormous platform assumption! */ #ifndef AF_INET6 # define AF_INET6 10 #endif /* *--------------------------------------------------------------------------- * Set of MT-safe implementations of some known-to-be-MT-unsafe library calls. * Instead of returning pointers to the static storage, those return pointers * to the TSD data. *--------------------------------------------------------------------------- */ #include <pwd.h> #include <grp.h> MODULE_SCOPE struct passwd * TclpGetPwNam(const char *name); MODULE_SCOPE struct group * TclpGetGrNam(const char *name); MODULE_SCOPE struct passwd * TclpGetPwUid(uid_t uid); MODULE_SCOPE struct group * TclpGetGrGid(gid_t gid); MODULE_SCOPE struct hostent * TclpGetHostByName(const char *name); MODULE_SCOPE struct hostent * TclpGetHostByAddr(const char *addr, int length, int type); MODULE_SCOPE void *TclpMakeTcpClientChannelMode( void *tcpSocket, int mode); #endif /* _TCLUNIXPORT */ /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to unix/tclUnixSock.c.
| ︙ | ︙ | |||
235 236 237 238 239 240 241 |
* as it exceeds SYS_NMLN. See if we can just get the immediate
* nodename and get a proper answer that way.
*/
char *dot = strchr(u.nodename, '.');
if (dot != NULL) {
| | | | < < < | 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 |
* as it exceeds SYS_NMLN. See if we can just get the immediate
* nodename and get a proper answer that way.
*/
char *dot = strchr(u.nodename, '.');
if (dot != NULL) {
char *node = Tcl_Alloc(dot - u.nodename + 1);
memcpy(node, u.nodename, dot - u.nodename);
node[dot - u.nodename] = '\0';
hp = TclpGetHostByName(node);
Tcl_Free(node);
}
}
if (hp != NULL) {
native = hp->h_name;
} else {
native = u.nodename;
}
}
#else /* !NO_UNAME */
/*
* Uname doesn't exist; try gethostname instead.
*
* There is no portable macro for the maximum length of host names
* returned by gethostbyname(). We should only trust SYS_NMLN if it is at
* least 255 + 1 bytes to comply with DNS host name limits.
|
| ︙ | ︙ | |||
280 281 282 283 284 285 286 |
if (gethostname(buffer, sizeof(buffer)) > -1) { /* INTL: Native. */
native = buffer;
}
#endif /* NO_UNAME */
*encodingPtr = Tcl_GetEncoding(NULL, NULL);
| > | | | > > > > > | 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 |
if (gethostname(buffer, sizeof(buffer)) > -1) { /* INTL: Native. */
native = buffer;
}
#endif /* NO_UNAME */
*encodingPtr = Tcl_GetEncoding(NULL, NULL);
if (native) {
*lengthPtr = strlen(native);
*valuePtr = Tcl_Alloc(*lengthPtr + 1);
memcpy(*valuePtr, native, *lengthPtr + 1);
} else {
*lengthPtr = 0;
*valuePtr = Tcl_Alloc(1);
*valuePtr[0] = '\0';
}
}
/*
* ----------------------------------------------------------------------
*
* Tcl_GetHostName --
*
|
| ︙ | ︙ | |||
306 307 308 309 310 311 312 |
*
* ----------------------------------------------------------------------
*/
const char *
Tcl_GetHostName(void)
{
| | > | 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 |
*
* ----------------------------------------------------------------------
*/
const char *
Tcl_GetHostName(void)
{
Tcl_Obj *tclObj = TclGetProcessGlobalValue(&hostName);
return TclGetString(tclObj);
}
/*
* ----------------------------------------------------------------------
*
* TclpHasSockets --
*
|
| ︙ | ︙ | |||
533 534 535 536 537 538 539 |
TcpState *statePtr = instanceData;
int bytesRead;
*errorCodePtr = 0;
if (WaitForConnect(statePtr, errorCodePtr) != 0) {
return -1;
}
| | | 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 |
TcpState *statePtr = instanceData;
int bytesRead;
*errorCodePtr = 0;
if (WaitForConnect(statePtr, errorCodePtr) != 0) {
return -1;
}
bytesRead = recv(statePtr->fds.fd, buf, bufSize, 0);
if (bytesRead > -1) {
return bytesRead;
}
if (errno == ECONNRESET) {
/*
* Turn ECONNRESET into a soft EOF condition.
*/
|
| ︙ | ︙ | |||
583 584 585 586 587 588 589 |
TcpState *statePtr = instanceData;
int written;
*errorCodePtr = 0;
if (WaitForConnect(statePtr, errorCodePtr) != 0) {
return -1;
}
| | | 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 |
TcpState *statePtr = instanceData;
int written;
*errorCodePtr = 0;
if (WaitForConnect(statePtr, errorCodePtr) != 0) {
return -1;
}
written = send(statePtr->fds.fd, buf, toWrite, 0);
if (written > -1) {
return written;
}
*errorCodePtr = errno;
return -1;
}
|
| ︙ | ︙ | |||
642 643 644 645 646 647 648 |
}
}
fds = statePtr->fds.next;
while (fds != NULL) {
TcpFdList *next = fds->next;
| | | | 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 |
}
}
fds = statePtr->fds.next;
while (fds != NULL) {
TcpFdList *next = fds->next;
Tcl_Free(fds);
fds = next;
}
if (statePtr->addrlist != NULL) {
freeaddrinfo(statePtr->addrlist);
}
if (statePtr->myaddrlist != NULL) {
freeaddrinfo(statePtr->myaddrlist);
}
Tcl_Free(statePtr);
return errorCode;
}
/*
*----------------------------------------------------------------------
*
* TcpClose2Proc --
|
| ︙ | ︙ | |||
1120 1121 1122 1123 1124 1125 1126 | /* * ---------------------------------------------------------------------- * * TcpAsyncCallback -- * * Called by the event handler that TcpConnect sets up internally for | | | 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 | /* * ---------------------------------------------------------------------- * * TcpAsyncCallback -- * * Called by the event handler that TcpConnect sets up internally for * [socket -async] to get notified when the asynchronous connection * attempt has succeeded or failed. * * ---------------------------------------------------------------------- */ static void TcpAsyncCallback( |
| ︙ | ︙ | |||
1153 1154 1155 1156 1157 1158 1159 | * and an error message is left in interp. * * Side effects: * Opens a socket. * * Remarks: * A single host name may resolve to more than one IP address, e.g. for | | | | 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 |
* and an error message is left in interp.
*
* Side effects:
* Opens a socket.
*
* Remarks:
* A single host name may resolve to more than one IP address, e.g. for
* an IPv4/IPv6 dual stack host. For handling asynchronously connecting
* sockets in the background for such hosts, this function can act as a
* coroutine. On the first call, it sets up the control variables for the
* two nested loops over the local and remote addresses. Once the first
* connection attempt is in progress, it sets up itself as a writable
* event handler for that socket, and returns. When the callback occurs,
* control is transferred to the "reenter" label, right after the initial
* return and the loops resume as if they had never been interrupted.
* For synchronously connecting sockets, the loops work the usual way.
*
* ----------------------------------------------------------------------
*/
static int
TcpConnect(
Tcl_Interp *interp, /* For error reporting; can be NULL. */
|
| ︙ | ︙ | |||
1392 1393 1394 1395 1396 1397 1398 |
return NULL;
}
/*
* Allocate a new TcpState for this socket.
*/
| | | 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 |
return NULL;
}
/*
* Allocate a new TcpState for this socket.
*/
statePtr = Tcl_Alloc(sizeof(TcpState));
memset(statePtr, 0, sizeof(TcpState));
statePtr->flags = async ? TCP_ASYNC_CONNECT : 0;
statePtr->cachedBlocking = TCL_MODE_BLOCKING;
statePtr->addrlist = addrlist;
statePtr->myaddrlist = myaddrlist;
statePtr->fds.fd = -1;
|
| ︙ | ︙ | |||
1471 1472 1473 1474 1475 1476 1477 |
void *sock, /* The socket to wrap up into a channel. */
int mode) /* ORed combination of TCL_READABLE and
* TCL_WRITABLE to indicate file mode. */
{
TcpState *statePtr;
char channelName[SOCK_CHAN_LENGTH];
| | | 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 |
void *sock, /* The socket to wrap up into a channel. */
int mode) /* ORed combination of TCL_READABLE and
* TCL_WRITABLE to indicate file mode. */
{
TcpState *statePtr;
char channelName[SOCK_CHAN_LENGTH];
statePtr = Tcl_Alloc(sizeof(TcpState));
memset(statePtr, 0, sizeof(TcpState));
statePtr->fds.fd = PTR2INT(sock);
statePtr->flags = 0;
sprintf(channelName, SOCK_TEMPLATE, (long)statePtr);
statePtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
|
| ︙ | ︙ | |||
1694 1695 1696 1697 1698 1699 1700 |
continue;
}
if (statePtr == NULL) {
/*
* Allocate a new TcpState for this socket.
*/
| | | | 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 |
continue;
}
if (statePtr == NULL) {
/*
* Allocate a new TcpState for this socket.
*/
statePtr = Tcl_Alloc(sizeof(TcpState));
memset(statePtr, 0, sizeof(TcpState));
statePtr->acceptProc = acceptProc;
statePtr->acceptProcData = acceptProcData;
sprintf(channelName, SOCK_TEMPLATE, (long) statePtr);
newfds = &statePtr->fds;
} else {
newfds = Tcl_Alloc(sizeof(TcpFdList));
memset(newfds, (int) 0, sizeof(TcpFdList));
fds->next = newfds;
}
newfds->fd = sock;
newfds->statePtr = statePtr;
fds = newfds;
|
| ︙ | ︙ | |||
1786 1787 1788 1789 1790 1791 1792 |
/*
* Set close-on-exec flag to prevent the newly accepted socket from being
* inherited by child processes.
*/
(void) fcntl(newsock, F_SETFD, FD_CLOEXEC);
| | | 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 |
/*
* Set close-on-exec flag to prevent the newly accepted socket from being
* inherited by child processes.
*/
(void) fcntl(newsock, F_SETFD, FD_CLOEXEC);
newSockState = Tcl_Alloc(sizeof(TcpState));
memset(newSockState, 0, sizeof(TcpState));
newSockState->flags = 0;
newSockState->fds.fd = newsock;
sprintf(channelName, SOCK_TEMPLATE, (long) newSockState);
newSockState->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
newSockState, TCL_READABLE | TCL_WRITABLE);
|
| ︙ | ︙ |
Changes to unix/tclUnixTest.c.
| ︙ | ︙ | |||
566 567 568 569 570 571 572 |
return TCL_ERROR;
}
/* Only needed when pthread_atfork is not present,
* should not hurt otherwise. */
if (pid==0) {
Tcl_InitNotifier();
}
| | | 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 |
return TCL_ERROR;
}
/* Only needed when pthread_atfork is not present,
* should not hurt otherwise. */
if (pid==0) {
Tcl_InitNotifier();
}
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(pid));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestgetencpathObjCmd --
|
| ︙ | ︙ | |||
757 758 759 760 761 762 763 |
Tcl_DString buffer;
const char *translated;
translated = Tcl_TranslateFileName(interp, Tcl_GetString(objv[i]), &buffer);
if (translated == NULL) {
return TCL_ERROR;
}
| | | 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 |
Tcl_DString buffer;
const char *translated;
translated = Tcl_TranslateFileName(interp, Tcl_GetString(objv[i]), &buffer);
if (translated == NULL) {
return TCL_ERROR;
}
if (chmod(translated, mode) != 0) {
Tcl_AppendResult(interp, translated, ": ", Tcl_PosixError(interp),
NULL);
return TCL_ERROR;
}
Tcl_DStringFree(&buffer);
}
return TCL_OK;
|
| ︙ | ︙ |
Changes to unix/tclUnixThrd.c.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 | * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > | | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 |
*
* 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
/*
* TIP #509. Ensures that Tcl's mutexes are reentrant.
*
*----------------------------------------------------------------------
*
* PMutexInit --
*
* Sets up the memory pointed to by its argument so that it contains the
* implementation of a recursive lock. Caller supplies the space.
*
*----------------------------------------------------------------------
*
* PMutexDestroy --
*
* Tears down the implementation of a recursive lock (but does not
* deallocate the space holding the lock).
*
*----------------------------------------------------------------------
*
* PMutexLock --
*
* Locks a recursive lock. (Similar to pthread_mutex_lock)
*
*----------------------------------------------------------------------
*
* PMutexUnlock --
*
* Unlocks a recursive lock. (Similar to pthread_mutex_unlock)
*
*----------------------------------------------------------------------
*
* PCondWait --
*
* Waits on a condition variable linked a recursive lock. (Similar to
* pthread_cond_wait)
*
*----------------------------------------------------------------------
*
* PCondTimedWait --
*
* Waits for a limited amount of time on a condition variable linked to a
* recursive lock. (Similar to pthread_cond_timedwait)
*
*----------------------------------------------------------------------
*/
#ifndef HAVE_DECL_PTHREAD_MUTEX_RECURSIVE
#define HAVE_DECL_PTHREAD_MUTEX_RECURSIVE 0
#endif
#if HAVE_DECL_PTHREAD_MUTEX_RECURSIVE
/*
* Pthread has native reentrant (AKA recursive) mutexes. Use them for
* Tcl_Mutex.
*/
typedef pthread_mutex_t PMutex;
static void
PMutexInit(
PMutex *pmutexPtr)
{
pthread_mutexattr_t attr;
pthread_mutexattr_init(&attr);
pthread_mutexattr_settype(&attr, PTHREAD_MUTEX_RECURSIVE);
pthread_mutex_init(pmutexPtr, &attr);
}
#define PMutexDestroy pthread_mutex_destroy
#define PMutexLock pthread_mutex_lock
#define PMutexUnlock pthread_mutex_unlock
#define PCondWait pthread_cond_wait
#define PCondTimedWait pthread_cond_timedwait
#else /* !HAVE_PTHREAD_MUTEX_RECURSIVE */
/*
* No native support for reentrant mutexes. Emulate them with regular mutexes
* and thread-local counters.
*/
typedef struct PMutex {
pthread_mutex_t mutex;
pthread_t thread;
int counter;
} PMutex;
static void
PMutexInit(
PMutex *pmutexPtr)
{
pthread_mutex_init(&pmutexPtr->mutex, NULL);
pmutexPtr->thread = 0;
pmutexPtr->counter = 0;
}
static void
PMutexDestroy(
PMutex *pmutexPtr)
{
pthread_mutex_destroy(&pmutexPtr->mutex);
}
static void
PMutexLock(
PMutex *pmutexPtr)
{
if (pmutexPtr->thread != pthread_self() || pmutexPtr->counter == 0) {
pthread_mutex_lock(&pmutexPtr->mutex);
pmutexPtr->thread = pthread_self();
pmutexPtr->counter = 0;
}
pmutexPtr->counter++;
}
static void
PMutexUnlock(
PMutex *pmutexPtr)
{
pmutexPtr->counter--;
if (pmutexPtr->counter == 0) {
pmutexPtr->thread = 0;
pthread_mutex_unlock(&pmutexPtr->mutex);
}
}
static void
PCondWait(
pthread_cond_t *pcondPtr,
PMutex *pmutexPtr)
{
pthread_cond_wait(pcondPtr, &pmutexPtr->mutex);
}
static void
PCondTimedWait(
pthread_cond_t *pcondPtr,
PMutex *pmutexPtr,
struct timespec *ptime)
{
pthread_cond_timedwait(pcondPtr, &pmutexPtr->mutex, ptime);
}
#endif /* HAVE_PTHREAD_MUTEX_RECURSIVE */
/*
* masterLock is used to serialize creation of mutexes, condition variables,
* and thread local storage. This is the only place that can count on the
* ability to statically initialize the mutex.
*/
static pthread_mutex_t masterLock = PTHREAD_MUTEX_INITIALIZER;
/*
* initLock is used to serialize initialization and finalization of Tcl. It
* cannot use any dyamically allocated storage.
*/
static pthread_mutex_t initLock = PTHREAD_MUTEX_INITIALIZER;
/*
* allocLock is used by Tcl's version of malloc for synchronization. For
* obvious reasons, cannot use any dyamically allocated storage.
*/
static PMutex allocLock;
static pthread_once_t allocLockInitOnce = PTHREAD_ONCE_INIT;
static void
allocLockInit(void)
{
PMutexInit(&allocLock);
}
static PMutex *allocLockPtr = &allocLock;
#endif /* TCL_THREADS */
/*
*----------------------------------------------------------------------
*
* TclpThreadCreate --
|
| ︙ | ︙ | |||
58 59 60 61 62 63 64 |
*/
int
TclpThreadCreate(
Tcl_ThreadId *idPtr, /* Return, the ID of the thread */
Tcl_ThreadCreateProc *proc, /* Main() function of the thread */
ClientData clientData, /* The one argument to Main() */
| | | | | 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 |
*/
int
TclpThreadCreate(
Tcl_ThreadId *idPtr, /* Return, the ID of the thread */
Tcl_ThreadCreateProc *proc, /* Main() function of the thread */
ClientData clientData, /* The one argument to Main() */
size_t stackSize, /* Size of stack for the new thread */
int flags) /* Flags controlling behaviour of the new
* thread. */
{
#if TCL_THREADS
pthread_attr_t attr;
pthread_t theThread;
int result;
pthread_attr_init(&attr);
pthread_attr_setscope(&attr, PTHREAD_SCOPE_SYSTEM);
#ifdef HAVE_PTHREAD_ATTR_SETSTACKSIZE
if (stackSize != TCL_THREAD_STACK_DEFAULT) {
pthread_attr_setstacksize(&attr, stackSize);
#ifdef TCL_THREAD_STACK_MIN
} else {
/*
* Certain systems define a thread stack size that by default is too
* small for many operations. The user has the option of defining
* TCL_THREAD_STACK_MIN to a value large enough to work for their
* needs. This would look like (for 128K min stack):
|
| ︙ | ︙ | |||
97 98 99 100 101 102 103 |
if (!result && (size < TCL_THREAD_STACK_MIN)) {
pthread_attr_setstacksize(&attr, (size_t) TCL_THREAD_STACK_MIN);
}
#endif /* TCL_THREAD_STACK_MIN */
}
#endif /* HAVE_PTHREAD_ATTR_SETSTACKSIZE */
| | | | | | | 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 |
if (!result && (size < TCL_THREAD_STACK_MIN)) {
pthread_attr_setstacksize(&attr, (size_t) TCL_THREAD_STACK_MIN);
}
#endif /* TCL_THREAD_STACK_MIN */
}
#endif /* HAVE_PTHREAD_ATTR_SETSTACKSIZE */
if (!(flags & TCL_THREAD_JOINABLE)) {
pthread_attr_setdetachstate(&attr, PTHREAD_CREATE_DETACHED);
}
if (pthread_create(&theThread, &attr,
(void * (*)(void *)) proc, (void *) clientData) &&
pthread_create(&theThread, NULL,
(void * (*)(void *)) proc, (void *) clientData)) {
result = TCL_ERROR;
} else {
*idPtr = (Tcl_ThreadId) theThread;
result = TCL_OK;
}
pthread_attr_destroy(&attr);
return result;
#else
return TCL_ERROR;
#endif /* TCL_THREADS */
|
| ︙ | ︙ | |||
140 141 142 143 144 145 146 |
int
Tcl_JoinThread(
Tcl_ThreadId threadId, /* Id of the thread to wait upon. */
int *state) /* Reference to the storage the result of the
* thread we wait upon will be written into.
* May be NULL. */
{
| | < > < > > > | | 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 |
int
Tcl_JoinThread(
Tcl_ThreadId threadId, /* Id of the thread to wait upon. */
int *state) /* Reference to the storage the result of the
* thread we wait upon will be written into.
* May be NULL. */
{
#if TCL_THREADS
int result;
unsigned long retcode, *retcodePtr = &retcode;
result = pthread_join((pthread_t) threadId, (void**) retcodePtr);
if (state) {
*state = (int) retcode;
}
return (result == 0) ? TCL_OK : TCL_ERROR;
#else
return TCL_ERROR;
#endif
}
/*
*----------------------------------------------------------------------
*
* TclpThreadExit --
*
* This procedure terminates the current thread.
*
* Results:
* None.
*
* Side effects:
* This procedure terminates the current thread.
*
*----------------------------------------------------------------------
*/
void
TclpThreadExit(
int status)
{
#if TCL_THREADS
pthread_exit(INT2PTR(status));
#else /* TCL_THREADS */
exit(status);
#endif /* TCL_THREADS */
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetCurrentThread --
*
* This procedure returns the ID of the currently running thread.
*
* Results:
* A thread ID.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_ThreadId
Tcl_GetCurrentThread(void)
{
#if TCL_THREADS
return (Tcl_ThreadId) pthread_self();
#else
return (Tcl_ThreadId) 0;
#endif
}
/*
|
| ︙ | ︙ | |||
227 228 229 230 231 232 233 |
*
*----------------------------------------------------------------------
*/
void
TclpInitLock(void)
{
| | | 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 |
*
*----------------------------------------------------------------------
*/
void
TclpInitLock(void)
{
#if TCL_THREADS
pthread_mutex_lock(&initLock);
#endif
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
253 254 255 256 257 258 259 |
*
*----------------------------------------------------------------------
*/
void
TclFinalizeLock(void)
{
| | | 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 |
*
*----------------------------------------------------------------------
*/
void
TclFinalizeLock(void)
{
#if TCL_THREADS
/*
* You do not need to destroy mutexes that were created with the
* PTHREAD_MUTEX_INITIALIZER macro. These mutexes do not need any
* destruction: masterLock, allocLock, and initLock.
*/
pthread_mutex_unlock(&initLock);
|
| ︙ | ︙ | |||
284 285 286 287 288 289 290 |
*
*----------------------------------------------------------------------
*/
void
TclpInitUnlock(void)
{
| | | | < | 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 |
*
*----------------------------------------------------------------------
*/
void
TclpInitUnlock(void)
{
#if TCL_THREADS
pthread_mutex_unlock(&initLock);
#endif
}
/*
*----------------------------------------------------------------------
*
* TclpMasterLock
*
* This procedure is used to grab a lock that serializes creation and
* finalization of serialization objects. This interface is only needed
* in finalization; it is hidden during creation of the objects.
*
* This lock must be different than the initLock because the initLock is
* held during creation of synchronization objects.
*
* Results:
* None.
*
* Side effects:
* Acquire the master mutex.
*
*----------------------------------------------------------------------
*/
void
TclpMasterLock(void)
{
#if TCL_THREADS
pthread_mutex_lock(&masterLock);
#endif
}
/*
*----------------------------------------------------------------------
*
* TclpMasterUnlock
*
* This procedure is used to release a lock that serializes creation and
|
| ︙ | ︙ | |||
339 340 341 342 343 344 345 |
*
*----------------------------------------------------------------------
*/
void
TclpMasterUnlock(void)
{
| | | 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 |
*
*----------------------------------------------------------------------
*/
void
TclpMasterUnlock(void)
{
#if TCL_THREADS
pthread_mutex_unlock(&masterLock);
#endif
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
366 367 368 369 370 371 372 |
*
*----------------------------------------------------------------------
*/
Tcl_Mutex *
Tcl_GetAllocMutex(void)
{
| | | > > | | | | | | | | | | 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 |
*
*----------------------------------------------------------------------
*/
Tcl_Mutex *
Tcl_GetAllocMutex(void)
{
#if TCL_THREADS
PMutex **allocLockPtrPtr = &allocLockPtr;
pthread_once(&allocLockInitOnce, allocLockInit);
return (Tcl_Mutex *) allocLockPtrPtr;
#else
return NULL;
#endif
}
#if TCL_THREADS
/*
*----------------------------------------------------------------------
*
* Tcl_MutexLock --
*
* This procedure is invoked to lock a mutex. This procedure handles
* initializing the mutex, if necessary. The caller can rely on the fact
* that Tcl_Mutex is an opaque pointer. This routine will change that
* pointer from NULL after first use.
*
* Results:
* None.
*
* Side effects:
* May block the current thread. The mutex is acquired when this returns.
* Will allocate memory for a pthread_mutex_t and initialize this the
* first time this Tcl_Mutex is used.
*
*----------------------------------------------------------------------
*/
void
Tcl_MutexLock(
Tcl_Mutex *mutexPtr) /* Really (PMutex **) */
{
PMutex *pmutexPtr;
if (*mutexPtr == NULL) {
pthread_mutex_lock(&masterLock);
if (*mutexPtr == NULL) {
/*
* Double inside master lock check to avoid a race condition.
*/
pmutexPtr = Tcl_Alloc(sizeof(PMutex));
PMutexInit(pmutexPtr);
*mutexPtr = (Tcl_Mutex) pmutexPtr;
TclRememberMutex(mutexPtr);
}
pthread_mutex_unlock(&masterLock);
}
pmutexPtr = *((PMutex **) mutexPtr);
PMutexLock(pmutexPtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_MutexUnlock --
*
|
| ︙ | ︙ | |||
440 441 442 443 444 445 446 | * The mutex is released when this returns. * *---------------------------------------------------------------------- */ void Tcl_MutexUnlock( | | | | | 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 |
* The mutex is released when this returns.
*
*----------------------------------------------------------------------
*/
void
Tcl_MutexUnlock(
Tcl_Mutex *mutexPtr) /* Really (PMutex **) */
{
PMutex *pmutexPtr = *(PMutex **) mutexPtr;
PMutexUnlock(pmutexPtr);
}
/*
*----------------------------------------------------------------------
*
* TclpFinalizeMutex --
*
|
| ︙ | ︙ | |||
470 471 472 473 474 475 476 |
*----------------------------------------------------------------------
*/
void
TclpFinalizeMutex(
Tcl_Mutex *mutexPtr)
{
| | | | | | | | | | | | | 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 |
*----------------------------------------------------------------------
*/
void
TclpFinalizeMutex(
Tcl_Mutex *mutexPtr)
{
PMutex *pmutexPtr = *(PMutex **) mutexPtr;
if (pmutexPtr != NULL) {
PMutexDestroy(pmutexPtr);
Tcl_Free(pmutexPtr);
*mutexPtr = NULL;
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_ConditionWait --
*
* This procedure is invoked to wait on a condition variable. The mutex
* is automically released as part of the wait, and automatically grabbed
* when the condition is signaled.
*
* The mutex must be held when this procedure is called.
*
* Results:
* None.
*
* Side effects:
* May block the current thread. The mutex is acquired when this returns.
* Will allocate memory for a pthread_mutex_t and initialize this the
* first time this Tcl_Mutex is used.
*
*----------------------------------------------------------------------
*/
void
Tcl_ConditionWait(
Tcl_Condition *condPtr, /* Really (pthread_cond_t **) */
Tcl_Mutex *mutexPtr, /* Really (PMutex **) */
const Tcl_Time *timePtr) /* Timeout on waiting period */
{
pthread_cond_t *pcondPtr;
PMutex *pmutexPtr;
struct timespec ptime;
if (*condPtr == NULL) {
pthread_mutex_lock(&masterLock);
/*
* Double check inside mutex to avoid race, then initialize condition
* variable if necessary.
*/
if (*condPtr == NULL) {
pcondPtr = Tcl_Alloc(sizeof(pthread_cond_t));
pthread_cond_init(pcondPtr, NULL);
*condPtr = (Tcl_Condition) pcondPtr;
TclRememberCondition(condPtr);
}
pthread_mutex_unlock(&masterLock);
}
pmutexPtr = *((PMutex **) mutexPtr);
pcondPtr = *((pthread_cond_t **) condPtr);
if (timePtr == NULL) {
PCondWait(pcondPtr, pmutexPtr);
} else {
Tcl_Time now;
/*
* Make sure to take into account the microsecond component of the
* current time, including possible overflow situations. [Bug #411603]
*/
Tcl_GetTime(&now);
ptime.tv_sec = timePtr->sec + now.sec +
(timePtr->usec + now.usec) / 1000000;
ptime.tv_nsec = 1000 * ((timePtr->usec + now.usec) % 1000000);
PCondTimedWait(pcondPtr, pmutexPtr, &ptime);
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_ConditionNotify --
|
| ︙ | ︙ | |||
570 571 572 573 574 575 576 |
*----------------------------------------------------------------------
*/
void
Tcl_ConditionNotify(
Tcl_Condition *condPtr)
{
| | > | | 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 |
*----------------------------------------------------------------------
*/
void
Tcl_ConditionNotify(
Tcl_Condition *condPtr)
{
pthread_cond_t *pcondPtr = *((pthread_cond_t **) condPtr);
if (pcondPtr != NULL) {
pthread_cond_broadcast(pcondPtr);
} else {
/*
* No-one has used the condition variable, so there are no waiters.
*/
}
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
603 604 605 606 607 608 609 |
*----------------------------------------------------------------------
*/
void
TclpFinalizeCondition(
Tcl_Condition *condPtr)
{
| | | < < | | | | | | > | | | 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 |
*----------------------------------------------------------------------
*/
void
TclpFinalizeCondition(
Tcl_Condition *condPtr)
{
pthread_cond_t *pcondPtr = *(pthread_cond_t **) condPtr;
if (pcondPtr != NULL) {
pthread_cond_destroy(pcondPtr);
Tcl_Free(pcondPtr);
*condPtr = NULL;
}
}
/*
* Additions by AOL for specialized thread memory allocator.
*/
#ifdef USE_THREAD_ALLOC
static pthread_key_t key;
typedef struct {
Tcl_Mutex tlock;
PMutex plock;
} AllocMutex;
Tcl_Mutex *
TclpNewAllocMutex(void)
{
AllocMutex *lockPtr;
register PMutex *plockPtr;
lockPtr = malloc(sizeof(AllocMutex));
if (lockPtr == NULL) {
Tcl_Panic("could not allocate lock");
}
plockPtr = &lockPtr->plock;
lockPtr->tlock = (Tcl_Mutex) plockPtr;
PMutexInit(&lockPtr->plock);
return &lockPtr->tlock;
}
void
TclpFreeAllocMutex(
Tcl_Mutex *mutex) /* The alloc mutex to free. */
{
AllocMutex *lockPtr = (AllocMutex *) mutex;
if (!lockPtr) {
return;
}
PMutexDestroy(&lockPtr->plock);
free(lockPtr);
}
void
TclpInitAllocCache(void)
{
pthread_key_create(&key, NULL);
|
| ︙ | ︙ | |||
702 703 704 705 706 707 708 |
#endif /* USE_THREAD_ALLOC */
void *
TclpThreadCreateKey(void)
{
pthread_key_t *ptkeyPtr;
| | | 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 |
#endif /* USE_THREAD_ALLOC */
void *
TclpThreadCreateKey(void)
{
pthread_key_t *ptkeyPtr;
ptkeyPtr = TclpSysAlloc(sizeof(pthread_key_t));
if (NULL == ptkeyPtr) {
Tcl_Panic("unable to allocate thread key!");
}
if (pthread_key_create(ptkeyPtr, NULL)) {
Tcl_Panic("unable to create pthread key!");
}
|
| ︙ | ︙ |
Deleted unix/tclUnixThrd.h.
|
| < < < < < < < < < < < < < < < < < < < |
Changes to unix/tclUnixTime.c.
| ︙ | ︙ | |||
46 47 48 49 50 51 52 | * * Side effects: * None. * *---------------------------------------------------------------------- */ | | > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | | | 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 |
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_WideUInt
TclpGetSeconds(void)
{
return time(NULL);
}
/*
*----------------------------------------------------------------------
*
* TclpGetMicroseconds --
*
* This procedure returns the number of microseconds from the epoch.
* On most Unix systems the epoch is Midnight Jan 1, 1970 GMT.
*
* Results:
* Number of microseconds from the epoch.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_WideInt
TclpGetMicroseconds(void)
{
Tcl_Time time;
tclGetTimeProcPtr(&time, tclTimeClientData);
return ((Tcl_WideInt)time.sec)*1000000 + time.usec;
}
/*
*----------------------------------------------------------------------
*
* TclpGetClicks --
*
* This procedure returns a value that represents the highest resolution
* clock available on the system. There are no garantees on what the
* resolution will be. In Tcl we will call this value a "click". The
* start time is also system dependant.
*
* Results:
* Number of clicks from some start time.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_WideUInt
TclpGetClicks(void)
{
Tcl_WideUInt now;
#ifdef NO_GETTOD
if (tclGetTimeProcPtr != NativeGetTime) {
Tcl_Time time;
tclGetTimeProcPtr(&time, tclTimeClientData);
now = (Tcl_WideUInt)time.sec*1000000 + time.usec;
} else {
/*
* A semi-NativeGetTime, specialized to clicks.
*/
struct tms dummy;
now = (Tcl_WideUInt) times(&dummy);
}
#else
Tcl_Time time;
tclGetTimeProcPtr(&time, tclTimeClientData);
now = (Tcl_WideUInt)time.sec*1000000 + time.usec;
#endif
return now;
}
#ifdef TCL_WIDE_CLICKS
/*
*----------------------------------------------------------------------
*
* TclpGetWideClicks --
*
* This procedure returns a WideInt value that represents the highest
* resolution clock available on the system. There are no guarantees on
* what the resolution will be. In Tcl we will call this value a "click".
* The start time is also system dependent.
*
* Results:
* Number of WideInt clicks from some start time.
*
* Side effects:
* None.
*
|
| ︙ | ︙ | |||
187 188 189 190 191 192 193 194 195 196 197 198 199 200 |
#else
#error Wide high-resolution clicks not implemented on this platform
#endif
}
return nsec;
}
#endif /* TCL_WIDE_CLICKS */
/*
*----------------------------------------------------------------------
*
* Tcl_GetTime --
*
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 |
#else
#error Wide high-resolution clicks not implemented on this platform
#endif
}
return nsec;
}
/*
*----------------------------------------------------------------------
*
* TclpWideClickInMicrosec --
*
* This procedure return scale to convert click values from the
* TclpGetWideClicks native resolution to microsecond resolution
* and back.
*
* Results:
* 1 click in microseconds as double.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
double
TclpWideClickInMicrosec(void)
{
if (tclGetTimeProcPtr != NativeGetTime) {
return 1.0;
} else {
#ifdef MAC_OSX_TCL
static int initialized = 0;
static double scale = 0.0;
if (initialized) {
return scale;
} else {
mach_timebase_info_data_t tb;
mach_timebase_info(&tb);
/* value of tb.numer / tb.denom = 1 click in nanoseconds */
scale = ((double)tb.numer) / tb.denom / 1000;
initialized = 1;
return scale;
}
#else
#error Wide high-resolution clicks not implemented on this platform
#endif
}
}
#endif /* TCL_WIDE_CLICKS */
/*
*----------------------------------------------------------------------
*
* Tcl_GetTime --
*
|
| ︙ | ︙ |
Changes to unix/tclXtNotify.c.
| ︙ | ︙ | |||
264 265 266 267 268 269 270 |
*----------------------------------------------------------------------
*/
static void
SetTimer(
const Tcl_Time *timePtr) /* Timeout value, may be NULL. */
{
| | | | 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 |
*----------------------------------------------------------------------
*/
static void
SetTimer(
const Tcl_Time *timePtr) /* Timeout value, may be NULL. */
{
unsigned long timeout;
if (!initialized) {
InitNotifier();
}
TclSetAppContext(NULL);
if (notifier.currentTimeout != 0) {
XtRemoveTimeOut(notifier.currentTimeout);
}
if (timePtr) {
timeout = timePtr->sec * 1000 + timePtr->usec / 1000;
notifier.currentTimeout = XtAppAddTimeOut(notifier.appContext,
timeout, TimerProc, NULL);
} else {
notifier.currentTimeout = 0;
}
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
355 356 357 358 359 360 361 |
for (filePtr = notifier.firstFileHandlerPtr; filePtr != NULL;
filePtr = filePtr->nextPtr) {
if (filePtr->fd == fd) {
break;
}
}
if (filePtr == NULL) {
| | | 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 |
for (filePtr = notifier.firstFileHandlerPtr; filePtr != NULL;
filePtr = filePtr->nextPtr) {
if (filePtr->fd == fd) {
break;
}
}
if (filePtr == NULL) {
filePtr = Tcl_Alloc(sizeof(FileHandler));
filePtr->fd = fd;
filePtr->read = 0;
filePtr->write = 0;
filePtr->except = 0;
filePtr->readyMask = 0;
filePtr->mask = 0;
filePtr->nextPtr = notifier.firstFileHandlerPtr;
|
| ︙ | ︙ | |||
466 467 468 469 470 471 472 |
}
if (filePtr->mask & TCL_WRITABLE) {
XtRemoveInput(filePtr->write);
}
if (filePtr->mask & TCL_EXCEPTION) {
XtRemoveInput(filePtr->except);
}
| | | 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 |
}
if (filePtr->mask & TCL_WRITABLE) {
XtRemoveInput(filePtr->write);
}
if (filePtr->mask & TCL_EXCEPTION) {
XtRemoveInput(filePtr->except);
}
Tcl_Free(filePtr);
}
/*
*----------------------------------------------------------------------
*
* FileProc --
*
|
| ︙ | ︙ | |||
521 522 523 524 525 526 527 |
}
/*
* This is an interesting event, so put it onto the event queue.
*/
filePtr->readyMask |= mask;
| | | 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 |
}
/*
* This is an interesting event, so put it onto the event queue.
*/
filePtr->readyMask |= mask;
fileEvPtr = Tcl_Alloc(sizeof(FileHandlerEvent));
fileEvPtr->header.proc = FileHandlerEventProc;
fileEvPtr->fd = filePtr->fd;
Tcl_QueueEvent((Tcl_Event *) fileEvPtr, TCL_QUEUE_TAIL);
/*
* Process events on the Tcl event queue before returning to Xt.
*/
|
| ︙ | ︙ |
Changes to win/Makefile.in.
| ︙ | ︙ | |||
81 82 83 84 85 86 87 | #CFLAGS = $(CFLAGS_DEBUG) #CFLAGS = $(CFLAGS_OPTIMIZE) #CFLAGS = $(CFLAGS_DEBUG) $(CFLAGS_OPTIMIZE) CFLAGS = @CFLAGS@ @CFLAGS_DEFAULT@ -DUNICODE -D_UNICODE # To compile without backward compatibility and deprecated code uncomment the # following | | | | 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 | #CFLAGS = $(CFLAGS_DEBUG) #CFLAGS = $(CFLAGS_OPTIMIZE) #CFLAGS = $(CFLAGS_DEBUG) $(CFLAGS_OPTIMIZE) CFLAGS = @CFLAGS@ @CFLAGS_DEFAULT@ -DUNICODE -D_UNICODE # To compile without backward compatibility and deprecated code uncomment the # following NO_DEPRECATED_FLAGS = #NO_DEPRECATED_FLAGS = -DTCL_NO_DEPRECATED # To enable compilation debugging reverse the comment characters on one of the # following lines. COMPILE_DEBUG_FLAGS = #COMPILE_DEBUG_FLAGS = -DTCL_COMPILE_DEBUG #COMPILE_DEBUG_FLAGS = -DTCL_COMPILE_DEBUG -DTCL_COMPILE_STATS |
| ︙ | ︙ | |||
112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 |
includedir_native = $(shell $(CYGPATH) '$(includedir)')
mandir_native = $(shell $(CYGPATH) '$(mandir)')
TCL_LIBRARY_NATIVE = $(shell $(CYGPATH) '$(TCL_LIBRARY)')
GENERIC_DIR_NATIVE = $(shell $(CYGPATH) '$(GENERIC_DIR)')
TOMMATH_DIR_NATIVE = $(shell $(CYGPATH) '$(TOMMATH_DIR)')
WIN_DIR_NATIVE = $(shell $(CYGPATH) '$(WIN_DIR)')
ROOT_DIR_NATIVE = $(shell $(CYGPATH) '$(ROOT_DIR)')
ZLIB_DIR_NATIVE = $(shell $(CYGPATH) '$(ZLIB_DIR)')
#GENERIC_DIR_NATIVE = $(GENERIC_DIR)
#TOMMATH_DIR_NATIVE = $(TOMMATH_DIR)
#WIN_DIR_NATIVE = $(WIN_DIR)
#ROOT_DIR_NATIVE = $(ROOT_DIR)
# Fully qualify library path so that `make test`
# does not depend on the current directory.
LIBRARY_DIR1 = $(shell cd '$(ROOT_DIR_NATIVE)/library' ; pwd -P)
LIBRARY_DIR = $(shell $(CYGPATH) '$(LIBRARY_DIR1)')
DLLSUFFIX = @DLLSUFFIX@
LIBSUFFIX = @LIBSUFFIX@
EXESUFFIX = @EXESUFFIX@
VER = @TCL_MAJOR_VERSION@@TCL_MINOR_VERSION@
DOTVER = @TCL_MAJOR_VERSION@.@TCL_MINOR_VERSION@
DDEVER = @TCL_DDE_MAJOR_VERSION@@TCL_DDE_MINOR_VERSION@
DDEDOTVER = @TCL_DDE_MAJOR_VERSION@.@TCL_DDE_MINOR_VERSION@
REGVER = @TCL_REG_MAJOR_VERSION@@TCL_REG_MINOR_VERSION@
REGDOTVER = @TCL_REG_MAJOR_VERSION@.@TCL_REG_MINOR_VERSION@
TCL_STUB_LIB_FILE = @TCL_STUB_LIB_FILE@
TCL_DLL_FILE = @TCL_DLL_FILE@
TCL_LIB_FILE = @TCL_LIB_FILE@
DDE_DLL_FILE = tcldde$(DDEVER)${DLLSUFFIX}
DDE_LIB_FILE = @LIBPREFIX@tcldde$(DDEVER)${LIBSUFFIX}
REG_DLL_FILE = tclreg$(REGVER)${DLLSUFFIX}
REG_LIB_FILE = @LIBPREFIX@tclreg$(REGVER)${LIBSUFFIX}
TEST_DLL_FILE = tcltest$(VER)${DLLSUFFIX}
TEST_LIB_FILE = @LIBPREFIX@tcltest$(VER)${LIBSUFFIX}
ZLIB_DLL_FILE = zlib1.dll
SHARED_LIBRARIES = $(TCL_DLL_FILE) @ZLIB_DLL_FILE@
STATIC_LIBRARIES = $(TCL_LIB_FILE)
TCLSH = tclsh$(VER)${EXESUFFIX}
CAT32 = cat32$(EXEEXT)
MAN2TCL = man2tcl$(EXEEXT)
# For cross-compiled builds, TCL_EXE is the name of a tclsh executable that is
# available *BEFORE* running make for the first time. Certain build targets
# (make genstubs, make install) need it to be available on the PATH. This
# executable should *NOT* be required just to do a normal build although
| > > > > > > > > > > > > > | 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 |
includedir_native = $(shell $(CYGPATH) '$(includedir)')
mandir_native = $(shell $(CYGPATH) '$(mandir)')
TCL_LIBRARY_NATIVE = $(shell $(CYGPATH) '$(TCL_LIBRARY)')
GENERIC_DIR_NATIVE = $(shell $(CYGPATH) '$(GENERIC_DIR)')
TOMMATH_DIR_NATIVE = $(shell $(CYGPATH) '$(TOMMATH_DIR)')
WIN_DIR_NATIVE = $(shell $(CYGPATH) '$(WIN_DIR)')
ROOT_DIR_NATIVE = $(shell $(CYGPATH) '$(ROOT_DIR)')
ROOT_DIR_WIN_NATIVE = $(shell cd '$(ROOT_DIR)' ; pwd -W || pwd -P)
ZLIB_DIR_NATIVE = $(shell $(CYGPATH) '$(ZLIB_DIR)')
#GENERIC_DIR_NATIVE = $(GENERIC_DIR)
#TOMMATH_DIR_NATIVE = $(TOMMATH_DIR)
#WIN_DIR_NATIVE = $(WIN_DIR)
#ROOT_DIR_NATIVE = $(ROOT_DIR)
# Fully qualify library path so that `make test`
# does not depend on the current directory.
LIBRARY_DIR1 = $(shell cd '$(ROOT_DIR_NATIVE)/library' ; pwd -P)
LIBRARY_DIR = $(shell $(CYGPATH) '$(LIBRARY_DIR1)')
DLLSUFFIX = @DLLSUFFIX@
LIBSUFFIX = @LIBSUFFIX@
EXESUFFIX = @EXESUFFIX@
VER = @TCL_MAJOR_VERSION@@TCL_MINOR_VERSION@
DOTVER = @TCL_MAJOR_VERSION@.@TCL_MINOR_VERSION@
DDEVER = @TCL_DDE_MAJOR_VERSION@@TCL_DDE_MINOR_VERSION@
DDEDOTVER = @TCL_DDE_MAJOR_VERSION@.@TCL_DDE_MINOR_VERSION@
REGVER = @TCL_REG_MAJOR_VERSION@@TCL_REG_MINOR_VERSION@
REGDOTVER = @TCL_REG_MAJOR_VERSION@.@TCL_REG_MINOR_VERSION@
TCL_ZIP_FILE = @TCL_ZIP_FILE@
TCL_VFS_PATH = libtcl.vfs/tcl_library
TCL_VFS_ROOT = libtcl.vfs
TCL_STUB_LIB_FILE = @TCL_STUB_LIB_FILE@
TCL_DLL_FILE = @TCL_DLL_FILE@
TCL_LIB_FILE = @TCL_LIB_FILE@
DDE_DLL_FILE = tcldde$(DDEVER)${DLLSUFFIX}
DDE_LIB_FILE = @LIBPREFIX@tcldde$(DDEVER)${LIBSUFFIX}
REG_DLL_FILE = tclreg$(REGVER)${DLLSUFFIX}
REG_LIB_FILE = @LIBPREFIX@tclreg$(REGVER)${LIBSUFFIX}
TEST_DLL_FILE = tcltest$(VER)${DLLSUFFIX}
TEST_EXE_FILE = tcltest${EXESUFFIX}
TEST_LIB_FILE = @LIBPREFIX@tcltest$(VER)${LIBSUFFIX}
TEST_LOAD_PRMS = lappend ::auto_path {$(ROOT_DIR_WIN_NATIVE)/tests};\
package ifneeded dde 1.4.1 [list load [file normalize ${DDE_DLL_FILE}] dde];\
package ifneeded registry 1.3.3 [list load [file normalize ${REG_DLL_FILE}] registry]
TEST_LOAD_FACILITIES = package ifneeded Tcltest ${VERSION}@TCL_PATCH_LEVEL@ [list load [file normalize ${TEST_DLL_FILE}] Tcltest];\
$(TEST_LOAD_PRMS)
ZLIB_DLL_FILE = zlib1.dll
SHARED_LIBRARIES = $(TCL_DLL_FILE) @ZLIB_DLL_FILE@
STATIC_LIBRARIES = $(TCL_LIB_FILE)
TCLSH = tclsh$(VER)${EXESUFFIX}
WINE = @WINE@
CAT32 = cat32$(EXEEXT)
MAN2TCL = man2tcl$(EXEEXT)
# For cross-compiled builds, TCL_EXE is the name of a tclsh executable that is
# available *BEFORE* running make for the first time. Certain build targets
# (make genstubs, make install) need it to be available on the PATH. This
# executable should *NOT* be required just to do a normal build although
|
| ︙ | ︙ | |||
191 192 193 194 195 196 197 198 199 200 201 202 203 204 |
LIBS = @LIBS@ $(shell $(CYGPATH) '@ZLIB_LIBS@')
RMDIR = rm -rf
MKDIR = mkdir -p
SHELL = @SHELL@
RM = rm -f
COPY = cp
CC_SWITCHES = ${CFLAGS} ${CFLAGS_WARNING} ${TCL_SHLIB_CFLAGS} \
-I"${ZLIB_DIR_NATIVE}" -I"${GENERIC_DIR_NATIVE}" \
-DMP_PREC=4 -I"${TOMMATH_DIR_NATIVE}" -I"${WIN_DIR_NATIVE}" \
${AC_FLAGS} ${COMPILE_DEBUG_FLAGS} ${NO_DEPRECATED_FLAGS}
CC_OBJNAME = @CC_OBJNAME@
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 |
LIBS = @LIBS@ $(shell $(CYGPATH) '@ZLIB_LIBS@')
RMDIR = rm -rf
MKDIR = mkdir -p
SHELL = @SHELL@
RM = rm -f
COPY = cp
LN = ln
###
# Tip 430 - ZipFS Modifications
###
TCL_ZIP_FILE = @TCL_ZIP_FILE@
TCL_VFS_PATH = libtcl.vfs/tcl_library
TCL_VFS_ROOT = libtcl.vfs
HOST_CC = @CC_FOR_BUILD@
HOST_EXEEXT = @EXEEXT_FOR_BUILD@
HOST_OBJEXT = @OBJEXT_FOR_BUILD@
ZIPFS_BUILD = @ZIPFS_BUILD@
NATIVE_ZIP = @ZIP_PROG@
ZIP_PROG_OPTIONS = @ZIP_PROG_OPTIONS@
ZIP_PROG_VFSSEARCH = @ZIP_PROG_VFSSEARCH@
SHARED_BUILD = @SHARED_BUILD@
INSTALL_MSGS = @INSTALL_MSGS@
INSTALL_LIBRARIES = @INSTALL_LIBRARIES@
# Minizip
MINIZIP_OBJS = \
adler32.$(HOST_OBJEXT) \
compress.$(HOST_OBJEXT) \
crc32.$(HOST_OBJEXT) \
deflate.$(HOST_OBJEXT) \
infback.$(HOST_OBJEXT) \
inffast.$(HOST_OBJEXT) \
inflate.$(HOST_OBJEXT) \
inftrees.$(HOST_OBJEXT) \
ioapi.$(HOST_OBJEXT) \
iowin32.$(HOST_OBJEXT) \
trees.$(HOST_OBJEXT) \
uncompr.$(HOST_OBJEXT) \
zip.$(HOST_OBJEXT) \
zutil.$(HOST_OBJEXT) \
minizip.$(HOST_OBJEXT)
ZIP_INSTALL_OBJS = @ZIP_INSTALL_OBJS@
CC_SWITCHES = ${CFLAGS} ${CFLAGS_WARNING} ${TCL_SHLIB_CFLAGS} \
-I"${ZLIB_DIR_NATIVE}" -I"${GENERIC_DIR_NATIVE}" \
-DMP_PREC=4 -I"${TOMMATH_DIR_NATIVE}" -I"${WIN_DIR_NATIVE}" \
${AC_FLAGS} ${COMPILE_DEBUG_FLAGS} ${NO_DEPRECATED_FLAGS}
CC_OBJNAME = @CC_OBJNAME@
|
| ︙ | ︙ | |||
299 300 301 302 303 304 305 306 307 308 | tclThreadStorage.$(OBJEXT) \ tclTimer.$(OBJEXT) \ tclTomMathInterface.$(OBJEXT) \ tclTrace.$(OBJEXT) \ tclUtf.$(OBJEXT) \ tclUtil.$(OBJEXT) \ tclVar.$(OBJEXT) \ tclZlib.$(OBJEXT) TOMMATH_OBJS = \ | > < | 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 |
tclThreadStorage.$(OBJEXT) \
tclTimer.$(OBJEXT) \
tclTomMathInterface.$(OBJEXT) \
tclTrace.$(OBJEXT) \
tclUtf.$(OBJEXT) \
tclUtil.$(OBJEXT) \
tclVar.$(OBJEXT) \
tclZipfs.$(OBJEXT) \
tclZlib.$(OBJEXT)
TOMMATH_OBJS = \
bn_reverse.${OBJEXT} \
bn_fast_s_mp_mul_digs.${OBJEXT} \
bn_fast_s_mp_sqr.${OBJEXT} \
bn_mp_add.${OBJEXT} \
bn_mp_add_d.${OBJEXT} \
bn_mp_and.${OBJEXT} \
bn_mp_clamp.${OBJEXT} \
|
| ︙ | ︙ | |||
326 327 328 329 330 331 332 333 334 335 336 337 338 339 |
bn_mp_div_d.${OBJEXT} \
bn_mp_div_2.${OBJEXT} \
bn_mp_div_2d.${OBJEXT} \
bn_mp_div_3.${OBJEXT} \
bn_mp_exch.${OBJEXT} \
bn_mp_expt_d.${OBJEXT} \
bn_mp_expt_d_ex.${OBJEXT} \
bn_mp_get_int.${OBJEXT} \
bn_mp_get_long.${OBJEXT} \
bn_mp_get_long_long.${OBJEXT} \
bn_mp_grow.${OBJEXT} \
bn_mp_init.${OBJEXT} \
bn_mp_init_copy.${OBJEXT} \
bn_mp_init_multi.${OBJEXT} \
| > | 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 |
bn_mp_div_d.${OBJEXT} \
bn_mp_div_2.${OBJEXT} \
bn_mp_div_2d.${OBJEXT} \
bn_mp_div_3.${OBJEXT} \
bn_mp_exch.${OBJEXT} \
bn_mp_expt_d.${OBJEXT} \
bn_mp_expt_d_ex.${OBJEXT} \
bn_s_mp_get_bit.${OBJEXT} \
bn_mp_get_int.${OBJEXT} \
bn_mp_get_long.${OBJEXT} \
bn_mp_get_long_long.${OBJEXT} \
bn_mp_grow.${OBJEXT} \
bn_mp_init.${OBJEXT} \
bn_mp_init_copy.${OBJEXT} \
bn_mp_init_multi.${OBJEXT} \
|
| ︙ | ︙ | |||
360 361 362 363 364 365 366 367 368 369 370 371 372 373 |
bn_mp_set_long.${OBJEXT} \
bn_mp_set_long_long.${OBJEXT} \
bn_mp_shrink.${OBJEXT} \
bn_mp_sqr.${OBJEXT} \
bn_mp_sqrt.${OBJEXT} \
bn_mp_sub.${OBJEXT} \
bn_mp_sub_d.${OBJEXT} \
bn_mp_to_unsigned_bin.${OBJEXT} \
bn_mp_to_unsigned_bin_n.${OBJEXT} \
bn_mp_toom_mul.${OBJEXT} \
bn_mp_toom_sqr.${OBJEXT} \
bn_mp_toradix_n.${OBJEXT} \
bn_mp_unsigned_bin_size.${OBJEXT} \
bn_mp_xor.${OBJEXT} \
| > | 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 |
bn_mp_set_long.${OBJEXT} \
bn_mp_set_long_long.${OBJEXT} \
bn_mp_shrink.${OBJEXT} \
bn_mp_sqr.${OBJEXT} \
bn_mp_sqrt.${OBJEXT} \
bn_mp_sub.${OBJEXT} \
bn_mp_sub_d.${OBJEXT} \
bn_mp_signed_rsh.${OBJEXT} \
bn_mp_to_unsigned_bin.${OBJEXT} \
bn_mp_to_unsigned_bin_n.${OBJEXT} \
bn_mp_toom_mul.${OBJEXT} \
bn_mp_toom_sqr.${OBJEXT} \
bn_mp_toradix_n.${OBJEXT} \
bn_mp_unsigned_bin_size.${OBJEXT} \
bn_mp_xor.${OBJEXT} \
|
| ︙ | ︙ | |||
396 397 398 399 400 401 402 | DDE_OBJS = tclWinDde.$(OBJEXT) REG_OBJS = tclWinReg.$(OBJEXT) STUB_OBJS = \ tclStubLib.$(OBJEXT) \ | | > | 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 | DDE_OBJS = tclWinDde.$(OBJEXT) REG_OBJS = tclWinReg.$(OBJEXT) STUB_OBJS = \ tclStubLib.$(OBJEXT) \ tclTomMathStubLib.$(OBJEXT) \ tclWinPanic.$(OBJEXT) TCLSH_OBJS = tclAppInit.$(OBJEXT) ZLIB_OBJS = \ adler32.$(OBJEXT) \ compress.$(OBJEXT) \ crc32.$(OBJEXT) \ |
| ︙ | ︙ | |||
419 420 421 422 423 424 425 |
TCL_OBJS = ${GENERIC_OBJS} $(TOMMATH_OBJS) ${WIN_OBJS} @ZLIB_OBJS@
TCL_DOCS = "$(ROOT_DIR_NATIVE)"/doc/*.[13n]
all: binaries libraries doc packages
| > > > > > > > > > > > > > > > > > > > > > > > > > > > | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | > > > > > > > > > > > > > > > > > > > > > > > > | 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 |
TCL_OBJS = ${GENERIC_OBJS} $(TOMMATH_OBJS) ${WIN_OBJS} @ZLIB_OBJS@
TCL_DOCS = "$(ROOT_DIR_NATIVE)"/doc/*.[13n]
all: binaries libraries doc packages
# Test-suite helper (can be used to test Tcl from build directory with all expected modules).
# To start from windows shell use:
# > tcltest.cmd -verbose bps -file fileName.test
# or from mingw/msys shell:
# $ ./tcltest -verbose bps -file fileName.test
tcltest.cmd:
@echo 'Create tcltest.cmd helpers';
@(\
echo '@echo off'; \
echo 'rem set LANG=en_US'; \
echo 'set BDP=%~dp0'; \
echo 'set OWD=%CD%'; \
echo 'cd /d %TEMP%'; \
echo 'rem "%BDP%\$(TCLSH)" "$(ROOT_DIR_WIN_NATIVE)/tests/all.tcl" $(TESTFLAGS) -load "$(TEST_LOAD_FACILITIES)" %*'; \
echo '"%BDP%\$(TEST_EXE_FILE)" "$(ROOT_DIR_WIN_NATIVE)/tests/all.tcl" $(TESTFLAGS) -load "$(TEST_LOAD_PRMS)" %*'; \
echo 'cd /d %OWD%'; \
) > tcltest.cmd;
@(\
echo '#!/bin/sh'; \
echo '#LANG=en_US'; \
echo 'BDP=$$(dirname $$(readlink -f %0))'; \
echo 'cd /tmp'; \
echo '#"$$BDP/$(TCLSH)" "$(ROOT_DIR_WIN_NATIVE)/tests/all.tcl" $(TESTFLAGS) -load "$(TEST_LOAD_FACILITIES)" "$$@"'; \
echo '"$$BDP/$(TEST_EXE_FILE)" "$(ROOT_DIR_WIN_NATIVE)/tests/all.tcl" $(TESTFLAGS) -load "$(TEST_LOAD_PRMS)" "$$@"'; \
) > tcltest;
tcltest: $(TCLSH) $(TEST_EXE_FILE) $(TEST_DLL_FILE) tcltest.cmd
binaries: $(TCL_STUB_LIB_FILE) @LIBRARIES@ winextensions ${TCL_ZIP_FILE} $(TCLSH)
winextensions: ${DDE_DLL_FILE} ${REG_DLL_FILE}
libraries:
doc:
tclzipfile: ${TCL_ZIP_FILE}
${TCL_ZIP_FILE}: ${ZIP_INSTALL_OBJS} ${DDE_DLL_FILE} ${REG_DLL_FILE}
@rm -rf ${TCL_VFS_ROOT}
@mkdir -p ${TCL_VFS_PATH}
@echo "creating ${TCL_VFS_PATH} (prepare compression)"
@( \
$(LN) $$(find $(TOP_DIR)/library/* -maxdepth 0 -type f) ${TCL_VFS_PATH}/ && \
(for D in $$(find $(TOP_DIR)/library/* -maxdepth 0 -type d); do \
mkdir -p "${TCL_VFS_PATH}/$$(basename $$D)"; \
$(LN) -s $$D/* ${TCL_VFS_PATH}/$$(basename $$D)/; \
done) && \
$(LN) ${TCL_VFS_PATH}/manifest.txt ${TCL_VFS_PATH}/pkgIndex.tcl && \
$(LN) ${DDE_DLL_FILE} ${TCL_VFS_PATH}/dde/ && \
$(LN) ${REG_DLL_FILE} ${TCL_VFS_PATH}/reg/ \
) || ( \
$(COPY) -a $(TOP_DIR)/library/* ${TCL_VFS_PATH}; \
$(COPY) -a ${TCL_VFS_PATH}/manifest.txt ${TCL_VFS_PATH}/pkgIndex.tcl; \
$(COPY) ${DDE_DLL_FILE} ${TCL_VFS_PATH}/dde; \
$(COPY) ${REG_DLL_FILE} ${TCL_VFS_PATH}/reg; \
)
(zip=`(realpath '${NATIVE_ZIP}' || readlink -m '${NATIVE_ZIP}') 2>/dev/null || \
(echo '${NATIVE_ZIP}' | sed "s?^\./?$$(pwd)/?")`; \
cd ${TCL_VFS_ROOT} && \
$$zip ${ZIP_PROG_OPTIONS} ../${TCL_ZIP_FILE} ${ZIP_PROG_VFSSEARCH} >/dev/null && \
echo "${TCL_ZIP_FILE} successful created with $$zip" && \
cd ..)
$(TCLSH): $(TCLSH_OBJS) @LIBRARIES@ $(TCL_STUB_LIB_FILE) tclsh.$(RES)
$(CC) $(CFLAGS) $(TCLSH_OBJS) $(TCL_LIB_FILE) $(TCL_STUB_LIB_FILE) $(LIBS) \
tclsh.$(RES) $(CC_EXENAME) $(LDFLAGS_CONSOLE)
@VC_MANIFEST_EMBED_EXE@
cat32.$(OBJEXT): cat.c
$(CC) -c $(CC_SWITCHES) @DEPARG@ $(CC_OBJNAME)
$(CAT32): cat32.$(OBJEXT)
$(CC) $(CFLAGS) cat32.$(OBJEXT) $(CC_EXENAME) $(LIBS) $(LDFLAGS_CONSOLE)
# The following targets are configured by autoconf to generate either a shared
# library or static library
${TCL_STUB_LIB_FILE}: ${STUB_OBJS}
@$(RM) ${TCL_STUB_LIB_FILE}
@MAKE_STUB_LIB@ ${STUB_OBJS}
@POST_MAKE_LIB@
${TCL_DLL_FILE}: ${TCL_OBJS} tcl.$(RES) @ZLIB_DLL_FILE@ ${TCL_ZIP_FILE}
@$(RM) ${TCL_DLL_FILE} $(TCL_LIB_FILE)
@MAKE_DLL@ ${TCL_OBJS} tcl.$(RES) $(SHLIB_LD_LIBS)
@VC_MANIFEST_EMBED_DLL@
@if test "${ZIPFS_BUILD}" = "1" ; then \
cat ${TCL_ZIP_FILE} >> ${TCL_DLL_FILE}; \
${NATIVE_ZIP} -A ${TCL_DLL_FILE} \
|| echo 'ignore zip-error by adjust sfx process (not executable?)'; \
fi
${TCL_LIB_FILE}: ${TCL_OBJS} ${DDE_OBJS} ${REG_OBJS}
@$(RM) ${TCL_LIB_FILE}
@MAKE_LIB@ ${TCL_OBJS} ${DDE_OBJS} ${REG_OBJS}
@POST_MAKE_LIB@
${DDE_DLL_FILE}: ${TCL_STUB_LIB_FILE} ${DDE_OBJS}
@MAKE_DLL@ ${DDE_OBJS} $(TCL_STUB_LIB_FILE) $(SHLIB_LD_LIBS)
${REG_DLL_FILE}: ${TCL_STUB_LIB_FILE} ${REG_OBJS}
@MAKE_DLL@ ${REG_OBJS} $(TCL_STUB_LIB_FILE) $(SHLIB_LD_LIBS)
${TEST_DLL_FILE}: ${TCL_STUB_LIB_FILE} ${TCLTEST_OBJS}
@$(RM) ${TEST_DLL_FILE} ${TEST_LIB_FILE}
@MAKE_DLL@ ${TCLTEST_OBJS} $(TCL_STUB_LIB_FILE) $(SHLIB_LD_LIBS)
${TEST_EXE_FILE}: ${TCL_STUB_LIB_FILE} ${TCLTEST_OBJS} tclTestMain.${OBJEXT}
@$(RM) ${TEST_EXE_FILE}
$(CC) $(CFLAGS) $(TCLTEST_OBJS) tclTestMain.$(OBJEXT) $(TCL_LIB_FILE) $(TCL_STUB_LIB_FILE) $(LIBS) \
tclsh.$(RES) $(CC_EXENAME) $(LDFLAGS_CONSOLE)
# use pre-built zlib1.dll
${ZLIB_DLL_FILE}: ${TCL_STUB_LIB_FILE}
@if test "@ZLIB_LIBS@set" != "${ZLIB_DIR_NATIVE}/win32/zdll.libset" ; then \
$(COPY) $(ZLIB_DIR)/win64/${ZLIB_DLL_FILE} ${ZLIB_DLL_FILE}; \
else \
$(COPY) $(ZLIB_DIR)/win32/${ZLIB_DLL_FILE} ${ZLIB_DLL_FILE}; \
fi;
# Add the object extension to the implicit rules. By default .obj is not
# automatically added.
.SUFFIXES: .${OBJEXT}
.SUFFIXES: .$(RES)
.SUFFIXES: .rc
# Special case object targets
tclTestMain.${OBJEXT}: tclAppInit.c
$(CC) -c $(CC_SWITCHES) -DTCL_TEST -DBUILD_tcl $(EXTFLAGS) $(CC_OBJNAME) $(WIN_DIR)/tclAppInit.c
tclWinInit.${OBJEXT}: tclWinInit.c
$(CC) -c $(CC_SWITCHES) -DBUILD_tcl $(EXTFLAGS) @DEPARG@ $(CC_OBJNAME)
tclWinPipe.${OBJEXT}: tclWinPipe.c
$(CC) -c $(CC_SWITCHES) -DBUILD_tcl $(EXTFLAGS) @DEPARG@ $(CC_OBJNAME)
testMain.${OBJEXT}: tclAppInit.c
$(CC) -c $(CC_SWITCHES) -DTCL_TEST @DEPARG@ $(CC_OBJNAME)
tclMain2.${OBJEXT}: tclMain.c
$(CC) -c $(CC_SWITCHES) -DBUILD_tcl -DTCL_ASCII_MAIN @DEPARG@ $(CC_OBJNAME)
# TIP #430, ZipFS Support
tclZipfs.${OBJEXT}: $(GENERIC_DIR)/tclZipfs.c
$(CC) -c $(CC_SWITCHES) -DBUILD_tcl \
-DCFG_RUNTIME_PATH=\"$(bindir_native)\" \
-DCFG_RUNTIME_DLLFILE="\"$(TCL_DLL_FILE)\"" \
-DCFG_RUNTIME_ZIPFILE="\"$(TCL_ZIP_FILE)\"" \
-DCFG_RUNTIME_LIBDIR="\"$(bindir_native)\"" \
-DCFG_RUNTIME_SCRDIR="\"$(TCL_LIBRARY_NATIVE)\"" \
$(ZLIB_INCLUDE) -I$(ZLIB_DIR)/contrib/minizip @DEPARG@ $(CC_OBJNAME)
# TIP #59, embedding of configuration information into the binary library.
#
# Part of Tcl's configuration information are the paths where it was installed
# and where it will look for its libraries (which can be different). We derive
# this information from the variables which can be overridden by the user. As
# every path can be configured separately we do not remember one general
|
| ︙ | ︙ | |||
518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 |
-DCFG_INSTALL_DOCDIR=\"$(MAN_INSTALL_DIR)\" \
\
-DCFG_RUNTIME_LIBDIR=\"$(libdir_native)\" \
-DCFG_RUNTIME_BINDIR=\"$(bindir_native)\" \
-DCFG_RUNTIME_SCRDIR=\"$(TCL_LIBRARY_NATIVE)\" \
-DCFG_RUNTIME_INCDIR=\"$(includedir_native)\" \
-DCFG_RUNTIME_DOCDIR=\"$(mandir_native)\" \
-DBUILD_tcl \
@DEPARG@ $(CC_OBJNAME)
# The following objects are part of the stub library and should not be built
# as DLL objects but none of the symbols should be exported
tclStubLib.${OBJEXT}: tclStubLib.c
$(CC) -c $(CC_SWITCHES) -DSTATIC_BUILD @DEPARG@ $(CC_OBJNAME)
tclTomMathStubLib.${OBJEXT}: tclTomMathStubLib.c
$(CC) -c $(CC_SWITCHES) -DSTATIC_BUILD @DEPARG@ $(CC_OBJNAME)
# Implicit rule for all object files that will end up in the Tcl library
%.${OBJEXT}: %.c
$(CC) -c $(CC_SWITCHES) -DBUILD_tcl @DEPARG@ $(CC_OBJNAME)
.rc.$(RES):
$(RC) @RC_OUT@ $@ @RC_TYPE@ @RC_DEFINES@ @RC_INCLUDE@ "$(GENERIC_DIR_NATIVE)" @RC_INCLUDE@ "$(WIN_DIR_NATIVE)" @DEPARG@
# The following target generates the file generic/tclDate.c from the yacc
# grammar found in generic/tclGetDate.y. This is only run by hand as yacc is
# not available in all environments. The name of the .c file is different than
# the name of the .y file so that make doesn't try to automatically regenerate
# the .c file.
gendate:
bison --output-file=$(GENERIC_DIR)/tclDate.c \
--name-prefix=TclDate \
--no-lines \
$(GENERIC_DIR)/tclGetDate.y
# The following target generates the file generic/tclTomMath.h. It needs to be
# run (and the results checked) after updating to a new release of libtommath.
gentommath_h:
$(TCL_EXE) "$(ROOT_DIR_NATIVE)/tools/fix_tommath_h.tcl" \
"$(TOMMATH_DIR_NATIVE)/tommath.h" \
> "$(GENERIC_DIR_NATIVE)/tclTomMath.h"
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > | 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 |
-DCFG_INSTALL_DOCDIR=\"$(MAN_INSTALL_DIR)\" \
\
-DCFG_RUNTIME_LIBDIR=\"$(libdir_native)\" \
-DCFG_RUNTIME_BINDIR=\"$(bindir_native)\" \
-DCFG_RUNTIME_SCRDIR=\"$(TCL_LIBRARY_NATIVE)\" \
-DCFG_RUNTIME_INCDIR=\"$(includedir_native)\" \
-DCFG_RUNTIME_DOCDIR=\"$(mandir_native)\" \
-DCFG_RUNTIME_DLLFILE="\"$(TCL_DLL_FILE)\"" \
-DCFG_RUNTIME_ZIPFILE="\"$(TCL_ZIP_FILE)\"" \
-DBUILD_tcl \
@DEPARG@ $(CC_OBJNAME)
# The following objects are part of the stub library and should not be built
# as DLL objects but none of the symbols should be exported
tclStubLib.${OBJEXT}: tclStubLib.c
$(CC) -c $(CC_SWITCHES) -DSTATIC_BUILD @DEPARG@ $(CC_OBJNAME)
tclTomMathStubLib.${OBJEXT}: tclTomMathStubLib.c
$(CC) -c $(CC_SWITCHES) -DSTATIC_BUILD @DEPARG@ $(CC_OBJNAME)
tclWinPanic.${OBJEXT}: tclWinPanic.c
$(CC) -c $(CC_SWITCHES) -DSTATIC_BUILD @DEPARG@ $(CC_OBJNAME)
# Implicit rule for all object files that will end up in the Tcl library
%.${OBJEXT}: %.c
$(CC) -c $(CC_SWITCHES) -DBUILD_tcl @DEPARG@ $(CC_OBJNAME)
.rc.$(RES):
$(RC) @RC_OUT@ $@ @RC_TYPE@ @RC_DEFINES@ @RC_INCLUDE@ "$(GENERIC_DIR_NATIVE)" @RC_INCLUDE@ "$(WIN_DIR_NATIVE)" @DEPARG@
#--------------------------------------------------------------------------
# Minizip implementation
#--------------------------------------------------------------------------
adler32.$(HOST_OBJEXT):
$(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/adler32.c
compress.$(HOST_OBJEXT):
$(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/compress.c
crc32.$(HOST_OBJEXT):
$(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/crc32.c
deflate.$(HOST_OBJEXT):
$(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/deflate.c
ioapi.$(HOST_OBJEXT):
$(HOST_CC) -o $@ -DIOAPI_NO_64 -I$(ZLIB_DIR) -I$(ZLIB_DIR)/contrib/minizip -c $(ZLIB_DIR)/contrib/minizip/ioapi.c
iowin32.$(HOST_OBJEXT):
$(HOST_CC) -o $@ -I$(ZLIB_DIR) -I$(ZLIB_DIR)/contrib/minizip -c $(ZLIB_DIR)/contrib/minizip/iowin32.c
infback.$(HOST_OBJEXT):
$(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/infback.c
inffast.$(HOST_OBJEXT):
$(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/inffast.c
inflate.$(HOST_OBJEXT):
$(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/inflate.c
inftrees.$(HOST_OBJEXT):
$(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/inftrees.c
trees.$(HOST_OBJEXT):
$(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/trees.c
uncompr.$(HOST_OBJEXT):
$(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/uncompr.c
zip.$(HOST_OBJEXT):
$(HOST_CC) -o $@ -I$(ZLIB_DIR) -I$(ZLIB_DIR)/contrib/minizip -c $(ZLIB_DIR)/contrib/minizip/zip.c
zutil.$(HOST_OBJEXT):
$(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/zutil.c
minizip.$(HOST_OBJEXT):
$(HOST_CC) -o $@ -I$(ZLIB_DIR) -DIOAPI_NO_64 -I$(ZLIB_DIR)/contrib/minizip -c $(ZLIB_DIR)/contrib/minizip/minizip.c
minizip${HOST_EXEEXT}: $(MINIZIP_OBJS)
$(HOST_CC) -o $@ $(MINIZIP_OBJS)
# The following target generates the file generic/tclDate.c from the yacc
# grammar found in generic/tclGetDate.y. This is only run by hand as yacc is
# not available in all environments. The name of the .c file is different than
# the name of the .y file so that make doesn't try to automatically regenerate
# the .c file.
gendate:
bison --output-file=$(GENERIC_DIR)/tclDate.c \
--name-prefix=TclDate \
--no-lines \
$(GENERIC_DIR)/tclGetDate.y
# The following target generates the file generic/tclTomMath.h. It needs to be
# run (and the results checked) after updating to a new release of libtommath.
gentommath_h:
$(TCL_EXE) "$(ROOT_DIR_NATIVE)/tools/fix_tommath_h.tcl" \
"$(TOMMATH_DIR_NATIVE)/tommath.h" \
> "$(GENERIC_DIR_NATIVE)/tclTomMath.h"
INSTALL_BASE_TARGETS = install-binaries $(INSTALL_LIBRARIES) $(INSTALL_MSGS) $(INSTALL_TZDATA)
INSTALL_DOC_TARGETS = install-doc
INSTALL_PACKAGE_TARGETS = install-packages
INSTALL_DEV_TARGETS = install-headers
INSTALL_EXTRA_TARGETS =
INSTALL_TARGETS = $(INSTALL_BASE_TARGETS) $(INSTALL_DOC_TARGETS) $(INSTALL_DEV_TARGETS) \
$(INSTALL_PACKAGE_TARGETS) $(INSTALL_EXTRA_TARGETS)
install: $(INSTALL_TARGETS)
install-binaries: binaries
@for i in "$(LIB_INSTALL_DIR)" "$(BIN_INSTALL_DIR)" ; \
do \
if [ ! -d $$i ] ; then \
echo "Making directory $$i"; \
$(MKDIR) $$i; \
|
| ︙ | ︙ | |||
613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 |
$(LIB_INSTALL_DIR)/reg${REGDOTVER}; \
fi
@if [ -f $(REG_LIB_FILE) ]; then \
echo Installing $(REG_LIB_FILE); \
$(COPY) $(REG_LIB_FILE) $(LIB_INSTALL_DIR)/reg${REGDOTVER}; \
fi
install-libraries: libraries install-tzdata install-msgs
@for i in "$$($(CYGPATH) $(prefix)/lib)" "$(INCLUDE_INSTALL_DIR)" \
$(SCRIPT_INSTALL_DIR); \
do \
if [ ! -d $$i ] ; then \
echo "Making directory $$i"; \
$(MKDIR) $$i; \
else true; \
fi; \
done;
@for i in opt0.4 encoding ../tcl9 ../tcl9/9.0 ../tcl9/9.0/platform; \
do \
if [ ! -d $(SCRIPT_INSTALL_DIR)/$$i ] ; then \
echo "Making directory $(SCRIPT_INSTALL_DIR)/$$i"; \
$(MKDIR) $(SCRIPT_INSTALL_DIR)/$$i; \
else true; \
fi; \
done;
| > > > > > < < < < < < < < < | | | 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 |
$(LIB_INSTALL_DIR)/reg${REGDOTVER}; \
fi
@if [ -f $(REG_LIB_FILE) ]; then \
echo Installing $(REG_LIB_FILE); \
$(COPY) $(REG_LIB_FILE) $(LIB_INSTALL_DIR)/reg${REGDOTVER}; \
fi
install-libraries-zipfs-shared: libraries
install-libraries-zipfs-static: install-libraries-zipfs-shared
$(INSTALL_DATA) ${TCL_ZIP_FILE} "$(LIB_INSTALL_DIR)"
install-libraries: libraries install-tzdata install-msgs
@for i in "$$($(CYGPATH) $(prefix)/lib)" "$(INCLUDE_INSTALL_DIR)" \
$(SCRIPT_INSTALL_DIR); \
do \
if [ ! -d $$i ] ; then \
echo "Making directory $$i"; \
$(MKDIR) $$i; \
else true; \
fi; \
done;
@for i in opt0.4 encoding ../tcl9 ../tcl9/9.0 ../tcl9/9.0/platform; \
do \
if [ ! -d $(SCRIPT_INSTALL_DIR)/$$i ] ; then \
echo "Making directory $(SCRIPT_INSTALL_DIR)/$$i"; \
$(MKDIR) $(SCRIPT_INSTALL_DIR)/$$i; \
else true; \
fi; \
done;
@echo "Installing library files to $(SCRIPT_INSTALL_DIR)";
@for i in $(ROOT_DIR)/library/*.tcl $(ROOT_DIR)/library/tclIndex; \
do \
$(COPY) "$$i" "$(SCRIPT_INSTALL_DIR)"; \
done;
@echo "Installing package http 2.9.0 as a Tcl Module";
@$(COPY) $(ROOT_DIR)/library/http/http.tcl $(SCRIPT_INSTALL_DIR)/../tcl9/9.0/http-2.9.0.tm;
@echo "Installing library opt0.4 directory";
@for j in $(ROOT_DIR)/library/opt/*.tcl; \
do \
$(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/opt0.4"; \
done;
@echo "Installing package msgcat 1.7.0 as a Tcl Module";
@$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl9/9.0/msgcat-1.7.0.tm;
|
| ︙ | ︙ | |||
676 677 678 679 680 681 682 683 684 685 686 687 688 689 | install-msgs: @echo "Installing message catalogs" @$(TCL_EXE) "$(ROOT_DIR)/tools/installData.tcl" \ "$(ROOT_DIR)/library/msgs" "$(SCRIPT_INSTALL_DIR)/msgs" install-doc: doc # Optional target to install private headers install-private-headers: libraries @for i in $(PRIVATE_INCLUDE_INSTALL_DIR); \ do \ if [ ! -d $$i ] ; then \ echo "Making directory $$i"; \ | > > > > > > > > > > > > > > > > > > > > | 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 | install-msgs: @echo "Installing message catalogs" @$(TCL_EXE) "$(ROOT_DIR)/tools/installData.tcl" \ "$(ROOT_DIR)/library/msgs" "$(SCRIPT_INSTALL_DIR)/msgs" install-doc: doc install-headers: @for i in "$(INCLUDE_INSTALL_DIR)"; \ do \ if [ ! -d "$$i" ] ; then \ echo "Making directory $$i"; \ $(MKDIR) "$$i"; \ chmod 755 "$$i"; \ else true; \ fi; \ done; @echo "Installing header files to $(INCLUDE_INSTALL_DIR)/"; @for i in $(GENERIC_DIR)/tcl.h $(GENERIC_DIR)/tclDecls.h \ $(GENERIC_DIR)/tclOO.h $(GENERIC_DIR)/tclOODecls.h \ $(GENERIC_DIR)/tclPlatDecls.h \ $(GENERIC_DIR)/tclTomMath.h \ $(GENERIC_DIR)/tclTomMathDecls.h ; \ do \ $(COPY) $$i "$(INCLUDE_INSTALL_DIR)"; \ done; # Optional target to install private headers install-private-headers: libraries @for i in $(PRIVATE_INCLUDE_INSTALL_DIR); \ do \ if [ ! -d $$i ] ; then \ echo "Making directory $$i"; \ |
| ︙ | ︙ | |||
704 705 706 707 708 709 710 | # tcltest, i.e.: # % make test TESTFLAGS="-verbose bps -file fileName.test" test: test-tcl test-packages test-tcl: binaries $(TCLSH) $(CAT32) $(TEST_DLL_FILE) TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \ | | < < | | < < | | > > > | | | 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 |
# tcltest, i.e.:
# % make test TESTFLAGS="-verbose bps -file fileName.test"
test: test-tcl test-packages
test-tcl: binaries $(TCLSH) $(CAT32) $(TEST_DLL_FILE)
TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \
$(WINE) ./$(TCLSH) "$(ROOT_DIR_NATIVE)/tests/all.tcl" $(TESTFLAGS) \
-load "$(TEST_LOAD_FACILITIES)" | $(WINE) ./$(CAT32)
# Useful target to launch a built tclsh with the proper path,...
runtest: binaries $(TCLSH) $(TEST_DLL_FILE)
@TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \
$(WINE) ./$(TCLSH) $(TESTFLAGS) -load "$(TEST_LOAD_FACILITIES)" $(SCRIPT)
# This target can be used to run tclsh from the build directory via
# `make shell SCRIPT=foo.tcl`
shell: binaries
@TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \
$(WINE) ./$(TCLSH) $(SCRIPT)
# This target can be used to run tclsh inside either gdb or insight
gdb: binaries
@echo "set env TCL_LIBRARY=$(LIBRARY_DIR)" > gdb.run
gdb ./$(TCLSH) --command=gdb.run
rm gdb.run
depend:
Makefile: $(SRC_DIR)/Makefile.in
./config.status
cleanhelp:
$(RM) *.hlp *.cnt *.GID *.rtf man2tcl.exe
clean: cleanhelp clean-packages
$(RM) *.lib *.a *.exp *.dll *.$(RES) *.${OBJEXT} *~ \#* TAGS a.out
$(RM) $(TCLSH) $(CAT32) $(TEST_EXE_FILE) $(TEST_DLL_FILE) tcltest.cmd tcltest
$(RM) *.pch *.ilk *.pdb
$(RM) minizip${HOST_EXEEXT} *.${HOST_OBJEXT}
$(RM) *.zip
$(RMDIR) *.vfs
distclean: distclean-packages clean
$(RM) Makefile config.status config.cache config.log tclConfig.sh \
tcl.hpj config.status.lineno tclsh.exe.manifest
#
# Bundled package targets
#
PKG_CFG_ARGS = @PKG_CFG_ARGS@
PKG_DIR = ./pkgs
packages:
@builddir=`$(CYGPATH) $$(pwd -P)`; \
for i in $(PKGS_DIR)/*; do \
if [ -d $$i ] ; then \
if [ -x $$i/configure ] ; then \
pkg=`basename $$i`; \
mkdir -p $(PKG_DIR)/$$pkg; \
if [ ! -f $(PKG_DIR)/$$pkg/Makefile ]; then \
( cd $(PKG_DIR)/$$pkg; \
echo "Configuring package '$$i' wd = `$(CYGPATH) $$(pwd -P)`"; \
$$i/configure --with-tcl=$$builddir --with-tclinclude=$(GENERIC_DIR_NATIVE) $(PKG_CFG_ARGS) --enable-shared; ) \
fi ; \
echo "Building package '$$pkg'"; \
( cd $(PKG_DIR)/$$pkg; $(MAKE); ) \
fi; \
fi; \
done; \
cd $$builddir
|
| ︙ | ︙ | |||
872 873 874 875 876 877 878 879 880 | .PHONY: all tcltest binaries libraries doc gendate gentommath_h install .PHONY: install-binaries install-libraries install-tzdata install-msgs .PHONY: install-doc install-private-headers test test-tcl runtest shell .PHONY: gdb depend cleanhelp clean distclean packages install-packages .PHONY: test-packages clean-packages distclean-packages genstubs html .PHONY: html-tcl html-tk # DO NOT DELETE THIS LINE -- make depend depends on it. | > | 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 | .PHONY: all tcltest binaries libraries doc gendate gentommath_h install .PHONY: install-binaries install-libraries install-tzdata install-msgs .PHONY: install-doc install-private-headers test test-tcl runtest shell .PHONY: gdb depend cleanhelp clean distclean packages install-packages .PHONY: test-packages clean-packages distclean-packages genstubs html .PHONY: html-tcl html-tk .PHONY: iinstall-libraries-zipfs-shared install-libraries-zipfs-static tclzipfile # DO NOT DELETE THIS LINE -- make depend depends on it. |
win/buildall.vc.bat became executable.
| ︙ | ︙ |
Changes to win/configure.
| ︙ | ︙ | |||
695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 | TCL_VERSION MACHINE TCL_WIN_VERSION VC_MANIFEST_EMBED_EXE VC_MANIFEST_EMBED_DLL LDFLAGS_DEFAULT CFLAGS_DEFAULT ZLIB_OBJS ZLIB_LIBS ZLIB_DLL_FILE CFLAGS_WARNING CFLAGS_OPTIMIZE CFLAGS_DEBUG DL_LIBS CYGPATH | > > > > > > > > > > > > | | 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 | TCL_VERSION MACHINE TCL_WIN_VERSION VC_MANIFEST_EMBED_EXE VC_MANIFEST_EMBED_DLL LDFLAGS_DEFAULT CFLAGS_DEFAULT INSTALL_MSGS INSTALL_LIBRARIES TCL_ZIP_FILE ZIPFS_BUILD ZIP_INSTALL_OBJS ZIP_PROG_VFSSEARCH ZIP_PROG_OPTIONS ZIP_PROG TCLSH_PROG EXEEXT_FOR_BUILD CC_FOR_BUILD ZLIB_OBJS ZLIB_LIBS ZLIB_DLL_FILE CFLAGS_WARNING CFLAGS_OPTIMIZE CFLAGS_DEBUG DL_LIBS WINE CYGPATH SHARED_BUILD SET_MAKE RC RANLIB AR EGREP GREP CPP |
| ︙ | ︙ | |||
755 756 757 758 759 760 761 | PACKAGE_URL PACKAGE_BUGREPORT PACKAGE_STRING PACKAGE_VERSION PACKAGE_TARNAME PACKAGE_NAME PATH_SEPARATOR | | > < > | 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 |
PACKAGE_URL
PACKAGE_BUGREPORT
PACKAGE_STRING
PACKAGE_VERSION
PACKAGE_TARNAME
PACKAGE_NAME
PATH_SEPARATOR
SHELL
OBJEXT_FOR_BUILD'
ac_subst_files=''
ac_user_opts='
enable_option_checking
with_encoding
enable_shared
enable_64bit
enable_zipfs
enable_symbols
enable_embedded_manifest
'
ac_precious_vars='build_alias
host_alias
target_alias
CC
|
| ︙ | ︙ | |||
1382 1383 1384 1385 1386 1387 1388 | cat <<\_ACEOF Optional Features: --disable-option-checking ignore unrecognized --enable/--with options --disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no) --enable-FEATURE[=ARG] include FEATURE [ARG=yes] | < > | 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 |
cat <<\_ACEOF
Optional Features:
--disable-option-checking ignore unrecognized --enable/--with options
--disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no)
--enable-FEATURE[=ARG] include FEATURE [ARG=yes]
--enable-shared build and link with shared libraries (default: on)
--enable-64bit enable 64bit support (where applicable)
--enable-zipfs build with Zipfs support (default: on)
--enable-symbols build with debugging symbols (default: off)
--enable-embedded-manifest
embed manifest if possible (default: yes)
Optional Packages:
--with-PACKAGE[=ARG] use PACKAGE [ARG=yes]
--without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no)
|
| ︙ | ︙ | |||
3668 3669 3670 3671 3672 3673 3674 | #-------------------------------------------------------------------- # Determines the correct binary file extension (.o, .obj, .exe etc.) #-------------------------------------------------------------------- | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 3681 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 | #-------------------------------------------------------------------- # Determines the correct binary file extension (.o, .obj, .exe etc.) #-------------------------------------------------------------------- #------------------------------------------------------------------------ # Embedded configuration information, encoding to use for the values, TIP #59 #------------------------------------------------------------------------ |
| ︙ | ︙ | |||
3761 3762 3763 3764 3765 3766 3767 3768 3769 3770 3771 3772 3773 3774 |
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: static" >&5
$as_echo "static" >&6; }
SHARED_BUILD=0
$as_echo "#define STATIC_BUILD 1" >>confdefs.h
fi
#--------------------------------------------------------------------
# The statements below define a collection of compile flags. This
# macro depends on the value of SHARED_BUILD, and should be called
# after SC_ENABLE_SHARED checks the configure switches.
#--------------------------------------------------------------------
| > | 3741 3742 3743 3744 3745 3746 3747 3748 3749 3750 3751 3752 3753 3754 3755 |
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: static" >&5
$as_echo "static" >&6; }
SHARED_BUILD=0
$as_echo "#define STATIC_BUILD 1" >>confdefs.h
fi
#--------------------------------------------------------------------
# The statements below define a collection of compile flags. This
# macro depends on the value of SHARED_BUILD, and should be called
# after SC_ENABLE_SHARED checks the configure switches.
#--------------------------------------------------------------------
|
| ︙ | ︙ | |||
3840 3841 3842 3843 3844 3845 3846 3847 3848 3849 3850 3851 3852 3853 |
test -z "$ac_cv_prog_CYGPATH" && ac_cv_prog_CYGPATH="echo"
fi
fi
CYGPATH=$ac_cv_prog_CYGPATH
if test -n "$CYGPATH"; then
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $CYGPATH" >&5
$as_echo "$CYGPATH" >&6; }
else
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
$as_echo "no" >&6; }
fi
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 3821 3822 3823 3824 3825 3826 3827 3828 3829 3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 3846 3847 3848 3849 3850 3851 3852 3853 3854 3855 3856 3857 3858 3859 3860 3861 3862 3863 3864 3865 3866 3867 3868 3869 3870 3871 |
test -z "$ac_cv_prog_CYGPATH" && ac_cv_prog_CYGPATH="echo"
fi
fi
CYGPATH=$ac_cv_prog_CYGPATH
if test -n "$CYGPATH"; then
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $CYGPATH" >&5
$as_echo "$CYGPATH" >&6; }
else
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
$as_echo "no" >&6; }
fi
# Extract the first word of "wine", so it can be a program name with args.
set dummy wine; ac_word=$2
{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
$as_echo_n "checking for $ac_word... " >&6; }
if ${ac_cv_prog_WINE+:} false; then :
$as_echo_n "(cached) " >&6
else
if test -n "$WINE"; then
ac_cv_prog_WINE="$WINE" # Let the user override the test.
else
as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
for as_dir in $PATH
do
IFS=$as_save_IFS
test -z "$as_dir" && as_dir=.
for ac_exec_ext in '' $ac_executable_extensions; do
if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then
ac_cv_prog_WINE="wine"
$as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
break 2
fi
done
done
IFS=$as_save_IFS
fi
fi
WINE=$ac_cv_prog_WINE
if test -n "$WINE"; then
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $WINE" >&5
$as_echo "$WINE" >&6; }
else
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
$as_echo "no" >&6; }
fi
|
| ︙ | ︙ | |||
4130 4131 4132 4133 4134 4135 4136 |
LIBFLAGSUFFIX="\${DBGX}"
SHLIB_SUFFIX=.dll
EXTRA_CFLAGS="${extra_cflags}"
CFLAGS_DEBUG=-g
CFLAGS_OPTIMIZE="-O2 -fomit-frame-pointer"
| | | 4148 4149 4150 4151 4152 4153 4154 4155 4156 4157 4158 4159 4160 4161 4162 |
LIBFLAGSUFFIX="\${DBGX}"
SHLIB_SUFFIX=.dll
EXTRA_CFLAGS="${extra_cflags}"
CFLAGS_DEBUG=-g
CFLAGS_OPTIMIZE="-O2 -fomit-frame-pointer"
CFLAGS_WARNING="-Wall -Wwrite-strings -Wsign-compare -Wdeclaration-after-statement -Wpointer-arith"
LDFLAGS_DEBUG=
LDFLAGS_OPTIMIZE=
# Specify the CC output file names based on the target name
CC_OBJNAME="-o \$@"
CC_EXENAME="-o \$@"
|
| ︙ | ︙ | |||
4557 4558 4559 4560 4561 4562 4563 |
tcl_ok=yes
fi
if test "$tcl_ok" = "yes"; then :
ZLIB_DLL_FILE=\${ZLIB_DLL_FILE}
| | | 4575 4576 4577 4578 4579 4580 4581 4582 4583 4584 4585 4586 4587 4588 4589 |
tcl_ok=yes
fi
if test "$tcl_ok" = "yes"; then :
ZLIB_DLL_FILE=\${ZLIB_DLL_FILE}
if test "$do64bit" != "no"; then :
if test "$GCC" == "yes"; then :
ZLIB_LIBS=\${ZLIB_DIR_NATIVE}/win64/libz.dll.a
else
|
| ︙ | ︙ | |||
4690 4691 4692 4693 4694 4695 4696 4697 4698 4699 4700 4701 4702 4703 |
cat >>confdefs.h <<_ACEOF
#define uintptr_t $tcl_cv_uintptr_t
_ACEOF
fi
fi
#--------------------------------------------------------------------
# Perform additinal compiler tests.
#--------------------------------------------------------------------
# See if declarations like FINDEX_INFO_LEVELS are
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 4708 4709 4710 4711 4712 4713 4714 4715 4716 4717 4718 4719 4720 4721 4722 4723 4724 4725 4726 4727 4728 4729 4730 4731 4732 4733 4734 4735 4736 4737 4738 4739 4740 4741 4742 4743 4744 4745 4746 4747 4748 4749 4750 4751 4752 4753 4754 4755 4756 4757 4758 4759 4760 4761 4762 4763 4764 4765 4766 4767 4768 4769 4770 4771 4772 4773 4774 4775 4776 4777 4778 4779 4780 4781 4782 4783 4784 4785 4786 4787 4788 4789 4790 4791 4792 4793 4794 4795 4796 4797 4798 4799 4800 4801 4802 4803 4804 4805 4806 4807 4808 4809 4810 4811 4812 4813 4814 4815 4816 4817 4818 4819 4820 4821 4822 4823 4824 4825 4826 4827 4828 4829 4830 4831 4832 4833 4834 4835 4836 4837 4838 4839 4840 4841 4842 4843 4844 4845 4846 4847 4848 4849 4850 4851 4852 4853 4854 4855 4856 4857 4858 4859 4860 4861 4862 4863 4864 4865 4866 4867 4868 4869 4870 4871 4872 4873 4874 4875 4876 4877 4878 4879 4880 4881 4882 4883 4884 4885 4886 4887 4888 4889 4890 4891 4892 4893 4894 4895 4896 4897 4898 4899 4900 4901 4902 4903 4904 4905 4906 4907 4908 4909 4910 4911 4912 4913 4914 4915 4916 4917 4918 4919 4920 4921 4922 4923 |
cat >>confdefs.h <<_ACEOF
#define uintptr_t $tcl_cv_uintptr_t
_ACEOF
fi
fi
#--------------------------------------------------------------------
# Zipfs support - Tip 430
#--------------------------------------------------------------------
# Check whether --enable-zipfs was given.
if test "${enable_zipfs+set}" = set; then :
enableval=$enable_zipfs; tcl_ok=$enableval
else
tcl_ok=yes
fi
if test "$tcl_ok" = "yes" ; then
#
# Find a native compiler
#
# Put a plausible default for CC_FOR_BUILD in Makefile.
if test -z "$CC_FOR_BUILD"; then
if test "x$cross_compiling" = "xno"; then
CC_FOR_BUILD='$(CC)'
else
{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for gcc" >&5
$as_echo_n "checking for gcc... " >&6; }
if ${ac_cv_path_cc+:} false; then :
$as_echo_n "(cached) " >&6
else
search_path=`echo ${PATH} | sed -e 's/:/ /g'`
for dir in $search_path ; do
for j in `ls -r $dir/gcc 2> /dev/null` \
`ls -r $dir/gcc 2> /dev/null` ; do
if test x"$ac_cv_path_cc" = x ; then
if test -f "$j" ; then
ac_cv_path_cc=$j
break
fi
fi
done
done
fi
fi
fi
# Also set EXEEXT_FOR_BUILD.
if test "x$cross_compiling" = "xno"; then
EXEEXT_FOR_BUILD='$(EXEEXT)'
OBJEXT_FOR_BUILD='$(OBJEXT)'
else
OBJEXT_FOR_BUILD='.no'
{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for build system executable suffix" >&5
$as_echo_n "checking for build system executable suffix... " >&6; }
if ${bfd_cv_build_exeext+:} false; then :
$as_echo_n "(cached) " >&6
else
rm -f conftest*
echo 'int main () { return 0; }' > conftest.c
bfd_cv_build_exeext=
${CC_FOR_BUILD} -o conftest conftest.c 1>&5 2>&5
for file in conftest.*; do
case $file in
*.c | *.o | *.obj | *.ilk | *.pdb) ;;
*) bfd_cv_build_exeext=`echo $file | sed -e s/conftest//` ;;
esac
done
rm -f conftest*
test x"${bfd_cv_build_exeext}" = x && bfd_cv_build_exeext=no
fi
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $bfd_cv_build_exeext" >&5
$as_echo "$bfd_cv_build_exeext" >&6; }
EXEEXT_FOR_BUILD=""
test x"${bfd_cv_build_exeext}" != xno && EXEEXT_FOR_BUILD=${bfd_cv_build_exeext}
fi
#
# Find a native zip implementation
#
{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for tclsh" >&5
$as_echo_n "checking for tclsh... " >&6; }
if ${ac_cv_path_tclsh+:} false; then :
$as_echo_n "(cached) " >&6
else
search_path=`echo ${PATH} | sed -e 's/:/ /g'`
for dir in $search_path ; do
for j in `ls -r $dir/tclsh[8-9]*.exe 2> /dev/null` \
`ls -r $dir/tclsh* 2> /dev/null` ; do
if test x"$ac_cv_path_tclsh" = x ; then
if test -f "$j" ; then
ac_cv_path_tclsh=$j
break
fi
fi
done
done
fi
if test -f "$ac_cv_path_tclsh" ; then
TCLSH_PROG="$ac_cv_path_tclsh"
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $TCLSH_PROG" >&5
$as_echo "$TCLSH_PROG" >&6; }
else
# It is not an error if an installed version of Tcl can't be located.
TCLSH_PROG=""
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: No tclsh found on PATH" >&5
$as_echo "No tclsh found on PATH" >&6; }
fi
ZIP_PROG=""
ZIP_PROG_OPTIONS=""
ZIP_PROG_VFSSEARCH=""
ZIP_INSTALL_OBJS=""
{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for zip" >&5
$as_echo_n "checking for zip... " >&6; }
if ${ac_cv_path_zip+:} false; then :
$as_echo_n "(cached) " >&6
else
search_path=`echo ${PATH} | sed -e 's/:/ /g'`
for dir in $search_path ; do
for j in `ls -r $dir/zip 2> /dev/null` \
`ls -r $dir/zip 2> /dev/null` ; do
if test x"$ac_cv_path_zip" = x ; then
if test -f "$j" ; then
ac_cv_path_zip=$j
break
fi
fi
done
done
fi
if test -f "$ac_cv_path_zip" ; then
ZIP_PROG="$ac_cv_path_zip"
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ZIP_PROG" >&5
$as_echo "$ZIP_PROG" >&6; }
ZIP_PROG_OPTIONS="-rq"
ZIP_PROG_VFSSEARCH="*"
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: Found INFO Zip in environment" >&5
$as_echo "Found INFO Zip in environment" >&6; }
# Use standard arguments for zip
else
# It is not an error if an installed version of Zip can't be located.
# We can use the locally distributed minizip instead
ZIP_PROG="./minizip${EXEEXT_FOR_BUILD}"
ZIP_PROG_OPTIONS="-o -r"
ZIP_PROG_VFSSEARCH="*"
ZIP_INSTALL_OBJS="minizip${EXEEXT_FOR_BUILD}"
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: No zip found on PATH building minizip" >&5
$as_echo "No zip found on PATH building minizip" >&6; }
fi
ZIPFS_BUILD=1
TCL_ZIP_FILE=libtcl_${TCL_MAJOR_VERSION}_${TCL_MINOR_VERSION}_${TCL_PATCH_LEVEL}.zip
else
ZIPFS_BUILD=0
TCL_ZIP_FILE=
fi
# Do checking message here to not mess up interleaved configure output
{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for building with zipfs" >&5
$as_echo_n "checking for building with zipfs... " >&6; }
if test "${ZIPFS_BUILD}" = 1; then
if test "${SHARED_BUILD}" = 0; then
ZIPFS_BUILD=2;
$as_echo "#define ZIPFS_BUILD 2" >>confdefs.h
INSTALL_LIBRARIES=install-libraries-zipfs-static
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5
$as_echo "yes" >&6; }
else
$as_echo "#define ZIPFS_BUILD 1" >>confdefs.h
\
INSTALL_LIBRARIES=install-libraries-zipfs-shared
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5
$as_echo "yes" >&6; }
fi
else
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
$as_echo "no" >&6; }
INSTALL_LIBRARIES=install-libraries
INSTALL_MSGS=install-msgs
fi
#--------------------------------------------------------------------
# Perform additinal compiler tests.
#--------------------------------------------------------------------
# See if declarations like FINDEX_INFO_LEVELS are
|
| ︙ | ︙ |
Changes to win/configure.ac.
| ︙ | ︙ | |||
74 75 76 77 78 79 80 | #-------------------------------------------------------------------- # Determines the correct binary file extension (.o, .obj, .exe etc.) #-------------------------------------------------------------------- AC_OBJEXT AC_EXEEXT | < < < < < < | 74 75 76 77 78 79 80 81 82 83 84 85 86 87 | #-------------------------------------------------------------------- # Determines the correct binary file extension (.o, .obj, .exe etc.) #-------------------------------------------------------------------- AC_OBJEXT AC_EXEEXT #------------------------------------------------------------------------ # Embedded configuration information, encoding to use for the values, TIP #59 #------------------------------------------------------------------------ SC_TCL_CFG_ENCODING #-------------------------------------------------------------------- |
| ︙ | ︙ | |||
124 125 126 127 128 129 130 |
enableval="$enable_shared"
tcl_ok=$enableval
], [
tcl_ok=yes
])
AS_IF([test "$tcl_ok" = "yes"], [
AC_SUBST(ZLIB_DLL_FILE,[\${ZLIB_DLL_FILE}])
| | | 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 |
enableval="$enable_shared"
tcl_ok=$enableval
], [
tcl_ok=yes
])
AS_IF([test "$tcl_ok" = "yes"], [
AC_SUBST(ZLIB_DLL_FILE,[\${ZLIB_DLL_FILE}])
AS_IF([test "$do64bit" != "no"], [
AS_IF([test "$GCC" == "yes"],[
AC_SUBST(ZLIB_LIBS,[\${ZLIB_DIR_NATIVE}/win64/libz.dll.a])
], [
AC_SUBST(ZLIB_LIBS,[\${ZLIB_DIR_NATIVE}/win64/zdll.lib])
])
], [
AC_SUBST(ZLIB_LIBS,[\${ZLIB_DIR_NATIVE}/win32/zdll.lib])
|
| ︙ | ︙ | |||
169 170 171 172 173 174 175 176 177 178 179 180 181 182 |
test "$tcl_ok" = yes && break; fi
done])
if test "$tcl_cv_uintptr_t" != none; then
AC_DEFINE_UNQUOTED([uintptr_t], [$tcl_cv_uintptr_t], [Unsigned integer
type wide enough to hold a pointer.])
fi
])
#--------------------------------------------------------------------
# Perform additinal compiler tests.
#--------------------------------------------------------------------
# See if declarations like FINDEX_INFO_LEVELS are
# missing from winbase.h. This is known to be
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 |
test "$tcl_ok" = yes && break; fi
done])
if test "$tcl_cv_uintptr_t" != none; then
AC_DEFINE_UNQUOTED([uintptr_t], [$tcl_cv_uintptr_t], [Unsigned integer
type wide enough to hold a pointer.])
fi
])
#--------------------------------------------------------------------
# Zipfs support - Tip 430
#--------------------------------------------------------------------
AC_ARG_ENABLE(zipfs,
AC_HELP_STRING([--enable-zipfs],
[build with Zipfs support (default: on)]),
[tcl_ok=$enableval], [tcl_ok=yes])
if test "$tcl_ok" = "yes" ; then
#
# Find a native compiler
#
AX_CC_FOR_BUILD
#
# Find a native zip implementation
#
SC_PROG_TCLSH
SC_ZIPFS_SUPPORT
ZIPFS_BUILD=1
TCL_ZIP_FILE=libtcl_${TCL_MAJOR_VERSION}_${TCL_MINOR_VERSION}_${TCL_PATCH_LEVEL}.zip
else
ZIPFS_BUILD=0
TCL_ZIP_FILE=
fi
# Do checking message here to not mess up interleaved configure output
AC_MSG_CHECKING([for building with zipfs])
if test "${ZIPFS_BUILD}" = 1; then
if test "${SHARED_BUILD}" = 0; then
ZIPFS_BUILD=2;
AC_DEFINE(ZIPFS_BUILD, 2, [Are we building with zipfs enabled?])
INSTALL_LIBRARIES=install-libraries-zipfs-static
AC_MSG_RESULT([yes])
else
AC_DEFINE(ZIPFS_BUILD, 1, [Are we building with zipfs enabled?])\
INSTALL_LIBRARIES=install-libraries-zipfs-shared
AC_MSG_RESULT([yes])
fi
else
AC_MSG_RESULT([no])
INSTALL_LIBRARIES=install-libraries
INSTALL_MSGS=install-msgs
fi
AC_SUBST(ZIPFS_BUILD)
AC_SUBST(TCL_ZIP_FILE)
AC_SUBST(INSTALL_LIBRARIES)
AC_SUBST(INSTALL_MSGS)
#--------------------------------------------------------------------
# Perform additinal compiler tests.
#--------------------------------------------------------------------
# See if declarations like FINDEX_INFO_LEVELS are
# missing from winbase.h. This is known to be
|
| ︙ | ︙ |
Changes to win/makefile.vc.
| ︙ | ︙ | |||
51 52 53 54 55 56 57 | # vcvars32.bat according to the instructions for it. This can also # turn on the 64-bit compiler, if your SDK has it. # # Examples: # c:\tcl_src\win\>nmake -f makefile.vc release # c:\tcl_src\win\>nmake -f makefile.vc test # c:\tcl_src\win\>nmake -f makefile.vc install INSTALLDIR=c:\progra~1\tcl | | | 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 | # vcvars32.bat according to the instructions for it. This can also # turn on the 64-bit compiler, if your SDK has it. # # Examples: # c:\tcl_src\win\>nmake -f makefile.vc release # c:\tcl_src\win\>nmake -f makefile.vc test # c:\tcl_src\win\>nmake -f makefile.vc install INSTALLDIR=c:\progra~1\tcl # c:\tcl_src\win\>nmake -f makefile.vc release OPTS=pdbs # c:\tcl_src\win\>nmake -f makefile.vc release OPTS=symbols # # NOTE: # Before modifying this file, check whether the modification is applicable # to building extensions as well and if so, modify rules.vc instead. |
| ︙ | ︙ | |||
119 120 121 122 123 124 125 | TCLREGLIBNAME = $(PROJECT)reg$(REGVERSION)$(SUFX:t=).$(EXT) TCLREGLIB = $(OUT_DIR)\$(TCLREGLIBNAME) TCLDDELIBNAME = $(PROJECT)dde$(DDEVERSION)$(SUFX:t=).$(EXT) TCLDDELIB = $(OUT_DIR)\$(TCLDDELIBNAME) TCLTEST = $(OUT_DIR)\$(PROJECT)test.exe | < | 119 120 121 122 123 124 125 126 127 128 129 130 131 132 | TCLREGLIBNAME = $(PROJECT)reg$(REGVERSION)$(SUFX:t=).$(EXT) TCLREGLIB = $(OUT_DIR)\$(TCLREGLIBNAME) TCLDDELIBNAME = $(PROJECT)dde$(DDEVERSION)$(SUFX:t=).$(EXT) TCLDDELIB = $(OUT_DIR)\$(TCLDDELIBNAME) TCLTEST = $(OUT_DIR)\$(PROJECT)test.exe TCLSHOBJS = \ $(TMP_DIR)\tclAppInit.obj \ !if !$(STATIC_BUILD) !if $(TCL_USE_STATIC_PACKAGES) $(TMP_DIR)\tclWinReg.obj \ $(TMP_DIR)\tclWinDde.obj \ |
| ︙ | ︙ | |||
232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 | $(TMP_DIR)\tclThreadStorage.obj \ $(TMP_DIR)\tclTimer.obj \ $(TMP_DIR)\tclTomMathInterface.obj \ $(TMP_DIR)\tclTrace.obj \ $(TMP_DIR)\tclUtf.obj \ $(TMP_DIR)\tclUtil.obj \ $(TMP_DIR)\tclVar.obj \ $(TMP_DIR)\tclZlib.obj ZLIBOBJS = \ $(TMP_DIR)\adler32.obj \ $(TMP_DIR)\compress.obj \ $(TMP_DIR)\crc32.obj \ $(TMP_DIR)\deflate.obj \ $(TMP_DIR)\infback.obj \ $(TMP_DIR)\inffast.obj \ $(TMP_DIR)\inflate.obj \ $(TMP_DIR)\inftrees.obj \ $(TMP_DIR)\trees.obj \ $(TMP_DIR)\uncompr.obj \ $(TMP_DIR)\zutil.obj TOMMATHOBJS = \ | > < | 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 | $(TMP_DIR)\tclThreadStorage.obj \ $(TMP_DIR)\tclTimer.obj \ $(TMP_DIR)\tclTomMathInterface.obj \ $(TMP_DIR)\tclTrace.obj \ $(TMP_DIR)\tclUtf.obj \ $(TMP_DIR)\tclUtil.obj \ $(TMP_DIR)\tclVar.obj \ $(TMP_DIR)\tclZipfs.obj \ $(TMP_DIR)\tclZlib.obj ZLIBOBJS = \ $(TMP_DIR)\adler32.obj \ $(TMP_DIR)\compress.obj \ $(TMP_DIR)\crc32.obj \ $(TMP_DIR)\deflate.obj \ $(TMP_DIR)\infback.obj \ $(TMP_DIR)\inffast.obj \ $(TMP_DIR)\inflate.obj \ $(TMP_DIR)\inftrees.obj \ $(TMP_DIR)\trees.obj \ $(TMP_DIR)\uncompr.obj \ $(TMP_DIR)\zutil.obj TOMMATHOBJS = \ $(TMP_DIR)\bn_reverse.obj \ $(TMP_DIR)\bn_fast_s_mp_mul_digs.obj \ $(TMP_DIR)\bn_fast_s_mp_sqr.obj \ $(TMP_DIR)\bn_mp_add.obj \ $(TMP_DIR)\bn_mp_add_d.obj \ $(TMP_DIR)\bn_mp_and.obj \ $(TMP_DIR)\bn_mp_clamp.obj \ |
| ︙ | ︙ | |||
272 273 274 275 276 277 278 279 280 281 282 283 284 285 | $(TMP_DIR)\bn_mp_div_d.obj \ $(TMP_DIR)\bn_mp_div_2.obj \ $(TMP_DIR)\bn_mp_div_2d.obj \ $(TMP_DIR)\bn_mp_div_3.obj \ $(TMP_DIR)\bn_mp_exch.obj \ $(TMP_DIR)\bn_mp_expt_d.obj \ $(TMP_DIR)\bn_mp_expt_d_ex.obj \ $(TMP_DIR)\bn_mp_get_int.obj \ $(TMP_DIR)\bn_mp_get_long.obj \ $(TMP_DIR)\bn_mp_get_long_long.obj \ $(TMP_DIR)\bn_mp_grow.obj \ $(TMP_DIR)\bn_mp_init.obj \ $(TMP_DIR)\bn_mp_init_copy.obj \ $(TMP_DIR)\bn_mp_init_multi.obj \ | > | 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 | $(TMP_DIR)\bn_mp_div_d.obj \ $(TMP_DIR)\bn_mp_div_2.obj \ $(TMP_DIR)\bn_mp_div_2d.obj \ $(TMP_DIR)\bn_mp_div_3.obj \ $(TMP_DIR)\bn_mp_exch.obj \ $(TMP_DIR)\bn_mp_expt_d.obj \ $(TMP_DIR)\bn_mp_expt_d_ex.obj \ $(TMP_DIR)\bn_s_mp_get_bit.obj \ $(TMP_DIR)\bn_mp_get_int.obj \ $(TMP_DIR)\bn_mp_get_long.obj \ $(TMP_DIR)\bn_mp_get_long_long.obj \ $(TMP_DIR)\bn_mp_grow.obj \ $(TMP_DIR)\bn_mp_init.obj \ $(TMP_DIR)\bn_mp_init_copy.obj \ $(TMP_DIR)\bn_mp_init_multi.obj \ |
| ︙ | ︙ | |||
306 307 308 309 310 311 312 313 314 315 316 317 318 319 | $(TMP_DIR)\bn_mp_set_long.obj \ $(TMP_DIR)\bn_mp_set_long_long.obj \ $(TMP_DIR)\bn_mp_shrink.obj \ $(TMP_DIR)\bn_mp_sqr.obj \ $(TMP_DIR)\bn_mp_sqrt.obj \ $(TMP_DIR)\bn_mp_sub.obj \ $(TMP_DIR)\bn_mp_sub_d.obj \ $(TMP_DIR)\bn_mp_to_unsigned_bin.obj \ $(TMP_DIR)\bn_mp_to_unsigned_bin_n.obj \ $(TMP_DIR)\bn_mp_toom_mul.obj \ $(TMP_DIR)\bn_mp_toom_sqr.obj \ $(TMP_DIR)\bn_mp_toradix_n.obj \ $(TMP_DIR)\bn_mp_unsigned_bin_size.obj \ $(TMP_DIR)\bn_mp_xor.obj \ | > | 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 | $(TMP_DIR)\bn_mp_set_long.obj \ $(TMP_DIR)\bn_mp_set_long_long.obj \ $(TMP_DIR)\bn_mp_shrink.obj \ $(TMP_DIR)\bn_mp_sqr.obj \ $(TMP_DIR)\bn_mp_sqrt.obj \ $(TMP_DIR)\bn_mp_sub.obj \ $(TMP_DIR)\bn_mp_sub_d.obj \ $(TMP_DIR)\bn_mp_signed_rsh.obj \ $(TMP_DIR)\bn_mp_to_unsigned_bin.obj \ $(TMP_DIR)\bn_mp_to_unsigned_bin_n.obj \ $(TMP_DIR)\bn_mp_toom_mul.obj \ $(TMP_DIR)\bn_mp_toom_sqr.obj \ $(TMP_DIR)\bn_mp_toradix_n.obj \ $(TMP_DIR)\bn_mp_unsigned_bin_size.obj \ $(TMP_DIR)\bn_mp_xor.obj \ |
| ︙ | ︙ | |||
346 347 348 349 350 351 352 | !endif TCLOBJS = $(COREOBJS) $(ZLIBOBJS) $(TOMMATHOBJS) $(PLATFORMOBJS) TCLSTUBOBJS = \ $(TMP_DIR)\tclStubLib.obj \ $(TMP_DIR)\tclTomMathStubLib.obj \ | | > | 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 | !endif TCLOBJS = $(COREOBJS) $(ZLIBOBJS) $(TOMMATHOBJS) $(PLATFORMOBJS) TCLSTUBOBJS = \ $(TMP_DIR)\tclStubLib.obj \ $(TMP_DIR)\tclTomMathStubLib.obj \ $(TMP_DIR)\tclOOStubLib.obj \ $(TMP_DIR)\tclWinPanic.obj ### The following paths CANNOT have spaces in them as they appear on ### the left side of implicit rules. TOMMATHDIR = $(ROOT)\libtommath PKGSDIR = $(ROOT)\pkgs # Additional include and C macro definitions for the implicit rules |
| ︙ | ︙ | |||
378 379 380 381 382 383 384 | # Project specific targets #--------------------------------------------------------------------- release: setup $(TCLSH) $(TCLSTUBLIB) dlls pkgs core: setup $(TCLLIB) $(TCLSTUBLIB) shell: setup $(TCLSH) dlls: setup $(TCLREGLIB) $(TCLDDELIB) | | | > > > | | | | | 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 | # Project specific targets #--------------------------------------------------------------------- release: setup $(TCLSH) $(TCLSTUBLIB) dlls pkgs core: setup $(TCLLIB) $(TCLSTUBLIB) shell: setup $(TCLSH) dlls: setup $(TCLREGLIB) $(TCLDDELIB) all: setup $(TCLSH) $(TCLSTUBLIB) dlls pkgs tcltest: setup $(TCLTEST) dlls install: install-binaries install-libraries install-docs install-pkgs !if $(SYMBOLS) install: install-pdbs !endif setup: default-setup test: test-core test-pkgs test-core: setup $(TCLTEST) dlls set TCL_LIBRARY=$(ROOT:\=/)/library $(DEBUGGER) $(TCLTEST) "$(ROOT:\=/)/tests/all.tcl" $(TESTFLAGS) -loadfile << package ifneeded dde 1.4.1 [list load "$(TCLDDELIB:\=/)" dde] package ifneeded registry 1.3.3 [list load "$(TCLREGLIB:\=/)" registry] << runtest: setup $(TCLTEST) dlls set TCL_LIBRARY=$(ROOT:\=/)/library $(DEBUGGER) $(TCLTEST) $(SCRIPT) runshell: setup $(TCLSH) dlls set TCL_LIBRARY=$(ROOT:\=/)/library $(DEBUGGER) $(TCLSH) $(SCRIPT) |
| ︙ | ︙ | |||
413 414 415 416 417 418 419 420 421 422 | !else $(TCLLIB): $(TCLOBJS) $(DLLCMD) @<< $** << $(_VC_MANIFEST_EMBED_DLL) $(TCLIMPLIB): $(TCLLIB) !endif # $(STATIC_BUILD) | > < | 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 | !else $(TCLLIB): $(TCLOBJS) $(DLLCMD) @<< $** << $(_VC_MANIFEST_EMBED_DLL) $(TCLIMPLIB): $(TCLLIB) !endif # $(STATIC_BUILD) $(TCLSTUBLIB): $(TCLSTUBOBJS) $(LIBCMD) -nodefaultlib $(TCLSTUBOBJS) $(TCLSH): $(TCLSHOBJS) $(TCLSTUBLIB) $(TCLIMPLIB) $(CONEXECMD) -stack:2300000 $** $(_VC_MANIFEST_EMBED_EXE) |
| ︙ | ︙ | |||
479 480 481 482 483 484 485 | @for /d %d in ($(PKGSDIR)\*) do \ @if exist "%~fd\win\makefile.vc" ( \ pushd "%~fd\win" & \ $(MAKE) -$(MAKEFLAGS) -f makefile.vc TCLDIR=$(ROOT) clean &\ popd \ ) | < < < < < | 484 485 486 487 488 489 490 491 492 493 494 495 496 497 | @for /d %d in ($(PKGSDIR)\*) do \ @if exist "%~fd\win\makefile.vc" ( \ pushd "%~fd\win" & \ $(MAKE) -$(MAKEFLAGS) -f makefile.vc TCLDIR=$(ROOT) clean &\ popd \ ) #--------------------------------------------------------------------- # Regenerate the stubs files. [Development use only] #--------------------------------------------------------------------- genstubs: !if !exist($(TCLSH)) @echo Build tclsh first! |
| ︙ | ︙ | |||
577 578 579 580 581 582 583 | # Tcl itself. This is used when building extensions. #--------------------------------------------------------------------- tcl-nmake: $(OUT_DIR)\tcl.nmake $(OUT_DIR)\tcl.nmake: @type << >$@ CORE_MACHINE = $(MACHINE) CORE_DEBUG = $(DEBUG) | < | 577 578 579 580 581 582 583 584 585 586 587 588 589 590 | # Tcl itself. This is used when building extensions. #--------------------------------------------------------------------- tcl-nmake: $(OUT_DIR)\tcl.nmake $(OUT_DIR)\tcl.nmake: @type << >$@ CORE_MACHINE = $(MACHINE) CORE_DEBUG = $(DEBUG) CORE_USE_THREAD_ALLOC = $(USE_THREAD_ALLOC) CORE_USE_WIDECHAR_API = $(USE_WIDECHAR_API) << #--------------------------------------------------------------------- # Build tclConfig.sh for the TEA build system. #--------------------------------------------------------------------- |
| ︙ | ︙ | |||
633 634 635 636 637 638 639 | @TCL_INCLUDE_SPEC@ -I$(INCLUDE_INSTALL_DIR) @TCL_LIB_VERSIONS_OK@ @TCL_SRC_DIR@ $(ROOT) @TCL_PACKAGE_PATH@ @TCL_STUB_LIB_FILE@ $(TCLSTUBLIBNAME) @TCL_STUB_LIB_FLAG@ $(TCLSTUBLIBNAME) @TCL_STUB_LIB_SPEC@ -L$(LIB_INSTALL_DIR) $(TCLSTUBLIBNAME) | < | 632 633 634 635 636 637 638 639 640 641 642 643 644 645 | @TCL_INCLUDE_SPEC@ -I$(INCLUDE_INSTALL_DIR) @TCL_LIB_VERSIONS_OK@ @TCL_SRC_DIR@ $(ROOT) @TCL_PACKAGE_PATH@ @TCL_STUB_LIB_FILE@ $(TCLSTUBLIBNAME) @TCL_STUB_LIB_FLAG@ $(TCLSTUBLIBNAME) @TCL_STUB_LIB_SPEC@ -L$(LIB_INSTALL_DIR) $(TCLSTUBLIBNAME) @TCL_BUILD_STUB_LIB_SPEC@ -L$(OUT_DIR) $(TCLSTUBLIBNAME) @TCL_BUILD_STUB_LIB_PATH@ $(TCLSTUBLIB) @TCL_STUB_LIB_PATH@ $(LIB_INSTALL_DIR)\$(TCLSTUBLIBNAME) @CFG_TCL_EXPORT_FILE_SUFFIX@ $(VERSION)$(SUFX).lib @CFG_TCL_SHARED_LIB_SUFFIX@ $(VERSION)$(SUFX).dll @CFG_TCL_UNSHARED_LIB_SUFFIX@ $(VERSION)$(SUFX).lib !if $(STATIC_BUILD) |
| ︙ | ︙ | |||
683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 | $(TMP_DIR)\tclTestObj.obj: $(GENERICDIR)\tclTestObj.c $(cc32) $(appcflags) -Fo$@ $? $(TMP_DIR)\tclWinTest.obj: $(WINDIR)\tclWinTest.c $(CCAPPCMD) $? $(TMP_DIR)\tclZlib.obj: $(GENERICDIR)\tclZlib.c $(cc32) $(pkgcflags) -I$(COMPATDIR)\zlib -Fo$@ $? $(TMP_DIR)\tclPkgConfig.obj: $(GENERICDIR)\tclPkgConfig.c $(cc32) $(pkgcflags) \ -DCFG_INSTALL_LIBDIR="\"$(LIB_INSTALL_DIR:\=\\)\"" \ -DCFG_INSTALL_BINDIR="\"$(BIN_INSTALL_DIR:\=\\)\"" \ -DCFG_INSTALL_SCRDIR="\"$(SCRIPT_INSTALL_DIR:\=\\)\"" \ -DCFG_INSTALL_INCDIR="\"$(INCLUDE_INSTALL_DIR:\=\\)\"" \ -DCFG_INSTALL_DOCDIR="\"$(DOC_INSTALL_DIR:\=\\)\"" \ -DCFG_RUNTIME_LIBDIR="\"$(LIB_INSTALL_DIR:\=\\)\"" \ -DCFG_RUNTIME_BINDIR="\"$(BIN_INSTALL_DIR:\=\\)\"" \ -DCFG_RUNTIME_SCRDIR="\"$(SCRIPT_INSTALL_DIR:\=\\)\"" \ -DCFG_RUNTIME_INCDIR="\"$(INCLUDE_INSTALL_DIR:\=\\)\"" \ -DCFG_RUNTIME_DOCDIR="\"$(DOC_INSTALL_DIR:\=\\)\"" \ -Fo$@ $? $(TMP_DIR)\tclAppInit.obj: $(WINDIR)\tclAppInit.c $(cc32) $(appcflags) \ -DTCL_USE_STATIC_PACKAGES=$(TCL_USE_STATIC_PACKAGES) \ -Fo$@ $? ### The following objects should be built using the stub interfaces | > > > > > < | 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 | $(TMP_DIR)\tclTestObj.obj: $(GENERICDIR)\tclTestObj.c $(cc32) $(appcflags) -Fo$@ $? $(TMP_DIR)\tclWinTest.obj: $(WINDIR)\tclWinTest.c $(CCAPPCMD) $? $(TMP_DIR)\tclZipfs.obj: $(GENERICDIR)\tclZipfs.c $(cc32) $(pkgcflags) -I$(COMPATDIR)\zlib -I$(COMPATDIR)\zlib\contrib\minizip -Fo$@ $? $(TMP_DIR)\tclZlib.obj: $(GENERICDIR)\tclZlib.c $(cc32) $(pkgcflags) -I$(COMPATDIR)\zlib -Fo$@ $? $(TMP_DIR)\tclPkgConfig.obj: $(GENERICDIR)\tclPkgConfig.c $(cc32) $(pkgcflags) \ -DCFG_INSTALL_LIBDIR="\"$(LIB_INSTALL_DIR:\=\\)\"" \ -DCFG_INSTALL_BINDIR="\"$(BIN_INSTALL_DIR:\=\\)\"" \ -DCFG_INSTALL_SCRDIR="\"$(SCRIPT_INSTALL_DIR:\=\\)\"" \ -DCFG_INSTALL_INCDIR="\"$(INCLUDE_INSTALL_DIR:\=\\)\"" \ -DCFG_INSTALL_DOCDIR="\"$(DOC_INSTALL_DIR:\=\\)\"" \ -DCFG_RUNTIME_LIBDIR="\"$(LIB_INSTALL_DIR:\=\\)\"" \ -DCFG_RUNTIME_BINDIR="\"$(BIN_INSTALL_DIR:\=\\)\"" \ -DCFG_RUNTIME_SCRDIR="\"$(SCRIPT_INSTALL_DIR:\=\\)\"" \ -DCFG_RUNTIME_INCDIR="\"$(INCLUDE_INSTALL_DIR:\=\\)\"" \ -DCFG_RUNTIME_DOCDIR="\"$(DOC_INSTALL_DIR:\=\\)\"" \ -DCFG_RUNTIME_DLLFILE="\"$(CFG_RUNTIME_DLLFILE:\=\\)\"" \ -DCFG_RUNTIME_ZIPFILE="\"$(CFG_RUNTIME_ZIPFILE:\=\\)\"" \ -Fo$@ $? $(TMP_DIR)\tclAppInit.obj: $(WINDIR)\tclAppInit.c $(cc32) $(appcflags) \ -DTCL_USE_STATIC_PACKAGES=$(TCL_USE_STATIC_PACKAGES) \ -Fo$@ $? ### The following objects should be built using the stub interfaces $(TMP_DIR)\tclWinReg.obj: $(WINDIR)\tclWinReg.c !if $(STATIC_BUILD) $(cc32) $(appcflags) -DSTATIC_BUILD -Fo$@ $? !else $(cc32) $(appcflags) -DUSE_TCL_STUBS -Fo$@ $? !endif |
| ︙ | ︙ | |||
736 737 738 739 740 741 742 743 744 745 746 747 748 749 | $(cc32) $(stubscflags) -Fo$@ $? $(TMP_DIR)\tclTomMathStubLib.obj: $(GENERICDIR)\tclTomMathStubLib.c $(cc32) $(stubscflags) -Fo$@ $? $(TMP_DIR)\tclOOStubLib.obj: $(GENERICDIR)\tclOOStubLib.c $(cc32) $(stubscflags) -Fo$@ $? $(TMP_DIR)\tclsh.exe.manifest: $(WINDIR)\tclsh.exe.manifest.in @nmakehlp -s << $** >$@ @MACHINE@ $(MACHINE:IX86=X86) @TCL_WIN_VERSION@ $(DOTVERSION).0.0 << | > > > | 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 | $(cc32) $(stubscflags) -Fo$@ $? $(TMP_DIR)\tclTomMathStubLib.obj: $(GENERICDIR)\tclTomMathStubLib.c $(cc32) $(stubscflags) -Fo$@ $? $(TMP_DIR)\tclOOStubLib.obj: $(GENERICDIR)\tclOOStubLib.c $(cc32) $(stubscflags) -Fo$@ $? $(TMP_DIR)\tclWinPanic.obj: $(WINDIR)\tclWinPanic.c $(cc32) $(stubscflags) -Fo$@ $? $(TMP_DIR)\tclsh.exe.manifest: $(WINDIR)\tclsh.exe.manifest.in @nmakehlp -s << $** >$@ @MACHINE@ $(MACHINE:IX86=X86) @TCL_WIN_VERSION@ $(DOTVERSION).0.0 << |
| ︙ | ︙ | |||
906 907 908 909 910 911 912 913 914 915 916 917 918 919 | install-msgs: @echo Installing message catalogs @set TCL_LIBRARY=$(ROOT:\=/)/library @$(TCLSH_NATIVE) "$(ROOT:\=/)/tools/installData.tcl" \ "$(ROOT:\=/)/library/msgs" "$(SCRIPT_INSTALL_DIR)/msgs" #--------------------------------------------------------------------- # Clean up #--------------------------------------------------------------------- tidy: !if "$(TCLLIB)" != "$(TCLIMPLIB)" @echo Removing $(TCLLIB) ... | > > > > > | 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 | install-msgs: @echo Installing message catalogs @set TCL_LIBRARY=$(ROOT:\=/)/library @$(TCLSH_NATIVE) "$(ROOT:\=/)/tools/installData.tcl" \ "$(ROOT:\=/)/library/msgs" "$(SCRIPT_INSTALL_DIR)/msgs" install-pdbs: @echo Installing debug symbols @$(CPY) "$(OUT_DIR)\*.pdb" "$(BIN_INSTALL_DIR)\" # "emacs font-lock highlighting fix #--------------------------------------------------------------------- # Clean up #--------------------------------------------------------------------- tidy: !if "$(TCLLIB)" != "$(TCLIMPLIB)" @echo Removing $(TCLLIB) ... |
| ︙ | ︙ |
Changes to win/nmakehlp.c.
| ︙ | ︙ | |||
682 683 684 685 686 687 688 |
fclose(fp);
return 0;
}
BOOL FileExists(LPCTSTR szPath)
{
#ifndef INVALID_FILE_ATTRIBUTES
| | | | 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 |
fclose(fp);
return 0;
}
BOOL FileExists(LPCTSTR szPath)
{
#ifndef INVALID_FILE_ATTRIBUTES
#define INVALID_FILE_ATTRIBUTES ((DWORD)-1)
#endif
DWORD pathAttr = GetFileAttributes(szPath);
return (pathAttr != INVALID_FILE_ATTRIBUTES &&
!(pathAttr & FILE_ATTRIBUTE_DIRECTORY));
}
/*
* QualifyPath --
*
|
| ︙ | ︙ | |||
736 737 738 739 740 741 742 |
strncpy(path, dir, dirlen);
strncpy(path+dirlen, "\\*", 3); /* Including terminating \0 */
keylen = strlen(keypath);
#if 0 /* This function is not available in Visual C++ 6 */
/*
* Use numerics 0 -> FindExInfoStandard,
| | | | 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 |
strncpy(path, dir, dirlen);
strncpy(path+dirlen, "\\*", 3); /* Including terminating \0 */
keylen = strlen(keypath);
#if 0 /* This function is not available in Visual C++ 6 */
/*
* Use numerics 0 -> FindExInfoStandard,
* 1 -> FindExSearchLimitToDirectories,
* as these are not defined in Visual C++ 6
*/
hSearch = FindFirstFileEx(path, 0, &finfo, 1, NULL, 0);
#else
hSearch = FindFirstFile(path, &finfo);
#endif
if (hSearch == INVALID_HANDLE_VALUE)
return 1; /* Not found */
/* Loop through all subdirs checking if the keypath is under there */
ret = 1; /* Assume not found */
do {
int sublen;
/*
* We need to check it is a directory despite the
* FindExSearchLimitToDirectories in the above call. See SDK docs
*/
if ((finfo.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY) == 0)
continue;
sublen = strlen(finfo.cFileName);
if ((dirlen+1+sublen+1+keylen+1) > sizeof(path))
continue; /* Path does not fit, assume not matched */
|
| ︙ | ︙ | |||
782 783 784 785 786 787 788 | * LocateDependency -- * * Locates a dependency for a package. * keypath - a relative path within the package directory * that is used to confirm it is the correct directory. * The search path for the package directory is currently only * the parent and grandparent of the current working directory. | | | | | 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 |
* LocateDependency --
*
* Locates a dependency for a package.
* keypath - a relative path within the package directory
* that is used to confirm it is the correct directory.
* The search path for the package directory is currently only
* the parent and grandparent of the current working directory.
* If found, the command prints
* name_DIRPATH=<full path of located directory>
* and returns 0. If not found, does not print anything and returns 1.
*/
static int LocateDependency(const char *keypath)
{
int i, ret;
static const char *paths[] = {"..", "..\\..", "..\\..\\.."};
for (i = 0; i < (sizeof(paths)/sizeof(paths[0])); ++i) {
ret = LocateDependencyHelper(paths[i], keypath);
if (ret == 0)
return ret;
}
return ret;
}
|
| ︙ | ︙ |
Changes to win/rules.vc.
| ︙ | ︙ | |||
20 21 22 23 24 25 26 | !ifndef _RULES_VC _RULES_VC = 1 # The following macros define the version of the rules.vc nmake build system # For modifications that are not backward-compatible, you *must* change # the major version. RULES_VERSION_MAJOR = 1 | | | 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 | !ifndef _RULES_VC _RULES_VC = 1 # The following macros define the version of the rules.vc nmake build system # For modifications that are not backward-compatible, you *must* change # the major version. RULES_VERSION_MAJOR = 1 RULES_VERSION_MINOR = 3 # The PROJECT macro must be defined by parent makefile. !if "$(PROJECT)" == "" !error *** Error: Macro PROJECT not defined! Please define it before including rules.vc !endif !if "$(PRJ_PACKAGE_TCLNAME)" == "" |
| ︙ | ︙ | |||
470 471 472 473 474 475 476 477 478 479 480 481 482 483 | !endif !if "$(MACHINE)" != "$(ARCH)" !error Specified MACHINE macro $(MACHINE) does not match detected target architecture $(ARCH). !endif !else MACHINE=$(ARCH) !endif #------------------------------------------------------------ # Figure out the *host* architecture by reading the registry !if ![reg query HKLM\Hardware\Description\System\CentralProcessor\0 /v Identifier | findstr /i x86] NATIVE_ARCH=IX86 !else | > > > > > > > > > > > > > > > | 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 | !endif !if "$(MACHINE)" != "$(ARCH)" !error Specified MACHINE macro $(MACHINE) does not match detected target architecture $(ARCH). !endif !else MACHINE=$(ARCH) !endif #--------------------------------------------------------------- # The PLATFORM_IDENTIFY macro matches the values returned by # the Tcl platform::identify command !if "$(MACHINE)" == "AMD64" PLATFORM_IDENTIFY = win32-x86_64 !else PLATFORM_IDENTIFY = win32-ix86 !endif # The MULTIPLATFORM macro controls whether binary extensions are installed # in platform-specific directories. Intended to be set/used by extensions. !ifndef MULTIPLATFORM_INSTALL MULTIPLATFORM_INSTALL = 0 !endif #------------------------------------------------------------ # Figure out the *host* architecture by reading the registry !if ![reg query HKLM\Hardware\Description\System\CentralProcessor\0 /v Identifier | findstr /i x86] NATIVE_ARCH=IX86 !else |
| ︙ | ︙ | |||
726 727 728 729 730 731 732 | !if [nmakehlp -f $(OPTS) "staticpkg"] && $(STATIC_BUILD) !message *** Doing staticpkg TCL_USE_STATIC_PACKAGES = 1 !else TCL_USE_STATIC_PACKAGES = 0 !endif | | < < < < < < < | | 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 | !if [nmakehlp -f $(OPTS) "staticpkg"] && $(STATIC_BUILD) !message *** Doing staticpkg TCL_USE_STATIC_PACKAGES = 1 !else TCL_USE_STATIC_PACKAGES = 0 !endif # Yes, it's weird that the "symbols" option controls DEBUG and # the "pdbs" option controls SYMBOLS. That's historical. !if [nmakehlp -f $(OPTS) "symbols"] !message *** Doing symbols DEBUG = 1 !else DEBUG = 0 !endif |
| ︙ | ︙ | |||
770 771 772 773 774 775 776 | PGO = 0 !endif !if [nmakehlp -f $(OPTS) "loimpact"] !message *** Warning: ignoring option "loimpact" - deprecated on modern Windows. !endif | < < < < < < | 778 779 780 781 782 783 784 785 786 787 788 789 790 791 | PGO = 0 !endif !if [nmakehlp -f $(OPTS) "loimpact"] !message *** Warning: ignoring option "loimpact" - deprecated on modern Windows. !endif !if [nmakehlp -f $(OPTS) "tclalloc"] USE_THREAD_ALLOC = 0 !endif !if [nmakehlp -f $(OPTS) "unchecked"] !message *** Doing unchecked UNCHECKED = 1 |
| ︙ | ︙ | |||
966 967 968 969 970 971 972 | ################################################################ # 10. Construct output directory and file paths # Figure-out how to name our intermediate and output directories. # In order to avoid inadvertent mixing of object files built using # different compilers, build configurations etc., # # Naming convention (suffixes): | | | 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 | ################################################################ # 10. Construct output directory and file paths # Figure-out how to name our intermediate and output directories. # In order to avoid inadvertent mixing of object files built using # different compilers, build configurations etc., # # Naming convention (suffixes): # t = full thread support. (Not used for Tcl >= 8.7) # s = static library (as opposed to an import library) # g = linked to the debug enabled C run-time. # x = special static build when it links to the dynamic C run-time. # # The following macros are set in this section: # SUFX - the suffix to use for binaries based on above naming convention # BUILDDIRTOP - the toplevel default output directory |
| ︙ | ︙ | |||
1024 1025 1026 1027 1028 1029 1030 | EXT = lib !if !$(MSVCRT) TMP_DIRFULL = $(TMP_DIRFULL:X=) SUFX = $(SUFX:x=) !endif !endif | | | 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 | EXT = lib !if !$(MSVCRT) TMP_DIRFULL = $(TMP_DIRFULL:X=) SUFX = $(SUFX:x=) !endif !endif !if !$(TCL_THREADS) || $(TCL_VERSION) > 86 TMP_DIRFULL = $(TMP_DIRFULL:Threaded=) SUFX = $(SUFX:t=) !endif !ifndef TMP_DIR TMP_DIR = $(TMP_DIRFULL) !ifndef OUT_DIR |
| ︙ | ︙ | |||
1074 1075 1076 1077 1078 1079 1080 | !else # ! $(DOING_TCL) !if $(TCLINSTALL) # Building against an installed Tcl # When building extensions, we need to locate tclsh. Depending on version # of Tcl we are building against, this may or may not have a "t" suffix. # Try various possibilities in turn. | | < < < | | | | < < < | | | | 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 |
!else # ! $(DOING_TCL)
!if $(TCLINSTALL) # Building against an installed Tcl
# When building extensions, we need to locate tclsh. Depending on version
# of Tcl we are building against, this may or may not have a "t" suffix.
# Try various possibilities in turn.
TCLSH = $(_TCLDIR)\bin\tclsh$(TCL_VERSION)$(SUFX:t=).exe
!if !exist("$(TCLSH)")
TCLSH = $(_TCLDIR)\bin\tclsh$(TCL_VERSION)t$(SUFX:t=).exe
!endif
TCLSTUBLIB = $(_TCLDIR)\lib\tclstub$(TCL_VERSION).lib
TCLIMPLIB = $(_TCLDIR)\lib\tcl$(TCL_VERSION)$(SUFX:t=).lib
# When building extensions, may be linking against Tcl that does not add
# "t" suffix (e.g. 8.5 or 8.7). If lib not found check for that possibility.
!if !exist("$(TCLIMPLIB)")
TCLIMPLIB = $(_TCLDIR)\lib\tcl$(TCL_VERSION)t$(SUFX:t=).lib
!endif
TCL_LIBRARY = $(_TCLDIR)\lib
TCLREGLIB = $(_TCLDIR)\lib\tclreg13$(SUFX:t=).lib
TCLDDELIB = $(_TCLDIR)\lib\tcldde14$(SUFX:t=).lib
TCLTOOLSDIR = \must\have\tcl\sources\to\build\this\target
TCL_INCLUDES = -I"$(_TCLDIR)\include"
!else # Building against Tcl sources
TCLSH = $(_TCLDIR)\win\$(BUILDDIRTOP)\tclsh$(TCL_VERSION)$(SUFX:t=).exe
!if !exist($(TCLSH))
TCLSH = $(_TCLDIR)\win\$(BUILDDIRTOP)\tclsh$(TCL_VERSION)t$(SUFX:t=).exe
!endif
TCLSTUBLIB = $(_TCLDIR)\win\$(BUILDDIRTOP)\tclstub$(TCL_VERSION).lib
TCLIMPLIB = $(_TCLDIR)\win\$(BUILDDIRTOP)\tcl$(TCL_VERSION)$(SUFX:t=).lib
# When building extensions, may be linking against Tcl that does not add
# "t" suffix (e.g. 8.5 or 8.7). If lib not found check for that possibility.
!if !exist("$(TCLIMPLIB)")
TCLIMPLIB = $(_TCLDIR)\win\$(BUILDDIRTOP)\tcl$(TCL_VERSION)t$(SUFX:t=).lib
!endif
TCL_LIBRARY = $(_TCLDIR)\library
TCLREGLIB = $(_TCLDIR)\win\$(BUILDDIRTOP)\tclreg13$(SUFX:t=).lib
TCLDDELIB = $(_TCLDIR)\win\$(BUILDDIRTOP)\tcldde14$(SUFX:t=).lib
TCLTOOLSDIR = $(_TCLDIR)\tools
TCL_INCLUDES = -I"$(_TCLDIR)\generic" -I"$(_TCLDIR)\win"
|
| ︙ | ︙ | |||
1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 | !endif DEMO_INSTALL_DIR = $(SCRIPT_INSTALL_DIR)\demos INCLUDE_INSTALL_DIR = $(_INSTALLDIR)\include !else # extension other than Tk PRJ_INSTALL_DIR = $(_INSTALLDIR)\$(PROJECT)$(DOTVERSION) LIB_INSTALL_DIR = $(PRJ_INSTALL_DIR) BIN_INSTALL_DIR = $(PRJ_INSTALL_DIR) DOC_INSTALL_DIR = $(PRJ_INSTALL_DIR) SCRIPT_INSTALL_DIR = $(PRJ_INSTALL_DIR) DEMO_INSTALL_DIR = $(PRJ_INSTALL_DIR)\demos INCLUDE_INSTALL_DIR = $(_INSTALLDIR)\..\include !endif | > > > > > | 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 | !endif DEMO_INSTALL_DIR = $(SCRIPT_INSTALL_DIR)\demos INCLUDE_INSTALL_DIR = $(_INSTALLDIR)\include !else # extension other than Tk PRJ_INSTALL_DIR = $(_INSTALLDIR)\$(PROJECT)$(DOTVERSION) !if $(MULTIPLATFORM_INSTALL) LIB_INSTALL_DIR = $(PRJ_INSTALL_DIR)\$(PLATFORM_IDENTIFY) BIN_INSTALL_DIR = $(PRJ_INSTALL_DIR)\$(PLATFORM_IDENTIFY) !else LIB_INSTALL_DIR = $(PRJ_INSTALL_DIR) BIN_INSTALL_DIR = $(PRJ_INSTALL_DIR) !endif DOC_INSTALL_DIR = $(PRJ_INSTALL_DIR) SCRIPT_INSTALL_DIR = $(PRJ_INSTALL_DIR) DEMO_INSTALL_DIR = $(PRJ_INSTALL_DIR)\demos INCLUDE_INSTALL_DIR = $(_INSTALLDIR)\..\include !endif |
| ︙ | ︙ | |||
1260 1261 1262 1263 1264 1265 1266 | !if $(TCL_MEM_DEBUG) OPTDEFINES = $(OPTDEFINES) -DTCL_MEM_DEBUG !endif !if $(TCL_COMPILE_DEBUG) OPTDEFINES = $(OPTDEFINES) -DTCL_COMPILE_DEBUG -DTCL_COMPILE_STATS !endif | | | 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 | !if $(TCL_MEM_DEBUG) OPTDEFINES = $(OPTDEFINES) -DTCL_MEM_DEBUG !endif !if $(TCL_COMPILE_DEBUG) OPTDEFINES = $(OPTDEFINES) -DTCL_COMPILE_DEBUG -DTCL_COMPILE_STATS !endif !if $(TCL_THREADS) && $(TCL_VERSION) < 86 OPTDEFINES = $(OPTDEFINES) -DTCL_THREADS=1 !if $(USE_THREAD_ALLOC) OPTDEFINES = $(OPTDEFINES) -DUSE_THREAD_ALLOC=1 !endif !endif !if $(STATIC_BUILD) OPTDEFINES = $(OPTDEFINES) -DSTATIC_BUILD |
| ︙ | ︙ | |||
1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 | !ifndef DEFAULT_BUILD_TARGET DEFAULT_BUILD_TARGET = $(PROJECT) !endif default-target: $(DEFAULT_BUILD_TARGET) default-pkgindex: @echo package ifneeded $(PRJ_PACKAGE_TCLNAME) $(DOTVERSION) \ [list load [file join $$dir $(PRJLIBNAME)]] > $(OUT_DIR)\pkgIndex.tcl default-pkgindex-tea: @if exist $(ROOT)\pkgIndex.tcl.in nmakehlp -s << $(ROOT)\pkgIndex.tcl.in > $(OUT_DIR)\pkgIndex.tcl @PACKAGE_VERSION@ $(DOTVERSION) @PACKAGE_NAME@ $(PRJ_PACKAGE_TCLNAME) @PACKAGE_TCLNAME@ $(PRJ_PACKAGE_TCLNAME) @PKG_LIB_FILE@ $(PRJLIBNAME) << | > > > > > > | > | > > > > > > > | | | > | > > > > > > > | 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 |
!ifndef DEFAULT_BUILD_TARGET
DEFAULT_BUILD_TARGET = $(PROJECT)
!endif
default-target: $(DEFAULT_BUILD_TARGET)
!if $(MULTIPLATFORM_INSTALL)
default-pkgindex:
@echo package ifneeded $(PRJ_PACKAGE_TCLNAME) $(DOTVERSION) \
[list load [file join $$dir $(PLATFORM_IDENTIFY) $(PRJLIBNAME)]] > $(OUT_DIR)\pkgIndex.tcl
!else
default-pkgindex:
@echo package ifneeded $(PRJ_PACKAGE_TCLNAME) $(DOTVERSION) \
[list load [file join $$dir $(PRJLIBNAME)]] > $(OUT_DIR)\pkgIndex.tcl
!endif
default-pkgindex-tea:
@if exist $(ROOT)\pkgIndex.tcl.in nmakehlp -s << $(ROOT)\pkgIndex.tcl.in > $(OUT_DIR)\pkgIndex.tcl
@PACKAGE_VERSION@ $(DOTVERSION)
@PACKAGE_NAME@ $(PRJ_PACKAGE_TCLNAME)
@PACKAGE_TCLNAME@ $(PRJ_PACKAGE_TCLNAME)
@PKG_LIB_FILE@ $(PRJLIBNAME)
<<
default-install: default-install-binaries default-install-libraries
!if $(SYMBOLS)
default-install: default-install-pdbs
!endif
# Again to deal with historical brokenness, there is some confusion
# in terminlogy. For extensions, the "install-binaries" was used to
# locate target directory for *binary shared libraries* and thus
# the appropriate macro is LIB_INSTALL_DIR since BIN_INSTALL_DIR is
# for executables (exes). On the other hand the "install-libraries"
# target is for *scripts* and should have been called "install-scripts".
default-install-binaries: $(PRJLIB)
@echo Installing binaries to '$(LIB_INSTALL_DIR)'
@if not exist "$(LIB_INSTALL_DIR)" mkdir "$(LIB_INSTALL_DIR)"
@$(CPY) $(PRJLIB) "$(LIB_INSTALL_DIR)" >NUL
# Alias for default-install-scripts
default-install-libraries: default-install-scripts
default-install-scripts: $(OUT_DIR)\pkgIndex.tcl
@echo Installing libraries to '$(SCRIPT_INSTALL_DIR)'
@if exist $(LIBDIR) $(CPY) $(LIBDIR)\*.tcl "$(SCRIPT_INSTALL_DIR)"
@echo Installing package index in '$(SCRIPT_INSTALL_DIR)'
@$(CPY) $(OUT_DIR)\pkgIndex.tcl $(SCRIPT_INSTALL_DIR)
default-install-stubs:
@echo Installing stubs library to '$(SCRIPT_INSTALL_DIR)'
@if not exist "$(SCRIPT_INSTALL_DIR)" mkdir "$(SCRIPT_INSTALL_DIR)"
@$(CPY) $(PRJSTUBLIB) "$(SCRIPT_INSTALL_DIR)" >NUL
default-install-pdbs:
@echo Installing PDBs to '$(LIB_INSTALL_DIR)'
@if not exist "$(LIB_INSTALL_DIR)" mkdir "$(LIB_INSTALL_DIR)"
@$(CPY) "$(OUT_DIR)\*.pdb" "$(LIB_INSTALL_DIR)\"
default-install-docs-html:
@echo Installing documentation files to '$(DOC_INSTALL_DIR)'
@if not exist "$(DOC_INSTALL_DIR)" mkdir "$(DOC_INSTALL_DIR)"
@if exist $(DOCDIR) for %f in ("$(DOCDIR)\*.html" "$(DOCDIR)\*.css" "$(DOCDIR)\*.png") do @$(COPY) %f "$(DOC_INSTALL_DIR)"
default-install-docs-n:
@echo Installing documentation files to '$(DOC_INSTALL_DIR)'
|
| ︙ | ︙ | |||
1704 1705 1706 1707 1708 1709 1710 | !if $(CONFIG_CHECK) !ifdef TCLNMAKECONFIG !include $(TCLNMAKECONFIG) !if defined(CORE_MACHINE) && "$(CORE_MACHINE)" != "$(MACHINE)" !error ERROR: Build target ($(MACHINE)) does not match the Tcl library architecture ($(CORE_MACHINE)). !endif | < < < | 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 | !if $(CONFIG_CHECK) !ifdef TCLNMAKECONFIG !include $(TCLNMAKECONFIG) !if defined(CORE_MACHINE) && "$(CORE_MACHINE)" != "$(MACHINE)" !error ERROR: Build target ($(MACHINE)) does not match the Tcl library architecture ($(CORE_MACHINE)). !endif !if defined(CORE_DEBUG) && $(CORE_DEBUG) != $(DEBUG) !message WARNING: Value of DEBUG ($(DEBUG)) does not match its Tcl library configuration ($(DEBUG)). !endif !endif !endif # TCLNMAKECONFIG |
| ︙ | ︙ |
Changes to win/tcl.dsp.
| ︙ | ︙ | |||
200 201 202 203 204 205 206 | # End Source File # Begin Source File SOURCE=..\compat\tclErrno.h # End Source File # Begin Source File | < < < < | 200 201 202 203 204 205 206 207 208 209 210 211 212 213 | # End Source File # Begin Source File SOURCE=..\compat\tclErrno.h # End Source File # Begin Source File SOURCE=..\compat\waitpid.c # End Source File # End Group # Begin Group "doc" # PROP Default_Filter "" # Begin Source File |
| ︙ | ︙ | |||
1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 | SOURCE=.\tclWinLoad.c # End Source File # Begin Source File SOURCE=.\tclWinNotify.c # End Source File # Begin Source File SOURCE=.\tclWinPipe.c # End Source File # Begin Source File SOURCE=.\tclWinPort.h # End Source File | > > > > | 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 | SOURCE=.\tclWinLoad.c # End Source File # Begin Source File SOURCE=.\tclWinNotify.c # End Source File # Begin Source File SOURCE=.\tclWinPanic.c # End Source File # Begin Source File SOURCE=.\tclWinPipe.c # End Source File # Begin Source File SOURCE=.\tclWinPort.h # End Source File |
| ︙ | ︙ |
Changes to win/tcl.m4.
| ︙ | ︙ | |||
247 248 249 250 251 252 253 254 255 256 257 258 259 260 |
#
# Results:
#
# Substitutes the following vars:
# TCL_BIN_DIR
# TCL_SRC_DIR
# TCL_LIB_FILE
#
#------------------------------------------------------------------------
AC_DEFUN([SC_LOAD_TCLCONFIG], [
AC_MSG_CHECKING([for existence of ${TCL_BIN_DIR}/tclConfig.sh])
if test -f "${TCL_BIN_DIR}/tclConfig.sh" ; then
| > | 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 |
#
# Results:
#
# Substitutes the following vars:
# TCL_BIN_DIR
# TCL_SRC_DIR
# TCL_LIB_FILE
# TCL_ZIP_FILE
#
#------------------------------------------------------------------------
AC_DEFUN([SC_LOAD_TCLCONFIG], [
AC_MSG_CHECKING([for existence of ${TCL_BIN_DIR}/tclConfig.sh])
if test -f "${TCL_BIN_DIR}/tclConfig.sh" ; then
|
| ︙ | ︙ | |||
279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 |
TCL_STUB_LIB_PATH=${TCL_BUILD_STUB_LIB_PATH}
fi
#
# eval is required to do the TCL_DBGX substitution
#
eval "TCL_LIB_FILE=\"${TCL_LIB_FILE}\""
eval "TCL_LIB_FLAG=\"${TCL_LIB_FLAG}\""
eval "TCL_LIB_SPEC=\"${TCL_LIB_SPEC}\""
eval "TCL_STUB_LIB_FILE=\"${TCL_STUB_LIB_FILE}\""
eval "TCL_STUB_LIB_FLAG=\"${TCL_STUB_LIB_FLAG}\""
eval "TCL_STUB_LIB_SPEC=\"${TCL_STUB_LIB_SPEC}\""
AC_SUBST(TCL_VERSION)
AC_SUBST(TCL_BIN_DIR)
AC_SUBST(TCL_SRC_DIR)
AC_SUBST(TCL_LIB_FILE)
AC_SUBST(TCL_LIB_FLAG)
AC_SUBST(TCL_LIB_SPEC)
AC_SUBST(TCL_STUB_LIB_FILE)
AC_SUBST(TCL_STUB_LIB_FLAG)
AC_SUBST(TCL_STUB_LIB_SPEC)
| > > | 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 |
TCL_STUB_LIB_PATH=${TCL_BUILD_STUB_LIB_PATH}
fi
#
# eval is required to do the TCL_DBGX substitution
#
eval "TCL_ZIP_FILE=\"${TCL_ZIP_FILE}\""
eval "TCL_LIB_FILE=\"${TCL_LIB_FILE}\""
eval "TCL_LIB_FLAG=\"${TCL_LIB_FLAG}\""
eval "TCL_LIB_SPEC=\"${TCL_LIB_SPEC}\""
eval "TCL_STUB_LIB_FILE=\"${TCL_STUB_LIB_FILE}\""
eval "TCL_STUB_LIB_FLAG=\"${TCL_STUB_LIB_FLAG}\""
eval "TCL_STUB_LIB_SPEC=\"${TCL_STUB_LIB_SPEC}\""
AC_SUBST(TCL_VERSION)
AC_SUBST(TCL_BIN_DIR)
AC_SUBST(TCL_SRC_DIR)
AC_SUBST(TCL_ZIP_FILE)
AC_SUBST(TCL_LIB_FILE)
AC_SUBST(TCL_LIB_FLAG)
AC_SUBST(TCL_LIB_SPEC)
AC_SUBST(TCL_STUB_LIB_FILE)
AC_SUBST(TCL_STUB_LIB_FLAG)
AC_SUBST(TCL_STUB_LIB_SPEC)
|
| ︙ | ︙ | |||
376 377 378 379 380 381 382 |
AC_MSG_RESULT([shared])
SHARED_BUILD=1
else
AC_MSG_RESULT([static])
SHARED_BUILD=0
AC_DEFINE(STATIC_BUILD, 1, [Is this a static build?])
fi
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 |
AC_MSG_RESULT([shared])
SHARED_BUILD=1
else
AC_MSG_RESULT([static])
SHARED_BUILD=0
AC_DEFINE(STATIC_BUILD, 1, [Is this a static build?])
fi
AC_SUBST(SHARED_BUILD)
])
#------------------------------------------------------------------------
# SC_ENABLE_SYMBOLS --
#
# Specify if debugging symbols should be used.
# Memory (TCL_MEM_DEBUG) and compile (TCL_COMPILE_DEBUG) debugging
|
| ︙ | ︙ | |||
545 546 547 548 549 550 551 552 553 554 555 556 557 558 |
AC_MSG_RESULT($do64bit)
# Set some defaults (may get changed below)
EXTRA_CFLAGS=""
AC_DEFINE(MODULE_SCOPE, [extern], [No need to mark inidividual symbols as hidden])
AC_CHECK_PROG(CYGPATH, cygpath, cygpath -m, echo)
SHLIB_SUFFIX=".dll"
# MACHINE is IX86 for LINK, but this is used by the manifest,
# which requires x86|amd64|ia64.
MACHINE="X86"
| > | 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 |
AC_MSG_RESULT($do64bit)
# Set some defaults (may get changed below)
EXTRA_CFLAGS=""
AC_DEFINE(MODULE_SCOPE, [extern], [No need to mark inidividual symbols as hidden])
AC_CHECK_PROG(CYGPATH, cygpath, cygpath -m, echo)
AC_CHECK_PROG(WINE, wine, wine,)
SHLIB_SUFFIX=".dll"
# MACHINE is IX86 for LINK, but this is used by the manifest,
# which requires x86|amd64|ia64.
MACHINE="X86"
|
| ︙ | ︙ | |||
712 713 714 715 716 717 718 |
LIBFLAGSUFFIX="\${DBGX}"
SHLIB_SUFFIX=.dll
EXTRA_CFLAGS="${extra_cflags}"
CFLAGS_DEBUG=-g
CFLAGS_OPTIMIZE="-O2 -fomit-frame-pointer"
| | | 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 |
LIBFLAGSUFFIX="\${DBGX}"
SHLIB_SUFFIX=.dll
EXTRA_CFLAGS="${extra_cflags}"
CFLAGS_DEBUG=-g
CFLAGS_OPTIMIZE="-O2 -fomit-frame-pointer"
CFLAGS_WARNING="-Wall -Wwrite-strings -Wsign-compare -Wdeclaration-after-statement -Wpointer-arith"
LDFLAGS_DEBUG=
LDFLAGS_OPTIMIZE=
# Specify the CC output file names based on the target name
CC_OBJNAME="-o \[$]@"
CC_EXENAME="-o \[$]@"
|
| ︙ | ︙ | |||
1191 1192 1193 1194 1195 1196 1197 |
fi
])
fi
AC_MSG_RESULT([$result])
AC_SUBST(VC_MANIFEST_EMBED_DLL)
AC_SUBST(VC_MANIFEST_EMBED_EXE)
])
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 |
fi
])
fi
AC_MSG_RESULT([$result])
AC_SUBST(VC_MANIFEST_EMBED_DLL)
AC_SUBST(VC_MANIFEST_EMBED_EXE)
])
#------------------------------------------------------------------------
# SC_CC_FOR_BUILD
# For cross compiles, locate a C compiler that can generate native binaries.
#
# Arguments:
# none
#
# Results:
# Substitutes the following vars:
# CC_FOR_BUILD
# EXEEXT_FOR_BUILD
#------------------------------------------------------------------------
dnl Get a default for CC_FOR_BUILD to put into Makefile.
AC_DEFUN([AX_CC_FOR_BUILD],
[# Put a plausible default for CC_FOR_BUILD in Makefile.
if test -z "$CC_FOR_BUILD"; then
if test "x$cross_compiling" = "xno"; then
CC_FOR_BUILD='$(CC)'
else
AC_MSG_CHECKING([for gcc])
AC_CACHE_VAL(ac_cv_path_cc, [
search_path=`echo ${PATH} | sed -e 's/:/ /g'`
for dir in $search_path ; do
for j in `ls -r $dir/gcc 2> /dev/null` \
`ls -r $dir/gcc 2> /dev/null` ; do
if test x"$ac_cv_path_cc" = x ; then
if test -f "$j" ; then
ac_cv_path_cc=$j
break
fi
fi
done
done
])
fi
fi
AC_SUBST(CC_FOR_BUILD)
# Also set EXEEXT_FOR_BUILD.
if test "x$cross_compiling" = "xno"; then
EXEEXT_FOR_BUILD='$(EXEEXT)'
OBJEXT_FOR_BUILD='$(OBJEXT)'
else
OBJEXT_FOR_BUILD='.no'
AC_CACHE_CHECK([for build system executable suffix], bfd_cv_build_exeext,
[rm -f conftest*
echo 'int main () { return 0; }' > conftest.c
bfd_cv_build_exeext=
${CC_FOR_BUILD} -o conftest conftest.c 1>&5 2>&5
for file in conftest.*; do
case $file in
*.c | *.o | *.obj | *.ilk | *.pdb) ;;
*) bfd_cv_build_exeext=`echo $file | sed -e s/conftest//` ;;
esac
done
rm -f conftest*
test x"${bfd_cv_build_exeext}" = x && bfd_cv_build_exeext=no])
EXEEXT_FOR_BUILD=""
test x"${bfd_cv_build_exeext}" != xno && EXEEXT_FOR_BUILD=${bfd_cv_build_exeext}
fi
AC_SUBST(EXEEXT_FOR_BUILD)])dnl
AC_SUBST(OBJEXT_FOR_BUILD)])dnl
#------------------------------------------------------------------------
# SC_ZIPFS_SUPPORT
# Locate a zip encoder installed on the system path, or none.
#
# Arguments:
# none
#
# Results:
# Substitutes the following vars:
# ZIP_PROG
# ZIP_PROG_OPTIONS
# ZIP_PROG_VFSSEARCH
# ZIP_INSTALL_OBJS
#------------------------------------------------------------------------
AC_DEFUN([SC_ZIPFS_SUPPORT], [
ZIP_PROG=""
ZIP_PROG_OPTIONS=""
ZIP_PROG_VFSSEARCH=""
ZIP_INSTALL_OBJS=""
AC_MSG_CHECKING([for zip])
AC_CACHE_VAL(ac_cv_path_zip, [
search_path=`echo ${PATH} | sed -e 's/:/ /g'`
for dir in $search_path ; do
for j in `ls -r $dir/zip 2> /dev/null` \
`ls -r $dir/zip 2> /dev/null` ; do
if test x"$ac_cv_path_zip" = x ; then
if test -f "$j" ; then
ac_cv_path_zip=$j
break
fi
fi
done
done
])
if test -f "$ac_cv_path_zip" ; then
ZIP_PROG="$ac_cv_path_zip"
AC_MSG_RESULT([$ZIP_PROG])
ZIP_PROG_OPTIONS="-rq"
ZIP_PROG_VFSSEARCH="*"
AC_MSG_RESULT([Found INFO Zip in environment])
# Use standard arguments for zip
else
# It is not an error if an installed version of Zip can't be located.
# We can use the locally distributed minizip instead
ZIP_PROG="./minizip${EXEEXT_FOR_BUILD}"
ZIP_PROG_OPTIONS="-o -r"
ZIP_PROG_VFSSEARCH="*"
ZIP_INSTALL_OBJS="minizip${EXEEXT_FOR_BUILD}"
AC_MSG_RESULT([No zip found on PATH building minizip])
fi
AC_SUBST(ZIP_PROG)
AC_SUBST(ZIP_PROG_OPTIONS)
AC_SUBST(ZIP_PROG_VFSSEARCH)
AC_SUBST(ZIP_INSTALL_OBJS)
])
|
Changes to win/tcl.rc.
1 2 3 4 5 6 7 8 9 | // Version Resource Script // #include <winver.h> #include "tclWinInt.h" // // build-up the name suffix that defines the type of build this is. // | < < < < < < | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 | // Version Resource Script // #include <winver.h> #include "tclWinInt.h" // // build-up the name suffix that defines the type of build this is. // #if DEBUG && !UNCHECKED #define SUFFIX_DEBUG "g" #else #define SUFFIX_DEBUG "" #endif #define SUFFIX SUFFIX_DEBUG LANGUAGE 0x9, 0x1 /* LANG_ENGLISH, SUBLANG_DEFAULT */ VS_VERSION_INFO VERSIONINFO FILEVERSION TCL_MAJOR_VERSION,TCL_MINOR_VERSION,TCL_RELEASE_LEVEL,TCL_RELEASE_SERIAL PRODUCTVERSION TCL_MAJOR_VERSION,TCL_MINOR_VERSION,TCL_RELEASE_LEVEL,TCL_RELEASE_SERIAL |
| ︙ | ︙ |
Changes to win/tclAppInit.c.
| ︙ | ︙ | |||
31 32 33 34 35 36 37 | #if defined(STATIC_BUILD) && TCL_USE_STATIC_PACKAGES extern Tcl_PackageInitProc Registry_Init; extern Tcl_PackageInitProc Dde_Init; extern Tcl_PackageInitProc Dde_SafeInit; #endif | | > > | 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 | #if defined(STATIC_BUILD) && TCL_USE_STATIC_PACKAGES extern Tcl_PackageInitProc Registry_Init; extern Tcl_PackageInitProc Dde_Init; extern Tcl_PackageInitProc Dde_SafeInit; #endif #if defined(__GNUC__) || defined(TCL_BROKEN_MAINARGS) int _CRT_glob = 0; #endif /* __GNUC__ || TCL_BROKEN_MAINARGS */ #ifdef TCL_BROKEN_MAINARGS static void setargv(int *argcPtr, TCHAR ***argvPtr); #endif /* TCL_BROKEN_MAINARGS */ /* * The following #if block allows you to change the AppInit function by using * a #define of TCL_LOCAL_APPINIT instead of rewriting this entire file. The * #if checks for that #define and uses Tcl_AppInit if it does not exist. |
| ︙ | ︙ | |||
120 121 122 123 124 125 126 127 128 129 130 131 132 133 |
if (*p == '\\') {
*p = '/';
}
}
#ifdef TCL_LOCAL_MAIN_HOOK
TCL_LOCAL_MAIN_HOOK(&argc, &argv);
#endif
Tcl_Main(argc, argv, TCL_LOCAL_APPINIT);
return 0; /* Needed only to prevent compiler warning. */
}
/*
| > > > | 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 |
if (*p == '\\') {
*p = '/';
}
}
#ifdef TCL_LOCAL_MAIN_HOOK
TCL_LOCAL_MAIN_HOOK(&argc, &argv);
#elif !defined(_WIN32) || defined(UNICODE)
/* This doesn't work on Windows without UNICODE */
TclZipfs_AppHook(&argc, &argv);
#endif
Tcl_Main(argc, argv, TCL_LOCAL_APPINIT);
return 0; /* Needed only to prevent compiler warning. */
}
/*
|
| ︙ | ︙ | |||
258 259 260 261 262 263 264 |
}
if (*p == '\0') {
break;
}
}
}
| | < | | 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 |
}
if (*p == '\0') {
break;
}
}
}
/* Make sure we don't call Tcl_Alloc through the (not yet initialized) stub table */
# undef Tcl_Alloc
argSpace = Tcl_Alloc(size * sizeof(char *)
+ (_tcslen(cmdLine) * sizeof(TCHAR)) + sizeof(TCHAR));
argv = (TCHAR **) argSpace;
argSpace += size * (sizeof(char *)/sizeof(TCHAR));
size--;
p = cmdLine;
for (argc = 0; argc < size; argc++) {
|
| ︙ | ︙ |
Changes to win/tclConfig.sh.in.
| ︙ | ︙ | |||
36 37 38 39 40 41 42 43 44 45 46 47 48 49 | TCL_LDFLAGS_OPTIMIZE='@LDFLAGS_OPTIMIZE@' # Flag, 1: we built a shared lib, 0 we didn't TCL_SHARED_BUILD=@TCL_SHARED_BUILD@ # The name of the Tcl library (may be either a .a file or a shared library): TCL_LIB_FILE='@TCL_LIB_FILE@' # Flag to indicate whether shared libraries need export files. TCL_NEEDS_EXP_FILE=@TCL_NEEDS_EXP_FILE@ # String that can be evaluated to generate the part of the export file # name that comes after the "libxxx" (includes version number, if any, # extension, and anything else needed). May depend on the variables | > > > | 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 | TCL_LDFLAGS_OPTIMIZE='@LDFLAGS_OPTIMIZE@' # Flag, 1: we built a shared lib, 0 we didn't TCL_SHARED_BUILD=@TCL_SHARED_BUILD@ # The name of the Tcl library (may be either a .a file or a shared library): TCL_LIB_FILE='@TCL_LIB_FILE@' # The name of a zip containing the /library and /encodings (may be either a .zip file or a shared library): TCL_ZIP_FILE='@TCL_ZIP_FILE@' # Flag to indicate whether shared libraries need export files. TCL_NEEDS_EXP_FILE=@TCL_NEEDS_EXP_FILE@ # String that can be evaluated to generate the part of the export file # name that comes after the "libxxx" (includes version number, if any, # extension, and anything else needed). May depend on the variables |
| ︙ | ︙ | |||
171 172 173 174 175 176 177 | TCL_STUB_LIB_SPEC='@TCL_STUB_LIB_SPEC@' # Path to the Tcl stub library in the build directory. TCL_BUILD_STUB_LIB_PATH='@TCL_BUILD_STUB_LIB_PATH@' # Path to the Tcl stub library in the install directory. TCL_STUB_LIB_PATH='@TCL_STUB_LIB_PATH@' | < < < < | 174 175 176 177 178 179 180 | TCL_STUB_LIB_SPEC='@TCL_STUB_LIB_SPEC@' # Path to the Tcl stub library in the build directory. TCL_BUILD_STUB_LIB_PATH='@TCL_BUILD_STUB_LIB_PATH@' # Path to the Tcl stub library in the install directory. TCL_STUB_LIB_PATH='@TCL_STUB_LIB_PATH@' |
Changes to win/tclWin32Dll.c.
| ︙ | ︙ | |||
42 43 44 45 46 47 48 |
/*
* The following structure and linked list is to allow us to map between
* volume mount points and drive letters on the fly (no Win API exists for
* this).
*/
typedef struct MountPointMap {
| | | | 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 |
/*
* The following structure and linked list is to allow us to map between
* volume mount points and drive letters on the fly (no Win API exists for
* this).
*/
typedef struct MountPointMap {
WCHAR *volumeName; /* Native wide string volume name. */
WCHAR driveLetter; /* Drive letter corresponding to the volume
* name. */
struct MountPointMap *nextPtr;
/* Pointer to next structure in list, or
* NULL. */
} MountPointMap;
/*
|
| ︙ | ︙ | |||
251 252 253 254 255 256 257 |
* Clean up the mount point map.
*/
Tcl_MutexLock(&mountPointMap);
dlIter = driveLetterLookup;
while (dlIter != NULL) {
dlIter2 = dlIter->nextPtr;
| | | | 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 |
* Clean up the mount point map.
*/
Tcl_MutexLock(&mountPointMap);
dlIter = driveLetterLookup;
while (dlIter != NULL) {
dlIter2 = dlIter->nextPtr;
Tcl_Free(dlIter->volumeName);
Tcl_Free(dlIter);
dlIter = dlIter2;
}
Tcl_MutexUnlock(&mountPointMap);
}
/*
*--------------------------------------------------------------------
|
| ︙ | ︙ | |||
282 283 284 285 286 287 288 | * mount point. * *-------------------------------------------------------------------- */ char TclWinDriveLetterForVolMountPoint( | | | | | | | | 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 |
* mount point.
*
*--------------------------------------------------------------------
*/
char
TclWinDriveLetterForVolMountPoint(
const WCHAR *mountPoint)
{
MountPointMap *dlIter, *dlPtr2;
WCHAR Target[55]; /* Target of mount at mount point */
WCHAR drive[4] = TEXT("A:\\");
/*
* Detect the volume mounted there. Unfortunately, there is no simple way
* to map a unique volume name to a DOS drive letter. So, we have to build
* an associative array.
*/
Tcl_MutexLock(&mountPointMap);
dlIter = driveLetterLookup;
while (dlIter != NULL) {
if (wcscmp(dlIter->volumeName, mountPoint) == 0) {
/*
* We need to check whether this information is still valid, since
* either the user or various programs could have adjusted the
* mount points on the fly.
*/
drive[0] = (WCHAR) dlIter->driveLetter;
/*
* Try to read the volume mount point and see where it points.
*/
if (GetVolumeNameForVolumeMountPoint(drive,
Target, 55) != 0) {
if (wcscmp(dlIter->volumeName, Target) == 0) {
/*
* Nothing has changed.
*/
Tcl_MutexUnlock(&mountPointMap);
return (char) dlIter->driveLetter;
}
|
| ︙ | ︙ | |||
345 346 347 348 349 350 351 | } } /* * Now dlPtr2 points to the structure to free. */ | | | | 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 | } } /* * Now dlPtr2 points to the structure to free. */ Tcl_Free(dlPtr2->volumeName); Tcl_Free(dlPtr2); /* * Restart the loop - we could try to be clever and continue half * way through, but the logic is a bit messy, so it's cleanest * just to restart. */ |
| ︙ | ︙ | |||
375 376 377 378 379 380 381 |
if (GetVolumeNameForVolumeMountPoint(drive,
Target, 55) != 0) {
int alreadyStored = 0;
for (dlIter = driveLetterLookup; dlIter != NULL;
dlIter = dlIter->nextPtr) {
| | | | | | 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 |
if (GetVolumeNameForVolumeMountPoint(drive,
Target, 55) != 0) {
int alreadyStored = 0;
for (dlIter = driveLetterLookup; dlIter != NULL;
dlIter = dlIter->nextPtr) {
if (wcscmp(dlIter->volumeName, Target) == 0) {
alreadyStored = 1;
break;
}
}
if (!alreadyStored) {
dlPtr2 = Tcl_Alloc(sizeof(MountPointMap));
dlPtr2->volumeName = TclNativeDupInternalRep(Target);
dlPtr2->driveLetter = (char) drive[0];
dlPtr2->nextPtr = driveLetterLookup;
driveLetterLookup = dlPtr2;
}
}
}
/*
* Try again.
*/
for (dlIter = driveLetterLookup; dlIter != NULL;
dlIter = dlIter->nextPtr) {
if (wcscmp(dlIter->volumeName, mountPoint) == 0) {
Tcl_MutexUnlock(&mountPointMap);
return (char) dlIter->driveLetter;
}
}
/*
* The volume doesn't appear to correspond to a drive letter - we remember
* that fact and store '-1' so we don't have to look it up each time.
*/
dlPtr2 = Tcl_Alloc(sizeof(MountPointMap));
dlPtr2->volumeName = TclNativeDupInternalRep((ClientData) mountPoint);
dlPtr2->driveLetter = -1;
dlPtr2->nextPtr = driveLetterLookup;
driveLetterLookup = dlPtr2;
Tcl_MutexUnlock(&mountPointMap);
return -1;
}
|
| ︙ | ︙ | |||
443 444 445 446 447 448 449 |
* This saves you the trouble of writing the
* following type of fragment over and over:
*
* encoding <- Tcl_GetEncoding("unicode");
* nativeBuffer <- UtfToExternal(encoding, utfBuffer);
* Tcl_FreeEncoding(encoding);
*
| | | | | < < < | < < < < < | > > | | | | | > | | > > < < < < < < < < | | 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 |
* This saves you the trouble of writing the
* following type of fragment over and over:
*
* encoding <- Tcl_GetEncoding("unicode");
* nativeBuffer <- UtfToExternal(encoding, utfBuffer);
* Tcl_FreeEncoding(encoding);
*
* By convention, in Windows a WCHAR is a Unicode character. If you plan
* on targeting a Unicode interface when running on Windows, these
* functions should be used. If you plan on targetting a "char" oriented
* function on Windows, use Tcl_UtfToExternal() with an encoding of NULL.
*
* Results:
* The result is a pointer to the string in the desired target encoding.
* Storage for the result string is allocated in dsPtr; the caller must
* call Tcl_DStringFree() when the result is no longer needed.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
WCHAR *
Tcl_WinUtfToTChar(
const char *string, /* Source string in UTF-8. */
size_t len, /* Source string length in bytes, or -1
* for strlen(). */
Tcl_DString *dsPtr) /* Uninitialized or free DString in which the
* converted string is stored. */
{
Tcl_DStringInit(dsPtr);
if (!string) {
return NULL;
}
return TclUtfToWCharDString(string, len, dsPtr);
}
char *
Tcl_WinTCharToUtf(
const WCHAR *string, /* Source string in Unicode. */
size_t len, /* Source string length in bytes, or -1
* for platform-specific string length. */
Tcl_DString *dsPtr) /* Uninitialized or free DString in which the
* converted string is stored. */
{
Tcl_DStringInit(dsPtr);
if (!string) {
return NULL;
}
if (len == TCL_AUTO_LENGTH) {
len = wcslen((WCHAR *)string);
} else {
len /= 2;
}
return TclWCharToUtfDString((unsigned short *)string, len, dsPtr);
}
/*
*------------------------------------------------------------------------
*
* TclWinCPUID --
*
|
| ︙ | ︙ | |||
532 533 534 535 536 537 538 |
int index, /* Which CPUID value to retrieve. */
int *regsPtr) /* Registers after the CPUID. */
{
int status = TCL_ERROR;
#if defined(HAVE_INTRIN_H) && defined(_WIN64)
| | | 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 |
int index, /* Which CPUID value to retrieve. */
int *regsPtr) /* Registers after the CPUID. */
{
int status = TCL_ERROR;
#if defined(HAVE_INTRIN_H) && defined(_WIN64)
__cpuid((int *)regsPtr, index);
status = TCL_OK;
#elif defined(__GNUC__)
# if defined(_WIN64)
/*
* Execute the CPUID instruction with the given index, and store results
* off 'regPtr'.
|
| ︙ | ︙ |
Changes to win/tclWinChan.c.
| ︙ | ︙ | |||
92 93 94 95 96 97 98 | static void FileSetupProc(ClientData clientData, int flags); static void FileWatchProc(ClientData instanceData, int mask); static void FileThreadActionProc(ClientData instanceData, int action); static int FileTruncateProc(ClientData instanceData, Tcl_WideInt length); static DWORD FileGetType(HANDLE handle); | | | 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 |
static void FileSetupProc(ClientData clientData, int flags);
static void FileWatchProc(ClientData instanceData, int mask);
static void FileThreadActionProc(ClientData instanceData,
int action);
static int FileTruncateProc(ClientData instanceData,
Tcl_WideInt length);
static DWORD FileGetType(HANDLE handle);
static int NativeIsComPort(const WCHAR *nativeName);
/*
* This structure describes the channel type structure for file based IO.
*/
static const Tcl_ChannelType fileChannelType = {
"file", /* Type name. */
|
| ︙ | ︙ | |||
263 264 265 266 267 268 269 |
* (caused by persistent states that won't generate WinSock events).
*/
for (infoPtr = tsdPtr->firstFilePtr; infoPtr != NULL;
infoPtr = infoPtr->nextPtr) {
if (infoPtr->watchMask && !TEST_FLAG(infoPtr->flags, FILE_PENDING)) {
SET_FLAG(infoPtr->flags, FILE_PENDING);
| | | 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 |
* (caused by persistent states that won't generate WinSock events).
*/
for (infoPtr = tsdPtr->firstFilePtr; infoPtr != NULL;
infoPtr = infoPtr->nextPtr) {
if (infoPtr->watchMask && !TEST_FLAG(infoPtr->flags, FILE_PENDING)) {
SET_FLAG(infoPtr->flags, FILE_PENDING);
evPtr = Tcl_Alloc(sizeof(FileEvent));
evPtr->header.proc = FileEventProc;
evPtr->infoPtr = infoPtr;
Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL);
}
}
}
|
| ︙ | ︙ | |||
430 431 432 433 434 435 436 |
* pointer on the thread local list.
*/
FileThreadActionProc(fileInfoPtr,TCL_CHANNEL_THREAD_REMOVE);
break;
}
}
| | | 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 |
* pointer on the thread local list.
*/
FileThreadActionProc(fileInfoPtr,TCL_CHANNEL_THREAD_REMOVE);
break;
}
}
Tcl_Free(fileInfoPtr);
return errorCode;
}
/*
*----------------------------------------------------------------------
*
* FileSeekProc --
|
| ︙ | ︙ | |||
550 551 552 553 554 555 556 |
moveMethod = FILE_BEGIN;
} else if (mode == SEEK_CUR) {
moveMethod = FILE_CURRENT;
} else {
moveMethod = FILE_END;
}
| | | | | 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 |
moveMethod = FILE_BEGIN;
} else if (mode == SEEK_CUR) {
moveMethod = FILE_CURRENT;
} else {
moveMethod = FILE_END;
}
newPosHigh = (LONG)(offset >> 32);
newPos = SetFilePointer(infoPtr->handle, (LONG)offset,
&newPosHigh, moveMethod);
if (newPos == (LONG) INVALID_SET_FILE_POINTER) {
DWORD winError = GetLastError();
if (winError != NO_ERROR) {
TclWinConvertError(winError);
*errorCodePtr = errno;
return -1;
}
}
return (((Tcl_WideInt)((unsigned)newPos))
| ((Tcl_WideInt)newPosHigh << 32));
}
/*
*----------------------------------------------------------------------
*
* FileTruncateProc --
*
|
| ︙ | ︙ | |||
609 610 611 612 613 614 615 |
}
}
/*
* Move to where we want to truncate
*/
| | | | 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 |
}
}
/*
* Move to where we want to truncate
*/
newPosHigh = (LONG)(length >> 32);
newPos = SetFilePointer(infoPtr->handle, (LONG)length,
&newPosHigh, FILE_BEGIN);
if (newPos == (LONG) INVALID_SET_FILE_POINTER) {
DWORD winError = GetLastError();
if (winError != NO_ERROR) {
TclWinConvertError(winError);
return errno;
|
| ︙ | ︙ | |||
845 846 847 848 849 850 851 |
int mode, /* POSIX mode. */
int permissions) /* If the open involves creating a file, with
* what modes to create it? */
{
Tcl_Channel channel = 0;
int channelPermissions = 0;
DWORD accessMode = 0, createMode, shareMode, flags;
| | | 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 |
int mode, /* POSIX mode. */
int permissions) /* If the open involves creating a file, with
* what modes to create it? */
{
Tcl_Channel channel = 0;
int channelPermissions = 0;
DWORD accessMode = 0, createMode, shareMode, flags;
const WCHAR *nativeName;
HANDLE handle;
char channelName[16 + TCL_INTEGER_SPACE];
TclFile readFile = NULL, writeFile = NULL;
nativeName = Tcl_FSGetNativePath(pathPtr);
if (nativeName == NULL) {
if (interp) {
|
| ︙ | ︙ | |||
1361 1362 1363 1364 1365 1366 1367 |
for (infoPtr = tsdPtr->firstFilePtr; infoPtr != NULL;
infoPtr = infoPtr->nextPtr) {
if (infoPtr->handle == (HANDLE) handle) {
return (permissions==infoPtr->validMask) ? infoPtr->channel : NULL;
}
}
| | | 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 |
for (infoPtr = tsdPtr->firstFilePtr; infoPtr != NULL;
infoPtr = infoPtr->nextPtr) {
if (infoPtr->handle == (HANDLE) handle) {
return (permissions==infoPtr->validMask) ? infoPtr->channel : NULL;
}
}
infoPtr = Tcl_Alloc(sizeof(FileInfo));
/*
* TIP #218. Removed the code inserting the new structure into the global
* list. This is now handled in the thread action callbacks, and only
* there.
*/
|
| ︙ | ︙ | |||
1553 1554 1555 1556 1557 1558 1559 | * 1 = serial port, 0 = not. * *---------------------------------------------------------------------- */ static int NativeIsComPort( | | | 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 |
* 1 = serial port, 0 = not.
*
*----------------------------------------------------------------------
*/
static int
NativeIsComPort(
const WCHAR *nativePath) /* Path of file to access, native encoding. */
{
const WCHAR *p = (const WCHAR *) nativePath;
int i, len = wcslen(p);
/*
* 1. Look for com[1-9]:?
*/
|
| ︙ | ︙ |
Changes to win/tclWinConsole.c.
| ︙ | ︙ | |||
27 28 29 30 31 32 33 | TCL_DECLARE_MUTEX(consoleMutex) /* * Bit masks used in the flags field of the ConsoleInfo structure below. */ | | | > > | 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 | TCL_DECLARE_MUTEX(consoleMutex) /* * Bit masks used in the flags field of the ConsoleInfo structure below. */ #define CONSOLE_PENDING (1<<0) /* Message is pending in the queue. */ #define CONSOLE_ASYNC (1<<1) /* Channel is non-blocking. */ #define CONSOLE_READ_OPS (1<<4) /* Channel supports read-related ops. */ #define CONSOLE_RESET (1<<5) /* Console mode needs to be reset. */ /* * Bit masks used in the sharedFlags field of the ConsoleInfo structure below. */ #define CONSOLE_EOF (1<<2) /* Console has reached EOF. */ #define CONSOLE_BUFFERED (1<<3) /* Data was read into a buffer by the reader |
| ︙ | ︙ | |||
98 99 100 101 102 103 104 105 106 107 108 109 110 111 |
int toWrite; /* Current amount to be written. Access is
* synchronized with the writable object. */
int readFlags; /* Flags that are shared with the reader
* thread. Access is synchronized with the
* readable object. */
int bytesRead; /* Number of bytes in the buffer. */
int offset; /* Number of bytes read out of the buffer. */
char buffer[CONSOLE_BUFFER_SIZE];
/* Data consumed by reader thread. */
} ConsoleInfo;
typedef struct {
/*
* The following pointer refers to the head of the list of consoles that
| > | 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 |
int toWrite; /* Current amount to be written. Access is
* synchronized with the writable object. */
int readFlags; /* Flags that are shared with the reader
* thread. Access is synchronized with the
* readable object. */
int bytesRead; /* Number of bytes in the buffer. */
int offset; /* Number of bytes read out of the buffer. */
DWORD initMode; /* Initial console mode. */
char buffer[CONSOLE_BUFFER_SIZE];
/* Data consumed by reader thread. */
} ConsoleInfo;
typedef struct {
/*
* The following pointer refers to the head of the list of consoles that
|
| ︙ | ︙ | |||
140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 | static void ConsoleCheckProc(ClientData clientData, int flags); static int ConsoleCloseProc(ClientData instanceData, Tcl_Interp *interp); static int ConsoleEventProc(Tcl_Event *evPtr, int flags); static void ConsoleExitHandler(ClientData clientData); static int ConsoleGetHandleProc(ClientData instanceData, int direction, ClientData *handlePtr); static void ConsoleInit(void); static int ConsoleInputProc(ClientData instanceData, char *buf, int toRead, int *errorCode); static int ConsoleOutputProc(ClientData instanceData, const char *buf, int toWrite, int *errorCode); static DWORD WINAPI ConsoleReaderThread(LPVOID arg); static void ConsoleSetupProc(ClientData clientData, int flags); static void ConsoleWatchProc(ClientData instanceData, int mask); static DWORD WINAPI ConsoleWriterThread(LPVOID arg); static void ProcExitHandler(ClientData clientData); static int WaitForRead(ConsoleInfo *infoPtr, int blocking); static void ConsoleThreadActionProc(ClientData instanceData, int action); | > > > > > > | 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 | static void ConsoleCheckProc(ClientData clientData, int flags); static int ConsoleCloseProc(ClientData instanceData, Tcl_Interp *interp); static int ConsoleEventProc(Tcl_Event *evPtr, int flags); static void ConsoleExitHandler(ClientData clientData); static int ConsoleGetHandleProc(ClientData instanceData, int direction, ClientData *handlePtr); static int ConsoleGetOptionProc(ClientData instanceData, Tcl_Interp *interp, const char *optionName, Tcl_DString *dsPtr); static void ConsoleInit(void); static int ConsoleInputProc(ClientData instanceData, char *buf, int toRead, int *errorCode); static int ConsoleOutputProc(ClientData instanceData, const char *buf, int toWrite, int *errorCode); static DWORD WINAPI ConsoleReaderThread(LPVOID arg); static int ConsoleSetOptionProc(ClientData instanceData, Tcl_Interp *interp, const char *optionName, const char *value); static void ConsoleSetupProc(ClientData clientData, int flags); static void ConsoleWatchProc(ClientData instanceData, int mask); static DWORD WINAPI ConsoleWriterThread(LPVOID arg); static void ProcExitHandler(ClientData clientData); static int WaitForRead(ConsoleInfo *infoPtr, int blocking); static void ConsoleThreadActionProc(ClientData instanceData, int action); |
| ︙ | ︙ | |||
171 172 173 174 175 176 177 |
static const Tcl_ChannelType consoleChannelType = {
"console", /* Type name. */
TCL_CHANNEL_VERSION_5, /* v5 channel */
ConsoleCloseProc, /* Close proc. */
ConsoleInputProc, /* Input proc. */
ConsoleOutputProc, /* Output proc. */
NULL, /* Seek proc. */
| | | | 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 |
static const Tcl_ChannelType consoleChannelType = {
"console", /* Type name. */
TCL_CHANNEL_VERSION_5, /* v5 channel */
ConsoleCloseProc, /* Close proc. */
ConsoleInputProc, /* Input proc. */
ConsoleOutputProc, /* Output proc. */
NULL, /* Seek proc. */
ConsoleSetOptionProc, /* Set option proc. */
ConsoleGetOptionProc, /* Get option proc. */
ConsoleWatchProc, /* Set up notifier to watch the channel. */
ConsoleGetHandleProc, /* Get an OS handle from channel. */
NULL, /* close2proc. */
ConsoleBlockModeProc, /* Set blocking or non-blocking mode. */
NULL, /* Flush proc. */
NULL, /* Handler proc. */
NULL, /* Wide seek proc. */
|
| ︙ | ︙ | |||
451 452 453 454 455 456 457 |
if (infoPtr->watchMask & TCL_READABLE) {
if (WaitForRead(infoPtr, 0) >= 0) {
needEvent = 1;
}
}
if (needEvent) {
| | | 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 |
if (infoPtr->watchMask & TCL_READABLE) {
if (WaitForRead(infoPtr, 0) >= 0) {
needEvent = 1;
}
}
if (needEvent) {
ConsoleEvent *evPtr = Tcl_Alloc(sizeof(ConsoleEvent));
infoPtr->flags |= CONSOLE_PENDING;
evPtr->header.proc = ConsoleEventProc;
evPtr->infoPtr = infoPtr;
Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL);
}
}
|
| ︙ | ︙ | |||
563 564 565 566 567 568 569 570 571 572 573 574 575 576 |
TclPipeThreadStop(&consolePtr->writer.TI, consolePtr->writer.thread);
CloseHandle(consolePtr->writer.thread);
CloseHandle(consolePtr->writer.readyEvent);
consolePtr->writer.thread = NULL;
}
consolePtr->validMask &= ~TCL_WRITABLE;
/*
* Don't close the Win32 handle if the handle is a standard channel during
* the thread exit process. Otherwise, one thread may kill the stdio of
* another.
*/
| > > > > > > > > > > > | 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 |
TclPipeThreadStop(&consolePtr->writer.TI, consolePtr->writer.thread);
CloseHandle(consolePtr->writer.thread);
CloseHandle(consolePtr->writer.readyEvent);
consolePtr->writer.thread = NULL;
}
consolePtr->validMask &= ~TCL_WRITABLE;
/*
* If the user has been tinkering with the mode, reset it now. We ignore
* any errors from this; we're quite possibly about to close or exit
* anyway.
*/
if ((consolePtr->flags & CONSOLE_READ_OPS) &&
(consolePtr->flags & CONSOLE_RESET)) {
SetConsoleMode(consolePtr->handle, consolePtr->initMode);
}
/*
* Don't close the Win32 handle if the handle is a standard channel during
* the thread exit process. Otherwise, one thread may kill the stdio of
* another.
*/
|
| ︙ | ︙ | |||
586 587 588 589 590 591 592 |
consolePtr->watchMask &= consolePtr->validMask;
/*
* Remove the file from the list of watched files.
*/
| | | | | 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 |
consolePtr->watchMask &= consolePtr->validMask;
/*
* Remove the file from the list of watched files.
*/
for (nextPtrPtr = &tsdPtr->firstConsolePtr, infoPtr = *nextPtrPtr;
infoPtr != NULL;
nextPtrPtr = &infoPtr->nextPtr, infoPtr = *nextPtrPtr) {
if (infoPtr == (ConsoleInfo *) consolePtr) {
*nextPtrPtr = infoPtr->nextPtr;
break;
}
}
if (consolePtr->writeBuf != NULL) {
Tcl_Free(consolePtr->writeBuf);
consolePtr->writeBuf = 0;
}
Tcl_Free(consolePtr);
return errorCode;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
656 657 658 659 660 661 662 |
if (infoPtr->readFlags & CONSOLE_BUFFERED) {
/*
* Data is stored in the buffer.
*/
if (bufSize < (infoPtr->bytesRead - infoPtr->offset)) {
| | | | 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 |
if (infoPtr->readFlags & CONSOLE_BUFFERED) {
/*
* Data is stored in the buffer.
*/
if (bufSize < (infoPtr->bytesRead - infoPtr->offset)) {
memcpy(buf, &infoPtr->buffer[infoPtr->offset], bufSize);
bytesRead = bufSize;
infoPtr->offset += bufSize;
} else {
memcpy(buf, &infoPtr->buffer[infoPtr->offset], bufSize);
bytesRead = infoPtr->bytesRead - infoPtr->offset;
/*
* Reset the buffer.
*/
infoPtr->readFlags &= ~CONSOLE_BUFFERED;
|
| ︙ | ︙ | |||
762 763 764 765 766 767 768 |
if (toWrite > infoPtr->writeBufLen) {
/*
* Reallocate the buffer to be large enough to hold the data.
*/
if (infoPtr->writeBuf) {
| | | | | 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 |
if (toWrite > infoPtr->writeBufLen) {
/*
* Reallocate the buffer to be large enough to hold the data.
*/
if (infoPtr->writeBuf) {
Tcl_Free(infoPtr->writeBuf);
}
infoPtr->writeBufLen = toWrite;
infoPtr->writeBuf = Tcl_Alloc(toWrite);
}
memcpy(infoPtr->writeBuf, buf, toWrite);
infoPtr->toWrite = toWrite;
ResetEvent(threadInfo->readyEvent);
TclPipeThreadSignal(&threadInfo->TI);
bytesWritten = toWrite;
} else {
/*
* In the blocking case, just try to write the buffer directly. This
|
| ︙ | ︙ | |||
1299 1300 1301 1302 1303 1304 1305 |
ConsoleInit();
/*
* See if a channel with this handle already exists.
*/
| | | 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 |
ConsoleInit();
/*
* See if a channel with this handle already exists.
*/
infoPtr = Tcl_Alloc(sizeof(ConsoleInfo));
memset(infoPtr, 0, sizeof(ConsoleInfo));
infoPtr->validMask = permissions;
infoPtr->handle = handle;
infoPtr->channel = (Tcl_Channel) NULL;
wsprintfA(encoding, "cp%d", GetConsoleCP());
|
| ︙ | ︙ | |||
1328 1329 1330 1331 1332 1333 1334 |
if (permissions & TCL_READABLE) {
/*
* Make sure the console input buffer is ready for only character
* input notifications and the buffer is set for line buffering. IOW,
* we only want to catch when complete lines are ready for reading.
*/
| > | > | 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 |
if (permissions & TCL_READABLE) {
/*
* Make sure the console input buffer is ready for only character
* input notifications and the buffer is set for line buffering. IOW,
* we only want to catch when complete lines are ready for reading.
*/
infoPtr->flags |= CONSOLE_READ_OPS;
GetConsoleMode(infoPtr->handle, &infoPtr->initMode);
modes = infoPtr->initMode;
modes &= ~(ENABLE_WINDOW_INPUT | ENABLE_MOUSE_INPUT);
modes |= ENABLE_LINE_INPUT;
SetConsoleMode(infoPtr->handle, modes);
infoPtr->reader.readyEvent = CreateEvent(NULL, TRUE, TRUE, NULL);
infoPtr->reader.thread = CreateThread(NULL, 256, ConsoleReaderThread,
TclPipeThreadCreateTI(&infoPtr->reader.TI, infoPtr,
|
| ︙ | ︙ | |||
1356 1357 1358 1359 1360 1361 1362 |
/*
* Files have default translation of AUTO and ^Z eof char, which means
* that a ^Z will be accepted as EOF when reading.
*/
Tcl_SetChannelOption(NULL, infoPtr->channel, "-translation", "auto");
Tcl_SetChannelOption(NULL, infoPtr->channel, "-eofchar", "\032 {}");
| < < < < | 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 |
/*
* Files have default translation of AUTO and ^Z eof char, which means
* that a ^Z will be accepted as EOF when reading.
*/
Tcl_SetChannelOption(NULL, infoPtr->channel, "-translation", "auto");
Tcl_SetChannelOption(NULL, infoPtr->channel, "-eofchar", "\032 {}");
Tcl_SetChannelOption(NULL, infoPtr->channel, "-encoding", "unicode");
return infoPtr->channel;
}
/*
*----------------------------------------------------------------------
*
* ConsoleThreadActionProc --
|
| ︙ | ︙ | |||
1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 |
infoPtr->threadId = Tcl_GetChannelThread(infoPtr->channel);
}
} else {
infoPtr->threadId = NULL;
}
Tcl_MutexUnlock(&consoleMutex);
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 |
infoPtr->threadId = Tcl_GetChannelThread(infoPtr->channel);
}
} else {
infoPtr->threadId = NULL;
}
Tcl_MutexUnlock(&consoleMutex);
}
/*
*----------------------------------------------------------------------
*
* ConsoleSetOptionProc --
*
* Sets an option on a channel.
*
* Results:
* A standard Tcl result. Also sets the interp's result on error if
* interp is not NULL.
*
* Side effects:
* May modify an option on a console. Sets Error message if needed (by
* calling Tcl_BadChannelOption).
*
*----------------------------------------------------------------------
*/
static int
ConsoleSetOptionProc(
ClientData instanceData, /* File state. */
Tcl_Interp *interp, /* For error reporting - can be NULL. */
const char *optionName, /* Which option to set? */
const char *value) /* New value for option. */
{
ConsoleInfo *infoPtr = instanceData;
int len = strlen(optionName);
int vlen = strlen(value);
/*
* Option -inputmode normal|password|raw
*/
if ((infoPtr->flags & CONSOLE_READ_OPS) && (len > 1) &&
(strncmp(optionName, "-inputmode", len) == 0)) {
DWORD mode;
if (GetConsoleMode(infoPtr->handle, &mode) == 0) {
TclWinConvertError(GetLastError());
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't read console mode: %s",
Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
if (Tcl_UtfNcasecmp(value, "NORMAL", vlen) == 0) {
mode |= ENABLE_ECHO_INPUT | ENABLE_LINE_INPUT;
} else if (Tcl_UtfNcasecmp(value, "PASSWORD", vlen) == 0) {
mode |= ENABLE_LINE_INPUT;
mode &= ~ENABLE_ECHO_INPUT;
} else if (Tcl_UtfNcasecmp(value, "RAW", vlen) == 0) {
mode &= ~(ENABLE_ECHO_INPUT | ENABLE_LINE_INPUT);
} else if (Tcl_UtfNcasecmp(value, "RESET", vlen) == 0) {
/*
* Reset to the initial mode, whatever that is.
*/
mode = infoPtr->initMode;
} else {
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad mode \"%s\" for -inputmode: must be"
" normal, password, raw, or reset", value));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE",
"VALUE", NULL);
}
return TCL_ERROR;
}
if (SetConsoleMode(infoPtr->handle, mode) == 0) {
TclWinConvertError(GetLastError());
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't set console mode: %s",
Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
/*
* If we've changed the mode from default, schedule a reset later.
*/
if (mode == infoPtr->initMode) {
infoPtr->flags &= ~CONSOLE_RESET;
} else {
infoPtr->flags |= CONSOLE_RESET;
}
return TCL_OK;
}
if (infoPtr->flags & CONSOLE_READ_OPS) {
return Tcl_BadChannelOption(interp, optionName, "inputmode");
} else {
return Tcl_BadChannelOption(interp, optionName, "");
}
}
/*
*----------------------------------------------------------------------
*
* ConsoleGetOptionProc --
*
* Gets a mode associated with an IO channel. If the optionName arg is
* non-NULL, retrieves the value of that option. If the optionName arg is
* NULL, retrieves a list of alternating option names and values for the
* given channel.
*
* Results:
* A standard Tcl result. Also sets the supplied DString to the string
* value of the option(s) returned. Sets error message if needed
* (by calling Tcl_BadChannelOption).
*
*----------------------------------------------------------------------
*/
static int
ConsoleGetOptionProc(
ClientData instanceData, /* File state. */
Tcl_Interp *interp, /* For error reporting - can be NULL. */
const char *optionName, /* Option to get. */
Tcl_DString *dsPtr) /* Where to store value(s). */
{
ConsoleInfo *infoPtr = instanceData;
int valid = 0; /* Flag if valid option parsed. */
unsigned int len;
char buf[TCL_INTEGER_SPACE];
if (optionName == NULL) {
len = 0;
} else {
len = strlen(optionName);
}
/*
* Get option -inputmode
*
* This is a great simplification of the underlying reality, but actually
* represents what almost all scripts really want to know.
*/
if (infoPtr->flags & CONSOLE_READ_OPS) {
if (len == 0) {
Tcl_DStringAppendElement(dsPtr, "-inputmode");
}
if (len==0 || (len>1 && strncmp(optionName, "-inputmode", len)==0)) {
DWORD mode;
valid = 1;
if (GetConsoleMode(infoPtr->handle, &mode) == 0) {
TclWinConvertError(GetLastError());
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't read console mode: %s",
Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
if (mode & ENABLE_LINE_INPUT) {
if (mode & ENABLE_ECHO_INPUT) {
Tcl_DStringAppendElement(dsPtr, "normal");
} else {
Tcl_DStringAppendElement(dsPtr, "password");
}
} else {
Tcl_DStringAppendElement(dsPtr, "raw");
}
}
}
/*
* Get option -winsize
* Option is readonly and returned by [fconfigure chan -winsize] but not
* returned by [fconfigure chan] without explicit option name.
*/
if ((len > 1) && (strncmp(optionName, "-winsize", len) == 0)) {
CONSOLE_SCREEN_BUFFER_INFO consoleInfo;
valid = 1;
if (!GetConsoleScreenBufferInfo(infoPtr->handle, &consoleInfo)) {
TclWinConvertError(GetLastError());
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't read console size: %s",
Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
sprintf(buf, "%d",
consoleInfo.srWindow.Right - consoleInfo.srWindow.Left + 1);
Tcl_DStringAppendElement(dsPtr, buf);
sprintf(buf, "%d",
consoleInfo.srWindow.Bottom - consoleInfo.srWindow.Top + 1);
Tcl_DStringAppendElement(dsPtr, buf);
}
if (valid) {
return TCL_OK;
}
if (infoPtr->flags & CONSOLE_READ_OPS) {
return Tcl_BadChannelOption(interp, optionName, "inputmode winsize");
} else {
return Tcl_BadChannelOption(interp, optionName, "");
}
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to win/tclWinDde.c.
| ︙ | ︙ | |||
13 14 15 16 17 18 19 | #undef STATIC_BUILD #ifndef USE_TCL_STUBS # define USE_TCL_STUBS #endif #include "tclInt.h" #include <dde.h> #include <ddeml.h> | | < < < < < < < < | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
#undef STATIC_BUILD
#ifndef USE_TCL_STUBS
# define USE_TCL_STUBS
#endif
#include "tclInt.h"
#include <dde.h>
#include <ddeml.h>
#include <tchar.h>
#if !defined(NDEBUG)
/* test POKE server Implemented for debug mode only */
# undef CBF_FAIL_POKES
# define CBF_FAIL_POKES 0
#endif
|
| ︙ | ︙ | |||
83 84 85 86 87 88 89 | */ static HSZ ddeServiceGlobal = 0; static DWORD ddeInstance; /* The application instance handle given to us * by DdeInitialize. */ static int ddeIsServer = 0; | | | 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 |
*/
static HSZ ddeServiceGlobal = 0;
static DWORD ddeInstance; /* The application instance handle given to us
* by DdeInitialize. */
static int ddeIsServer = 0;
#define TCL_DDE_VERSION "1.4.1"
#define TCL_DDE_PACKAGE_NAME "dde"
#define TCL_DDE_SERVICE_NAME TEXT("TclEval")
#define TCL_DDE_EXECUTE_RESULT TEXT("$TCLEVAL$EXECUTE$RESULT")
#define DDE_FLAG_ASYNC 1
#define DDE_FLAG_BINARY 2
#define DDE_FLAG_FORCE 4
|
| ︙ | ︙ | |||
120 121 122 123 124 125 126 127 128 129 130 131 132 133 | Tcl_Obj *ddeObjectPtr); static int MakeDdeConnection(Tcl_Interp *interp, const TCHAR *name, HCONV *ddeConvPtr); static void SetDdeError(Tcl_Interp *interp); static int DdeObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); DLLEXPORT int Dde_Init(Tcl_Interp *interp); DLLEXPORT int Dde_SafeInit(Tcl_Interp *interp); /* *---------------------------------------------------------------------- * | > > > > > > > > > > > > > > > > > > > | 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 |
Tcl_Obj *ddeObjectPtr);
static int MakeDdeConnection(Tcl_Interp *interp,
const TCHAR *name, HCONV *ddeConvPtr);
static void SetDdeError(Tcl_Interp *interp);
static int DdeObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
static unsigned char *
getByteArrayFromObj(
Tcl_Obj *objPtr,
size_t *lengthPtr
) {
int length;
unsigned char *result = Tcl_GetByteArrayFromObj(objPtr, &length);
#if TCL_MAJOR_VERSION > 8
if (sizeof(TCL_HASH_TYPE) > sizeof(int)) {
/* 64-bit and TIP #494 situation: */
*lengthPtr = *(TCL_HASH_TYPE *) objPtr->internalRep.twoPtrValue.ptr1;
} else
#endif
/* 32-bit or without TIP #494 */
*lengthPtr = (size_t) (unsigned) length;
return result;
}
DLLEXPORT int Dde_Init(Tcl_Interp *interp);
DLLEXPORT int Dde_SafeInit(Tcl_Interp *interp);
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
144 145 146 147 148 149 150 |
*----------------------------------------------------------------------
*/
int
Dde_Init(
Tcl_Interp *interp)
{
| | | | 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 |
*----------------------------------------------------------------------
*/
int
Dde_Init(
Tcl_Interp *interp)
{
if (!Tcl_InitStubs(interp, "8.1", 0)) {
return TCL_ERROR;
}
Tcl_CreateObjCommand(interp, "dde", DdeObjCmd, NULL, NULL);
Tcl_CreateExitHandler(DdeExitProc, NULL);
return Tcl_PkgProvide(interp, TCL_DDE_PACKAGE_NAME, TCL_DDE_VERSION);
}
/*
*----------------------------------------------------------------------
*
* Dde_SafeInit --
*
|
| ︙ | ︙ | |||
376 377 378 379 380 381 382 |
/*
* See if the name is already in use, if so increment suffix.
*/
for (n = 0; n < srvCount; ++n) {
Tcl_Obj* namePtr;
Tcl_DString ds;
| < < < | | | | 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 |
/*
* See if the name is already in use, if so increment suffix.
*/
for (n = 0; n < srvCount; ++n) {
Tcl_Obj* namePtr;
Tcl_DString ds;
Tcl_ListObjIndex(interp, srvPtrPtr[n], 1, &namePtr);
Tcl_WinUtfToTChar(Tcl_GetString(namePtr), -1, &ds);
if (_tcscmp(actualName, (TCHAR *)Tcl_DStringValue(&ds)) == 0) {
suffix++;
Tcl_DStringFree(&ds);
break;
}
Tcl_DStringFree(&ds);
}
}
}
/*
* We have found a unique name. Now add it to the registry.
*/
riPtr = (RegisteredInterp *) Tcl_Alloc(sizeof(RegisteredInterp));
riPtr->interp = interp;
riPtr->name = (TCHAR *) Tcl_Alloc((_tcslen(actualName) + 1) * sizeof(TCHAR));
riPtr->nextPtr = tsdPtr->interpListPtr;
riPtr->handlerPtr = handlerPtr;
if (riPtr->handlerPtr != NULL) {
Tcl_IncrRefCount(riPtr->handlerPtr);
}
tsdPtr->interpListPtr = riPtr;
_tcscpy(riPtr->name, actualName);
|
| ︙ | ︙ | |||
499 500 501 502 503 504 505 |
if (searchPtr != NULL) {
if (prevPtr == NULL) {
tsdPtr->interpListPtr = tsdPtr->interpListPtr->nextPtr;
} else {
prevPtr->nextPtr = searchPtr->nextPtr;
}
}
| | | 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 |
if (searchPtr != NULL) {
if (prevPtr == NULL) {
tsdPtr->interpListPtr = tsdPtr->interpListPtr->nextPtr;
} else {
prevPtr->nextPtr = searchPtr->nextPtr;
}
}
Tcl_Free((char *) riPtr->name);
if (riPtr->handlerPtr) {
Tcl_DecrRefCount(riPtr->handlerPtr);
}
Tcl_EventuallyFree(clientData, TCL_DYNAMIC);
}
/*
|
| ︙ | ︙ | |||
537 538 539 540 541 542 543 |
ExecuteRemoteObject(
RegisteredInterp *riPtr, /* Info about this server. */
Tcl_Obj *ddeObjectPtr) /* The object to execute. */
{
Tcl_Obj *returnPackagePtr;
int result = TCL_OK;
| | | 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 |
ExecuteRemoteObject(
RegisteredInterp *riPtr, /* Info about this server. */
Tcl_Obj *ddeObjectPtr) /* The object to execute. */
{
Tcl_Obj *returnPackagePtr;
int result = TCL_OK;
if ((riPtr->handlerPtr == NULL) && Tcl_IsSafe(riPtr->interp)) {
Tcl_SetObjResult(riPtr->interp, Tcl_NewStringObj("permission denied: "
"a handler procedure must be defined for use in a safe "
"interp", -1));
Tcl_SetErrorCode(riPtr->interp, "TCL", "DDE", "SECURITY_CHECK", NULL);
result = TCL_ERROR;
}
|
| ︙ | ︙ | |||
566 567 568 569 570 571 572 |
if (result == TCL_OK) {
result = Tcl_EvalObjEx(riPtr->interp, ddeObjectPtr, TCL_EVAL_GLOBAL);
}
returnPackagePtr = Tcl_NewListObj(0, NULL);
Tcl_ListObjAppendElement(NULL, returnPackagePtr,
| | | < < < < < < < | < | 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 |
if (result == TCL_OK) {
result = Tcl_EvalObjEx(riPtr->interp, ddeObjectPtr, TCL_EVAL_GLOBAL);
}
returnPackagePtr = Tcl_NewListObj(0, NULL);
Tcl_ListObjAppendElement(NULL, returnPackagePtr,
Tcl_NewIntObj(result));
Tcl_ListObjAppendElement(NULL, returnPackagePtr,
Tcl_GetObjResult(riPtr->interp));
if (result == TCL_ERROR) {
Tcl_Obj *errorObjPtr = Tcl_GetVar2Ex(riPtr->interp, "errorCode", NULL,
TCL_GLOBAL_ONLY);
if (errorObjPtr) {
Tcl_ListObjAppendElement(NULL, returnPackagePtr, errorObjPtr);
}
errorObjPtr = Tcl_GetVar2Ex(riPtr->interp, "errorInfo", NULL,
TCL_GLOBAL_ONLY);
if (errorObjPtr) {
Tcl_ListObjAppendElement(NULL, returnPackagePtr, errorObjPtr);
}
}
return returnPackagePtr;
}
|
| ︙ | ︙ | |||
627 628 629 630 631 632 633 |
HSZ ddeTopic, HSZ ddeItem, /* String handles. Transaction-type
* dependent. */
HDDEDATA hData, /* DDE data. Transaction-type dependent. */
DWORD dwData1, DWORD dwData2)
/* Transaction-dependent data. */
{
Tcl_DString dString;
| | | 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 |
HSZ ddeTopic, HSZ ddeItem, /* String handles. Transaction-type
* dependent. */
HDDEDATA hData, /* DDE data. Transaction-type dependent. */
DWORD dwData1, DWORD dwData2)
/* Transaction-dependent data. */
{
Tcl_DString dString;
size_t len;
DWORD dlen;
TCHAR *utilString;
Tcl_Obj *ddeObjectPtr;
HDDEDATA ddeReturn = NULL;
RegisteredInterp *riPtr;
Conversation *convPtr, *prevConvPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
|
| ︙ | ︙ | |||
677 678 679 680 681 682 683 |
Tcl_DStringSetLength(&dString, (len + 1) * sizeof(TCHAR) - 1);
utilString = (TCHAR *) Tcl_DStringValue(&dString);
DdeQueryString(ddeInstance, ddeTopic, utilString, (DWORD) len + 1,
CP_WINUNICODE);
for (riPtr = tsdPtr->interpListPtr; riPtr != NULL;
riPtr = riPtr->nextPtr) {
if (_tcsicmp(riPtr->name, utilString) == 0) {
| | | 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 |
Tcl_DStringSetLength(&dString, (len + 1) * sizeof(TCHAR) - 1);
utilString = (TCHAR *) Tcl_DStringValue(&dString);
DdeQueryString(ddeInstance, ddeTopic, utilString, (DWORD) len + 1,
CP_WINUNICODE);
for (riPtr = tsdPtr->interpListPtr; riPtr != NULL;
riPtr = riPtr->nextPtr) {
if (_tcsicmp(riPtr->name, utilString) == 0) {
convPtr = (Conversation *) Tcl_Alloc(sizeof(Conversation));
convPtr->nextPtr = tsdPtr->currentConversations;
convPtr->returnPackagePtr = NULL;
convPtr->hConv = hConv;
convPtr->riPtr = riPtr;
tsdPtr->currentConversations = convPtr;
break;
}
|
| ︙ | ︙ | |||
707 708 709 710 711 712 713 |
tsdPtr->currentConversations = convPtr->nextPtr;
} else {
prevConvPtr->nextPtr = convPtr->nextPtr;
}
if (convPtr->returnPackagePtr != NULL) {
Tcl_DecrRefCount(convPtr->returnPackagePtr);
}
| | | 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 |
tsdPtr->currentConversations = convPtr->nextPtr;
} else {
prevConvPtr->nextPtr = convPtr->nextPtr;
}
if (convPtr->returnPackagePtr != NULL) {
Tcl_DecrRefCount(convPtr->returnPackagePtr);
}
Tcl_Free((char *) convPtr);
break;
}
}
return (HDDEDATA) TRUE;
case XTYP_REQUEST:
/*
|
| ︙ | ︙ | |||
733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 |
&& (convPtr->hConv != hConv); convPtr = convPtr->nextPtr) {
/*
* Empty loop body.
*/
}
if (convPtr != NULL) {
char *returnString;
len = DdeQueryString(ddeInstance, ddeItem, NULL, 0, CP_WINUNICODE);
Tcl_DStringInit(&dString);
Tcl_DStringSetLength(&dString, (len + 1) * sizeof(TCHAR) - 1);
utilString = (TCHAR *) Tcl_DStringValue(&dString);
DdeQueryString(ddeInstance, ddeItem, utilString, (DWORD) len + 1,
CP_WINUNICODE);
if (_tcsicmp(utilString, TCL_DDE_EXECUTE_RESULT) == 0) {
| > > < | | > | > | < | < < < | | < < | | < > > | < | > | 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 |
&& (convPtr->hConv != hConv); convPtr = convPtr->nextPtr) {
/*
* Empty loop body.
*/
}
if (convPtr != NULL) {
Tcl_DString dsBuf;
char *returnString;
len = DdeQueryString(ddeInstance, ddeItem, NULL, 0, CP_WINUNICODE);
Tcl_DStringInit(&dString);
Tcl_DStringInit(&dsBuf);
Tcl_DStringSetLength(&dString, (len + 1) * sizeof(TCHAR) - 1);
utilString = (TCHAR *) Tcl_DStringValue(&dString);
DdeQueryString(ddeInstance, ddeItem, utilString, (DWORD) len + 1,
CP_WINUNICODE);
if (_tcsicmp(utilString, TCL_DDE_EXECUTE_RESULT) == 0) {
returnString =
Tcl_GetString(convPtr->returnPackagePtr);
len = convPtr->returnPackagePtr->length;
if (uFmt != CF_TEXT) {
Tcl_WinUtfToTChar(returnString, len, &dsBuf);
returnString = Tcl_DStringValue(&dsBuf);
len = Tcl_DStringLength(&dsBuf) + sizeof(TCHAR) - 1;
}
ddeReturn = DdeCreateDataHandle(ddeInstance, (BYTE *)returnString,
(DWORD) len+1, 0, ddeItem, uFmt, 0);
} else {
if (Tcl_IsSafe(convPtr->riPtr->interp)) {
ddeReturn = NULL;
} else {
Tcl_DString ds;
Tcl_Obj *variableObjPtr;
Tcl_WinTCharToUtf(utilString, -1, &ds);
variableObjPtr = Tcl_GetVar2Ex(
convPtr->riPtr->interp, Tcl_DStringValue(&ds), NULL,
TCL_GLOBAL_ONLY);
if (variableObjPtr != NULL) {
returnString = Tcl_GetString(variableObjPtr);
len = variableObjPtr->length;
if (uFmt != CF_TEXT) {
Tcl_WinUtfToTChar(returnString, len, &dsBuf);
returnString = Tcl_DStringValue(&dsBuf);
len = Tcl_DStringLength(&dsBuf) + sizeof(TCHAR) - 1;
}
ddeReturn = DdeCreateDataHandle(ddeInstance,
(BYTE *)returnString, (DWORD) len+1, 0, ddeItem,
uFmt, 0);
} else {
ddeReturn = NULL;
}
Tcl_DStringFree(&ds);
}
}
Tcl_DStringFree(&dsBuf);
Tcl_DStringFree(&dString);
}
return ddeReturn;
#if !CBF_FAIL_POKES
case XTYP_POKE:
/*
|
| ︙ | ︙ | |||
809 810 811 812 813 814 815 |
&& (convPtr->hConv != hConv); convPtr = convPtr->nextPtr) {
/*
* Empty loop body.
*/
}
if (convPtr && !Tcl_IsSafe(convPtr->riPtr->interp)) {
| | | | | > | > | | < | > < < | | > | 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 |
&& (convPtr->hConv != hConv); convPtr = convPtr->nextPtr) {
/*
* Empty loop body.
*/
}
if (convPtr && !Tcl_IsSafe(convPtr->riPtr->interp)) {
Tcl_DString ds, ds2;
Tcl_Obj *variableObjPtr;
DWORD len2;
Tcl_DStringInit(&dString);
Tcl_DStringInit(&ds2);
len = DdeQueryString(ddeInstance, ddeItem, NULL, 0, CP_WINUNICODE);
Tcl_DStringSetLength(&dString, (len + 1) * sizeof(TCHAR) - 1);
utilString = (TCHAR *) Tcl_DStringValue(&dString);
DdeQueryString(ddeInstance, ddeItem, utilString, (DWORD) len + 1,
CP_WINUNICODE);
Tcl_WinTCharToUtf(utilString, -1, &ds);
utilString = (TCHAR *) DdeAccessData(hData, &len2);
len = len2;
if (uFmt != CF_TEXT) {
Tcl_WinTCharToUtf(utilString, -1, &ds2);
utilString = (TCHAR *) Tcl_DStringValue(&ds2);
}
variableObjPtr = Tcl_NewStringObj((char *)utilString, -1);
Tcl_SetVar2Ex(convPtr->riPtr->interp, Tcl_DStringValue(&ds), NULL,
variableObjPtr, TCL_GLOBAL_ONLY);
Tcl_DStringFree(&ds2);
Tcl_DStringFree(&ds);
Tcl_DStringFree(&dString);
ddeReturn = (HDDEDATA) DDE_FACK;
}
return ddeReturn;
#endif
|
| ︙ | ︙ | |||
872 873 874 875 876 877 878 |
/* Cannot be unicode, so assume utf-8 */
if (!string[dlen-1]) {
dlen--;
}
ddeObjectPtr = Tcl_NewStringObj(string, dlen);
} else {
/* unicode */
| > | > | > > | 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 |
/* Cannot be unicode, so assume utf-8 */
if (!string[dlen-1]) {
dlen--;
}
ddeObjectPtr = Tcl_NewStringObj(string, dlen);
} else {
/* unicode */
Tcl_DString dsBuf;
Tcl_WinTCharToUtf(utilString, dlen - sizeof(TCHAR), &dsBuf);
ddeObjectPtr = Tcl_NewStringObj(Tcl_DStringValue(&dsBuf),
Tcl_DStringLength(&dsBuf));
Tcl_DStringFree(&dsBuf);
}
Tcl_IncrRefCount(ddeObjectPtr);
DdeUnaccessData(hData);
if (convPtr->returnPackagePtr != NULL) {
Tcl_DecrRefCount(convPtr->returnPackagePtr);
}
convPtr->returnPackagePtr = NULL;
|
| ︙ | ︙ | |||
1106 1107 1108 1109 1110 1111 1112 |
#ifdef _WIN64
es = (DdeEnumServices *) GetWindowLongPtr(hwnd, GWLP_USERDATA);
#else
es = (DdeEnumServices *) GetWindowLong(hwnd, GWL_USERDATA);
#endif
| | | | 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 |
#ifdef _WIN64
es = (DdeEnumServices *) GetWindowLongPtr(hwnd, GWLP_USERDATA);
#else
es = (DdeEnumServices *) GetWindowLong(hwnd, GWL_USERDATA);
#endif
if (((es->service == (ATOM)0) || (es->service == service))
&& ((es->topic == (ATOM)0) || (es->topic == topic))) {
Tcl_Obj *matchPtr = Tcl_NewListObj(0, NULL);
Tcl_Obj *resultPtr = Tcl_GetObjResult(es->interp);
GlobalGetAtomName(service, sz, 255);
Tcl_WinTCharToUtf(sz, -1, &dString);
Tcl_ListObjAppendElement(NULL, matchPtr, Tcl_NewStringObj(Tcl_DStringValue(&dString), -1));
Tcl_DStringFree(&dString);
|
| ︙ | ︙ | |||
1289 1290 1291 1292 1293 1294 1295 |
static const char *const ddeEvalOptions[] = {
"-async", NULL
};
static const char *const ddeReqOptions[] = {
"-binary", NULL
};
| | > > | | > > > | | | 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 |
static const char *const ddeEvalOptions[] = {
"-async", NULL
};
static const char *const ddeReqOptions[] = {
"-binary", NULL
};
int index, i, argIndex;
size_t length;
int flags = 0, result = TCL_OK, firstArg = 0;
HSZ ddeService = NULL, ddeTopic = NULL, ddeItem = NULL, ddeCookie = NULL;
HDDEDATA ddeData = NULL, ddeItemData = NULL, ddeReturn;
HCONV hConv = NULL;
const TCHAR *serviceName = NULL, *topicName = NULL;
const char *string;
DWORD ddeResult;
Tcl_Obj *objPtr, *handlerPtr = NULL;
Tcl_DString serviceBuf, topicBuf, itemBuf;
/*
* Initialize DDE server/client
*/
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "command ?arg ...?");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], ddeCommands, "command", 0,
&index) != TCL_OK) {
return TCL_ERROR;
}
Tcl_DStringInit(&serviceBuf);
Tcl_DStringInit(&topicBuf);
Tcl_DStringInit(&itemBuf);
switch ((enum DdeSubcommands) index) {
case DDE_SERVERNAME:
for (i = 2; i < objc; i++) {
if (Tcl_GetIndexFromObj(interp, objv[i], ddeSrvOptions,
"option", 0, &argIndex) != TCL_OK) {
/*
* If it is the last argument, it might be a server name
* instead of a bad argument.
*/
if (i != objc-1) {
return TCL_ERROR;
|
| ︙ | ︙ | |||
1362 1363 1364 1365 1366 1367 1368 |
firstArg = (objc == i) ? 1 : i;
break;
case DDE_EXECUTE:
if (objc == 5) {
firstArg = 2;
break;
| | | | | | | | | 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 |
firstArg = (objc == i) ? 1 : i;
break;
case DDE_EXECUTE:
if (objc == 5) {
firstArg = 2;
break;
} else if ((objc >= 6) && (objc <= 7)) {
firstArg = objc - 3;
for (i = 2; i < firstArg; i++) {
if (Tcl_GetIndexFromObj(interp, objv[i], ddeExecOptions,
"option", 0, &argIndex) != TCL_OK) {
goto wrongDdeExecuteArgs;
}
if (argIndex == DDE_EXEC_ASYNC) {
flags |= DDE_FLAG_ASYNC;
} else {
flags |= DDE_FLAG_BINARY;
}
}
break;
}
/* otherwise... */
wrongDdeExecuteArgs:
Tcl_WrongNumArgs(interp, 2, objv,
"?-async? ?-binary? serviceName topicName value");
return TCL_ERROR;
case DDE_POKE:
if (objc == 6) {
firstArg = 2;
break;
} else if ((objc == 7) && (Tcl_GetIndexFromObj(NULL, objv[2],
ddeReqOptions, "option", 0, &argIndex) == TCL_OK)) {
flags |= DDE_FLAG_BINARY;
firstArg = 3;
break;
}
/*
* Otherwise...
*/
Tcl_WrongNumArgs(interp, 2, objv,
"?-binary? serviceName topicName item value");
return TCL_ERROR;
case DDE_REQUEST:
if (objc == 5) {
firstArg = 2;
break;
} else if ((objc == 6) && (Tcl_GetIndexFromObj(NULL, objv[2],
ddeReqOptions, "option", 0, &argIndex) == TCL_OK)) {
flags |= DDE_FLAG_BINARY;
firstArg = 3;
break;
}
/*
* Otherwise ...
|
| ︙ | ︙ | |||
1432 1433 1434 1435 1436 1437 1438 |
case DDE_EVAL:
if (objc < 4) {
wrongDdeEvalArgs:
Tcl_WrongNumArgs(interp, 2, objv, "?-async? serviceName args");
return TCL_ERROR;
} else {
firstArg = 2;
| | | < | | | > | > < | | | > | > | | < | | > | | > > | | > > > > | | | | > > | 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 |
case DDE_EVAL:
if (objc < 4) {
wrongDdeEvalArgs:
Tcl_WrongNumArgs(interp, 2, objv, "?-async? serviceName args");
return TCL_ERROR;
} else {
firstArg = 2;
if (Tcl_GetIndexFromObj(NULL, objv[2], ddeEvalOptions, "option",
0, &argIndex) == TCL_OK) {
if (objc < 5) {
goto wrongDdeEvalArgs;
}
flags |= DDE_FLAG_ASYNC;
firstArg++;
}
break;
}
}
Initialize();
if (firstArg != 1) {
const char *src = Tcl_GetString(objv[firstArg]);
length = objv[firstArg]->length;
Tcl_WinUtfToTChar(src, length, &serviceBuf);
serviceName = (TCHAR *) Tcl_DStringValue(&serviceBuf);
length = Tcl_DStringLength(&serviceBuf) / sizeof(TCHAR);
} else {
length = 0;
}
if (length == 0) {
serviceName = NULL;
} else if ((index != DDE_SERVERNAME) && (index != DDE_EVAL)) {
ddeService = DdeCreateStringHandle(ddeInstance, (void *) serviceName,
CP_WINUNICODE);
}
if ((index != DDE_SERVERNAME) && (index != DDE_EVAL)) {
const char *src = Tcl_GetString(objv[firstArg + 1]);
length = objv[firstArg + 1]->length;
topicName = Tcl_WinUtfToTChar(src, length, &topicBuf);
length = Tcl_DStringLength(&topicBuf) / sizeof(TCHAR);
if (length == 0) {
topicName = NULL;
} else {
ddeTopic = DdeCreateStringHandle(ddeInstance, (void *) topicName,
CP_WINUNICODE);
}
}
switch ((enum DdeSubcommands) index) {
case DDE_SERVERNAME:
serviceName = DdeSetServerName(interp, serviceName, flags,
handlerPtr);
if (serviceName != NULL) {
Tcl_DString dsBuf;
Tcl_WinTCharToUtf(serviceName, -1, &dsBuf);
Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_DStringValue(&dsBuf),
Tcl_DStringLength(&dsBuf)));
Tcl_DStringFree(&dsBuf);
} else {
Tcl_ResetResult(interp);
}
break;
case DDE_EXECUTE: {
size_t dataLength;
const void *dataString;
Tcl_DString dsBuf;
Tcl_DStringInit(&dsBuf);
if (flags & DDE_FLAG_BINARY) {
dataString =
getByteArrayFromObj(objv[firstArg + 2], &dataLength);
} else {
const char *src;
src = Tcl_GetString(objv[firstArg + 2]);
dataLength = objv[firstArg + 2]->length;
dataString = (const TCHAR *)
Tcl_WinUtfToTChar(src, dataLength, &dsBuf);
dataLength = Tcl_DStringLength(&dsBuf) + sizeof(TCHAR);
}
if (dataLength + 1 < 2) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("cannot execute null data", -1));
Tcl_DStringFree(&dsBuf);
Tcl_SetErrorCode(interp, "TCL", "DDE", "NULL", NULL);
result = TCL_ERROR;
break;
}
hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL);
DdeFreeStringHandle(ddeInstance, ddeService);
DdeFreeStringHandle(ddeInstance, ddeTopic);
if (hConv == NULL) {
Tcl_DStringFree(&dsBuf);
SetDdeError(interp);
result = TCL_ERROR;
break;
}
ddeData = DdeCreateDataHandle(ddeInstance, (BYTE *) dataString,
(DWORD) dataLength, 0, 0, (flags & DDE_FLAG_BINARY) ? CF_TEXT : CF_UNICODETEXT, 0);
|
| ︙ | ︙ | |||
1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 |
}
}
DdeFreeDataHandle(ddeData);
} else {
SetDdeError(interp);
result = TCL_ERROR;
}
break;
}
case DDE_REQUEST: {
| > < | > | < | | > | | 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 |
}
}
DdeFreeDataHandle(ddeData);
} else {
SetDdeError(interp);
result = TCL_ERROR;
}
Tcl_DStringFree(&dsBuf);
break;
}
case DDE_REQUEST: {
const TCHAR *itemString;
const char *src;
src = Tcl_GetString(objv[firstArg + 2]);
length = objv[firstArg + 2]->length;
itemString = Tcl_WinUtfToTChar(src, length, &itemBuf);
length = Tcl_DStringLength(&itemBuf) / sizeof(TCHAR);
if (length == 0) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("cannot request value of null data", -1));
Tcl_SetErrorCode(interp, "TCL", "DDE", "NULL", NULL);
result = TCL_ERROR;
goto cleanup;
|
| ︙ | ︙ | |||
1579 1580 1581 1582 1583 1584 1585 |
ddeData = DdeClientTransaction(NULL, 0, hConv, ddeItem,
(flags & DDE_FLAG_BINARY) ? CF_TEXT : CF_UNICODETEXT, XTYP_REQUEST, 5000, NULL);
if (ddeData == NULL) {
SetDdeError(interp);
result = TCL_ERROR;
} else {
DWORD tmp;
| | | > | > | | > | > > | < < | < < | < < > > > > > > | > > > | | | 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 |
ddeData = DdeClientTransaction(NULL, 0, hConv, ddeItem,
(flags & DDE_FLAG_BINARY) ? CF_TEXT : CF_UNICODETEXT, XTYP_REQUEST, 5000, NULL);
if (ddeData == NULL) {
SetDdeError(interp);
result = TCL_ERROR;
} else {
DWORD tmp;
TCHAR *dataString = (TCHAR *) DdeAccessData(ddeData, &tmp);
if (flags & DDE_FLAG_BINARY) {
returnObjPtr =
Tcl_NewByteArrayObj((BYTE *) dataString, tmp);
} else {
Tcl_DString dsBuf;
if ((tmp >= sizeof(TCHAR))
&& !dataString[tmp / sizeof(TCHAR) - 1]) {
tmp -= sizeof(TCHAR);
}
Tcl_WinTCharToUtf(dataString, tmp, &dsBuf);
returnObjPtr =
Tcl_NewStringObj(Tcl_DStringValue(&dsBuf),
Tcl_DStringLength(&dsBuf));
Tcl_DStringFree(&dsBuf);
}
DdeUnaccessData(ddeData);
DdeFreeDataHandle(ddeData);
Tcl_SetObjResult(interp, returnObjPtr);
}
} else {
SetDdeError(interp);
result = TCL_ERROR;
}
}
break;
}
case DDE_POKE: {
Tcl_DString dsBuf;
const TCHAR *itemString;
BYTE *dataString;
const char *src;
src = Tcl_GetString(objv[firstArg + 2]);
length = objv[firstArg + 2]->length;
itemString = Tcl_WinUtfToTChar(src, length, &itemBuf);
length = Tcl_DStringLength(&itemBuf) / sizeof(TCHAR);
if (length == 0) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("cannot have a null item", -1));
Tcl_SetErrorCode(interp, "TCL", "DDE", "NULL", NULL);
result = TCL_ERROR;
goto cleanup;
}
Tcl_DStringInit(&dsBuf);
if (flags & DDE_FLAG_BINARY) {
dataString = (BYTE *)
getByteArrayFromObj(objv[firstArg + 3], &length);
} else {
const char *data =
Tcl_GetString(objv[firstArg + 3]);
length = objv[firstArg + 3]->length;
dataString = (BYTE *)
Tcl_WinUtfToTChar(data, length, &dsBuf);
length = Tcl_DStringLength(&dsBuf) + sizeof(TCHAR);
}
hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL);
DdeFreeStringHandle(ddeInstance, ddeService);
DdeFreeStringHandle(ddeInstance, ddeTopic);
if (hConv == NULL) {
|
| ︙ | ︙ | |||
1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 |
result = TCL_ERROR;
}
} else {
SetDdeError(interp);
result = TCL_ERROR;
}
}
break;
}
case DDE_SERVICES:
result = DdeGetServicesList(interp, serviceName, topicName);
break;
| > | 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 |
result = TCL_ERROR;
}
} else {
SetDdeError(interp);
result = TCL_ERROR;
}
}
Tcl_DStringFree(&dsBuf);
break;
}
case DDE_SERVICES:
result = DdeGetServicesList(interp, serviceName, topicName);
break;
|
| ︙ | ︙ | |||
1710 1711 1712 1713 1714 1715 1716 | * Don't exchange objects between interps. The target interp would * compile an object, producing a bytecode structure that refers * to other objects owned by the target interp. If the target * interp is then deleted, the bytecode structure would be * referring to deallocated objects. */ | | | 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 |
* Don't exchange objects between interps. The target interp would
* compile an object, producing a bytecode structure that refers
* to other objects owned by the target interp. If the target
* interp is then deleted, the bytecode structure would be
* referring to deallocated objects.
*/
if (Tcl_IsSafe(riPtr->interp) && (riPtr->handlerPtr == NULL)) {
Tcl_SetObjResult(riPtr->interp, Tcl_NewStringObj(
"permission denied: a handler procedure must be"
" defined for use in a safe interp", -1));
Tcl_SetErrorCode(interp, "TCL", "DDE", "SECURITY_CHECK",
NULL);
result = TCL_ERROR;
}
|
| ︙ | ︙ | |||
1746 1747 1748 1749 1750 1751 1752 |
if (result == TCL_OK) {
Tcl_IncrRefCount(objPtr);
result = Tcl_EvalObjEx(sendInterp, objPtr, TCL_EVAL_GLOBAL);
Tcl_DecrRefCount(objPtr);
}
if (interp != sendInterp) {
if (result == TCL_ERROR) {
| < | < < < | < | < > > | > > > > | | > | 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 |
if (result == TCL_OK) {
Tcl_IncrRefCount(objPtr);
result = Tcl_EvalObjEx(sendInterp, objPtr, TCL_EVAL_GLOBAL);
Tcl_DecrRefCount(objPtr);
}
if (interp != sendInterp) {
if (result == TCL_ERROR) {
/*
* An error occurred, so transfer error information from
* the destination interpreter back to our interpreter.
*/
Tcl_ResetResult(interp);
objPtr = Tcl_GetVar2Ex(sendInterp, "errorInfo", NULL,
TCL_GLOBAL_ONLY);
if (objPtr) {
Tcl_AppendObjToErrorInfo(interp, objPtr);
}
objPtr = Tcl_GetVar2Ex(sendInterp, "errorCode", NULL,
TCL_GLOBAL_ONLY);
if (objPtr) {
Tcl_SetObjErrorCode(interp, objPtr);
}
}
Tcl_SetObjResult(interp, Tcl_GetObjResult(sendInterp));
}
Tcl_Release(riPtr);
Tcl_Release(sendInterp);
} else {
Tcl_DString dsBuf;
/*
* This is a non-local request. Send the script to the server and
* poll it for a result.
*/
if (MakeDdeConnection(interp, serviceName, &hConv) != TCL_OK) {
invalidServerResponse:
Tcl_SetObjResult(interp,
Tcl_NewStringObj("invalid data returned from server", -1));
Tcl_SetErrorCode(interp, "TCL", "DDE", "BAD_RESPONSE", NULL);
result = TCL_ERROR;
goto cleanup;
}
objPtr = Tcl_ConcatObj(objc, objv);
string = Tcl_GetString(objPtr);
length = objPtr->length;
Tcl_WinUtfToTChar(string, length, &dsBuf);
string = Tcl_DStringValue(&dsBuf);
length = Tcl_DStringLength(&dsBuf) + sizeof(TCHAR);
ddeItemData = DdeCreateDataHandle(ddeInstance, (BYTE *) string,
(DWORD) length, 0, 0, CF_UNICODETEXT, 0);
Tcl_DStringFree(&dsBuf);
if (flags & DDE_FLAG_ASYNC) {
ddeData = DdeClientTransaction((LPBYTE) ddeItemData,
0xFFFFFFFF, hConv, 0,
CF_UNICODETEXT, XTYP_EXECUTE, TIMEOUT_ASYNC, &ddeResult);
DdeAbandonTransaction(ddeInstance, hConv, ddeResult);
} else {
|
| ︙ | ︙ | |||
1821 1822 1823 1824 1825 1826 1827 |
SetDdeError(interp);
result = TCL_ERROR;
goto cleanup;
}
if (!(flags & DDE_FLAG_ASYNC)) {
Tcl_Obj *resultPtr;
| | < | | > > | > > > | | 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 |
SetDdeError(interp);
result = TCL_ERROR;
goto cleanup;
}
if (!(flags & DDE_FLAG_ASYNC)) {
Tcl_Obj *resultPtr;
TCHAR *ddeDataString;
/*
* The return handle has a two or four element list in it. The
* first element is the return code (TCL_OK, TCL_ERROR, etc.).
* The second is the result of the script. If the return code
* is TCL_ERROR, then the third element is the value of the
* variable "errorCode", and the fourth is the value of the
* variable "errorInfo".
*/
length = DdeGetData(ddeData, NULL, 0, 0);
ddeDataString = (TCHAR *) Tcl_Alloc(length);
DdeGetData(ddeData, (BYTE *) ddeDataString, (DWORD) length, 0);
if (length > sizeof(TCHAR)) {
length -= sizeof(TCHAR);
}
Tcl_WinTCharToUtf(ddeDataString, length, &dsBuf);
resultPtr = Tcl_NewStringObj(Tcl_DStringValue(&dsBuf),
Tcl_DStringLength(&dsBuf));
Tcl_DStringFree(&dsBuf);
Tcl_Free((char *) ddeDataString);
if (Tcl_ListObjIndex(NULL, resultPtr, 0, &objPtr) != TCL_OK) {
Tcl_DecrRefCount(resultPtr);
goto invalidServerResponse;
}
if (Tcl_GetIntFromObj(NULL, objPtr, &result) != TCL_OK) {
Tcl_DecrRefCount(resultPtr);
|
| ︙ | ︙ | |||
1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 |
}
if (ddeData != NULL) {
DdeFreeDataHandle(ddeData);
}
if (hConv != NULL) {
DdeDisconnect(hConv);
}
return result;
}
/*
* Local variables:
* mode: c
* indent-tabs-mode: t
* tab-width: 8
* c-basic-offset: 4
* fill-column: 78
* End:
*/
| > > > | 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 |
}
if (ddeData != NULL) {
DdeFreeDataHandle(ddeData);
}
if (hConv != NULL) {
DdeDisconnect(hConv);
}
Tcl_DStringFree(&itemBuf);
Tcl_DStringFree(&topicBuf);
Tcl_DStringFree(&serviceBuf);
return result;
}
/*
* Local variables:
* mode: c
* indent-tabs-mode: t
* tab-width: 8
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to win/tclWinError.c.
| ︙ | ︙ | |||
377 378 379 380 381 382 383 | * * Side effects: * None. * *---------------------------------------------------------------------- */ | | | > > > < < < < < < | 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 |
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
void
tclWinDebugPanic(
const char *format, ...)
{
#define TCL_MAX_WARN_LEN 1024
va_list argList;
va_start(argList, format);
if (IsDebuggerPresent()) {
WCHAR msgString[TCL_MAX_WARN_LEN];
char buf[TCL_MAX_WARN_LEN * 3];
vsnprintf(buf, sizeof(buf), format, argList);
msgString[TCL_MAX_WARN_LEN-1] = L'\0';
MultiByteToWideChar(CP_UTF8, 0, buf, -1, msgString, TCL_MAX_WARN_LEN);
/*
* Truncate MessageBox string if it is too long to not overflow the buffer.
*/
if (msgString[TCL_MAX_WARN_LEN-1] != L'\0') {
memcpy(msgString + (TCL_MAX_WARN_LEN - 5), L" ...", 5 * sizeof(WCHAR));
}
OutputDebugStringW(msgString);
} else {
if (!isatty(fileno(stderr))) {
fprintf(stderr, "\xef\xbb\xbf");
}
vfprintf(stderr, format, argList);
fprintf(stderr, "\n");
fflush(stderr);
}
}
#endif
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* tab-width: 8
* End:
*/
|
Changes to win/tclWinFCmd.c.
| ︙ | ︙ | |||
67 68 69 70 71 72 73 |
{GetWinFileShortName, CannotSetAttribute},
{GetWinFileAttributes, SetWinFileAttributes}};
/*
* Prototype for the TraverseWinTree callback function.
*/
| | | | | | | | | | | 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 |
{GetWinFileShortName, CannotSetAttribute},
{GetWinFileAttributes, SetWinFileAttributes}};
/*
* Prototype for the TraverseWinTree callback function.
*/
typedef int (TraversalProc)(const WCHAR *srcPtr, const WCHAR *dstPtr,
int type, Tcl_DString *errorPtr);
/*
* Declarations for local functions defined in this file:
*/
static void StatError(Tcl_Interp *interp, Tcl_Obj *fileName);
static int ConvertFileNameFormat(Tcl_Interp *interp,
int objIndex, Tcl_Obj *fileName, int longShort,
Tcl_Obj **attributePtrPtr);
static int DoCopyFile(const WCHAR *srcPtr, const WCHAR *dstPtr);
static int DoCreateDirectory(const WCHAR *pathPtr);
static int DoRemoveJustDirectory(const WCHAR *nativeSrc,
int ignoreError, Tcl_DString *errorPtr);
static int DoRemoveDirectory(Tcl_DString *pathPtr, int recursive,
Tcl_DString *errorPtr);
static int DoRenameFile(const WCHAR *nativeSrc,
const WCHAR *dstPtr);
static int TraversalCopy(const WCHAR *srcPtr, const WCHAR *dstPtr,
int type, Tcl_DString *errorPtr);
static int TraversalDelete(const WCHAR *srcPtr,
const WCHAR *dstPtr, int type,
Tcl_DString *errorPtr);
static int TraverseWinTree(TraversalProc *traverseProc,
Tcl_DString *sourcePtr, Tcl_DString *dstPtr,
Tcl_DString *errorPtr);
/*
*---------------------------------------------------------------------------
|
| ︙ | ︙ | |||
147 148 149 150 151 152 153 |
{
return DoRenameFile(Tcl_FSGetNativePath(srcPathPtr),
Tcl_FSGetNativePath(destPathPtr));
}
static int
DoRenameFile(
| | | | 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 |
{
return DoRenameFile(Tcl_FSGetNativePath(srcPathPtr),
Tcl_FSGetNativePath(destPathPtr));
}
static int
DoRenameFile(
const WCHAR *nativeSrc, /* Pathname of file or dir to be renamed
* (native). */
const WCHAR *nativeDst) /* New pathname for file or directory
* (native). */
{
#if defined(HAVE_NO_SEH) && !defined(_WIN64)
TCLEXCEPTION_REGISTRATION registration;
#endif
DWORD srcAttr, dstAttr;
int retval = -1;
|
| ︙ | ︙ | |||
303 304 305 306 307 308 309 |
if (errno == EBADF) {
errno = EACCES;
return TCL_ERROR;
}
if (errno == EACCES) {
decode:
if (srcAttr & FILE_ATTRIBUTE_DIRECTORY) {
| | | | | 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 |
if (errno == EBADF) {
errno = EACCES;
return TCL_ERROR;
}
if (errno == EACCES) {
decode:
if (srcAttr & FILE_ATTRIBUTE_DIRECTORY) {
WCHAR *nativeSrcRest, *nativeDstRest;
const char **srcArgv, **dstArgv;
int size, srcArgc, dstArgc;
WCHAR nativeSrcPath[MAX_PATH];
WCHAR nativeDstPath[MAX_PATH];
Tcl_DString srcString, dstString;
const char *src, *dst;
size = GetFullPathName(nativeSrc, MAX_PATH,
nativeSrcPath, &nativeSrcRest);
if ((size == 0) || (size > MAX_PATH)) {
return TCL_ERROR;
|
| ︙ | ︙ | |||
333 334 335 336 337 338 339 | /* * Check whether the destination path is actually inside the * source path. This is true if the prefix matches, and the next * character is either end-of-string or a directory separator */ | | | 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 |
/*
* Check whether the destination path is actually inside the
* source path. This is true if the prefix matches, and the next
* character is either end-of-string or a directory separator
*/
if ((strncmp(src, dst, Tcl_DStringLength(&srcString))==0)
&& (dst[Tcl_DStringLength(&srcString)] == '\\'
|| dst[Tcl_DStringLength(&srcString)] == '/'
|| dst[Tcl_DStringLength(&srcString)] == '\0')) {
/*
* Trying to move a directory into itself.
*/
|
| ︙ | ︙ | |||
372 373 374 375 376 377 378 | * The MoveFile system call already handles the case of moving * a file between filesystems. */ Tcl_SetErrno(EXDEV); } | | | | 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 | * The MoveFile system call already handles the case of moving * a file between filesystems. */ Tcl_SetErrno(EXDEV); } Tcl_Free((void *)srcArgv); Tcl_Free((void *)dstArgv); } /* * Other types of access failure is that dst is a read-only * filesystem, that an open file referred to src or dest, or that src * or dest specified the current working directory on the current * filesystem. EACCES is returned for those cases. |
| ︙ | ︙ | |||
441 442 443 444 445 446 447 | * * 1. Rename existing file to temp name. * 2. Rename old file to new name. * 3. If success, delete temp file. If failure, put temp file * back to old name. */ | | | | | | 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 |
*
* 1. Rename existing file to temp name.
* 2. Rename old file to new name.
* 3. If success, delete temp file. If failure, put temp file
* back to old name.
*/
WCHAR *nativeRest, *nativeTmp, *nativePrefix;
int result, size;
WCHAR tempBuf[MAX_PATH];
size = GetFullPathName(nativeDst, MAX_PATH,
tempBuf, &nativeRest);
if ((size == 0) || (size > MAX_PATH) || (nativeRest == NULL)) {
return TCL_ERROR;
}
nativeTmp = (WCHAR *) tempBuf;
nativeRest[0] = L'\0';
result = TCL_ERROR;
nativePrefix = (WCHAR *) L"tclr";
if (GetTempFileName(nativeTmp, nativePrefix,
0, tempBuf) != 0) {
/*
* Strictly speaking, need the following DeleteFile and
* MoveFile to be joined as an atomic operation so no
* other app comes along in the meantime and creates the
* same temp file.
|
| ︙ | ︙ | |||
536 537 538 539 540 541 542 |
{
return DoCopyFile(Tcl_FSGetNativePath(srcPathPtr),
Tcl_FSGetNativePath(destPathPtr));
}
static int
DoCopyFile(
| | | | 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 |
{
return DoCopyFile(Tcl_FSGetNativePath(srcPathPtr),
Tcl_FSGetNativePath(destPathPtr));
}
static int
DoCopyFile(
const WCHAR *nativeSrc, /* Pathname of file to be copied (native). */
const WCHAR *nativeDst) /* Pathname of file to copy to (native). */
{
#if defined(HAVE_NO_SEH) && !defined(_WIN64)
TCLEXCEPTION_REGISTRATION registration;
#endif
int retval = -1;
/*
|
| ︙ | ︙ | |||
745 746 747 748 749 750 751 |
}
int
TclpDeleteFile(
const void *nativePath) /* Pathname of file to be removed (native). */
{
DWORD attr;
| | | 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 |
}
int
TclpDeleteFile(
const void *nativePath) /* Pathname of file to be removed (native). */
{
DWORD attr;
const WCHAR *path = nativePath;
/*
* The DeleteFile API acts differently under Win95/98 and NT WRT NULL and
* "". Avoid passing these values.
*/
if (path == NULL || path[0] == '\0') {
|
| ︙ | ︙ | |||
855 856 857 858 859 860 861 |
Tcl_Obj *pathPtr)
{
return DoCreateDirectory(Tcl_FSGetNativePath(pathPtr));
}
static int
DoCreateDirectory(
| | | 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 |
Tcl_Obj *pathPtr)
{
return DoCreateDirectory(Tcl_FSGetNativePath(pathPtr));
}
static int
DoCreateDirectory(
const WCHAR *nativePath) /* Pathname of directory to create (native). */
{
if (CreateDirectory(nativePath, NULL) == 0) {
DWORD error = GetLastError();
TclWinConvertError(error);
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
907 908 909 910 911 912 913 |
normSrcPtr = Tcl_FSGetNormalizedPath(NULL,srcPathPtr);
normDestPtr = Tcl_FSGetNormalizedPath(NULL,destPathPtr);
if ((normSrcPtr == NULL) || (normDestPtr == NULL)) {
return TCL_ERROR;
}
| | | | 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 |
normSrcPtr = Tcl_FSGetNormalizedPath(NULL,srcPathPtr);
normDestPtr = Tcl_FSGetNormalizedPath(NULL,destPathPtr);
if ((normSrcPtr == NULL) || (normDestPtr == NULL)) {
return TCL_ERROR;
}
Tcl_WinUtfToTChar(TclGetString(normSrcPtr), -1, &srcString);
Tcl_WinUtfToTChar(TclGetString(normDestPtr), -1, &dstString);
ret = TraverseWinTree(TraversalCopy, &srcString, &dstString, &ds);
Tcl_DStringFree(&srcString);
Tcl_DStringFree(&dstString);
if (ret != TCL_OK) {
|
| ︙ | ︙ | |||
980 981 982 983 984 985 986 |
*/
Tcl_DString native;
normPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
if (normPtr == NULL) {
return TCL_ERROR;
}
| | | 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 |
*/
Tcl_DString native;
normPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
if (normPtr == NULL) {
return TCL_ERROR;
}
Tcl_WinUtfToTChar(TclGetString(normPtr), -1, &native);
ret = DoRemoveDirectory(&native, recursive, &ds);
Tcl_DStringFree(&native);
} else {
ret = DoRemoveJustDirectory(Tcl_FSGetNativePath(pathPtr), 0, &ds);
}
if (ret != TCL_OK) {
|
| ︙ | ︙ | |||
1005 1006 1007 1008 1009 1010 1011 |
}
return ret;
}
static int
DoRemoveJustDirectory(
| | | > | 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 |
}
return ret;
}
static int
DoRemoveJustDirectory(
const WCHAR *nativePath, /* Pathname of directory to be removed
* (native). */
int ignoreError, /* If non-zero, don't initialize the errorPtr
* under some circumstances on return. */
Tcl_DString *errorPtr) /* If non-NULL, uninitialized or free DString
* filled with UTF-8 name of file causing
* error. */
{
DWORD attr;
/*
* The RemoveDirectory API acts differently under Win95/98 and NT WRT NULL
* and "". Avoid passing these values.
*/
if (nativePath == NULL || nativePath[0] == '\0') {
Tcl_SetErrno(ENOENT);
Tcl_DStringInit(errorPtr);
return TCL_ERROR;
}
attr = GetFileAttributes(nativePath);
if (attr & FILE_ATTRIBUTE_REPARSE_POINT) {
/*
* It is a symbolic link - remove it.
|
| ︙ | ︙ | |||
1104 1105 1106 1107 1108 1109 1110 |
* don't want to initialise the errorPtr yet.
*/
return TCL_ERROR;
}
end:
if (errorPtr != NULL) {
| < | < | | 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 |
* don't want to initialise the errorPtr yet.
*/
return TCL_ERROR;
}
end:
if (errorPtr != NULL) {
char *p = Tcl_WinTCharToUtf(nativePath, -1, errorPtr);
for (; *p; ++p) {
if (*p == '\\') *p = '/';
}
}
return TCL_ERROR;
}
static int
DoRemoveDirectory(
Tcl_DString *pathPtr, /* Pathname of directory to be removed
* (native). */
int recursive, /* If non-zero, removes directories that are
* nonempty. Otherwise, will only remove empty
* directories. */
Tcl_DString *errorPtr) /* If non-NULL, uninitialized or free DString
* filled with UTF-8 name of file causing
* error. */
{
int res = DoRemoveJustDirectory((const WCHAR *)Tcl_DStringValue(pathPtr), recursive,
errorPtr);
if ((res == TCL_ERROR) && (recursive != 0) && (Tcl_GetErrno() == EEXIST)) {
/*
* The directory is nonempty, but the recursive flag has been
* specified, so we recursively remove all the files in the directory.
*/
|
| ︙ | ︙ | |||
1177 1178 1179 1180 1181 1182 1183 |
* parallel with source directory (native),
* may be NULL. */
Tcl_DString *errorPtr) /* If non-NULL, uninitialized or free DString
* filled with UTF-8 name of file causing
* error. */
{
DWORD sourceAttr;
| | | | | 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 |
* parallel with source directory (native),
* may be NULL. */
Tcl_DString *errorPtr) /* If non-NULL, uninitialized or free DString
* filled with UTF-8 name of file causing
* error. */
{
DWORD sourceAttr;
WCHAR *nativeSource, *nativeTarget, *nativeErrfile;
int result, found, sourceLen, targetLen = 0, oldSourceLen, oldTargetLen;
HANDLE handle;
WIN32_FIND_DATA data;
nativeErrfile = NULL;
result = TCL_OK;
oldTargetLen = 0; /* lint. */
nativeSource = (WCHAR *) Tcl_DStringValue(sourcePtr);
nativeTarget = (WCHAR *)
(targetPtr == NULL ? NULL : Tcl_DStringValue(targetPtr));
oldSourceLen = Tcl_DStringLength(sourcePtr);
sourceAttr = GetFileAttributes(nativeSource);
if (sourceAttr == 0xffffffff) {
nativeErrfile = nativeSource;
goto end;
|
| ︙ | ︙ | |||
1214 1215 1216 1217 1218 1219 1220 |
/*
* Process the regular file
*/
return traverseProc(nativeSource, nativeTarget, DOTREE_F, errorPtr);
}
| | | | | | | | | | | | 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 |
/*
* Process the regular file
*/
return traverseProc(nativeSource, nativeTarget, DOTREE_F, errorPtr);
}
Tcl_DStringAppend(sourcePtr, (char *) L"\\*.*", 4 * sizeof(WCHAR) + 1);
Tcl_DStringSetLength(sourcePtr, Tcl_DStringLength(sourcePtr) - 1);
nativeSource = (WCHAR *) Tcl_DStringValue(sourcePtr);
handle = FindFirstFile(nativeSource, &data);
if (handle == INVALID_HANDLE_VALUE) {
/*
* Can't read directory.
*/
TclWinConvertError(GetLastError());
nativeErrfile = nativeSource;
goto end;
}
Tcl_DStringSetLength(sourcePtr, oldSourceLen + 1);
Tcl_DStringSetLength(sourcePtr, oldSourceLen);
result = traverseProc(nativeSource, nativeTarget, DOTREE_PRED,
errorPtr);
if (result != TCL_OK) {
FindClose(handle);
return result;
}
sourceLen = oldSourceLen + sizeof(WCHAR);
Tcl_DStringAppend(sourcePtr, (char *) L"\\", sizeof(WCHAR) + 1);
Tcl_DStringSetLength(sourcePtr, sourceLen);
if (targetPtr != NULL) {
oldTargetLen = Tcl_DStringLength(targetPtr);
targetLen = oldTargetLen;
targetLen += sizeof(WCHAR);
Tcl_DStringAppend(targetPtr, (char *) L"\\", sizeof(WCHAR) + 1);
Tcl_DStringSetLength(targetPtr, targetLen);
}
found = 1;
for (; found; found = FindNextFile(handle, &data)) {
WCHAR *nativeName;
int len;
WCHAR *wp = data.cFileName;
if (*wp == '.') {
wp++;
if (*wp == '.') {
wp++;
}
if (*wp == '\0') {
continue;
}
}
nativeName = (WCHAR *) data.cFileName;
len = wcslen(data.cFileName) * sizeof(WCHAR);
/*
* Append name after slash, and recurse on the file.
*/
Tcl_DStringAppend(sourcePtr, (char *) nativeName, len + 1);
Tcl_DStringSetLength(sourcePtr, Tcl_DStringLength(sourcePtr) - 1);
|
| ︙ | ︙ | |||
1311 1312 1313 1314 1315 1316 1317 |
}
if (result == TCL_OK) {
/*
* Call traverseProc() on a directory after visiting all the
* files in that directory.
*/
| | | | 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 |
}
if (result == TCL_OK) {
/*
* Call traverseProc() on a directory after visiting all the
* files in that directory.
*/
result = traverseProc((const WCHAR *)Tcl_DStringValue(sourcePtr),
(const WCHAR *)(targetPtr == NULL ? NULL : Tcl_DStringValue(targetPtr)),
DOTREE_POSTD, errorPtr);
}
end:
if (nativeErrfile != NULL) {
TclWinConvertError(GetLastError());
if (errorPtr != NULL) {
|
| ︙ | ︙ | |||
1347 1348 1349 1350 1351 1352 1353 | * Depending on the value of type, src may be copied to dst. * *---------------------------------------------------------------------- */ static int TraversalCopy( | | | | 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 |
* Depending on the value of type, src may be copied to dst.
*
*----------------------------------------------------------------------
*/
static int
TraversalCopy(
const WCHAR *nativeSrc, /* Source pathname to copy. */
const WCHAR *nativeDst, /* Destination pathname of copy. */
int type, /* Reason for call - see TraverseWinTree() */
Tcl_DString *errorPtr) /* If non-NULL, initialized DString filled
* with UTF-8 name of file causing error. */
{
switch (type) {
case DOTREE_F:
if (DoCopyFile(nativeSrc, nativeDst) == TCL_OK) {
|
| ︙ | ︙ | |||
1413 1414 1415 1416 1417 1418 1419 | * set accordingly. * *---------------------------------------------------------------------- */ static int TraversalDelete( | | | | 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 |
* set accordingly.
*
*----------------------------------------------------------------------
*/
static int
TraversalDelete(
const WCHAR *nativeSrc, /* Source pathname to delete. */
const WCHAR *dstPtr, /* Not used. */
int type, /* Reason for call - see TraverseWinTree() */
Tcl_DString *errorPtr) /* If non-NULL, initialized DString filled
* with UTF-8 name of file causing error. */
{
switch (type) {
case DOTREE_F:
if (TclpDeleteFile(nativeSrc) == TCL_OK) {
|
| ︙ | ︙ | |||
1500 1501 1502 1503 1504 1505 1506 |
GetWinFileAttributes(
Tcl_Interp *interp, /* The interp we are using for errors. */
int objIndex, /* The index of the attribute. */
Tcl_Obj *fileName, /* The name of the file. */
Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */
{
DWORD result;
| | > | < | 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 |
GetWinFileAttributes(
Tcl_Interp *interp, /* The interp we are using for errors. */
int objIndex, /* The index of the attribute. */
Tcl_Obj *fileName, /* The name of the file. */
Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */
{
DWORD result;
const WCHAR *nativeName;
int attr;
nativeName = Tcl_FSGetNativePath(fileName);
result = GetFileAttributes(nativeName);
if (result == 0xffffffff) {
StatError(interp, fileName);
return TCL_ERROR;
}
attr = (int)(result & attributeArray[objIndex]);
if ((objIndex == WIN_HIDDEN_ATTRIBUTE) && (attr != 0)) {
/*
* It is hidden. However there is a bug on some Windows OSes in which
* root volumes (drives) formatted as NTFS are declared hidden when
* they are not (and cannot be).
*
* We test for, and fix that case, here.
*/
size_t len;
const char *str = TclGetStringFromObj(fileName, &len);
if (len < 4) {
if (len == 0) {
/*
* Not sure if this is possible, but we pass it on anyway.
*/
} else if (len == 1 && (str[0] == '/' || str[0] == '\\')) {
|
| ︙ | ︙ | |||
1546 1547 1548 1549 1550 1551 1552 |
*/
attr = 0;
}
}
}
| | | 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 |
*/
attr = 0;
}
}
}
*attributePtrPtr = Tcl_NewWideIntObj(attr != 0);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ConvertFileNameFormat --
|
| ︙ | ︙ | |||
1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 |
int objIndex, /* The index of the attribute. */
Tcl_Obj *fileName, /* The name of the file. */
int longShort, /* 0 to short name, 1 to long name. */
Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */
{
int pathc, i;
Tcl_Obj *splitPath;
splitPath = Tcl_FSSplitPath(fileName, &pathc);
if (splitPath == NULL || pathc == 0) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not read \"%s\": no such file or directory",
| > | | | | < | | | 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 |
int objIndex, /* The index of the attribute. */
Tcl_Obj *fileName, /* The name of the file. */
int longShort, /* 0 to short name, 1 to long name. */
Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */
{
int pathc, i;
Tcl_Obj *splitPath;
size_t length;
splitPath = Tcl_FSSplitPath(fileName, &pathc);
if (splitPath == NULL || pathc == 0) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not read \"%s\": no such file or directory",
TclGetString(fileName)));
errno = ENOENT;
Tcl_PosixError(interp);
}
goto cleanup;
}
/*
* We will decrement this again at the end. It is safer to do this in
* case any of the calls below retain a reference to splitPath.
*/
Tcl_IncrRefCount(splitPath);
for (i = 0; i < pathc; i++) {
Tcl_Obj *elt;
char *pathv;
Tcl_ListObjIndex(NULL, splitPath, i, &elt);
pathv = TclGetStringFromObj(elt, &length);
if ((pathv[0] == '/') || ((length == 3) && (pathv[1] == ':'))
|| (strcmp(pathv, ".") == 0) || (strcmp(pathv, "..") == 0)) {
/*
* Handle "/", "//machine/export", "c:/", "." or ".." by just
* copying the string literally. Uppercase the drive letter, just
* because it looks better under Windows to do so.
*/
simple:
/*
* Here we are modifying the string representation in place.
*
* I believe this is legal, since this won't affect any file
* representation this thing may have.
*/
pathv[0] = (char) Tcl_UniCharToUpper(UCHAR(pathv[0]));
} else {
Tcl_Obj *tempPath;
Tcl_DString ds;
Tcl_DString dsTemp;
const WCHAR *nativeName;
const char *tempString;
WIN32_FIND_DATA data;
HANDLE handle;
DWORD attr;
tempPath = Tcl_FSJoinPath(splitPath, i+1);
Tcl_IncrRefCount(tempPath);
/*
* We'd like to call Tcl_FSGetNativePath(tempPath) but that is
* likely to lead to infinite loops.
*/
tempString = TclGetStringFromObj(tempPath, &length);
nativeName = Tcl_WinUtfToTChar(tempString, length, &ds);
Tcl_DecrRefCount(tempPath);
handle = FindFirstFile(nativeName, &data);
if (handle == INVALID_HANDLE_VALUE) {
/*
* FindFirstFile() doesn't like root directories. We would
* only get a root directory here if the caller specified "c:"
* or "c:." and the current directory on the drive was the
|
| ︙ | ︙ | |||
1680 1681 1682 1683 1684 1685 1686 |
nativeName = data.cAlternateFileName;
if (longShort) {
if (data.cFileName[0] != '\0') {
nativeName = data.cFileName;
}
} else {
if (data.cAlternateFileName[0] == '\0') {
| | | 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 |
nativeName = data.cAlternateFileName;
if (longShort) {
if (data.cFileName[0] != '\0') {
nativeName = data.cFileName;
}
} else {
if (data.cAlternateFileName[0] == '\0') {
nativeName = (WCHAR *) data.cFileName;
}
}
/*
* Purify reports a extraneous UMR in Tcl_WinTCharToUtf() trying
* to dereference nativeName as a Unicode string. I have proven to
* myself that purify is wrong by running the following example
|
| ︙ | ︙ | |||
1826 1827 1828 1829 1830 1831 1832 |
Tcl_Interp *interp, /* The interp we are using for errors. */
int objIndex, /* The index of the attribute. */
Tcl_Obj *fileName, /* The name of the file. */
Tcl_Obj *attributePtr) /* The new value of the attribute. */
{
DWORD fileAttributes, old;
int yesNo, result;
| | | 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 |
Tcl_Interp *interp, /* The interp we are using for errors. */
int objIndex, /* The index of the attribute. */
Tcl_Obj *fileName, /* The name of the file. */
Tcl_Obj *attributePtr) /* The new value of the attribute. */
{
DWORD fileAttributes, old;
int yesNo, result;
const WCHAR *nativeName;
nativeName = Tcl_FSGetNativePath(fileName);
fileAttributes = old = GetFileAttributes(nativeName);
if (fileAttributes == 0xffffffff) {
StatError(interp, fileName);
return TCL_ERROR;
|
| ︙ | ︙ | |||
1881 1882 1883 1884 1885 1886 1887 |
Tcl_Interp *interp, /* The interp we are using for errors. */
int objIndex, /* The index of the attribute. */
Tcl_Obj *fileName, /* The name of the file. */
Tcl_Obj *attributePtr) /* The new value of the attribute. */
{
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"cannot set attribute \"%s\" for file \"%s\": attribute is readonly",
| | | 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 |
Tcl_Interp *interp, /* The interp we are using for errors. */
int objIndex, /* The index of the attribute. */
Tcl_Obj *fileName, /* The name of the file. */
Tcl_Obj *attributePtr) /* The new value of the attribute. */
{
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"cannot set attribute \"%s\" for file \"%s\": attribute is readonly",
tclpFileAttrStrings[objIndex], TclGetString(fileName)));
errno = EINVAL;
Tcl_PosixError(interp);
return TCL_ERROR;
}
/*
*---------------------------------------------------------------------------
|
| ︙ | ︙ | |||
1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 |
Tcl_ListObjAppendElement(NULL, resultPtr, elemPtr);
}
}
Tcl_IncrRefCount(resultPtr);
return resultPtr;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 |
Tcl_ListObjAppendElement(NULL, resultPtr, elemPtr);
}
}
Tcl_IncrRefCount(resultPtr);
return resultPtr;
}
/*
*----------------------------------------------------------------------
*
* TclpCreateTemporaryDirectory --
*
* Creates a temporary directory, possibly based on the supplied bits and
* pieces of template supplied in the arguments.
*
* Results:
* An object (refcount 0) containing the name of the newly-created
* directory, or NULL on failure.
*
* Side effects:
* Accesses the native filesystem. Makes a directory.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclpCreateTemporaryDirectory(
Tcl_Obj *dirObj,
Tcl_Obj *basenameObj)
{
Tcl_DString base, name; /* Contains WCHARs */
int baseLen;
DWORD error;
WCHAR tempBuf[MAX_PATH + 1];
DWORD len = GetTempPathW(MAX_PATH, tempBuf);
/*
* Build the path in writable memory from the user-supplied pieces and
* some defaults. First, the parent temporary directory.
*/
if (dirObj) {
Tcl_GetString(dirObj);
if (dirObj->length < 1) {
goto useSystemTemp;
}
Tcl_WinUtfToTChar(Tcl_GetString(dirObj), -1, &base);
if (dirObj->bytes[dirObj->length - 1] != '\\') {
TclUtfToWCharDString("\\", -1, &base);
}
} else {
useSystemTemp:
Tcl_DStringInit(&base);
Tcl_DStringAppend(&base, (char *) tempBuf, len * sizeof(WCHAR));
}
/*
* Next, the base of the directory name.
*/
#define DEFAULT_TEMP_DIR_PREFIX "tcl"
#define SUFFIX_LENGTH 8
if (basenameObj) {
Tcl_WinUtfToTChar(Tcl_GetString(basenameObj), -1, &name);
TclDStringAppendDString(&base, &name);
Tcl_DStringFree(&name);
} else {
TclUtfToWCharDString(DEFAULT_TEMP_DIR_PREFIX, -1, &base);
}
TclUtfToWCharDString("_", -1, &base);
/*
* Now we keep on trying random suffixes until we get one that works
* (i.e., that doesn't trigger the ERROR_ALREADY_EXISTS error). Note that
* SUFFIX_LENGTH is longer than on Unix because we expect to be not on a
* case-sensitive filesystem.
*/
baseLen = Tcl_DStringLength(&base);
do {
char tempbuf[SUFFIX_LENGTH + 1];
int i;
static const char randChars[] =
"QWERTYUIOPASDFGHJKLZXCVBNM1234567890";
static const int numRandChars = sizeof(randChars) - 1;
/*
* Put a random suffix on the end.
*/
error = ERROR_SUCCESS;
tempbuf[SUFFIX_LENGTH] = '\0';
for (i = 0 ; i < SUFFIX_LENGTH; i++) {
tempbuf[i] = randChars[(int) (rand() % numRandChars)];
}
Tcl_DStringSetLength(&base, baseLen);
TclUtfToWCharDString(tempbuf, -1, &base);
} while (!CreateDirectoryW((LPCWSTR) Tcl_DStringValue(&base), NULL)
&& (error = GetLastError()) == ERROR_ALREADY_EXISTS);
/*
* Check for other errors. The big ones are ERROR_PATH_NOT_FOUND and
* ERROR_ACCESS_DENIED.
*/
if (error != ERROR_SUCCESS) {
TclWinConvertError(error);
Tcl_DStringFree(&base);
return NULL;
}
/*
* We actually made the directory, so we're done! Report what we made back
* as a (clean) Tcl_Obj.
*/
Tcl_WinTCharToUtf((LPCWSTR) Tcl_DStringValue(&base), -1, &name);
Tcl_DStringFree(&base);
return TclDStringToObj(&name);
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to win/tclWinFile.c.
| ︙ | ︙ | |||
152 153 154 155 156 157 158 | static time_t ToCTime(FILETIME fileTime); static void FromCTime(time_t posixTime, FILETIME *fileTime); /* * Declarations for local functions defined in this file: */ | | | | | | | | | | | | | | | | | | | | 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 |
static time_t ToCTime(FILETIME fileTime);
static void FromCTime(time_t posixTime, FILETIME *fileTime);
/*
* Declarations for local functions defined in this file:
*/
static int NativeAccess(const WCHAR *path, int mode);
static int NativeDev(const WCHAR *path);
static int NativeStat(const WCHAR *path, Tcl_StatBuf *statPtr,
int checkLinks);
static unsigned short NativeStatMode(DWORD attr, int checkLinks,
int isExec);
static int NativeIsExec(const WCHAR *path);
static int NativeReadReparse(const WCHAR *LinkDirectory,
REPARSE_DATA_BUFFER *buffer, DWORD desiredAccess);
static int NativeWriteReparse(const WCHAR *LinkDirectory,
REPARSE_DATA_BUFFER *buffer);
static int NativeMatchType(int isDrive, DWORD attr,
const WCHAR *nativeName, Tcl_GlobTypeData *types);
static int WinIsDrive(const char *name, size_t nameLen);
static int WinIsReserved(const char *path);
static Tcl_Obj * WinReadLink(const WCHAR *LinkSource);
static Tcl_Obj * WinReadLinkDirectory(const WCHAR *LinkDirectory);
static int WinLink(const WCHAR *LinkSource,
const WCHAR *LinkTarget, int linkAction);
static int WinSymLinkDirectory(const WCHAR *LinkDirectory,
const WCHAR *LinkTarget);
MODULE_SCOPE void tclWinDebugPanic(const char *format, ...);
/*
*--------------------------------------------------------------------
*
* WinLink --
*
* Make a link from source to target.
*
*--------------------------------------------------------------------
*/
static int
WinLink(
const WCHAR *linkSourcePath,
const WCHAR *linkTargetPath,
int linkAction)
{
WCHAR tempFileName[MAX_PATH];
WCHAR *tempFilePart;
DWORD attr;
/*
* Get the full path referenced by the target.
*/
if (!GetFullPathName(linkTargetPath, MAX_PATH, tempFileName,
|
| ︙ | ︙ | |||
302 303 304 305 306 307 308 | * What does 'LinkSource' point to? * *-------------------------------------------------------------------- */ static Tcl_Obj * WinReadLink( | | | | | 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 |
* What does 'LinkSource' point to?
*
*--------------------------------------------------------------------
*/
static Tcl_Obj *
WinReadLink(
const WCHAR *linkSourcePath)
{
WCHAR tempFileName[MAX_PATH];
WCHAR *tempFilePart;
DWORD attr;
/*
* Get the full path referenced by the target.
*/
if (!GetFullPathName(linkSourcePath, MAX_PATH, tempFileName,
|
| ︙ | ︙ | |||
366 367 368 369 370 371 372 | * Zero on success. * *-------------------------------------------------------------------- */ static int WinSymLinkDirectory( | | | | 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 |
* Zero on success.
*
*--------------------------------------------------------------------
*/
static int
WinSymLinkDirectory(
const WCHAR *linkDirPath,
const WCHAR *linkTargetPath)
{
DUMMY_REPARSE_BUFFER dummy;
REPARSE_DATA_BUFFER *reparseBuffer = (REPARSE_DATA_BUFFER *) &dummy;
int len;
WCHAR nativeTarget[MAX_PATH];
WCHAR *loop;
|
| ︙ | ︙ | |||
438 439 440 441 442 443 444 | * Zero on success. * *-------------------------------------------------------------------- */ int TclWinSymLinkCopyDirectory( | | | | 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 |
* Zero on success.
*
*--------------------------------------------------------------------
*/
int
TclWinSymLinkCopyDirectory(
const WCHAR *linkOrigPath, /* Existing junction - reparse point */
const WCHAR *linkCopyPath) /* Will become a duplicate junction */
{
DUMMY_REPARSE_BUFFER dummy;
REPARSE_DATA_BUFFER *reparseBuffer = (REPARSE_DATA_BUFFER *) &dummy;
if (NativeReadReparse(linkOrigPath, reparseBuffer, GENERIC_READ)) {
return -1;
}
|
| ︙ | ︙ | |||
469 470 471 472 473 474 475 | * Zero on success. * *-------------------------------------------------------------------- */ int TclWinSymLinkDelete( | | | 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 |
* Zero on success.
*
*--------------------------------------------------------------------
*/
int
TclWinSymLinkDelete(
const WCHAR *linkOrigPath,
int linkOnly)
{
/*
* It is a symbolic link - remove it.
*/
DUMMY_REPARSE_BUFFER dummy;
|
| ︙ | ︙ | |||
526 527 528 529 530 531 532 533 534 535 | * anything went wrong. * * In the future we should enhance this to return a path object rather * than a string. * *-------------------------------------------------------------------- */ static Tcl_Obj * WinReadLinkDirectory( | > > > > > | | 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 |
* anything went wrong.
*
* In the future we should enhance this to return a path object rather
* than a string.
*
*--------------------------------------------------------------------
*/
#if defined (__clang__) || ((__GNUC__) && ((__GNUC__ > 4) || ((__GNUC__ == 4) && (__GNUC_MINOR__ > 5))))
#pragma GCC diagnostic push
#pragma GCC diagnostic ignored "-Warray-bounds"
#endif
static Tcl_Obj *
WinReadLinkDirectory(
const WCHAR *linkDirPath)
{
int attr, len, offset;
DUMMY_REPARSE_BUFFER dummy;
REPARSE_DATA_BUFFER *reparseBuffer = (REPARSE_DATA_BUFFER *) &dummy;
Tcl_Obj *retVal;
Tcl_DString ds;
const char *copy;
|
| ︙ | ︙ | |||
563 564 565 566 567 568 569 | * There is an assumption in this code that 'wide' interfaces are * being used (see tclWin32Dll.c), which is true for the only systems * which support reparse tags at present. If that changes in the * future, this code will have to be generalised. */ offset = 0; | < | 568 569 570 571 572 573 574 575 576 577 578 579 580 581 |
* There is an assumption in this code that 'wide' interfaces are
* being used (see tclWin32Dll.c), which is true for the only systems
* which support reparse tags at present. If that changes in the
* future, this code will have to be generalised.
*/
offset = 0;
if (reparseBuffer->MountPointReparseBuffer.PathBuffer[0] == L'\\') {
/*
* Check whether this is a mounted volume.
*/
if (wcsncmp(reparseBuffer->MountPointReparseBuffer.PathBuffer,
L"\\??\\Volume{",11) == 0) {
|
| ︙ | ︙ | |||
625 626 627 628 629 630 631 | /* * Strip off the prefix. */ offset = 4; } } | < | | > > > > | | > | 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 |
/*
* Strip off the prefix.
*/
offset = 4;
}
}
Tcl_WinTCharToUtf(
reparseBuffer->MountPointReparseBuffer.PathBuffer,
reparseBuffer->MountPointReparseBuffer
.SubstituteNameLength, &ds);
copy = Tcl_DStringValue(&ds)+offset;
len = Tcl_DStringLength(&ds)-offset;
retVal = Tcl_NewStringObj(copy,len);
Tcl_IncrRefCount(retVal);
Tcl_DStringFree(&ds);
return retVal;
}
invalidError:
Tcl_SetErrno(EINVAL);
return NULL;
}
#if defined (__clang__) || ((__GNUC__) && ((__GNUC__ > 4) || ((__GNUC__ == 4) && (__GNUC_MINOR__ > 5))))
#pragma GCC diagnostic pop
#endif
/*
*--------------------------------------------------------------------
*
* NativeReadReparse --
*
* Read the junction/reparse information from a given NTFS directory.
*
* Assumption that linkDirPath is a valid, existing directory.
*
* Returns:
* Zero on success.
*
*--------------------------------------------------------------------
*/
static int
NativeReadReparse(
const WCHAR *linkDirPath, /* The junction to read */
REPARSE_DATA_BUFFER *buffer,/* Pointer to buffer. Cannot be NULL */
DWORD desiredAccess)
{
HANDLE hFile;
DWORD returnedLength;
hFile = CreateFile(linkDirPath, desiredAccess, FILE_SHARE_READ, NULL,
OPEN_EXISTING,
FILE_FLAG_OPEN_REPARSE_POINT | FILE_FLAG_BACKUP_SEMANTICS, NULL);
if (hFile == INVALID_HANDLE_VALUE) {
/*
* Error creating directory.
*/
|
| ︙ | ︙ | |||
718 719 720 721 722 723 724 | * Assumption that LinkDirectory does not exist. * *-------------------------------------------------------------------- */ static int NativeWriteReparse( | | | 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 |
* Assumption that LinkDirectory does not exist.
*
*--------------------------------------------------------------------
*/
static int
NativeWriteReparse(
const WCHAR *linkDirPath,
REPARSE_DATA_BUFFER *buffer)
{
HANDLE hFile;
DWORD returnedLength;
/*
* Create the directory - it must not already exist.
|
| ︙ | ︙ | |||
790 791 792 793 794 795 796 | * * Side effects: * None. * *---------------------------------------------------------------------- */ | | | | 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 |
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
void
tclWinDebugPanic(
const char *format, ...)
{
#define TCL_MAX_WARN_LEN 1024
va_list argList;
char buf[TCL_MAX_WARN_LEN * 3];
WCHAR msgString[TCL_MAX_WARN_LEN];
va_start(argList, format);
vsnprintf(buf, sizeof(buf), format, argList);
msgString[TCL_MAX_WARN_LEN-1] = L'\0';
MultiByteToWideChar(CP_UTF8, 0, buf, -1, msgString, TCL_MAX_WARN_LEN);
|
| ︙ | ︙ | |||
820 821 822 823 824 825 826 |
if (IsDebuggerPresent()) {
OutputDebugStringW(msgString);
} else {
MessageBeep(MB_ICONEXCLAMATION);
MessageBoxW(NULL, msgString, L"Fatal Error",
MB_ICONSTOP | MB_OK | MB_TASKMODAL | MB_SETFOREGROUND);
}
| < < < < < < < < < < | | 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 |
if (IsDebuggerPresent()) {
OutputDebugStringW(msgString);
} else {
MessageBeep(MB_ICONEXCLAMATION);
MessageBoxW(NULL, msgString, L"Fatal Error",
MB_ICONSTOP | MB_OK | MB_TASKMODAL | MB_SETFOREGROUND);
}
}
/*
*---------------------------------------------------------------------------
*
* TclpFindExecutable --
*
* This function computes the absolute path name of the current
* application.
|
| ︙ | ︙ | |||
855 856 857 858 859 860 861 |
void
TclpFindExecutable(
const char *argv0) /* If NULL, install PanicMessageBox, otherwise
* ignore. */
{
WCHAR wName[MAX_PATH];
| | < < < < < < < < < < < < < < < < < < < | 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 |
void
TclpFindExecutable(
const char *argv0) /* If NULL, install PanicMessageBox, otherwise
* ignore. */
{
WCHAR wName[MAX_PATH];
char name[MAX_PATH * 3];
GetModuleFileNameW(NULL, wName, MAX_PATH);
WideCharToMultiByte(CP_UTF8, 0, wName, -1, name, sizeof(name), NULL, NULL);
TclWinNoBackslash(name);
TclSetObjNameOfExecutable(Tcl_NewStringObj(name, -1), NULL);
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
911 912 913 914 915 916 917 |
Tcl_Obj *resultPtr, /* List object to lappend 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. */
{
| | > | | | 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 |
Tcl_Obj *resultPtr, /* List object to lappend 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 WCHAR *native;
if (types != NULL && types->type == TCL_GLOB_TYPE_MOUNT) {
/*
* The native filesystem never adds mounts.
*/
return TCL_OK;
}
if (pattern == NULL || (*pattern == '\0')) {
Tcl_Obj *norm = Tcl_FSGetNormalizedPath(NULL, pathPtr);
if (norm != NULL) {
/*
* Match a single file directly.
*/
DWORD attr;
WIN32_FILE_ATTRIBUTE_DATA data;
size_t length = 0;
const char *str = TclGetStringFromObj(norm, &length);
native = Tcl_FSGetNativePath(pathPtr);
if (GetFileAttributesEx(native,
GetFileExInfoStandard, &data) != TRUE) {
return TCL_OK;
}
attr = data.dwFileAttributes;
if (NativeMatchType(WinIsDrive(str, length), attr, native, types)) {
Tcl_ListObjAppendElement(interp, resultPtr, pathPtr);
}
}
return TCL_OK;
} else {
DWORD attr;
HANDLE handle;
|
| ︙ | ︙ | |||
991 992 993 994 995 996 997 | /* * Build up the directory name for searching, including a trailing * directory separator. */ Tcl_DStringInit(&dsOrig); | | < | 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 |
/*
* Build up the directory name for searching, including a trailing
* directory separator.
*/
Tcl_DStringInit(&dsOrig);
dirName = TclGetStringFromObj(fileNamePtr, &dirLength);
Tcl_DStringAppend(&dsOrig, dirName, dirLength);
lastChar = dirName[dirLength -1];
if ((lastChar != '\\') && (lastChar != '/') && (lastChar != ':')) {
TclDStringAppendLiteral(&dsOrig, "/");
dirLength++;
}
|
| ︙ | ︙ | |||
1311 1312 1313 1314 1315 1316 1317 |
*/
static int
NativeMatchType(
int isDrive, /* Is this a drive. */
DWORD attr, /* We already know the attributes for the
* file. */
| | | 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 |
*/
static int
NativeMatchType(
int isDrive, /* Is this a drive. */
DWORD attr, /* We already know the attributes for the
* file. */
const WCHAR *nativeName, /* Native path to check. */
Tcl_GlobTypeData *types) /* Type description to match against. */
{
/*
* 'attr' represents the attributes of the file, but we only want to
* retrieve this info if it is absolutely necessary because it is an
* expensive call. Unfortunately, to deal with hidden files properly, we
* must always retrieve it.
|
| ︙ | ︙ | |||
1432 1433 1434 1435 1436 1437 1438 |
const char *
TclpGetUserHome(
const char *name, /* User name for desired home directory. */
Tcl_DString *bufferPtr) /* Uninitialized or free DString filled with
* name of user's home directory. */
{
| | | | | | > | | > > > > > > > > > > > > > > > > > > > > > | | | | | > > > > > > > > > > > > > > > > > > > > > > > | | | < < < | | | > > > > > > > > > > | 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 |
const char *
TclpGetUserHome(
const char *name, /* User name for desired home directory. */
Tcl_DString *bufferPtr) /* Uninitialized or free DString filled with
* name of user's home directory. */
{
char *result = NULL;
USER_INFO_1 *uiPtr;
Tcl_DString ds;
int nameLen = -1;
int rc = 0;
const char *domain;
WCHAR *wName, *wHomeDir, *wDomain;
WCHAR buf[MAX_PATH];
Tcl_DStringInit(bufferPtr);
wDomain = NULL;
domain = Tcl_UtfFindFirst(name, '@');
if (domain == NULL) {
const char *ptr;
/*
* No domain. Firstly check it's the current user
*/
ptr = TclpGetUserName(&ds);
if (ptr != NULL && strcasecmp(name, ptr) == 0) {
/*
* Try safest and fastest way to get current user home
*/
ptr = TclGetEnv("HOME", &ds);
if (ptr != NULL) {
Tcl_JoinPath(1, &ptr, bufferPtr);
rc = 1;
result = Tcl_DStringValue(bufferPtr);
}
}
Tcl_DStringFree(&ds);
} else {
Tcl_DStringInit(&ds);
wName = TclUtfToWCharDString(domain + 1, -1, &ds);
rc = NetGetDCName(NULL, wName, (LPBYTE *) &wDomain);
Tcl_DStringFree(&ds);
nameLen = domain - name;
}
if (rc == 0) {
Tcl_DStringInit(&ds);
wName = TclUtfToWCharDString(name, nameLen, &ds);
while (NetUserGetInfo(wDomain, wName, 1, (LPBYTE *) &uiPtr) != 0) {
/*
* User does not exist; if domain was not specified, try again
* using current domain.
*/
rc = 1;
if (domain != NULL) {
break;
}
/*
* Get current domain
*/
rc = NetGetDCName(NULL, NULL, (LPBYTE *) &wDomain);
if (rc != 0) {
break;
}
domain = INT2PTR(-1); /* repeat once */
}
if (rc == 0) {
DWORD i, size = MAX_PATH;
wHomeDir = uiPtr->usri1_home_dir;
if ((wHomeDir != NULL) && (wHomeDir[0] != L'\0')) {
size = lstrlenW(wHomeDir);
TclWCharToUtfDString(wHomeDir, size, bufferPtr);
} else {
/*
* User exists but has no home dir. Return
* "{GetProfilesDirectory}/<user>".
*/
GetProfilesDirectoryW(buf, &size);
TclWCharToUtfDString(buf, size-1, bufferPtr);
Tcl_DStringAppend(bufferPtr, "/", 1);
Tcl_DStringAppend(bufferPtr, name, nameLen);
}
result = Tcl_DStringValue(bufferPtr);
/*
* Be sure we return normalized path
*/
for (i = 0; i < size; ++i) {
if (result[i] == '\\') {
result[i] = '/';
}
}
NetApiBufferFree((void *) uiPtr);
}
Tcl_DStringFree(&ds);
}
if (wDomain != NULL) {
NetApiBufferFree((void *) wDomain);
}
|
| ︙ | ︙ | |||
1530 1531 1532 1533 1534 1535 1536 | * See access documentation. * *--------------------------------------------------------------------------- */ static int NativeAccess( | | | 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 |
* See access documentation.
*
*---------------------------------------------------------------------------
*/
static int
NativeAccess(
const WCHAR *nativePath, /* Path of file to access, native encoding. */
int mode) /* Permission setting. */
{
DWORD attr;
attr = GetFileAttributes(nativePath);
if (attr == INVALID_FILE_ATTRIBUTES) {
|
| ︙ | ︙ | |||
1557 1558 1559 1560 1561 1562 1563 |
/*
* File exists, nothing else to check.
*/
return 0;
}
| > > > | < | | | | | > > > > > > > > > > > > > > > > > > > > > > > | < | > > | | > > | > > > > > > > > < < > > | | | > > > > > > < | 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 |
/*
* File exists, nothing else to check.
*/
return 0;
}
/*
* If it's not a directory (assume file), do several fast checks:
*/
if (!(attr & FILE_ATTRIBUTE_DIRECTORY)) {
/*
* If the attributes say this is not writable at all. The file is a
* regular file (i.e., not a directory), then the file is not
* writable, full stop. For directories, the read-only bit is
* (mostly) ignored by Windows, so we can't ascertain anything about
* directory access from the attrib data. However, if we have the
* advanced 'getFileSecurityProc', then more robust ACL checks will be
* done below.
*/
if ((mode & W_OK) && (attr & FILE_ATTRIBUTE_READONLY)) {
Tcl_SetErrno(EACCES);
return -1;
}
/*
* If doesn't have the correct extension, it can't be executable
*/
if ((mode & X_OK) && !NativeIsExec(nativePath)) {
Tcl_SetErrno(EACCES);
return -1;
}
/*
* Special case for read/write/executable check on file
*/
if ((mode & (R_OK|W_OK|X_OK)) && !(mode & ~(R_OK|W_OK|X_OK))) {
DWORD mask = 0;
HANDLE hFile;
if (mode & R_OK) {
mask |= GENERIC_READ;
}
if (mode & W_OK) {
mask |= GENERIC_WRITE;
}
if (mode & X_OK) {
mask |= GENERIC_EXECUTE;
}
hFile = CreateFile(nativePath, mask,
FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE,
NULL, OPEN_EXISTING, FILE_FLAG_NO_BUFFERING, NULL);
if (hFile != INVALID_HANDLE_VALUE) {
CloseHandle(hFile);
return 0;
}
/*
* Fast exit if access was denied
*/
if (GetLastError() == ERROR_ACCESS_DENIED) {
Tcl_SetErrno(EACCES);
return -1;
}
}
/*
* We cannnot verify the access fast, check it below using security
* info.
*/
}
/*
* It looks as if the permissions are ok, but if we are on NT, 2000 or XP,
* we have a more complex permissions structure so we try to check that.
* The code below is remarkably complex for such a simple thing as finding
* what permissions the OS has set for a file.
*/
{
SECURITY_DESCRIPTOR *sdPtr = NULL;
unsigned long size;
PSID pSid = 0;
BOOL SidDefaulted;
SID_IDENTIFIER_AUTHORITY samba_unmapped = {{0, 0, 0, 0, 0, 22}};
GENERIC_MAPPING genMap;
|
| ︙ | ︙ | |||
1756 1757 1758 1759 1760 1761 1762 |
CloseHandle(hToken);
if (!accessYesNo) {
Tcl_SetErrno(EACCES);
return -1;
}
}
| < | | > | | | | > | 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 |
CloseHandle(hToken);
if (!accessYesNo) {
Tcl_SetErrno(EACCES);
return -1;
}
}
return 0;
}
/*
*----------------------------------------------------------------------
*
* NativeIsExec --
*
* Determines if a path is executable. On windows this is simply defined
* by whether the path ends in a standard executable extension.
*
* Results:
* 1 = executable, 0 = not.
*
*----------------------------------------------------------------------
*/
static int
NativeIsExec(
const WCHAR *path)
{
int len = wcslen(path);
if (len < 5) {
return 0;
}
if (path[len-4] != '.') {
return 0;
}
path += len-3;
if ((wcsicmp(path, L"exe") == 0)
|| (wcsicmp(path, L"com") == 0)
|| (wcsicmp(path, L"cmd") == 0)
|| (wcsicmp(path, L"cmd") == 0)
|| (wcsicmp(path, L"bat") == 0)) {
return 1;
}
return 0;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
1818 1819 1820 1821 1822 1823 1824 |
*/
int
TclpObjChdir(
Tcl_Obj *pathPtr) /* Path to new working directory. */
{
int result;
| | | 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 |
*/
int
TclpObjChdir(
Tcl_Obj *pathPtr) /* Path to new working directory. */
{
int result;
const WCHAR *nativePath;
nativePath = Tcl_FSGetNativePath(pathPtr);
if (!nativePath) {
return -1;
}
result = SetCurrentDirectory(nativePath);
|
| ︙ | ︙ | |||
1862 1863 1864 1865 1866 1867 1868 |
const char *
TclpGetCwd(
Tcl_Interp *interp, /* If non-NULL, used for error reporting. */
Tcl_DString *bufferPtr) /* Uninitialized or free DString filled with
* name of current directory. */
{
| | | 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 |
const char *
TclpGetCwd(
Tcl_Interp *interp, /* If non-NULL, used for error reporting. */
Tcl_DString *bufferPtr) /* Uninitialized or free DString filled with
* name of current directory. */
{
WCHAR buffer[MAX_PATH];
char *p;
WCHAR *native;
if (GetCurrentDirectory(MAX_PATH, buffer) == 0) {
TclWinConvertError(GetLastError());
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
|
| ︙ | ︙ | |||
1885 1886 1887 1888 1889 1890 1891 |
*/
native = (WCHAR *) buffer;
if ((native[0] != '\0') && (native[1] == ':')
&& (native[2] == '\\') && (native[3] == '\\')) {
native += 2;
}
| | | 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 |
*/
native = (WCHAR *) buffer;
if ((native[0] != '\0') && (native[1] == ':')
&& (native[2] == '\\') && (native[3] == '\\')) {
native += 2;
}
Tcl_WinTCharToUtf(native, -1, bufferPtr);
/*
* Convert to forward slashes for easier use in scripts.
*/
for (p = Tcl_DStringValue(bufferPtr); *p != '\0'; p++) {
if (*p == '\\') {
|
| ︙ | ︙ | |||
1940 1941 1942 1943 1944 1945 1946 | * See stat documentation. * *---------------------------------------------------------------------- */ static int NativeStat( | | | | | | | | < | > > > | > > | 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 |
* See stat documentation.
*
*----------------------------------------------------------------------
*/
static int
NativeStat(
const WCHAR *nativePath, /* Path of file to stat */
Tcl_StatBuf *statPtr, /* Filled with results of stat call. */
int checkLinks) /* If non-zero, behave like 'lstat' */
{
DWORD attr;
int dev, nlink = 1;
unsigned short mode;
unsigned int inode = 0;
HANDLE fileHandle;
DWORD fileType = FILE_TYPE_UNKNOWN;
/*
* If we can use 'createFile' on this, then we can use the resulting
* fileHandle to read more information (nlink, ino) than we can get from
* other attributes reading APIs. If not, then we try to fall back on the
* 'getFileAttributesExProc', and if that isn't available, then on even
* simpler routines.
*
* Special consideration must be given to Windows hardcoded names like
* CON, NULL, COM1, LPT1 etc. For these, we still need to do the
* CreateFile as some may not exist (e.g. there is no CON in wish by
* default). However the subsequent GetFileInformationByHandle will
* fail. We do a WinIsReserved to see if it is one of the special names,
* and if successful, mock up a BY_HANDLE_FILE_INFORMATION structure.
*/
fileHandle = CreateFile(nativePath, GENERIC_READ,
FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE,
NULL, OPEN_EXISTING,
FILE_FLAG_BACKUP_SEMANTICS | FILE_FLAG_OPEN_REPARSE_POINT, NULL);
if (fileHandle != INVALID_HANDLE_VALUE) {
BY_HANDLE_FILE_INFORMATION data;
if (GetFileInformationByHandle(fileHandle,&data) != TRUE) {
fileType = GetFileType(fileHandle);
CloseHandle(fileHandle);
if (fileType != FILE_TYPE_CHAR && fileType != FILE_TYPE_DISK) {
Tcl_SetErrno(ENOENT);
return -1;
}
/*
* Mock up the expected structure
*/
memset(&data, 0, sizeof(data));
statPtr->st_atime = 0;
statPtr->st_mtime = 0;
statPtr->st_ctime = 0;
} else {
CloseHandle(fileHandle);
statPtr->st_atime = ToCTime(data.ftLastAccessTime);
|
| ︙ | ︙ | |||
2080 2081 2082 2083 2084 2085 2086 | * Calculate just the 'st_dev' field of a 'stat' structure. * *---------------------------------------------------------------------- */ static int NativeDev( | | | | | | 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 |
* Calculate just the 'st_dev' field of a 'stat' structure.
*
*----------------------------------------------------------------------
*/
static int
NativeDev(
const WCHAR *nativePath) /* Full path of file to stat */
{
int dev;
Tcl_DString ds;
WCHAR nativeFullPath[MAX_PATH];
WCHAR *nativePart;
const char *fullPath;
GetFullPathName(nativePath, MAX_PATH, nativeFullPath, &nativePart);
fullPath = Tcl_WinTCharToUtf(nativeFullPath, -1, &ds);
if ((fullPath[0] == '\\') && (fullPath[1] == '\\')) {
const char *p;
DWORD dw;
const WCHAR *nativeVol;
Tcl_DString volString;
p = strchr(fullPath + 2, '\\');
p = strchr(p + 1, '\\');
if (p == NULL) {
/*
* Add terminating backslash to fullpath or GetVolumeInformation()
|
| ︙ | ︙ | |||
2256 2257 2258 2259 2260 2261 2262 |
*----------------------------------------------------------------------
*/
ClientData
TclpGetNativeCwd(
ClientData clientData)
{
| | | | 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 |
*----------------------------------------------------------------------
*/
ClientData
TclpGetNativeCwd(
ClientData clientData)
{
WCHAR buffer[MAX_PATH];
if (GetCurrentDirectory(MAX_PATH, buffer) == 0) {
TclWinConvertError(GetLastError());
return NULL;
}
if (clientData != NULL) {
if (wcscmp((const WCHAR *) clientData, buffer) == 0) {
return clientData;
}
}
return TclNativeDupInternalRep(buffer);
}
|
| ︙ | ︙ | |||
2305 2306 2307 2308 2309 2310 2311 |
TclpObjLink(
Tcl_Obj *pathPtr,
Tcl_Obj *toPtr,
int linkAction)
{
if (toPtr != NULL) {
int res;
| | | | | 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 |
TclpObjLink(
Tcl_Obj *pathPtr,
Tcl_Obj *toPtr,
int linkAction)
{
if (toPtr != NULL) {
int res;
const WCHAR *LinkTarget;
const WCHAR *LinkSource = Tcl_FSGetNativePath(pathPtr);
Tcl_Obj *normalizedToPtr = Tcl_FSGetNormalizedPath(NULL, toPtr);
if (normalizedToPtr == NULL) {
return NULL;
}
LinkTarget = Tcl_FSGetNativePath(normalizedToPtr);
if (LinkSource == NULL || LinkTarget == NULL) {
return NULL;
}
res = WinLink(LinkSource, LinkTarget, linkAction);
if (res == 0) {
return toPtr;
} else {
return NULL;
}
} else {
const WCHAR *LinkSource = Tcl_FSGetNativePath(pathPtr);
if (LinkSource == NULL) {
return NULL;
}
return WinReadLink(LinkSource);
}
}
|
| ︙ | ︙ | |||
2359 2360 2361 2362 2363 2364 2365 |
Tcl_Obj *
TclpFilesystemPathType(
Tcl_Obj *pathPtr)
{
#define VOL_BUF_SIZE 32
int found;
| | | | 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 |
Tcl_Obj *
TclpFilesystemPathType(
Tcl_Obj *pathPtr)
{
#define VOL_BUF_SIZE 32
int found;
WCHAR volType[VOL_BUF_SIZE];
char *firstSeparator;
const char *path;
Tcl_Obj *normPath = Tcl_FSGetNormalizedPath(NULL, pathPtr);
if (normPath == NULL) {
return NULL;
}
path = TclGetString(normPath);
if (path == NULL) {
return NULL;
}
firstSeparator = strchr(path, '/');
if (firstSeparator == NULL) {
found = GetVolumeInformation(Tcl_FSGetNativePath(pathPtr),
|
| ︙ | ︙ | |||
2445 2446 2447 2448 2449 2450 2451 |
Tcl_DString dsNorm; /* This will hold the normalized string. */
char *path, *currentPathEndPosition;
Tcl_Obj *temp = NULL;
int isDrive = 1;
Tcl_DString ds; /* Some workspace. */
Tcl_DStringInit(&dsNorm);
| | | | 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 |
Tcl_DString dsNorm; /* This will hold the normalized string. */
char *path, *currentPathEndPosition;
Tcl_Obj *temp = NULL;
int isDrive = 1;
Tcl_DString ds; /* Some workspace. */
Tcl_DStringInit(&dsNorm);
path = TclGetString(pathPtr);
currentPathEndPosition = path + nextCheckpoint;
if (*currentPathEndPosition == '/') {
currentPathEndPosition++;
}
while (1) {
char cur = *currentPathEndPosition;
if ((cur=='/' || cur==0) && (path != currentPathEndPosition)) {
/*
* Reached directory separator, or end of string.
*/
WIN32_FILE_ATTRIBUTE_DATA data;
const WCHAR *nativePath = Tcl_WinUtfToTChar(path,
currentPathEndPosition - path, &ds);
if (GetFileAttributesEx(nativePath,
GetFileExInfoStandard, &data) != TRUE) {
/*
* File doesn't exist.
*/
|
| ︙ | ︙ | |||
2492 2493 2494 2495 2496 2497 2498 |
}
}
Tcl_DStringAppend(&dsNorm,
(const char *)nativePath,
(int)(sizeof(WCHAR) * len));
lastValidPathEnd = currentPathEndPosition;
} else if (nextCheckpoint == 0) {
| > | | | > | | | | | < | | | | | | | | 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 |
}
}
Tcl_DStringAppend(&dsNorm,
(const char *)nativePath,
(int)(sizeof(WCHAR) * len));
lastValidPathEnd = currentPathEndPosition;
} else if (nextCheckpoint == 0) {
/*
* Path starts with a drive designation that's not
* actually on the system. We still must normalize up
* past the first separator. [Bug 3603434]
*/
currentPathEndPosition++;
}
}
Tcl_DStringFree(&ds);
break;
}
/*
* File 'nativePath' does exist if we get here. We now want to
* check if it is a symlink and otherwise continue with the
* rest of the path.
*/
/*
* Check for symlinks, except at last component of path (we don't
* follow final symlinks). Also a drive (C:/) for example, may
* sometimes have the reparse flag set for some reason I don't
* understand. We therefore don't perform this check for drives.
*/
if (cur != 0 && !isDrive &&
data.dwFileAttributes & FILE_ATTRIBUTE_REPARSE_POINT){
Tcl_Obj *to = WinReadLinkDirectory(nativePath);
if (to != NULL) {
/*
* Read the reparse point ok. Now, reparse points need not
* be normalized, otherwise we could use:
*
* Tcl_GetStringFromObj(to, &pathLen);
* nextCheckpoint = pathLen;
*
* So, instead we have to start from the beginning.
*/
nextCheckpoint = 0;
Tcl_AppendToObj(to, currentPathEndPosition, -1);
/*
* Convert link to forward slashes.
*/
for (path = TclGetString(to); *path != 0; path++) {
if (*path == '\\') {
*path = '/';
}
}
path = TclGetString(to);
currentPathEndPosition = path + nextCheckpoint;
if (temp != NULL) {
Tcl_DecrRefCount(temp);
}
temp = to;
/*
* Reset variables so we can restart normalization.
*/
isDrive = 1;
Tcl_DStringFree(&dsNorm);
Tcl_DStringFree(&ds);
continue;
}
}
#ifndef TclNORM_LONG_PATH
/*
* Now we convert the tail of the current path to its 'long form',
* and append it to 'dsNorm' which holds the current normalized
* path
*/
if (isDrive) {
WCHAR drive = ((WCHAR *) nativePath)[0];
if (drive >= L'a') {
drive -= (L'a' - L'A');
|
| ︙ | ︙ | |||
2595 2596 2597 2598 2599 2600 2601 |
checkDots++;
}
}
if (checkDots != NULL) {
int dotLen = currentPathEndPosition-lastValidPathEnd;
/*
| | | | | | | | < | 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 |
checkDots++;
}
}
if (checkDots != NULL) {
int dotLen = currentPathEndPosition-lastValidPathEnd;
/*
* Path is just dots. We shouldn't really ever see a path
* like that. However, to be nice we at least don't mangle
* the path - we just add the dots as a path segment and
* continue.
*/
Tcl_DStringAppend(&dsNorm, ((const char *)nativePath)
+ Tcl_DStringLength(&ds)
- (dotLen * sizeof(WCHAR)),
dotLen * sizeof(WCHAR));
} else {
/*
* Normal path.
*/
WIN32_FIND_DATAW fData;
HANDLE handle;
handle = FindFirstFileW((WCHAR *) nativePath, &fData);
if (handle == INVALID_HANDLE_VALUE) {
/*
* This is usually the '/' in 'c:/' at end of string.
*/
Tcl_DStringAppend(&dsNorm, (const char *) L"/",
sizeof(WCHAR));
} else {
WCHAR *nativeName;
|
| ︙ | ︙ | |||
2647 2648 2649 2650 2651 2652 2653 |
Tcl_DStringFree(&ds);
lastValidPathEnd = currentPathEndPosition;
if (cur == 0) {
break;
}
/*
| | | | | | 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 |
Tcl_DStringFree(&ds);
lastValidPathEnd = currentPathEndPosition;
if (cur == 0) {
break;
}
/*
* If we get here, we've got past one directory delimiter, so we
* know it is no longer a drive.
*/
isDrive = 0;
}
currentPathEndPosition++;
#ifdef TclNORM_LONG_PATH
/*
* Convert the entire known path to long form.
*/
if (1) {
WCHAR wpath[MAX_PATH];
const WCHAR *nativePath =
Tcl_WinUtfToTChar(path, lastValidPathEnd - path, &ds);
DWORD wpathlen = GetLongPathNameProc(nativePath,
(WCHAR *) wpath, MAX_PATH);
/*
* We have to make the drive letter uppercase.
*/
if (wpath[0] >= L'a') {
wpath[0] -= (L'a' - L'A');
|
| ︙ | ︙ | |||
2693 2694 2695 2696 2697 2698 2699 |
if (lastValidPathEnd != NULL) {
/*
* Concatenate the normalized string in dsNorm with the tail of the
* path which we didn't recognise. The string in dsNorm is in the
* native encoding, so we have to convert it to Utf.
*/
| | > | | | 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 |
if (lastValidPathEnd != NULL) {
/*
* Concatenate the normalized string in dsNorm with the tail of the
* path which we didn't recognise. The string in dsNorm is in the
* native encoding, so we have to convert it to Utf.
*/
Tcl_WinTCharToUtf((const WCHAR *) Tcl_DStringValue(&dsNorm),
Tcl_DStringLength(&dsNorm), &ds);
nextCheckpoint = Tcl_DStringLength(&ds);
if (*lastValidPathEnd != 0) {
/*
* Not the end of the string.
*/
char *path;
Tcl_Obj *tmpPathPtr;
size_t length;
tmpPathPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds),
nextCheckpoint);
Tcl_AppendToObj(tmpPathPtr, lastValidPathEnd, -1);
path = TclGetStringFromObj(tmpPathPtr, &length);
Tcl_SetStringObj(pathPtr, path, length);
Tcl_DecrRefCount(tmpPathPtr);
} else {
/*
* End of string was reached above.
*/
Tcl_SetStringObj(pathPtr, Tcl_DStringValue(&ds), nextCheckpoint);
|
| ︙ | ︙ | |||
2776 2777 2778 2779 2780 2781 2782 |
if (path[0] == '/') {
/*
* Path of form /foo/bar which is a path in the root directory of the
* current volume.
*/
| | > | < | 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 |
if (path[0] == '/') {
/*
* Path of form /foo/bar which is a path in the root directory of the
* current volume.
*/
const char *drive = TclGetString(useThisCwd);
absolutePath = Tcl_NewStringObj(drive,2);
Tcl_AppendToObj(absolutePath, path, -1);
Tcl_IncrRefCount(absolutePath);
/*
* We have a refCount on the cwd.
*/
} else {
/*
* Path of form C:foo/bar, but this only makes sense if the cwd is
* also on drive C.
*/
size_t cwdLen;
const char *drive = TclGetStringFromObj(useThisCwd, &cwdLen);
char drive_cur = path[0];
if (drive_cur >= 'a') {
drive_cur -= ('a' - 'A');
}
if (drive[0] == drive_cur) {
absolutePath = Tcl_DuplicateObj(useThisCwd);
|
| ︙ | ︙ | |||
2865 2866 2867 2868 2869 2870 2871 |
Tcl_Obj *
TclpNativeToNormalized(
ClientData clientData)
{
Tcl_DString ds;
Tcl_Obj *objPtr;
| | | | 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 |
Tcl_Obj *
TclpNativeToNormalized(
ClientData clientData)
{
Tcl_DString ds;
Tcl_Obj *objPtr;
size_t len;
char *copy, *p;
Tcl_WinTCharToUtf((const WCHAR *) clientData, -1, &ds);
copy = Tcl_DStringValue(&ds);
len = Tcl_DStringLength(&ds);
/*
* Certain native path representations on Windows have this special prefix
* to indicate that they are to be treated specially. For example
* extremely long paths, or symlinks.
|
| ︙ | ︙ | |||
2941 2942 2943 2944 2945 2946 2947 |
* shorter so the utf-to-external conversion will be somewhat faster).
*/
validPathPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr);
if (validPathPtr == NULL) {
return NULL;
}
| > > | > > > > | > > > < | | > | > > > > | > > > | | > > > > | > > | | > > | | | | > | > | | < | | | | > | | > | | > | | > | | | | | > | | | > < | 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 |
* shorter so the utf-to-external conversion will be somewhat faster).
*/
validPathPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr);
if (validPathPtr == NULL) {
return NULL;
}
/*
* refCount of validPathPtr was already incremented in
* Tcl_FSGetTranslatedPath
*/
} else {
/*
* Make sure the normalized path is set.
*/
validPathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
if (validPathPtr == NULL) {
return NULL;
}
/*
* validPathPtr returned from Tcl_FSGetNormalizedPath is owned by Tcl,
* so incr refCount here
*/
Tcl_IncrRefCount(validPathPtr);
}
str = TclGetStringFromObj(validPathPtr, &len);
if (strlen(str) != len) {
/*
* String contains NUL-bytes. This is invalid.
*/
goto done;
}
/*
* For a reserved device, strip a possible postfix ':'
*/
len = WinIsReserved(str);
if (len == 0) {
/*
* Let MultiByteToWideChar check for other invalid sequences, like
* 0xC0 0x80 (== overlong NUL). See bug [3118489]: NUL in filenames
*/
len = MultiByteToWideChar(CP_UTF8, MB_ERR_INVALID_CHARS, str, -1, 0, 0);
if (len==0) {
goto done;
}
}
/*
* Overallocate 6 chars, making some room for extended paths
*/
wp = nativePathPtr = Tcl_Alloc((len + 6) * sizeof(WCHAR));
if (nativePathPtr==0) {
goto done;
}
MultiByteToWideChar(CP_UTF8, MB_ERR_INVALID_CHARS, str, -1, nativePathPtr,
len + 1);
/*
* If path starts with "//?/" or "\\?\" (extended path), translate any
* slashes to backslashes but leave the '?' intact
*/
if ((str[0] == '\\' || str[0] == '/') && (str[1] == '\\' || str[1] == '/')
&& str[2] == '?' && (str[3] == '\\' || str[3] == '/')) {
wp[0] = wp[1] = wp[3] = '\\';
str += 4;
wp += 4;
}
/*
* If there is no "\\?\" prefix but there is a drive or UNC path prefix
* and the path is larger than MAX_PATH chars, no Win32 API function can
* handle that unless it is prefixed with the extended path prefix. See:
* <http://msdn.microsoft.com/en-us/library/aa365247(VS.85).aspx#maxpath>
*/
if (((str[0] >= 'A' && str[0] <= 'Z') || (str[0] >= 'a' && str[0] <= 'z'))
&& str[1] == ':') {
if (wp == nativePathPtr && len > MAX_PATH
&& (str[2] == '\\' || str[2] == '/')) {
memmove(wp + 4, wp, len * sizeof(WCHAR));
memcpy(wp, L"\\\\?\\", 4 * sizeof(WCHAR));
wp += 4;
}
/*
* If (remainder of) path starts with "<drive>:", leave the ':'
* intact.
*/
wp += 2;
} else if (wp == nativePathPtr && len > MAX_PATH
&& (str[0] == '\\' || str[0] == '/')
&& (str[1] == '\\' || str[1] == '/') && str[2] != '?') {
memmove(wp + 6, wp, len * sizeof(WCHAR));
memcpy(wp, L"\\\\?\\UNC", 7 * sizeof(WCHAR));
wp += 7;
}
/*
* In the remainder of the path, translate invalid characters to
* characters in the Unicode private use area.
*/
while (*wp != '\0') {
if ((*wp < ' ') || wcschr(L"\"*:<>?|", *wp)) {
*wp |= 0xF000;
} else if (*wp == '/') {
*wp = '\\';
}
++wp;
}
done:
TclDecrRefCount(validPathPtr);
return nativePathPtr;
}
/*
*---------------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
3061 3062 3063 3064 3065 3066 3067 |
char *copy;
size_t len;
if (clientData == NULL) {
return NULL;
}
| | | | 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 |
char *copy;
size_t len;
if (clientData == NULL) {
return NULL;
}
len = sizeof(WCHAR) * (wcslen((const WCHAR *) clientData) + 1);
copy = Tcl_Alloc(len);
memcpy(copy, clientData, len);
return copy;
}
/*
*---------------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
3092 3093 3094 3095 3096 3097 3098 |
int
TclpUtime(
Tcl_Obj *pathPtr, /* File to modify */
struct utimbuf *tval) /* New modification date structure */
{
int res = 0;
HANDLE fileHandle;
| | | 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 |
int
TclpUtime(
Tcl_Obj *pathPtr, /* File to modify */
struct utimbuf *tval) /* New modification date structure */
{
int res = 0;
HANDLE fileHandle;
const WCHAR *native;
DWORD attr = 0;
DWORD flags = FILE_ATTRIBUTE_NORMAL;
FILETIME lastAccessTime, lastModTime;
FromCTime(tval->actime, &lastAccessTime);
FromCTime(tval->modtime, &lastModTime);
|
| ︙ | ︙ | |||
3143 3144 3145 3146 3147 3148 3149 |
*---------------------------------------------------------------------------
*/
int
TclWinFileOwned(
Tcl_Obj *pathPtr) /* File whose ownership is to be checked */
{
| | | | > | | > > | | | | > > | > > | > | > > | > | | > | | 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 |
*---------------------------------------------------------------------------
*/
int
TclWinFileOwned(
Tcl_Obj *pathPtr) /* File whose ownership is to be checked */
{
const WCHAR *native;
PSID ownerSid = NULL;
PSECURITY_DESCRIPTOR secd = NULL;
HANDLE token;
LPBYTE buf = NULL;
DWORD bufsz;
int owned = 0;
native = Tcl_FSGetNativePath(pathPtr);
if (GetNamedSecurityInfo((LPTSTR) native, SE_FILE_OBJECT,
OWNER_SECURITY_INFORMATION, &ownerSid, NULL, NULL, NULL,
&secd) != ERROR_SUCCESS) {
/*
* Either not a file, or we do not have access to it in which case we
* are in all likelihood not the owner.
*/
return 0;
}
/*
* Getting the current process SID is a multi-step process. We make the
* assumption that if a call fails, this process is so underprivileged it
* could not possibly own anything. Normally a process can *always* look
* up its own token.
*/
if (OpenProcessToken(GetCurrentProcess(), TOKEN_QUERY, &token)) {
/*
* Find out how big the buffer needs to be.
*/
bufsz = 0;
GetTokenInformation(token, TokenUser, NULL, 0, &bufsz);
if (bufsz) {
buf = Tcl_Alloc(bufsz);
if (GetTokenInformation(token, TokenUser, buf, bufsz, &bufsz)) {
owned = EqualSid(ownerSid, ((PTOKEN_USER) buf)->User.Sid);
}
}
CloseHandle(token);
}
/*
* Free allocations and be done.
*/
if (secd) {
LocalFree(secd); /* Also frees ownerSid */
}
if (buf) {
Tcl_Free(buf);
}
return (owned != 0); /* Convert non-0 to 1 */
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to win/tclWinInit.c.
| ︙ | ︙ | |||
97 98 99 100 101 102 103 |
{0, 0, NULL, NULL, InitializeDefaultLibraryDir, NULL, NULL};
static TclInitProcessGlobalValueProc InitializeSourceLibraryDir;
static ProcessGlobalValue sourceLibraryDir =
{0, 0, NULL, NULL, InitializeSourceLibraryDir, NULL, NULL};
static void AppendEnvironment(Tcl_Obj *listPtr, const char *lib);
| < | 97 98 99 100 101 102 103 104 105 106 107 108 109 110 |
{0, 0, NULL, NULL, InitializeDefaultLibraryDir, NULL, NULL};
static TclInitProcessGlobalValueProc InitializeSourceLibraryDir;
static ProcessGlobalValue sourceLibraryDir =
{0, 0, NULL, NULL, InitializeSourceLibraryDir, NULL, NULL};
static void AppendEnvironment(Tcl_Obj *listPtr, const char *lib);
/*
*---------------------------------------------------------------------------
*
* TclpInitPlatform --
*
* Initialize all the platform-dependant things like signals,
|
| ︙ | ︙ | |||
170 171 172 173 174 175 176 177 178 179 180 181 182 183 |
size_t *lengthPtr,
Tcl_Encoding *encodingPtr)
{
#define LIBRARY_SIZE 64
Tcl_Obj *pathPtr;
char installLib[LIBRARY_SIZE];
const char *bytes;
pathPtr = Tcl_NewObj();
/*
* Initialize the substring used when locating the script library. The
* installLib variable computes the script library path relative to the
* installed DLL.
| > | 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 |
size_t *lengthPtr,
Tcl_Encoding *encodingPtr)
{
#define LIBRARY_SIZE 64
Tcl_Obj *pathPtr;
char installLib[LIBRARY_SIZE];
const char *bytes;
size_t length;
pathPtr = Tcl_NewObj();
/*
* Initialize the substring used when locating the script library. The
* installLib variable computes the script library path relative to the
* installed DLL.
|
| ︙ | ︙ | |||
205 206 207 208 209 210 211 |
* Look for the library in its source checkout location.
*/
Tcl_ListObjAppendElement(NULL, pathPtr,
TclGetProcessGlobalValue(&sourceLibraryDir));
*encodingPtr = NULL;
| | | | | | 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 |
* Look for the library in its source checkout location.
*/
Tcl_ListObjAppendElement(NULL, pathPtr,
TclGetProcessGlobalValue(&sourceLibraryDir));
*encodingPtr = NULL;
bytes = TclGetStringFromObj(pathPtr, &length);
*lengthPtr = length++;
*valuePtr = Tcl_Alloc(length);
memcpy(*valuePtr, bytes, length);
Tcl_DecrRefCount(pathPtr);
}
/*
*---------------------------------------------------------------------------
*
* AppendEnvironment --
|
| ︙ | ︙ | |||
238 239 240 241 242 243 244 |
static void
AppendEnvironment(
Tcl_Obj *pathPtr,
const char *lib)
{
int pathc;
WCHAR wBuf[MAX_PATH];
| | | | < | < < < | 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 |
static void
AppendEnvironment(
Tcl_Obj *pathPtr,
const char *lib)
{
int pathc;
WCHAR wBuf[MAX_PATH];
char buf[MAX_PATH * 3];
Tcl_Obj *objPtr;
Tcl_DString ds;
const char **pathv;
char *shortlib;
/*
* The shortlib value needs to be the tail component of the lib path. For
* example, "lib/tcl8.4" -> "tcl8.4" while "usr/share/tcl8.5" -> "tcl8.5".
*/
for (shortlib = (char *) &lib[strlen(lib)-1]; shortlib>lib ; shortlib--) {
if (*shortlib == '/') {
if ((size_t)(shortlib - lib) == strlen(lib) - 1) {
Tcl_Panic("last character in lib cannot be '/'");
}
shortlib++;
break;
}
}
if (shortlib == lib) {
Tcl_Panic("no '/' character found in lib");
}
/*
* The "L" preceeding the TCL_LIBRARY string is used to tell VC++ that
* this is a unicode string.
*/
GetEnvironmentVariableW(L"TCL_LIBRARY", wBuf, MAX_PATH);
WideCharToMultiByte(CP_UTF8, 0, wBuf, -1, buf, MAX_PATH * 3, NULL, NULL);
if (buf[0] != '\0') {
objPtr = Tcl_NewStringObj(buf, -1);
Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
TclWinNoBackslash(buf);
Tcl_SplitPath(buf, &pathc, &pathv);
|
| ︙ | ︙ | |||
302 303 304 305 306 307 308 |
Tcl_DStringInit(&ds);
(void) Tcl_JoinPath(pathc, pathv, &ds);
objPtr = TclDStringToObj(&ds);
} else {
objPtr = Tcl_NewStringObj(buf, -1);
}
Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
| | | 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 |
Tcl_DStringInit(&ds);
(void) Tcl_JoinPath(pathc, pathv, &ds);
objPtr = TclDStringToObj(&ds);
} else {
objPtr = Tcl_NewStringObj(buf, -1);
}
Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
Tcl_Free((void *)pathv);
}
}
/*
*---------------------------------------------------------------------------
*
* InitializeDefaultLibraryDir --
|
| ︙ | ︙ | |||
331 332 333 334 335 336 337 |
InitializeDefaultLibraryDir(
char **valuePtr,
size_t *lengthPtr,
Tcl_Encoding *encodingPtr)
{
HMODULE hModule = TclWinGetTclInstance();
WCHAR wName[MAX_PATH + LIBRARY_SIZE];
| | | | < < < | | 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 |
InitializeDefaultLibraryDir(
char **valuePtr,
size_t *lengthPtr,
Tcl_Encoding *encodingPtr)
{
HMODULE hModule = TclWinGetTclInstance();
WCHAR wName[MAX_PATH + LIBRARY_SIZE];
char name[(MAX_PATH + LIBRARY_SIZE) * 3];
char *end, *p;
GetModuleFileNameW(hModule, wName, MAX_PATH);
WideCharToMultiByte(CP_UTF8, 0, wName, -1, name, MAX_PATH * 3, NULL, NULL);
end = strrchr(name, '\\');
*end = '\0';
p = strrchr(name, '\\');
if (p != NULL) {
end = p;
}
*end = '\\';
TclWinNoBackslash(name);
sprintf(end + 1, "lib/tcl%s", TCL_VERSION);
*lengthPtr = strlen(name);
*valuePtr = Tcl_Alloc(*lengthPtr + 1);
*encodingPtr = NULL;
memcpy(*valuePtr, name, *lengthPtr + 1);
}
/*
*---------------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
382 383 384 385 386 387 388 |
InitializeSourceLibraryDir(
char **valuePtr,
size_t *lengthPtr,
Tcl_Encoding *encodingPtr)
{
HMODULE hModule = TclWinGetTclInstance();
WCHAR wName[MAX_PATH + LIBRARY_SIZE];
| | | | < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 |
InitializeSourceLibraryDir(
char **valuePtr,
size_t *lengthPtr,
Tcl_Encoding *encodingPtr)
{
HMODULE hModule = TclWinGetTclInstance();
WCHAR wName[MAX_PATH + LIBRARY_SIZE];
char name[(MAX_PATH + LIBRARY_SIZE) * 3];
char *end, *p;
GetModuleFileNameW(hModule, wName, MAX_PATH);
WideCharToMultiByte(CP_UTF8, 0, wName, -1, name, MAX_PATH * 3, NULL, NULL);
end = strrchr(name, '\\');
*end = '\0';
p = strrchr(name, '\\');
if (p != NULL) {
end = p;
}
*end = '\\';
TclWinNoBackslash(name);
sprintf(end + 1, "../library");
*lengthPtr = strlen(name);
*valuePtr = Tcl_Alloc(*lengthPtr + 1);
*encodingPtr = NULL;
memcpy(*valuePtr, name, *lengthPtr + 1);
}
/*
*---------------------------------------------------------------------------
*
* TclpSetInitialEncodings --
*
* Based on the locale, determine the encoding of the operating system
|
| ︙ | ︙ | |||
483 484 485 486 487 488 489 490 491 492 493 494 495 496 |
{
Tcl_DStringInit(bufPtr);
Tcl_DStringSetLength(bufPtr, 2+TCL_INTEGER_SPACE);
wsprintfA(Tcl_DStringValue(bufPtr), "cp%d", GetACP());
Tcl_DStringSetLength(bufPtr, strlen(Tcl_DStringValue(bufPtr)));
return Tcl_DStringValue(bufPtr);
}
/*
*---------------------------------------------------------------------------
*
* TclpSetVariables --
*
* Performs platform-specific interpreter initialization related to the
| > > > > > > > > > > > > > > > > > > > > > | 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 |
{
Tcl_DStringInit(bufPtr);
Tcl_DStringSetLength(bufPtr, 2+TCL_INTEGER_SPACE);
wsprintfA(Tcl_DStringValue(bufPtr), "cp%d", GetACP());
Tcl_DStringSetLength(bufPtr, strlen(Tcl_DStringValue(bufPtr)));
return Tcl_DStringValue(bufPtr);
}
const char *
TclpGetUserName(
Tcl_DString *bufferPtr) /* Uninitialized or free DString filled with
* the name of user. */
{
Tcl_DStringInit(bufferPtr);
if (TclGetEnv("USERNAME", bufferPtr) == NULL) {
WCHAR szUserName[UNLEN+1];
DWORD cchUserNameLen = UNLEN;
if (!GetUserName(szUserName, &cchUserNameLen)) {
return NULL;
}
cchUserNameLen--;
cchUserNameLen *= sizeof(WCHAR);
Tcl_WinTCharToUtf(szUserName, cchUserNameLen, bufferPtr);
}
return Tcl_DStringValue(bufferPtr);
}
/*
*---------------------------------------------------------------------------
*
* TclpSetVariables --
*
* Performs platform-specific interpreter initialization related to the
|
| ︙ | ︙ | |||
514 515 516 517 518 519 520 |
union {
SYSTEM_INFO info;
OemId oemId;
} sys;
static OSVERSIONINFOW osInfo;
static int osInfoInitialized = 0;
Tcl_DString ds;
| < < | | 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 |
union {
SYSTEM_INFO info;
OemId oemId;
} sys;
static OSVERSIONINFOW osInfo;
static int osInfoInitialized = 0;
Tcl_DString ds;
Tcl_SetVar2Ex(interp, "tclDefaultLibrary", NULL,
TclGetProcessGlobalValue(&defaultLibraryDir), TCL_GLOBAL_ONLY);
if (!osInfoInitialized) {
HMODULE handle = GetModuleHandle(L"NTDLL");
int(__stdcall *getversion)(void *) =
(int(__stdcall *)(void *)) GetProcAddress(handle, "RtlGetVersion");
osInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFOW);
if (!getversion || getversion(&osInfo)) {
GetVersionExW(&osInfo);
}
osInfoInitialized = 1;
|
| ︙ | ︙ | |||
590 591 592 593 594 595 596 |
/*
* Initialize the user name from the environment first, since this is much
* faster than asking the system.
* Note: cchUserNameLen is number of characters including nul terminator.
*/
| < < | < < < < < | | | | | > | | | | | | | 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 |
/*
* Initialize the user name from the environment first, since this is much
* faster than asking the system.
* Note: cchUserNameLen is number of characters including nul terminator.
*/
ptr = TclpGetUserName(&ds);
Tcl_SetVar2(interp, "tcl_platform", "user", ptr ? ptr : "",
TCL_GLOBAL_ONLY);
Tcl_DStringFree(&ds);
/*
* Define what the platform PATH separator is. [TIP #315]
*/
Tcl_SetVar2(interp, "tcl_platform","pathSeparator", ";", TCL_GLOBAL_ONLY);
}
/*
*----------------------------------------------------------------------
*
* TclpFindVariable --
*
* Locate the entry in environ for a given name. On Unix this routine is
* case sensitive, on Windows this matches mixed case.
*
* Results:
* The return value is the index in environ of an entry with the name
* "name", or TCL_IO_FAILURE if there is no such entry. The integer
* at *lengthPtr is filled in with the length of name (if a matching
* entry is found) or the length of the environ array (if no
* matching entry is found).
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
size_t
TclpFindVariable(
const char *name, /* Name of desired environment variable
* (UTF-8). */
size_t *lengthPtr) /* Used to return length of name (for
* successful searches) or number of non-NULL
* entries in environ (for unsuccessful
* searches). */
{
size_t i, length, result = TCL_IO_FAILURE;
register const char *env, *p1, *p2;
char *envUpper, *nameUpper;
Tcl_DString envString;
/*
* Convert the name to all upper case for the case insensitive comparison.
*/
length = strlen(name);
nameUpper = Tcl_Alloc(length + 1);
memcpy(nameUpper, name, length+1);
Tcl_UtfToUpper(nameUpper);
Tcl_DStringInit(&envString);
for (i = 0, env = environ[i]; env != NULL; i++, env = environ[i]) {
/*
* Chop the env string off after the equal sign, then Convert the name
* to all upper case, so we do not have to convert all the characters
* after the equal sign.
*/
envUpper = Tcl_ExternalToUtfDString(NULL, env, -1, &envString);
p1 = strchr(envUpper, '=');
if (p1 == NULL) {
continue;
}
length = p1 - envUpper;
Tcl_DStringSetLength(&envString, length+1);
Tcl_UtfToUpper(envUpper);
p1 = envUpper;
p2 = nameUpper;
for (; *p2 == *p1; p1++, p2++) {
/* NULL loop body. */
|
| ︙ | ︙ | |||
687 688 689 690 691 692 693 |
Tcl_DStringFree(&envString);
}
*lengthPtr = i;
done:
Tcl_DStringFree(&envString);
| | | 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 |
Tcl_DStringFree(&envString);
}
*lengthPtr = i;
done:
Tcl_DStringFree(&envString);
Tcl_Free(nameUpper);
return result;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to win/tclWinInt.h.
| ︙ | ︙ | |||
47 48 49 50 51 52 53 | /* * Declarations of functions that are not accessible by way of the * stubs table. */ MODULE_SCOPE char TclWinDriveLetterForVolMountPoint( | | | | | < < < < < | | | 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 |
/*
* Declarations of functions that are not accessible by way of the
* stubs table.
*/
MODULE_SCOPE char TclWinDriveLetterForVolMountPoint(
const WCHAR *mountPoint);
MODULE_SCOPE void TclWinEncodingsCleanup();
MODULE_SCOPE void TclWinInit(HINSTANCE hInst);
MODULE_SCOPE TclFile TclWinMakeFile(HANDLE handle);
MODULE_SCOPE Tcl_Channel TclWinOpenConsoleChannel(HANDLE handle,
char *channelName, int permissions);
MODULE_SCOPE Tcl_Channel TclWinOpenFileChannel(HANDLE handle, char *channelName,
int permissions, int appendMode);
MODULE_SCOPE Tcl_Channel TclWinOpenSerialChannel(HANDLE handle,
char *channelName, int permissions);
MODULE_SCOPE HANDLE TclWinSerialOpen(HANDLE handle, const WCHAR *name,
DWORD access);
MODULE_SCOPE int TclWinSymLinkCopyDirectory(const TCHAR *LinkOriginal,
const TCHAR *LinkCopy);
MODULE_SCOPE int TclWinSymLinkDelete(const TCHAR *LinkOriginal,
int linkOnly);
MODULE_SCOPE int TclWinFileOwned(Tcl_Obj *);
MODULE_SCOPE const char*TclpGetUserName(Tcl_DString *bufferPtr);
/* Needed by tclWinFile.c and tclWinFCmd.c */
#ifndef FILE_ATTRIBUTE_REPARSE_POINT
#define FILE_ATTRIBUTE_REPARSE_POINT 0x00000400
#endif
/*
*----------------------------------------------------------------------
* Declarations of helper-workers threaded facilities for a pipe based channel.
*
* Corresponding functionality provided in "tclWinPipe.c".
*----------------------------------------------------------------------
*/
typedef struct TclPipeThreadInfo {
HANDLE evControl; /* Auto-reset event used by the main thread to
* signal when the pipe thread should attempt
* to do read/write operation. Additionally
* used as signal to stop (state set to -1) */
volatile LONG state; /* Indicates current state of the thread */
void *clientData; /* Referenced data of the main thread */
HANDLE evWakeUp; /* Optional wake-up event worker set by shutdown */
} TclPipeThreadInfo;
/* If pipe-workers will use some tcl subsystem, we can use Tcl_Alloc without
* more overhead for finalize thread (should be executed anyway)
*
* #define _PTI_USE_CKALLOC 1
*/
/*
* State of the pipe-worker.
|
| ︙ | ︙ | |||
118 119 120 121 122 123 124 | #define PTI_STATE_STOP 2 /* thread should stop work (owns TI structure) */ #define PTI_STATE_END 4 /* thread should stop work (worker is busy) */ #define PTI_STATE_DOWN 8 /* worker is down */ MODULE_SCOPE TclPipeThreadInfo * TclPipeThreadCreateTI(TclPipeThreadInfo **pipeTIPtr, | | | 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 |
#define PTI_STATE_STOP 2 /* thread should stop work (owns TI structure) */
#define PTI_STATE_END 4 /* thread should stop work (worker is busy) */
#define PTI_STATE_DOWN 8 /* worker is down */
MODULE_SCOPE
TclPipeThreadInfo * TclPipeThreadCreateTI(TclPipeThreadInfo **pipeTIPtr,
void *clientData, HANDLE wakeEvent);
MODULE_SCOPE int TclPipeThreadWaitForSignal(TclPipeThreadInfo **pipeTIPtr);
static inline void
TclPipeThreadSignal(
TclPipeThreadInfo **pipeTIPtr)
{
TclPipeThreadInfo *pipeTI = *pipeTIPtr;
|
| ︙ | ︙ |
Changes to win/tclWinLoad.c.
| ︙ | ︙ | |||
91 92 93 94 95 96 97 |
/*
* Remember the first error on load attempt to be used if the
* second load attempt below also fails.
*/
firstError = (nativeName == NULL) ?
ERROR_MOD_NOT_FOUND : GetLastError();
| | | 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 |
/*
* Remember the first error on load attempt to be used if the
* second load attempt below also fails.
*/
firstError = (nativeName == NULL) ?
ERROR_MOD_NOT_FOUND : GetLastError();
nativeName = Tcl_WinUtfToTChar(TclGetString(pathPtr), -1, &ds);
hInstance = LoadLibraryEx(nativeName, NULL,
LOAD_WITH_ALTERED_SEARCH_PATH);
Tcl_DStringFree(&ds);
}
if (hInstance == NULL) {
DWORD lastError;
|
| ︙ | ︙ | |||
113 114 115 116 117 118 119 |
if (firstError == ERROR_MOD_NOT_FOUND ||
firstError == ERROR_DLL_NOT_FOUND)
lastError = GetLastError();
else
lastError = firstError;
errMsg = Tcl_ObjPrintf("couldn't load library \"%s\": ",
| | | 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 |
if (firstError == ERROR_MOD_NOT_FOUND ||
firstError == ERROR_DLL_NOT_FOUND)
lastError = GetLastError();
else
lastError = firstError;
errMsg = Tcl_ObjPrintf("couldn't load library \"%s\": ",
TclGetString(pathPtr));
/*
* Check for possible DLL errors. This doesn't work quite right,
* because Windows seems to only return ERROR_MOD_NOT_FOUND for just
* about any problem, but it's better than nothing. It'd be even
* better if there was a way to get what DLLs
*/
|
| ︙ | ︙ | |||
166 167 168 169 170 171 172 |
return TCL_ERROR;
}
/*
* Succeded; package everything up for Tcl.
*/
| | | 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 |
return TCL_ERROR;
}
/*
* Succeded; package everything up for Tcl.
*/
handlePtr = Tcl_Alloc(sizeof(struct Tcl_LoadHandle_));
handlePtr->clientData = (ClientData) hInstance;
handlePtr->findSymbolProcPtr = &FindSymbol;
handlePtr->unloadFileProcPtr = &UnloadFile;
*loadHandle = handlePtr;
*unloadProcPtr = &UnloadFile;
return TCL_OK;
}
|
| ︙ | ︙ | |||
251 252 253 254 255 256 257 |
Tcl_LoadHandle loadHandle) /* loadHandle returned by a previous call to
* TclpDlopen(). The loadHandle is a token
* that represents the loaded file. */
{
HINSTANCE hInstance = (HINSTANCE) loadHandle->clientData;
FreeLibrary(hInstance);
| | | 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 |
Tcl_LoadHandle loadHandle) /* loadHandle returned by a previous call to
* TclpDlopen(). The loadHandle is a token
* that represents the loaded file. */
{
HINSTANCE hInstance = (HINSTANCE) loadHandle->clientData;
FreeLibrary(hInstance);
Tcl_Free(loadHandle);
}
/*
*----------------------------------------------------------------------
*
* TclGuessPackageName --
*
|
| ︙ | ︙ | |||
412 413 414 415 416 417 418 |
return TCL_ERROR;
/*
* Store our computed value in the global.
*/
copyToGlobalBuffer:
| | | 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 |
return TCL_ERROR;
/*
* Store our computed value in the global.
*/
copyToGlobalBuffer:
dllDirectoryName = Tcl_Alloc((nameLen+1) * sizeof(WCHAR));
wcscpy(dllDirectoryName, name);
return TCL_OK;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to win/tclWinNotify.c.
| ︙ | ︙ | |||
32 33 34 35 36 37 38 |
DWORD thread; /* Identifier for thread associated with this
* notifier. */
HANDLE event; /* Event object used to wake up the notifier
* thread. */
int pending; /* Alert message pending, this field is locked
* by the notifierMutex. */
HWND hwnd; /* Messaging window. */
| < | 32 33 34 35 36 37 38 39 40 41 42 43 44 45 |
DWORD thread; /* Identifier for thread associated with this
* notifier. */
HANDLE event; /* Event object used to wake up the notifier
* thread. */
int pending; /* Alert message pending, this field is locked
* by the notifierMutex. */
HWND hwnd; /* Messaging window. */
int timerActive; /* 1 if interval timer is running. */
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
/*
* The following static indicates the number of threads that have initialized
|
| ︙ | ︙ | |||
305 306 307 308 309 310 311 |
*/
timeout = timePtr->sec * 1000 + timePtr->usec / 1000;
if (timeout == 0) {
timeout = 1;
}
}
| < | | 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 |
*/
timeout = timePtr->sec * 1000 + timePtr->usec / 1000;
if (timeout == 0) {
timeout = 1;
}
}
if (timeout != 0) {
tsdPtr->timerActive = 1;
SetTimer(tsdPtr->hwnd, INTERVAL_TIMER,
timeout, NULL);
} else {
tsdPtr->timerActive = 0;
KillTimer(tsdPtr->hwnd, INTERVAL_TIMER);
}
}
}
|
| ︙ | ︙ |
Added win/tclWinPanic.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 |
/*
* tclWinPanic.c --
*
* Contains the Windows-specific command-line panic proc.
*
* Copyright (c) 2013 by Jan Nijtmans.
* All rights reserved.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
/*
*----------------------------------------------------------------------
*
* Tcl_ConsolePanic --
*
* Display a message. If a debugger is present, present it directly to
* the debugger, otherwise send it to stderr.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
TCL_NORETURN1 void
Tcl_ConsolePanic(
const char *format, ...)
{
#define TCL_MAX_WARN_LEN 26000
va_list argList;
WCHAR msgString[TCL_MAX_WARN_LEN];
char buf[TCL_MAX_WARN_LEN * 3];
HANDLE handle = GetStdHandle(STD_ERROR_HANDLE);
DWORD dummy;
va_start(argList, format);
vsnprintf(buf+3, sizeof(buf)-3, format, argList);
buf[sizeof(buf)-1] = 0;
msgString[TCL_MAX_WARN_LEN-1] = L'\0';
MultiByteToWideChar(CP_UTF8, 0, buf+3, -1, msgString, TCL_MAX_WARN_LEN);
/*
* Truncate MessageBox string if it is too long to not overflow the buffer.
*/
if (msgString[TCL_MAX_WARN_LEN-1] != L'\0') {
memcpy(msgString + (TCL_MAX_WARN_LEN - 5), L" ...", 5 * sizeof(WCHAR));
}
if (IsDebuggerPresent()) {
OutputDebugStringW(msgString);
} else if (_isatty(2)) {
WriteConsoleW(handle, msgString, wcslen(msgString), &dummy, 0);
} else {
buf[0] = 0xEF; buf[1] = 0xBB; buf[2] = 0xBF; /* UTF-8 bom */
WriteFile(handle, buf, strlen(buf), &dummy, 0);
WriteFile(handle, "\n", 1, &dummy, 0);
FlushFileBuffers(handle);
}
# if defined(__GNUC__)
__builtin_trap();
# elif defined(_WIN64)
__debugbreak();
# elif defined(_MSC_VER)
_asm {int 3}
# else
DebugBreak();
# endif
#if defined(_WIN32)
ExitProcess(1);
#else
abort();
#endif
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* tab-width: 8
* End:
*/
|
Changes to win/tclWinPipe.c.
| ︙ | ︙ | |||
57 58 59 60 61 62 63 |
/*
* This list is used to map from pids to process handles.
*/
typedef struct ProcInfo {
HANDLE hProcess;
| | | 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 |
/*
* This list is used to map from pids to process handles.
*/
typedef struct ProcInfo {
HANDLE hProcess;
size_t dwProcessId;
struct ProcInfo *nextPtr;
} ProcInfo;
static ProcInfo *procList;
/*
* Bit masks used in the flags field of the PipeInfo structure below.
|
| ︙ | ︙ | |||
120 121 122 123 124 125 126 |
HANDLE readable; /* Manual-reset event to signal when the
* reader thread has finished waiting for
* input. */
DWORD writeError; /* An error caused by the last background
* write. Set to 0 if no error has been
* detected. This word is shared with the
* writer thread so access must be
| | < | 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 |
HANDLE readable; /* Manual-reset event to signal when the
* reader thread has finished waiting for
* input. */
DWORD writeError; /* An error caused by the last background
* write. Set to 0 if no error has been
* detected. This word is shared with the
* writer thread so access must be
* synchronized with the writable object. */
char *writeBuf; /* Current background output buffer. Access is
* synchronized with the writable object. */
int writeBufLen; /* Size of write buffer. Access is
* synchronized with the writable object. */
int toWrite; /* Current amount to be written. Access is
* synchronized with the writable object. */
int readFlags; /* Flags that are shared with the reader
|
| ︙ | ︙ | |||
187 188 189 190 191 192 193 | int toRead, int *errorCode); static int PipeOutputProc(ClientData instanceData, const char *buf, int toWrite, int *errorCode); static DWORD WINAPI PipeReaderThread(LPVOID arg); static void PipeSetupProc(ClientData clientData, int flags); static void PipeWatchProc(ClientData instanceData, int mask); static DWORD WINAPI PipeWriterThread(LPVOID arg); | | | 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 | int toRead, int *errorCode); static int PipeOutputProc(ClientData instanceData, const char *buf, int toWrite, int *errorCode); static DWORD WINAPI PipeReaderThread(LPVOID arg); static void PipeSetupProc(ClientData clientData, int flags); static void PipeWatchProc(ClientData instanceData, int mask); static DWORD WINAPI PipeWriterThread(LPVOID arg); static int TempFileName(WCHAR name[MAX_PATH]); static int WaitForRead(PipeInfo *infoPtr, int blocking); static void PipeThreadActionProc(ClientData instanceData, int action); /* * This structure describes the channel type structure for command pipe based * I/O. |
| ︙ | ︙ | |||
214 215 216 217 218 219 220 |
PipeGetHandleProc, /* Get an OS handle from channel. */
PipeClose2Proc, /* close2proc */
PipeBlockModeProc, /* Set blocking or non-blocking mode.*/
NULL, /* flush proc. */
NULL, /* handler proc. */
NULL, /* wide seek proc */
PipeThreadActionProc, /* thread action proc */
| | | 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 |
PipeGetHandleProc, /* Get an OS handle from channel. */
PipeClose2Proc, /* close2proc */
PipeBlockModeProc, /* Set blocking or non-blocking mode.*/
NULL, /* flush proc. */
NULL, /* handler proc. */
NULL, /* wide seek proc */
PipeThreadActionProc, /* thread action proc */
NULL /* truncate */
};
/*
*----------------------------------------------------------------------
*
* PipeInit --
*
|
| ︙ | ︙ | |||
399 400 401 402 403 404 405 |
if ((infoPtr->watchMask & TCL_READABLE) &&
(WaitForRead(infoPtr, 0) >= 0)) {
needEvent = 1;
}
if (needEvent) {
infoPtr->flags |= PIPE_PENDING;
| | | 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 |
if ((infoPtr->watchMask & TCL_READABLE) &&
(WaitForRead(infoPtr, 0) >= 0)) {
needEvent = 1;
}
if (needEvent) {
infoPtr->flags |= PIPE_PENDING;
evPtr = Tcl_Alloc(sizeof(PipeEvent));
evPtr->header.proc = PipeEventProc;
evPtr->infoPtr = infoPtr;
Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL);
}
}
}
|
| ︙ | ︙ | |||
430 431 432 433 434 435 436 |
TclFile
TclWinMakeFile(
HANDLE handle) /* Type-specific data. */
{
WinFile *filePtr;
| | | 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 |
TclFile
TclWinMakeFile(
HANDLE handle) /* Type-specific data. */
{
WinFile *filePtr;
filePtr = Tcl_Alloc(sizeof(WinFile));
filePtr->type = WIN_FILE;
filePtr->handle = handle;
return (TclFile)filePtr;
}
/*
|
| ︙ | ︙ | |||
459 460 461 462 463 464 465 | * None. * *---------------------------------------------------------------------- */ static int TempFileName( | | | | 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TempFileName(
WCHAR name[MAX_PATH]) /* Buffer in which name for temporary file
* gets stored. */
{
const WCHAR *prefix = L"TCL";
if (GetTempPath(MAX_PATH, name) != 0) {
if (GetTempFileName(name, prefix, 0, name) != 0) {
return 1;
}
}
name[0] = '.';
name[1] = '\0';
|
| ︙ | ︙ | |||
529 530 531 532 533 534 535 |
TclpOpenFile(
const char *path, /* The name of the file to open. */
int mode) /* In what mode to open the file? */
{
HANDLE handle;
DWORD accessMode, createMode, shareMode, flags;
Tcl_DString ds;
| | | 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 |
TclpOpenFile(
const char *path, /* The name of the file to open. */
int mode) /* In what mode to open the file? */
{
HANDLE handle;
DWORD accessMode, createMode, shareMode, flags;
Tcl_DString ds;
const WCHAR *nativePath;
/*
* Map the access bits to the NT access mode.
*/
switch (mode & (O_RDONLY | O_WRONLY | O_RDWR)) {
case O_RDONLY:
|
| ︙ | ︙ | |||
646 647 648 649 650 651 652 |
*----------------------------------------------------------------------
*/
TclFile
TclpCreateTempFile(
const char *contents) /* String to write into temp file, or NULL. */
{
| | | 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 |
*----------------------------------------------------------------------
*/
TclFile
TclpCreateTempFile(
const char *contents) /* String to write into temp file, or NULL. */
{
WCHAR name[MAX_PATH];
const char *native;
Tcl_DString dstring;
HANDLE handle;
if (TempFileName(name) == 0) {
return NULL;
}
|
| ︙ | ︙ | |||
740 741 742 743 744 745 746 |
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclpTempFileName(void)
{
| | | 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 |
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclpTempFileName(void)
{
WCHAR fileName[MAX_PATH];
if (TempFileName(fileName) == 0) {
return NULL;
}
return TclpNativeToNormalized(fileName);
}
|
| ︙ | ︙ | |||
822 823 824 825 826 827 828 |
if (!TclInThreadExit()
|| ((GetStdHandle(STD_INPUT_HANDLE) != filePtr->handle)
&& (GetStdHandle(STD_OUTPUT_HANDLE) != filePtr->handle)
&& (GetStdHandle(STD_ERROR_HANDLE) != filePtr->handle))) {
if (filePtr->handle != NULL &&
CloseHandle(filePtr->handle) == FALSE) {
TclWinConvertError(GetLastError());
| | | | | | | | 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 |
if (!TclInThreadExit()
|| ((GetStdHandle(STD_INPUT_HANDLE) != filePtr->handle)
&& (GetStdHandle(STD_OUTPUT_HANDLE) != filePtr->handle)
&& (GetStdHandle(STD_ERROR_HANDLE) != filePtr->handle))) {
if (filePtr->handle != NULL &&
CloseHandle(filePtr->handle) == FALSE) {
TclWinConvertError(GetLastError());
Tcl_Free(filePtr);
return -1;
}
}
break;
default:
Tcl_Panic("TclpCloseFile: unexpected file type");
}
Tcl_Free(filePtr);
return 0;
}
/*
*--------------------------------------------------------------------------
*
* TclpGetPid --
*
* Given a HANDLE to a child process, return the process id for that
* child process.
*
* Results:
* Returns the process id for the child process. If the pid was not known
* by Tcl, either because the pid was not created by Tcl or the child
* process has already been reaped, TCL_IO_FAILURE is returned.
*
* Side effects:
* None.
*
*--------------------------------------------------------------------------
*/
size_t
TclpGetPid(
Tcl_Pid pid) /* The HANDLE of the child process. */
{
ProcInfo *infoPtr;
PipeInit();
Tcl_MutexLock(&pipeMutex);
for (infoPtr = procList; infoPtr != NULL; infoPtr = infoPtr->nextPtr) {
if (infoPtr->dwProcessId == (size_t) pid) {
Tcl_MutexUnlock(&pipeMutex);
return infoPtr->dwProcessId;
}
}
Tcl_MutexUnlock(&pipeMutex);
return TCL_IO_FAILURE;
}
/*
*----------------------------------------------------------------------
*
* TclpCreateProcess --
*
|
| ︙ | ︙ | |||
932 933 934 935 936 937 938 |
* from the child will be discarded. errorFile
* may be the same as outputFile. */
Tcl_Pid *pidPtr) /* If this function is successful, pidPtr is
* filled with the process id of the child
* process. */
{
int result, applType, createFlags;
| | | | 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 |
* from the child will be discarded. errorFile
* may be the same as outputFile. */
Tcl_Pid *pidPtr) /* If this function is successful, pidPtr is
* filled with the process id of the child
* process. */
{
int result, applType, createFlags;
Tcl_DString cmdLine; /* Complete command line (WCHAR). */
STARTUPINFO startInfo;
PROCESS_INFORMATION procInfo;
SECURITY_ATTRIBUTES secAtts;
HANDLE hProcess, h, inputHandle, outputHandle, errorHandle;
char execPath[MAX_PATH * 3];
WinFile *filePtr;
PipeInit();
applType = ApplicationType(interp, argv[0], execPath);
if (applType == APPL_NONE) {
return TCL_ERROR;
|
| ︙ | ︙ | |||
1044 1045 1046 1047 1048 1049 1050 | * the child process would hang forever waiting for input from the * unmapped console window used by the helper application. * * Fortunately, the helper application will detect a closed pipe as a * sink. */ | | | | 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 |
* the child process would hang forever waiting for input from the
* unmapped console window used by the helper application.
*
* Fortunately, the helper application will detect a closed pipe as a
* sink.
*/
startInfo.hStdOutput = CreateFile(L"NUL:", GENERIC_WRITE, 0,
&secAtts, OPEN_ALWAYS, FILE_ATTRIBUTE_NORMAL, NULL);
} else {
DuplicateHandle(hProcess, outputHandle, hProcess,
&startInfo.hStdOutput, 0, TRUE, DUPLICATE_SAME_ACCESS);
}
if (startInfo.hStdOutput == INVALID_HANDLE_VALUE) {
TclWinConvertError(GetLastError());
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't duplicate output handle: %s",
Tcl_PosixError(interp)));
goto end;
}
if (errorHandle == INVALID_HANDLE_VALUE) {
/*
* If handle was not set, errors should be sent to an infinitely deep
* sink.
*/
startInfo.hStdError = CreateFile(L"NUL:", GENERIC_WRITE, 0,
&secAtts, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL);
} else {
DuplicateHandle(hProcess, errorHandle, hProcess, &startInfo.hStdError,
0, TRUE, DUPLICATE_SAME_ACCESS);
}
if (startInfo.hStdError == INVALID_HANDLE_VALUE) {
TclWinConvertError(GetLastError());
|
| ︙ | ︙ | |||
1130 1131 1132 1133 1134 1135 1136 |
* Additionally, when calling a 16-bit dos or windows application, all
* path names must use the short, cryptic, path format (e.g., using
* ab~1.def instead of "a b.default").
*/
BuildCommandLine(execPath, argc, argv, &cmdLine);
| | | 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 |
* Additionally, when calling a 16-bit dos or windows application, all
* path names must use the short, cryptic, path format (e.g., using
* ab~1.def instead of "a b.default").
*/
BuildCommandLine(execPath, argc, argv, &cmdLine);
if (CreateProcess(NULL, (WCHAR *) Tcl_DStringValue(&cmdLine),
NULL, NULL, TRUE, (DWORD) createFlags, NULL, NULL, &startInfo,
&procInfo) == 0) {
TclWinConvertError(GetLastError());
Tcl_SetObjResult(interp, Tcl_ObjPrintf("couldn't execute \"%s\": %s",
argv[0], Tcl_PosixError(interp)));
goto end;
}
|
| ︙ | ︙ | |||
1159 1160 1161 1162 1163 1164 1165 |
* CreateProcess() and CloseHandle(), the problem does not occur." PSS ID
* Number: Q124121
*/
WaitForInputIdle(procInfo.hProcess, 5000);
CloseHandle(procInfo.hThread);
| | | 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 |
* CreateProcess() and CloseHandle(), the problem does not occur." PSS ID
* Number: Q124121
*/
WaitForInputIdle(procInfo.hProcess, 5000);
CloseHandle(procInfo.hThread);
*pidPtr = (Tcl_Pid) (size_t) procInfo.dwProcessId;
if (*pidPtr != 0) {
TclWinAddProcess(procInfo.hProcess, procInfo.dwProcessId);
}
result = TCL_OK;
end:
Tcl_DStringFree(&cmdLine);
|
| ︙ | ︙ | |||
1256 1257 1258 1259 1260 1261 1262 |
Tcl_Interp *interp, /* Interp, for error message. */
const char *originalName, /* Name of the application to find. */
char fullName[]) /* Filled with complete path to
* application. */
{
int applType, i, nameLen, found;
HANDLE hFile;
| | | | | | 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 |
Tcl_Interp *interp, /* Interp, for error message. */
const char *originalName, /* Name of the application to find. */
char fullName[]) /* Filled with complete path to
* application. */
{
int applType, i, nameLen, found;
HANDLE hFile;
WCHAR *rest;
char *ext;
char buf[2];
DWORD attr, read;
IMAGE_DOS_HEADER header;
Tcl_DString nameBuf, ds;
const WCHAR *nativeName;
WCHAR nativeFullPath[MAX_PATH];
static const char extensions[][5] = {"", ".com", ".exe", ".bat", ".cmd"};
/*
* Look for the program as an external program. First try the name as it
* is, then try adding .com, .exe, .bat and .cmd, in that order, to the name,
* looking for an executable.
*
* Using the raw SearchPath() function doesn't do quite what is necessary.
* If the name of the executable already contains a '.' character, it will
* not try appending the specified extension when searching (in other
* words, SearchPath will not find the program "a.b.exe" if the arguments
* specified "a.b" and ".exe"). So, first look for the file as it is
|
| ︙ | ︙ | |||
1387 1388 1389 1390 1391 1392 1393 |
if (applType == APPL_NONE) {
TclWinConvertError(GetLastError());
Tcl_SetObjResult(interp, Tcl_ObjPrintf("couldn't execute \"%s\": %s",
originalName, Tcl_PosixError(interp)));
return APPL_NONE;
}
| | | 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 |
if (applType == APPL_NONE) {
TclWinConvertError(GetLastError());
Tcl_SetObjResult(interp, Tcl_ObjPrintf("couldn't execute \"%s\": %s",
originalName, Tcl_PosixError(interp)));
return APPL_NONE;
}
if (applType == APPL_WIN3X) {
/*
* Replace long path name of executable with short path name for
* 16-bit applications. Otherwise the application may not be able to
* correctly parse its own command line to separate off the
* application name from the arguments.
*/
|
| ︙ | ︙ | |||
1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 |
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static void
BuildCommandLine(
const char *executable, /* Full path of executable (including
* extension). Replacement for argv[0]. */
int argc, /* Number of arguments. */
const char **argv, /* Argument strings in UTF. */
Tcl_DString *linePtr) /* Initialized Tcl_DString that receives the
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | > > > > > > > > > > > > > | > | | > > | > > | | < > | | | | > | > > > | > > > > > > | < > > | > > > > > > > > > > > > > > > > > > > | | < > > | > | | > > > | > | > > > > | | < | | > | > > > | > > | > > > | > | > > | > > > > | > > > | > > > | | > | > > > > > | > | > | > | > | | > > | > > > | > > | | | > > > > > > > > | > > > > | 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 |
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static const char *
BuildCmdLineBypassBS(
const char *current,
const char **bspos)
{
/*
* Mark first backslash position.
*/
if (!*bspos) {
*bspos = current;
}
do {
current++;
} while (*current == '\\');
return current;
}
static void
QuoteCmdLineBackslash(
Tcl_DString *dsPtr,
const char *start,
const char *current,
const char *bspos)
{
if (!bspos) {
if (current > start) { /* part before current (special) */
Tcl_DStringAppend(dsPtr, start, (int) (current - start));
}
} else {
if (bspos > start) { /* part before first backslash */
Tcl_DStringAppend(dsPtr, start, (int) (bspos - start));
}
while (bspos++ < current) { /* each backslash twice */
TclDStringAppendLiteral(dsPtr, "\\\\");
}
}
}
static const char *
QuoteCmdLinePart(
Tcl_DString *dsPtr,
const char *start,
const char *special,
const char *specMetaChars,
const char **bspos)
{
if (!*bspos) {
/*
* Rest before special (before quote).
*/
QuoteCmdLineBackslash(dsPtr, start, special, NULL);
start = special;
} else {
/*
* Rest before first backslash and backslashes into new quoted block.
*/
QuoteCmdLineBackslash(dsPtr, start, *bspos, NULL);
start = *bspos;
}
/*
* escape all special chars enclosed in quotes like `"..."`, note that
* here we don't must escape `\` (with `\`), because it's outside of the
* main quotes, so `\` remains `\`, but important - not at end of part,
* because results as before the quote, so `%\%\` should be escaped as
* `"%\%"\\`).
*/
TclDStringAppendLiteral(dsPtr, "\""); /* opening escape quote-char */
do {
*bspos = NULL;
special++;
if (*special == '\\') {
/*
* Bypass backslashes (and mark first backslash position).
*/
special = BuildCmdLineBypassBS(special, bspos);
if (*special == '\0') {
break;
}
}
} while (*special && strchr(specMetaChars, *special));
if (!*bspos) {
/*
* Unescaped rest before quote.
*/
QuoteCmdLineBackslash(dsPtr, start, special, NULL);
} else {
/*
* Unescaped rest before first backslash (rather belongs to the main
* block).
*/
QuoteCmdLineBackslash(dsPtr, start, *bspos, NULL);
}
TclDStringAppendLiteral(dsPtr, "\""); /* closing escape quote-char */
return special;
}
static void
BuildCommandLine(
const char *executable, /* Full path of executable (including
* extension). Replacement for argv[0]. */
int argc, /* Number of arguments. */
const char **argv, /* Argument strings in UTF. */
Tcl_DString *linePtr) /* Initialized Tcl_DString that receives the
* command line (WCHAR). */
{
const char *arg, *start, *special, *bspos;
int quote = 0, i;
Tcl_DString ds;
static const char specMetaChars[] = "&|^<>!()%";
/* Characters to enclose in quotes if unpaired
* quote flag set. */
static const char specMetaChars2[] = "%";
/* Character to enclose in quotes in any case
* (regardless of unpaired-flag). */
/*
* Quote flags:
* CL_ESCAPE - escape argument;
* CL_QUOTE - enclose in quotes;
* CL_UNPAIRED - previous arguments chain contains unpaired quote-char;
*/
enum {CL_ESCAPE = 1, CL_QUOTE = 2, CL_UNPAIRED = 4};
Tcl_DStringInit(&ds);
/*
* Prime the path. Add a space separator if we were primed with something.
*/
TclDStringAppendDString(&ds, linePtr);
if (Tcl_DStringLength(linePtr) > 0) {
TclDStringAppendLiteral(&ds, " ");
}
for (i = 0; i < argc; i++) {
if (i == 0) {
arg = executable;
} else {
arg = argv[i];
TclDStringAppendLiteral(&ds, " ");
}
quote &= ~(CL_ESCAPE|CL_QUOTE); /* reset escape flags */
bspos = NULL;
if (arg[0] == '\0') {
quote = CL_QUOTE;
} else {
for (start = arg;
*start != '\0' &&
(quote & (CL_ESCAPE|CL_QUOTE)) != (CL_ESCAPE|CL_QUOTE);
start++) {
if (*start & 0x80) {
continue;
}
if (TclIsSpaceProc(*start)) {
quote |= CL_QUOTE; /* quote only */
if (bspos) { /* if backslash found, escape & quote */
quote |= CL_ESCAPE;
break;
}
continue;
}
if (strchr(specMetaChars, *start)) {
quote |= (CL_ESCAPE|CL_QUOTE); /* escape & quote */
break;
}
if (*start == '"') {
quote |= CL_ESCAPE; /* escape only */
continue;
}
if (*start == '\\') {
bspos = start;
if (quote & CL_QUOTE) { /* if quote, escape & quote */
quote |= CL_ESCAPE;
break;
}
continue;
}
}
bspos = NULL;
}
if (quote & CL_QUOTE) {
/*
* Start of argument (main opening quote-char).
*/
TclDStringAppendLiteral(&ds, "\"");
}
if (!(quote & CL_ESCAPE)) {
/*
* Nothing to escape.
*/
Tcl_DStringAppend(&ds, arg, -1);
} else {
start = arg;
for (special = arg; *special != '\0'; ) {
/*
* Position of `\` is important before quote or at end (equal
* `\"` because quoted).
*/
if (*special == '\\') {
/*
* Bypass backslashes (and mark first backslash position)
*/
special = BuildCmdLineBypassBS(special, &bspos);
if (*special == '\0') {
break;
}
}
/* ["] */
if (*special == '"') {
/*
* Invert the unpaired flag - observe unpaired quotes
*/
quote ^= CL_UNPAIRED;
/*
* Add part before (and escape backslashes before quote).
*/
QuoteCmdLineBackslash(&ds, start, special, bspos);
bspos = NULL;
/*
* Escape using backslash
*/
TclDStringAppendLiteral(&ds, "\\\"");
start = ++special;
continue;
}
/*
* Unpaired (escaped) quote causes special handling on
* meta-chars
*/
if ((quote & CL_UNPAIRED) && strchr(specMetaChars, *special)) {
special = QuoteCmdLinePart(&ds, start, special,
specMetaChars, &bspos);
/*
* Start to current or first backslash
*/
start = !bspos ? special : bspos;
continue;
}
/*
* Special case for % - should be enclosed always (paired
* also)
*/
if (strchr(specMetaChars2, *special)) {
special = QuoteCmdLinePart(&ds, start, special,
specMetaChars2, &bspos);
/*
* Start to current or first backslash.
*/
start = !bspos ? special : bspos;
continue;
}
/*
* Other not special (and not meta) character
*/
bspos = NULL; /* reset last backslash position (not
* interesting) */
special++;
}
/*
* Rest of argument (and escape backslashes before closing main
* quote)
*/
QuoteCmdLineBackslash(&ds, start, special,
(quote & CL_QUOTE) ? bspos : NULL);
}
if (quote & CL_QUOTE) {
/*
* End of argument (main closing quote-char)
*/
TclDStringAppendLiteral(&ds, "\"");
}
}
Tcl_DStringFree(linePtr);
Tcl_WinUtfToTChar(Tcl_DStringValue(&ds), Tcl_DStringLength(&ds), linePtr);
Tcl_DStringFree(&ds);
}
|
| ︙ | ︙ | |||
1543 1544 1545 1546 1547 1548 1549 |
TclFile writeFile, /* If non-null, gives the file for writing. */
TclFile errorFile, /* If non-null, gives the file where errors
* can be read. */
int numPids, /* The number of pids in the pid array. */
Tcl_Pid *pidPtr) /* An array of process identifiers. */
{
char channelName[16 + TCL_INTEGER_SPACE];
| | | 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 |
TclFile writeFile, /* If non-null, gives the file for writing. */
TclFile errorFile, /* If non-null, gives the file where errors
* can be read. */
int numPids, /* The number of pids in the pid array. */
Tcl_Pid *pidPtr) /* An array of process identifiers. */
{
char channelName[16 + TCL_INTEGER_SPACE];
PipeInfo *infoPtr = Tcl_Alloc(sizeof(PipeInfo));
PipeInit();
infoPtr->watchMask = 0;
infoPtr->flags = 0;
infoPtr->readFlags = 0;
infoPtr->readFile = readFile;
|
| ︙ | ︙ | |||
1701 1702 1703 1704 1705 1706 1707 |
return;
}
pipePtr = Tcl_GetChannelInstanceData(chan);
TclNewObj(pidsObj);
for (i = 0; i < pipePtr->numPids; i++) {
Tcl_ListObjAppendElement(NULL, pidsObj,
| | | | 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 |
return;
}
pipePtr = Tcl_GetChannelInstanceData(chan);
TclNewObj(pidsObj);
for (i = 0; i < pipePtr->numPids; i++) {
Tcl_ListObjAppendElement(NULL, pidsObj,
Tcl_NewWideIntObj(
TclpGetPid(pipePtr->pidPtr[i])));
Tcl_DetachPids(1, &pipePtr->pidPtr[i]);
}
Tcl_SetObjResult(interp, pidsObj);
if (pipePtr->numPids > 0) {
Tcl_Free(pipePtr->pidPtr);
pipePtr->numPids = 0;
}
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1894 1895 1896 1897 1898 1899 1900 |
*/
if (pipePtr->errorFile) {
WinFile *filePtr = (WinFile *) pipePtr->errorFile;
errChan = Tcl_MakeFileChannel((ClientData) filePtr->handle,
TCL_READABLE);
| | | | | | 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 |
*/
if (pipePtr->errorFile) {
WinFile *filePtr = (WinFile *) pipePtr->errorFile;
errChan = Tcl_MakeFileChannel((ClientData) filePtr->handle,
TCL_READABLE);
Tcl_Free(filePtr);
} else {
errChan = NULL;
}
result = TclCleanupChildren(interp, pipePtr->numPids,
pipePtr->pidPtr, errChan);
}
if (pipePtr->numPids > 0) {
Tcl_Free(pipePtr->pidPtr);
}
if (pipePtr->writeBuf != NULL) {
Tcl_Free(pipePtr->writeBuf);
}
Tcl_Free(pipePtr);
if (errorCode == 0) {
return result;
}
return errorCode;
}
|
| ︙ | ︙ | |||
2045 2046 2047 2048 2049 2050 2051 |
PipeInfo *infoPtr = (PipeInfo *) instanceData;
WinFile *filePtr = (WinFile*) infoPtr->writeFile;
DWORD bytesWritten, timeout;
*errorCode = 0;
/* avoid blocking if pipe-thread exited */
| | > | | 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 |
PipeInfo *infoPtr = (PipeInfo *) instanceData;
WinFile *filePtr = (WinFile*) infoPtr->writeFile;
DWORD bytesWritten, timeout;
*errorCode = 0;
/* avoid blocking if pipe-thread exited */
timeout = ((infoPtr->flags & PIPE_ASYNC)
|| !TclPipeThreadIsAlive(&infoPtr->writeTI)
|| TclInExit() || TclInThreadExit()) ? 0 : INFINITE;
if (WaitForSingleObject(infoPtr->writable, timeout) == WAIT_TIMEOUT) {
/*
* The writer thread is blocked waiting for a write to complete and
* the channel is in non-blocking mode.
*/
errno = EWOULDBLOCK;
|
| ︙ | ︙ | |||
2079 2080 2081 2082 2083 2084 2085 |
if (toWrite > infoPtr->writeBufLen) {
/*
* Reallocate the buffer to be large enough to hold the data.
*/
if (infoPtr->writeBuf) {
| | | | | 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 |
if (toWrite > infoPtr->writeBufLen) {
/*
* Reallocate the buffer to be large enough to hold the data.
*/
if (infoPtr->writeBuf) {
Tcl_Free(infoPtr->writeBuf);
}
infoPtr->writeBufLen = toWrite;
infoPtr->writeBuf = Tcl_Alloc(toWrite);
}
memcpy(infoPtr->writeBuf, buf, toWrite);
infoPtr->toWrite = toWrite;
ResetEvent(infoPtr->writable);
TclPipeThreadSignal(&infoPtr->writeTI);
bytesWritten = toWrite;
} else {
/*
* In the blocking case, just try to write the buffer directly. This
|
| ︙ | ︙ | |||
2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 |
* Since most of the work is handled by the background threads, we just
* need to update the watchMask and then force the notifier to poll once.
*/
infoPtr->watchMask = mask & infoPtr->validMask;
if (infoPtr->watchMask) {
Tcl_Time blockTime = { 0, 0 };
if (!oldMask) {
infoPtr->nextPtr = tsdPtr->firstPipePtr;
tsdPtr->firstPipePtr = infoPtr;
}
Tcl_SetMaxBlockTime(&blockTime);
} else {
if (oldMask) {
| > | 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 |
* Since most of the work is handled by the background threads, we just
* need to update the watchMask and then force the notifier to poll once.
*/
infoPtr->watchMask = mask & infoPtr->validMask;
if (infoPtr->watchMask) {
Tcl_Time blockTime = { 0, 0 };
if (!oldMask) {
infoPtr->nextPtr = tsdPtr->firstPipePtr;
tsdPtr->firstPipePtr = infoPtr;
}
Tcl_SetMaxBlockTime(&blockTime);
} else {
if (oldMask) {
|
| ︙ | ︙ | |||
2343 2344 2345 2346 2347 2348 2349 |
* Find the process and cut it from the process list.
*/
Tcl_MutexLock(&pipeMutex);
prevPtrPtr = &procList;
for (infoPtr = procList; infoPtr != NULL;
prevPtrPtr = &infoPtr->nextPtr, infoPtr = infoPtr->nextPtr) {
| | | 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 |
* Find the process and cut it from the process list.
*/
Tcl_MutexLock(&pipeMutex);
prevPtrPtr = &procList;
for (infoPtr = procList; infoPtr != NULL;
prevPtrPtr = &infoPtr->nextPtr, infoPtr = infoPtr->nextPtr) {
if (infoPtr->dwProcessId == (size_t) pid) {
*prevPtrPtr = infoPtr->nextPtr;
break;
}
}
Tcl_MutexUnlock(&pipeMutex);
/*
|
| ︙ | ︙ | |||
2461 2462 2463 2464 2465 2466 2467 |
}
/*
* Officially close the process handle.
*/
CloseHandle(infoPtr->hProcess);
| | | 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 |
}
/*
* Officially close the process handle.
*/
CloseHandle(infoPtr->hProcess);
Tcl_Free(infoPtr);
return result;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
2487 2488 2489 2490 2491 2492 2493 |
*
*----------------------------------------------------------------------
*/
void
TclWinAddProcess(
void *hProcess, /* Handle to process */
| | | | 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 |
*
*----------------------------------------------------------------------
*/
void
TclWinAddProcess(
void *hProcess, /* Handle to process */
size_t id) /* Global process identifier */
{
ProcInfo *procPtr = Tcl_Alloc(sizeof(ProcInfo));
PipeInit();
procPtr->hProcess = hProcess;
procPtr->dwProcessId = id;
Tcl_MutexLock(&pipeMutex);
procPtr->nextPtr = procList;
|
| ︙ | ︙ | |||
2539 2540 2541 2542 2543 2544 2545 |
if (objc > 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?channelId?");
return TCL_ERROR;
}
if (objc == 1) {
Tcl_SetObjResult(interp, Tcl_NewWideIntObj((unsigned) getpid()));
} else {
| | | 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 |
if (objc > 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?channelId?");
return TCL_ERROR;
}
if (objc == 1) {
Tcl_SetObjResult(interp, Tcl_NewWideIntObj((unsigned) getpid()));
} else {
chan = Tcl_GetChannel(interp, TclGetString(objv[1]),
NULL);
if (chan == (Tcl_Channel) NULL) {
return TCL_ERROR;
}
chanTypePtr = Tcl_GetChannelType(chan);
if (chanTypePtr != &pipeChannelType) {
return TCL_OK;
|
| ︙ | ︙ | |||
2701 2702 2703 2704 2705 2706 2707 |
*----------------------------------------------------------------------
*/
static DWORD WINAPI
PipeReaderThread(
LPVOID arg)
{
| | > | | 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 |
*----------------------------------------------------------------------
*/
static DWORD WINAPI
PipeReaderThread(
LPVOID arg)
{
TclPipeThreadInfo *pipeTI = (TclPipeThreadInfo *) arg;
PipeInfo *infoPtr = NULL; /* access info only after success init/wait */
HANDLE handle = NULL;
DWORD count, err;
int done = 0;
while (!done) {
/*
* Wait for the main thread to signal before attempting to wait on the
* pipe becoming readable.
*/
if (!TclPipeThreadWaitForSignal(&pipeTI)) {
/* exit */
break;
}
if (!infoPtr) {
infoPtr = (PipeInfo *) pipeTI->clientData;
handle = ((WinFile *) infoPtr->readFile)->handle;
}
/*
* Try waiting for 0 bytes. This will block until some data is
* available on NT, but will return immediately on Win 95. So, if no
* data is available after the first read, we block until we can read
|
| ︙ | ︙ | |||
2971 2972 2973 2974 2975 2976 2977 |
Tcl_Channel
TclpOpenTemporaryFile(
Tcl_Obj *dirObj,
Tcl_Obj *basenameObj,
Tcl_Obj *extensionObj,
Tcl_Obj *resultingNameObj)
{
| | > | | | | | | | 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 |
Tcl_Channel
TclpOpenTemporaryFile(
Tcl_Obj *dirObj,
Tcl_Obj *basenameObj,
Tcl_Obj *extensionObj,
Tcl_Obj *resultingNameObj)
{
WCHAR name[MAX_PATH];
char *namePtr;
HANDLE handle;
DWORD flags = FILE_ATTRIBUTE_TEMPORARY;
size_t length;
int counter, counter2;
Tcl_DString buf;
if (!resultingNameObj) {
flags |= FILE_FLAG_DELETE_ON_CLOSE;
}
namePtr = (char *) name;
length = GetTempPath(MAX_PATH, name);
if (length == 0) {
goto gotError;
}
namePtr += length * sizeof(WCHAR);
if (basenameObj) {
const char *string = TclGetStringFromObj(basenameObj, &length);
Tcl_WinUtfToTChar(string, length, &buf);
memcpy(namePtr, Tcl_DStringValue(&buf), Tcl_DStringLength(&buf));
namePtr += Tcl_DStringLength(&buf);
Tcl_DStringFree(&buf);
} else {
const WCHAR *baseStr = L"TCL";
length = 3 * sizeof(WCHAR);
memcpy(namePtr, baseStr, length);
namePtr += length;
}
counter = TclpGetClicks() % 65533;
counter2 = 1024; /* Only try this many times! Prevents
* an infinite loop. */
|
| ︙ | ︙ | |||
3063 3064 3065 3066 3067 3068 3069 |
ClientData clientData,
HANDLE wakeEvent)
{
TclPipeThreadInfo *pipeTI;
#ifndef _PTI_USE_CKALLOC
pipeTI = malloc(sizeof(TclPipeThreadInfo));
#else
| | | | 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 |
ClientData clientData,
HANDLE wakeEvent)
{
TclPipeThreadInfo *pipeTI;
#ifndef _PTI_USE_CKALLOC
pipeTI = malloc(sizeof(TclPipeThreadInfo));
#else
pipeTI = Tcl_Alloc(sizeof(TclPipeThreadInfo));
#endif /* !_PTI_USE_CKALLOC */
pipeTI->evControl = CreateEvent(NULL, FALSE, FALSE, NULL);
pipeTI->state = PTI_STATE_IDLE;
pipeTI->clientData = clientData;
pipeTI->evWakeUp = wakeEvent;
return (*pipeTIPtr = pipeTI);
}
|
| ︙ | ︙ | |||
3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 |
HANDLE wakeEvent;
if (!pipeTI) {
return 0;
}
wakeEvent = pipeTI->evWakeUp;
/*
* Wait for the main thread to signal before attempting to do the work.
*/
| > > | > > | > | > | > > > > | < > > < > > | > > | > | > | > > > | > > | > | > > | 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 |
HANDLE wakeEvent;
if (!pipeTI) {
return 0;
}
wakeEvent = pipeTI->evWakeUp;
/*
* Wait for the main thread to signal before attempting to do the work.
*/
/*
* Reset work state of thread (idle/waiting)
*/
state = InterlockedCompareExchange(&pipeTI->state, PTI_STATE_IDLE,
PTI_STATE_WORK);
if (state & (PTI_STATE_STOP|PTI_STATE_END)) {
/*
* End of work, check the owner of structure.
*/
goto end;
}
/*
* Entering wait
*/
waitResult = WaitForSingleObject(pipeTI->evControl, INFINITE);
if (waitResult != WAIT_OBJECT_0) {
/*
* The control event was not signaled, so end of work (unexpected
* behaviour, main thread can be dead?).
*/
goto end;
}
/*
* Try to set work state of thread
*/
state = InterlockedCompareExchange(&pipeTI->state, PTI_STATE_WORK,
PTI_STATE_IDLE);
if (state & (PTI_STATE_STOP|PTI_STATE_END)) {
/*
* End of work
*/
goto end;
}
/*
* Signaled to work.
*/
return 1;
end:
/*
* End of work, check the owner of the TI structure.
*/
if (state != PTI_STATE_STOP) {
*pipeTIPtr = NULL;
} else {
pipeTI->evWakeUp = NULL;
}
if (wakeEvent) {
SetEvent(wakeEvent);
|
| ︙ | ︙ | |||
3166 3167 3168 3169 3170 3171 3172 | * 1 if signaled (or pipe-thread is down), 0 if pipe thread still working. * *---------------------------------------------------------------------- */ int TclPipeThreadStopSignal( | | > < | | | < | | | < > > | < | < | | | | > | > | | 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 |
* 1 if signaled (or pipe-thread is down), 0 if pipe thread still working.
*
*----------------------------------------------------------------------
*/
int
TclPipeThreadStopSignal(
TclPipeThreadInfo **pipeTIPtr,
HANDLE wakeEvent)
{
TclPipeThreadInfo *pipeTI = *pipeTIPtr;
HANDLE evControl;
int state;
if (!pipeTI) {
return 1;
}
evControl = pipeTI->evControl;
pipeTI->evWakeUp = wakeEvent;
state = InterlockedCompareExchange(&pipeTI->state, PTI_STATE_STOP,
PTI_STATE_IDLE);
switch (state) {
case PTI_STATE_IDLE:
/*
* Thread was idle/waiting, notify it goes teardown
*/
SetEvent(evControl);
*pipeTIPtr = NULL;
case PTI_STATE_DOWN:
return 1;
default:
/*
* Thread works currently, we should try to end it, own the TI
* structure (because of possible sharing the joint structures with
* thread)
*/
InterlockedExchange(&pipeTI->state, PTI_STATE_END);
break;
}
return 0;
}
/*
|
| ︙ | ︙ | |||
3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 |
if (!pipeTI) {
return;
}
pipeTI = *pipeTIPtr;
evControl = pipeTI->evControl;
pipeTI->evWakeUp = NULL;
/*
* Try to sane stop the pipe worker, corresponding its current state
*/
| > | | | | < | | | > > | > | > > > | | > | > > | | > | > > | > | | | | | > | > | | | > | > | < > < > > | | > | < > > | | | | | < | | | | | > | | | > | | | > | | > | > | | | < > | > > > < > | | | | | 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 3505 3506 3507 3508 3509 3510 3511 3512 3513 3514 3515 3516 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 3549 3550 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 3590 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 3629 3630 3631 3632 3633 3634 3635 3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 3652 3653 |
if (!pipeTI) {
return;
}
pipeTI = *pipeTIPtr;
evControl = pipeTI->evControl;
pipeTI->evWakeUp = NULL;
/*
* Try to sane stop the pipe worker, corresponding its current state
*/
state = InterlockedCompareExchange(&pipeTI->state, PTI_STATE_STOP,
PTI_STATE_IDLE);
switch (state) {
case PTI_STATE_IDLE:
/*
* Thread was idle/waiting, notify it goes teardown
*/
SetEvent(evControl);
/*
* We don't need to wait for it at all, thread frees himself (owns the
* TI structure)
*/
pipeTI = NULL;
break;
case PTI_STATE_STOP:
/*
* Already stopped, thread frees himself (owns the TI structure)
*/
pipeTI = NULL;
break;
case PTI_STATE_DOWN:
/*
* Thread already down (?), do nothing
*/
/*
* We don't need to wait for it, but we should free pipeTI
*/
hThread = NULL;
break;
/* case PTI_STATE_WORK: */
default:
/*
* Thread works currently, we should try to end it, own the TI
* structure (because of possible sharing the joint structures with
* thread)
*/
state = InterlockedCompareExchange(&pipeTI->state, PTI_STATE_END,
PTI_STATE_WORK);
if (state == PTI_STATE_DOWN) {
/*
* We don't need to wait for it, but we should free pipeTI
*/
hThread = NULL;
}
break;
}
if (pipeTI && hThread) {
DWORD exitCode;
/*
* The thread may already have closed on its own. Check its exit
* code.
*/
GetExitCodeThread(hThread, &exitCode);
if (exitCode == STILL_ACTIVE) {
int inExit = (TclInExit() || TclInThreadExit());
/*
* Set the stop event so that if the pipe thread is blocked
* somewhere, it may hereafter sane exit cleanly.
*/
SetEvent(evControl);
/*
* Cancel all sync-IO of this thread (may be blocked there).
*/
CancelSynchronousIo(hThread);
/*
* Wait at most 20 milliseconds for the reader thread to close
* (regarding TIP#398-fast-exit).
*/
/*
* If we want TIP#398-fast-exit.
*/
if (WaitForSingleObject(hThread, inExit ? 0 : 20) == WAIT_TIMEOUT) {
/*
* The thread must be blocked waiting for the pipe to become
* readable in ReadFile(). There isn't a clean way to exit the
* thread from this condition. We should terminate the child
* process instead to get the reader thread to fall out of
* ReadFile with a FALSE. (below) is not the correct way to do
* this, but will stay here until a better solution is found.
*
* Note that we need to guard against terminating the thread
* while it is in the middle of Tcl_ThreadAlert because it
* won't be able to release the notifier lock.
*
* Also note that terminating threads during their
* initialization or teardown phase may result in ntdll.dll's
* LoaderLock to remain locked indefinitely. This causes
* ntdll.dll's LdrpInitializeThread() to deadlock trying to
* acquire LoaderLock. LdrpInitializeThread() is executed
* within new threads to perform initialization and to execute
* DllMain() of all loaded dlls. As a result, all new threads
* are deadlocked in their initialization phase and never
* execute, even though CreateThread() reports successful
* thread creation. This results in a very weird process-wide
* behavior, which is extremely hard to debug.
*
* THREADS SHOULD NEVER BE TERMINATED. Period.
*
* But for now, check if thread is exiting, and if so, let it
* die peacefully.
*
* Also don't terminate if in exit (otherwise deadlocked in
* ntdll.dll's).
*/
if (pipeTI->state != PTI_STATE_DOWN
&& WaitForSingleObject(hThread,
inExit ? 50 : 5000) != WAIT_OBJECT_0) {
/* BUG: this leaks memory */
if (inExit || !TerminateThread(hThread, 0)) {
/*
* in exit or terminate fails, just give thread a
* chance to exit
*/
if (InterlockedExchange(&pipeTI->state,
PTI_STATE_STOP) != PTI_STATE_DOWN) {
pipeTI = NULL;
}
}
}
}
}
}
*pipeTIPtr = NULL;
if (pipeTI) {
if (pipeTI->evWakeUp) {
SetEvent(pipeTI->evWakeUp);
}
CloseHandle(pipeTI->evControl);
#ifndef _PTI_USE_CKALLOC
free(pipeTI);
#else
Tcl_Free(pipeTI);
#endif /* !_PTI_USE_CKALLOC */
}
}
/*
*----------------------------------------------------------------------
*
* TclPipeThreadExit --
|
| ︙ | ︙ | |||
3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 |
void
TclPipeThreadExit(
TclPipeThreadInfo **pipeTIPtr)
{
LONG state;
TclPipeThreadInfo *pipeTI = *pipeTIPtr;
/*
* If state of thread was set to stop (exactly), we can sane free its info
* structure, otherwise it is shared with main thread, so main thread will
* own it.
*/
if (!pipeTI) {
return;
}
*pipeTIPtr = NULL;
| > > | | | | | | | 3668 3669 3670 3671 3672 3673 3674 3675 3676 3677 3678 3679 3680 3681 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 3695 3696 3697 3698 3699 3700 3701 3702 3703 3704 3705 3706 3707 3708 |
void
TclPipeThreadExit(
TclPipeThreadInfo **pipeTIPtr)
{
LONG state;
TclPipeThreadInfo *pipeTI = *pipeTIPtr;
/*
* If state of thread was set to stop (exactly), we can sane free its info
* structure, otherwise it is shared with main thread, so main thread will
* own it.
*/
if (!pipeTI) {
return;
}
*pipeTIPtr = NULL;
state = InterlockedExchange(&pipeTI->state, PTI_STATE_DOWN);
if (state == PTI_STATE_STOP) {
CloseHandle(pipeTI->evControl);
if (pipeTI->evWakeUp) {
SetEvent(pipeTI->evWakeUp);
}
#ifndef _PTI_USE_CKALLOC
free(pipeTI);
#else
Tcl_Free(pipeTI);
/* be sure all subsystems used are finalized */
Tcl_FinalizeThread();
#endif /* !_PTI_USE_CKALLOC */
}
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to win/tclWinPort.h.
| ︙ | ︙ | |||
48 49 50 51 52 53 54 | #define INCL_WINSOCK_API_TYPEDEFS 1 #include <winsock2.h> #include <ws2tcpip.h> #ifdef HAVE_WSPIAPI_H # include <wspiapi.h> #endif | < < < < < < < < < | 48 49 50 51 52 53 54 55 56 57 58 59 60 61 |
#define INCL_WINSOCK_API_TYPEDEFS 1
#include <winsock2.h>
#include <ws2tcpip.h>
#ifdef HAVE_WSPIAPI_H
# include <wspiapi.h>
#endif
/*
* Pull in the typedef of TCHAR for windows.
*/
#include <tchar.h>
#ifndef _TCHAR_DEFINED
/* Borland seems to forget to set this. */
typedef _TCHAR TCHAR;
|
| ︙ | ︙ | |||
547 548 549 550 551 552 553 | /* * The following macros have trivial definitions, allowing generic code to * address platform-specific issues. */ | | | 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 | /* * The following macros have trivial definitions, allowing generic code to * address platform-specific issues. */ #define TclpReleaseFile(file) Tcl_Free(file) /* * The following macros and declarations wrap the C runtime library * functions. */ #define TclpExit exit |
| ︙ | ︙ |
Changes to win/tclWinReg.c.
| ︙ | ︙ | |||
18 19 20 21 22 23 24 | #endif #include "tclInt.h" #ifdef _MSC_VER # pragma comment (lib, "advapi32.lib") #endif #include <stdlib.h> | < < < < < < < | 18 19 20 21 22 23 24 25 26 27 28 29 30 31 | #endif #include "tclInt.h" #ifdef _MSC_VER # pragma comment (lib, "advapi32.lib") #endif #include <stdlib.h> /* * Ensure that we can say which registry is being accessed. */ #ifndef KEY_WOW64_64KEY # define KEY_WOW64_64KEY (0x0100) #endif |
| ︙ | ︙ | |||
126 127 128 129 130 131 132 133 134 135 136 137 138 139 | const TCHAR * pKeyName, REGSAM mode); static int RegistryObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int SetValue(Tcl_Interp *interp, Tcl_Obj *keyNameObj, Tcl_Obj *valueNameObj, Tcl_Obj *dataObj, Tcl_Obj *typeObj, REGSAM mode); DLLEXPORT int Registry_Init(Tcl_Interp *interp); DLLEXPORT int Registry_Unload(Tcl_Interp *interp, int flags); /* *---------------------------------------------------------------------- * | > > > > > > > > > > > > > > > > > > > | 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 |
const TCHAR * pKeyName, REGSAM mode);
static int RegistryObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
static int SetValue(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
Tcl_Obj *valueNameObj, Tcl_Obj *dataObj,
Tcl_Obj *typeObj, REGSAM mode);
static unsigned char *
getByteArrayFromObj(
Tcl_Obj *objPtr,
size_t *lengthPtr
) {
int length;
unsigned char *result = Tcl_GetByteArrayFromObj(objPtr, &length);
#if TCL_MAJOR_VERSION > 8
if (sizeof(TCL_HASH_TYPE) > sizeof(int)) {
/* 64-bit and TIP #494 situation: */
*lengthPtr = *(TCL_HASH_TYPE *) objPtr->internalRep.twoPtrValue.ptr1;
} else
#endif
/* 32-bit or without TIP #494 */
*lengthPtr = (size_t) (unsigned) length;
return result;
}
DLLEXPORT int Registry_Init(Tcl_Interp *interp);
DLLEXPORT int Registry_Unload(Tcl_Interp *interp, int flags);
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
159 160 161 162 163 164 165 |
if (Tcl_InitStubs(interp, "8.5", 0) == NULL) {
return TCL_ERROR;
}
cmd = Tcl_CreateObjCommand(interp, "registry", RegistryObjCmd,
interp, DeleteCmd);
Tcl_SetAssocData(interp, REGISTRY_ASSOC_KEY, NULL, cmd);
| | | 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 |
if (Tcl_InitStubs(interp, "8.5", 0) == NULL) {
return TCL_ERROR;
}
cmd = Tcl_CreateObjCommand(interp, "registry", RegistryObjCmd,
interp, DeleteCmd);
Tcl_SetAssocData(interp, REGISTRY_ASSOC_KEY, NULL, cmd);
return Tcl_PkgProvide(interp, "registry", "1.3.3");
}
/*
*----------------------------------------------------------------------
*
* Registry_Unload --
*
|
| ︙ | ︙ | |||
410 411 412 413 414 415 416 |
REGSAM saveMode = mode;
/*
* Find the parent of the key being deleted and open it.
*/
keyName = Tcl_GetString(keyNameObj);
| | | | | | 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 |
REGSAM saveMode = mode;
/*
* Find the parent of the key being deleted and open it.
*/
keyName = Tcl_GetString(keyNameObj);
buffer = Tcl_Alloc(keyNameObj->length + 1);
strcpy(buffer, keyName);
if (ParseKeyName(interp, buffer, &hostName, &rootKey,
&keyName) != TCL_OK) {
Tcl_Free(buffer);
return TCL_ERROR;
}
if (*keyName == '\0') {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("bad key: cannot delete root keys", -1));
Tcl_SetErrorCode(interp, "WIN_REG", "DEL_ROOT_KEY", NULL);
Tcl_Free(buffer);
return TCL_ERROR;
}
tail = strrchr(keyName, '\\');
if (tail) {
*tail++ = '\0';
} else {
tail = keyName;
keyName = NULL;
}
mode |= KEY_ENUMERATE_SUB_KEYS | DELETE;
result = OpenSubKey(hostName, rootKey, keyName, mode, 0, &subkey);
if (result != ERROR_SUCCESS) {
Tcl_Free(buffer);
if (result == ERROR_FILE_NOT_FOUND) {
return TCL_OK;
}
Tcl_SetObjResult(interp,
Tcl_NewStringObj("unable to delete key: ", -1));
AppendSystemError(interp, result);
return TCL_ERROR;
|
| ︙ | ︙ | |||
466 467 468 469 470 471 472 |
AppendSystemError(interp, result);
result = TCL_ERROR;
} else {
result = TCL_OK;
}
RegCloseKey(subkey);
| | | 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 |
AppendSystemError(interp, result);
result = TCL_ERROR;
} else {
result = TCL_OK;
}
RegCloseKey(subkey);
Tcl_Free(buffer);
return result;
}
/*
*----------------------------------------------------------------------
*
* DeleteValue --
|
| ︙ | ︙ | |||
495 496 497 498 499 500 501 |
Tcl_Interp *interp, /* Current interpreter. */
Tcl_Obj *keyNameObj, /* Name of key. */
Tcl_Obj *valueNameObj, /* Name of value to delete. */
REGSAM mode) /* Mode flags to pass. */
{
HKEY key;
char *valueName;
| < < | | 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 |
Tcl_Interp *interp, /* Current interpreter. */
Tcl_Obj *keyNameObj, /* Name of key. */
Tcl_Obj *valueNameObj, /* Name of value to delete. */
REGSAM mode) /* Mode flags to pass. */
{
HKEY key;
char *valueName;
DWORD result;
Tcl_DString ds;
/*
* Attempt to open the key for deletion.
*/
mode |= KEY_SET_VALUE;
if (OpenKey(interp, keyNameObj, mode, 0, &key) != TCL_OK) {
return TCL_ERROR;
}
valueName = Tcl_GetString(valueNameObj);
Tcl_WinUtfToTChar(valueName, valueNameObj->length, &ds);
result = RegDeleteValue(key, (const TCHAR *)Tcl_DStringValue(&ds));
Tcl_DStringFree(&ds);
if (result != ERROR_SUCCESS) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unable to delete value \"%s\" from key \"%s\": ",
Tcl_GetString(valueNameObj), Tcl_GetString(keyNameObj)));
AppendSystemError(interp, result);
|
| ︙ | ︙ | |||
599 600 601 602 603 604 605 | "unable to enumerate subkeys of \"%s\": ", Tcl_GetString(keyNameObj))); AppendSystemError(interp, result); result = TCL_ERROR; } break; } | | < | 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 |
"unable to enumerate subkeys of \"%s\": ",
Tcl_GetString(keyNameObj)));
AppendSystemError(interp, result);
result = TCL_ERROR;
}
break;
}
name = Tcl_WinTCharToUtf(buffer, bufSize * sizeof(TCHAR), &ds);
if (pattern && !Tcl_StringMatch(name, pattern)) {
Tcl_DStringFree(&ds);
continue;
}
result = Tcl_ListObjAppendElement(interp, resultPtr,
Tcl_NewStringObj(name, Tcl_DStringLength(&ds)));
Tcl_DStringFree(&ds);
|
| ︙ | ︙ | |||
651 652 653 654 655 656 657 |
REGSAM mode) /* Mode flags to pass. */
{
HKEY key;
DWORD result, type;
Tcl_DString ds;
const char *valueName;
const TCHAR *nativeValue;
| < < | | 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 |
REGSAM mode) /* Mode flags to pass. */
{
HKEY key;
DWORD result, type;
Tcl_DString ds;
const char *valueName;
const TCHAR *nativeValue;
/*
* Attempt to open the key for reading.
*/
mode |= KEY_QUERY_VALUE;
if (OpenKey(interp, keyNameObj, mode, 0, &key) != TCL_OK) {
return TCL_ERROR;
}
/*
* Get the type of the value.
*/
valueName = Tcl_GetString(valueNameObj);
nativeValue = Tcl_WinUtfToTChar(valueName, valueNameObj->length, &ds);
result = RegQueryValueEx(key, nativeValue, NULL, &type,
NULL, NULL);
Tcl_DStringFree(&ds);
RegCloseKey(key);
if (result != ERROR_SUCCESS) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
|
| ︙ | ︙ | |||
724 725 726 727 728 729 730 |
REGSAM mode) /* Mode flags to pass. */
{
HKEY key;
const char *valueName;
const TCHAR *nativeValue;
DWORD result, length, type;
Tcl_DString data, buf;
| < | 731 732 733 734 735 736 737 738 739 740 741 742 743 744 |
REGSAM mode) /* Mode flags to pass. */
{
HKEY key;
const char *valueName;
const TCHAR *nativeValue;
DWORD result, length, type;
Tcl_DString data, buf;
/*
* Attempt to open the key for reading.
*/
mode |= KEY_QUERY_VALUE;
if (OpenKey(interp, keyNameObj, mode, 0, &key) != TCL_OK) {
|
| ︙ | ︙ | |||
750 751 752 753 754 755 756 |
*/
Tcl_DStringInit(&data);
Tcl_DStringSetLength(&data, TCL_DSTRING_STATIC_SIZE - 1);
length = TCL_DSTRING_STATIC_SIZE/sizeof(TCHAR) - 1;
valueName = Tcl_GetString(valueNameObj);
| < | | 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 |
*/
Tcl_DStringInit(&data);
Tcl_DStringSetLength(&data, TCL_DSTRING_STATIC_SIZE - 1);
length = TCL_DSTRING_STATIC_SIZE/sizeof(TCHAR) - 1;
valueName = Tcl_GetString(valueNameObj);
nativeValue = Tcl_WinUtfToTChar(valueName, valueNameObj->length, &buf);
result = RegQueryValueEx(key, nativeValue, NULL, &type,
(BYTE *) Tcl_DStringValue(&data), &length);
while (result == ERROR_MORE_DATA) {
/*
* The Windows docs say that in this error case, we just need to
* expand our buffer and request more data. Required for
|
| ︙ | ︙ | |||
940 941 942 943 944 945 946 |
Tcl_Interp *interp, /* Current interpreter. */
Tcl_Obj *keyNameObj, /* Key to open. */
REGSAM mode, /* Access mode. */
int flags, /* 0 or REG_CREATE. */
HKEY *keyPtr) /* Returned HKEY. */
{
char *keyName, *buffer, *hostName;
| < | < | | 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 |
Tcl_Interp *interp, /* Current interpreter. */
Tcl_Obj *keyNameObj, /* Key to open. */
REGSAM mode, /* Access mode. */
int flags, /* 0 or REG_CREATE. */
HKEY *keyPtr) /* Returned HKEY. */
{
char *keyName, *buffer, *hostName;
HKEY rootKey;
DWORD result;
keyName = Tcl_GetString(keyNameObj);
buffer = Tcl_Alloc(keyNameObj->length + 1);
strcpy(buffer, keyName);
result = ParseKeyName(interp, buffer, &hostName, &rootKey, &keyName);
if (result == TCL_OK) {
result = OpenSubKey(hostName, rootKey, keyName, mode, flags, keyPtr);
if (result != ERROR_SUCCESS) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("unable to open key: ", -1));
AppendSystemError(interp, result);
result = TCL_ERROR;
} else {
result = TCL_OK;
}
}
Tcl_Free(buffer);
return result;
}
/*
*----------------------------------------------------------------------
*
* OpenSubKey --
|
| ︙ | ︙ | |||
1015 1016 1017 1018 1019 1020 1021 |
}
/*
* Now open the specified key with the requested permissions. Note that
* this key must be closed by the caller.
*/
| > | > > | > | 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 |
}
/*
* Now open the specified key with the requested permissions. Note that
* this key must be closed by the caller.
*/
if (keyName) {
keyName = (char *) Tcl_WinUtfToTChar(keyName, -1, &buf);
}
if (flags & REG_CREATE) {
DWORD create;
result = RegCreateKeyEx(rootKey, (TCHAR *)keyName, 0, NULL,
REG_OPTION_NON_VOLATILE, mode, NULL, keyPtr, &create);
} else if (rootKey == HKEY_PERFORMANCE_DATA) {
/*
* Here we fudge it for this special root key. See MSDN for more info
* on HKEY_PERFORMANCE_DATA and the peculiarities surrounding it.
*/
*keyPtr = HKEY_PERFORMANCE_DATA;
result = ERROR_SUCCESS;
} else {
result = RegOpenKeyEx(rootKey, (TCHAR *)keyName, 0, mode,
keyPtr);
}
if (keyName) {
Tcl_DStringFree(&buf);
}
/*
* Be sure to close the root key since we are done with it now.
*/
if (hostName) {
RegCloseKey(rootKey);
|
| ︙ | ︙ | |||
1244 1245 1246 1247 1248 1249 1250 |
Tcl_Obj *keyNameObj, /* Name of key. */
Tcl_Obj *valueNameObj, /* Name of value to set. */
Tcl_Obj *dataObj, /* Data to be written. */
Tcl_Obj *typeObj, /* Type of data to be written. */
REGSAM mode) /* Mode flags to pass. */
{
int type;
| < < | | 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 |
Tcl_Obj *keyNameObj, /* Name of key. */
Tcl_Obj *valueNameObj, /* Name of value to set. */
Tcl_Obj *dataObj, /* Data to be written. */
Tcl_Obj *typeObj, /* Type of data to be written. */
REGSAM mode) /* Mode flags to pass. */
{
int type;
DWORD result;
HKEY key;
const char *valueName;
Tcl_DString nameBuf;
if (typeObj == NULL) {
type = REG_SZ;
} else if (Tcl_GetIndexFromObj(interp, typeObj, typeNames, "type",
0, (int *) &type) != TCL_OK) {
if (Tcl_GetIntFromObj(NULL, typeObj, (int *) &type) != TCL_OK) {
return TCL_ERROR;
}
Tcl_ResetResult(interp);
}
mode |= KEY_ALL_ACCESS;
if (OpenKey(interp, keyNameObj, mode, 1, &key) != TCL_OK) {
return TCL_ERROR;
}
valueName = Tcl_GetString(valueNameObj);
valueName = (char *) Tcl_WinUtfToTChar(valueName, valueNameObj->length, &nameBuf);
if (type == REG_DWORD || type == REG_DWORD_BIG_ENDIAN) {
int value;
if (Tcl_GetIntFromObj(interp, dataObj, &value) != TCL_OK) {
RegCloseKey(key);
Tcl_DStringFree(&nameBuf);
|
| ︙ | ︙ | |||
1301 1302 1303 1304 1305 1306 1307 |
* nulls, which aren't allowed in REG_MULTI_SZ values.
*/
Tcl_DStringInit(&data);
for (i = 0; i < objc; i++) {
const char *bytes = Tcl_GetString(objv[i]);
| < | < | < | | | | 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 |
* nulls, which aren't allowed in REG_MULTI_SZ values.
*/
Tcl_DStringInit(&data);
for (i = 0; i < objc; i++) {
const char *bytes = Tcl_GetString(objv[i]);
Tcl_DStringAppend(&data, bytes, objv[i]->length);
/*
* Add a null character to separate this value from the next.
*/
Tcl_DStringAppend(&data, "", 1); /* NUL-terminated string */
}
Tcl_WinUtfToTChar(Tcl_DStringValue(&data), Tcl_DStringLength(&data)+1,
&buf);
result = RegSetValueEx(key, (TCHAR *) valueName, 0,
(DWORD) type, (BYTE *) Tcl_DStringValue(&buf),
(DWORD) Tcl_DStringLength(&buf));
Tcl_DStringFree(&data);
Tcl_DStringFree(&buf);
} else if (type == REG_SZ || type == REG_EXPAND_SZ) {
Tcl_DString buf;
const char *data = Tcl_GetString(dataObj);
data = (char *) Tcl_WinUtfToTChar(data, dataObj->length, &buf);
/*
* Include the null in the length, padding if needed for WCHAR.
*/
Tcl_DStringSetLength(&buf, Tcl_DStringLength(&buf)+1);
result = RegSetValueEx(key, (TCHAR *) valueName, 0,
(DWORD) type, (BYTE *) data, (DWORD) Tcl_DStringLength(&buf) + 1);
Tcl_DStringFree(&buf);
} else {
BYTE *data;
size_t bytelength;
/*
* Store binary data in the registry.
*/
data = (BYTE *) getByteArrayFromObj(dataObj, &bytelength);
result = RegSetValueEx(key, (TCHAR *) valueName, 0,
(DWORD) type, data, (DWORD) bytelength);
}
Tcl_DStringFree(&nameBuf);
RegCloseKey(key);
|
| ︙ | ︙ | |||
1404 1405 1406 1407 1408 1409 1410 |
}
if (Tcl_GetIntFromObj(interp, objv[2], &timeout) != TCL_OK) {
return TCL_ERROR;
}
}
str = Tcl_GetString(objv[0]);
| < | | 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 |
}
if (Tcl_GetIntFromObj(interp, objv[2], &timeout) != TCL_OK) {
return TCL_ERROR;
}
}
str = Tcl_GetString(objv[0]);
wstr = (WCHAR *) Tcl_WinUtfToTChar(str, objv[0]->length, &ds);
if (Tcl_DStringLength(&ds) == 0) {
wstr = NULL;
}
/*
* Use the ignore the result.
*/
|
| ︙ | ︙ |
Changes to win/tclWinSerial.c.
| ︙ | ︙ | |||
39 40 41 42 43 44 45 46 47 48 49 50 51 52 | /* * Bit masks used in the sharedFlags field of the SerialInfo structure below. */ #define SERIAL_EOF (1<<2) /* Serial has reached EOF. */ #define SERIAL_ERROR (1<<4) /* * Default time to block between checking status on the serial port. */ #define SERIAL_DEFAULT_BLOCKTIME 10 /* 10 msec */ /* | > > > > > > > > > | 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 | /* * Bit masks used in the sharedFlags field of the SerialInfo structure below. */ #define SERIAL_EOF (1<<2) /* Serial has reached EOF. */ #define SERIAL_ERROR (1<<4) /* * Bit masks used for noting whether to drain or discard output on close. They * are disjoint from each other; at most one may be set at a time. */ #define SERIAL_CLOSE_DRAIN (1<<6) /* Drain all output on close. */ #define SERIAL_CLOSE_DISCARD (1<<7) /* Discard all output on close. */ #define SERIAL_CLOSE_MASK (3<<6) /* Both two bits above. */ /* * Default time to block between checking status on the serial port. */ #define SERIAL_DEFAULT_BLOCKTIME 10 /* 10 msec */ /* |
| ︙ | ︙ | |||
518 519 520 521 522 523 524 |
/*
* Queue an event if the serial is signaled for reading or writing.
*/
if (needEvent) {
infoPtr->flags |= SERIAL_PENDING;
| | | 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 |
/*
* Queue an event if the serial is signaled for reading or writing.
*/
if (needEvent) {
infoPtr->flags |= SERIAL_PENDING;
evPtr = Tcl_Alloc(sizeof(SerialEvent));
evPtr->header.proc = SerialEventProc;
evPtr->infoPtr = infoPtr;
Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL);
}
}
}
|
| ︙ | ︙ | |||
600 601 602 603 604 605 606 |
if (serialPtr->validMask & TCL_READABLE) {
PurgeComm(serialPtr->handle, PURGE_RXABORT | PURGE_RXCLEAR);
CloseHandle(serialPtr->osRead.hEvent);
}
serialPtr->validMask &= ~TCL_READABLE;
if (serialPtr->writeThread) {
| < | 609 610 611 612 613 614 615 616 617 618 619 620 621 622 |
if (serialPtr->validMask & TCL_READABLE) {
PurgeComm(serialPtr->handle, PURGE_RXABORT | PURGE_RXCLEAR);
CloseHandle(serialPtr->osRead.hEvent);
}
serialPtr->validMask &= ~TCL_READABLE;
if (serialPtr->writeThread) {
TclPipeThreadStop(&serialPtr->writeTI, serialPtr->writeThread);
CloseHandle(serialPtr->osWrite.hEvent);
CloseHandle(serialPtr->evWritable);
CloseHandle(serialPtr->writeThread);
serialPtr->writeThread = NULL;
|
| ︙ | ︙ | |||
650 651 652 653 654 655 656 |
}
/*
* Wrap the error file into a channel and give it to the cleanup routine.
*/
if (serialPtr->writeBuf != NULL) {
| | | | 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 |
}
/*
* Wrap the error file into a channel and give it to the cleanup routine.
*/
if (serialPtr->writeBuf != NULL) {
Tcl_Free(serialPtr->writeBuf);
serialPtr->writeBuf = NULL;
}
Tcl_Free(serialPtr);
if (errorCode == 0) {
return result;
}
return errorCode;
}
|
| ︙ | ︙ | |||
1015 1016 1017 1018 1019 1020 1021 |
if (toWrite > infoPtr->writeBufLen) {
/*
* Reallocate the buffer to be large enough to hold the data.
*/
if (infoPtr->writeBuf) {
| | | | | 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 |
if (toWrite > infoPtr->writeBufLen) {
/*
* Reallocate the buffer to be large enough to hold the data.
*/
if (infoPtr->writeBuf) {
Tcl_Free(infoPtr->writeBuf);
}
infoPtr->writeBufLen = toWrite;
infoPtr->writeBuf = Tcl_Alloc(toWrite);
}
memcpy(infoPtr->writeBuf, buf, toWrite);
infoPtr->toWrite = toWrite;
ResetEvent(infoPtr->evWritable);
TclPipeThreadSignal(&infoPtr->writeTI);
bytesWritten = (DWORD) toWrite;
} else {
/*
|
| ︙ | ︙ | |||
1274 1275 1276 1277 1278 1279 1280 |
/*
* Wait for the main thread to signal before attempting to write.
*/
if (!TclPipeThreadWaitForSignal(&pipeTI)) {
/* exit */
break;
}
| | | 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 |
/*
* Wait for the main thread to signal before attempting to write.
*/
if (!TclPipeThreadWaitForSignal(&pipeTI)) {
/* exit */
break;
}
infoPtr = (SerialInfo *) pipeTI->clientData;
buf = infoPtr->writeBuf;
toWrite = infoPtr->toWrite;
myWrite.hEvent = CreateEvent(NULL, TRUE, FALSE, NULL);
/*
|
| ︙ | ︙ | |||
1338 1339 1340 1341 1342 1343 1344 |
*/
Tcl_ThreadAlert(infoPtr->threadId);
}
Tcl_MutexUnlock(&serialMutex);
}
| > > > > > > > > > > > > > > > > | > > | 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 |
*/
Tcl_ThreadAlert(infoPtr->threadId);
}
Tcl_MutexUnlock(&serialMutex);
}
/*
* We're about to close, so do any drain or discard required.
*/
if (infoPtr) {
switch (infoPtr->flags & SERIAL_CLOSE_MASK) {
case SERIAL_CLOSE_DRAIN:
FlushFileBuffers(infoPtr->handle);
break;
case SERIAL_CLOSE_DISCARD:
PurgeComm(infoPtr->handle, PURGE_TXABORT | PURGE_TXCLEAR);
break;
}
}
/*
* Worker exit, so inform the main thread or free TI-structure (if owned).
*/
TclPipeThreadExit(&pipeTI);
return 0;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
1364 1365 1366 1367 1368 1369 1370 |
*
*----------------------------------------------------------------------
*/
HANDLE
TclWinSerialOpen(
HANDLE handle,
| | | 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 |
*
*----------------------------------------------------------------------
*/
HANDLE
TclWinSerialOpen(
HANDLE handle,
const WCHAR *name,
DWORD access)
{
SerialInit();
/*
* If an open channel is specified, close it
*/
|
| ︙ | ︙ | |||
1417 1418 1419 1420 1421 1422 1423 |
char *channelName,
int permissions)
{
SerialInfo *infoPtr;
SerialInit();
| | | 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 |
char *channelName,
int permissions)
{
SerialInfo *infoPtr;
SerialInit();
infoPtr = Tcl_Alloc(sizeof(SerialInfo));
memset(infoPtr, 0, sizeof(SerialInfo));
infoPtr->validMask = permissions;
infoPtr->handle = handle;
infoPtr->channel = (Tcl_Channel) NULL;
infoPtr->readable = 0;
infoPtr->writable = 1;
|
| ︙ | ︙ | |||
1591 1592 1593 1594 1595 1596 1597 |
const char *value) /* New value for option. */
{
SerialInfo *infoPtr;
DCB dcb;
BOOL result, flag;
size_t len, vlen;
Tcl_DString ds;
| | > > > > > > > > > > > > > > > > > > > > > > > > > > | 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 |
const char *value) /* New value for option. */
{
SerialInfo *infoPtr;
DCB dcb;
BOOL result, flag;
size_t len, vlen;
Tcl_DString ds;
const WCHAR *native;
int argc;
const char **argv;
infoPtr = (SerialInfo *) instanceData;
/*
* Parse options. This would be far easier if we had Tcl_Objs to work with
* as that would let us use Tcl_GetIndexFromObj()...
*/
len = strlen(optionName);
vlen = strlen(value);
/*
* Option -closemode drain|discard|default
*/
if ((len > 2) && (strncmp(optionName, "-closemode", len) == 0)) {
if (Tcl_UtfNcasecmp(value, "DEFAULT", vlen) == 0) {
infoPtr->flags &= ~SERIAL_CLOSE_MASK;
} else if (Tcl_UtfNcasecmp(value, "DRAIN", vlen) == 0) {
infoPtr->flags &= ~SERIAL_CLOSE_MASK;
infoPtr->flags |= SERIAL_CLOSE_DRAIN;
} else if (Tcl_UtfNcasecmp(value, "DISCARD", vlen) == 0) {
infoPtr->flags &= ~SERIAL_CLOSE_MASK;
infoPtr->flags |= SERIAL_CLOSE_DISCARD;
} else {
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad mode \"%s\" for -closemode: must be"
" default, discard, or drain", value));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE",
"VALUE", NULL);
}
return TCL_ERROR;
}
return TCL_OK;
}
/*
* Option -mode baud,parity,databits,stopbits
*/
if ((len > 2) && (strncmp(optionName, "-mode", len) == 0)) {
if (!GetCommState(infoPtr->handle, &dcb)) {
|
| ︙ | ︙ | |||
1714 1715 1716 1717 1718 1719 1720 |
return TCL_ERROR;
}
if (argc != 2) {
badXchar:
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad value for -xchar: should be a list of"
| | | | | | | 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 |
return TCL_ERROR;
}
if (argc != 2) {
badXchar:
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad value for -xchar: should be a list of"
" two elements with each a single 8-bit character", -1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "XCHAR", NULL);
}
Tcl_Free((void *)argv);
return TCL_ERROR;
}
/*
* These dereferences are safe, even in the zero-length string cases,
* because that just makes the xon/xoff character into NUL. When the
* character looks like it is UTF-8 encoded, decode it before casting
* into the format required for the Win guts. Note that this does not
* convert character sets; it is expected that when people set the
* control characters to something large and custom, they'll know the
* hex/octal value rather than the printable form.
*/
dcb.XonChar = argv[0][0];
dcb.XoffChar = argv[1][0];
if (argv[0][0] & 0x80 || argv[1][0] & 0x80) {
Tcl_UniChar character = 0;
int charLen;
charLen = Tcl_UtfToUniChar(argv[0], &character);
if ((character > 0xFF) || argv[0][charLen]) {
goto badXchar;
}
dcb.XonChar = (char) character;
charLen = Tcl_UtfToUniChar(argv[1], &character);
if ((character > 0xFF) || argv[1][charLen]) {
goto badXchar;
}
dcb.XoffChar = (char) character;
}
Tcl_Free((void *)argv);
if (!SetCommState(infoPtr->handle, &dcb)) {
goto setStateFailed;
}
return TCL_OK;
}
|
| ︙ | ︙ | |||
1773 1774 1775 1776 1777 1778 1779 |
if ((argc % 2) == 1) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad value \"%s\" for -ttycontrol: should be "
"a list of signal,value pairs", value));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "TTYCONTROL", NULL);
}
| | | 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 |
if ((argc % 2) == 1) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad value \"%s\" for -ttycontrol: should be "
"a list of signal,value pairs", value));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "TTYCONTROL", NULL);
}
Tcl_Free((void *)argv);
return TCL_ERROR;
}
for (i = 0; i < argc - 1; i += 2) {
if (Tcl_GetBoolean(interp, argv[i+1], &flag) == TCL_ERROR) {
result = TCL_ERROR;
break;
|
| ︙ | ︙ | |||
1831 1832 1833 1834 1835 1836 1837 | NULL); } result = TCL_ERROR; break; } } | | | | | 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 |
NULL);
}
result = TCL_ERROR;
break;
}
}
Tcl_Free((void *)argv);
return result;
}
/*
* Option -sysbuffer {read_size write_size}
* Option -sysbuffer read_size
*/
if ((len > 1) && (strncmp(optionName, "-sysbuffer", len) == 0)) {
/*
* -sysbuffer 4096 or -sysbuffer {64536 4096}
*/
int inSize = -1, outSize = -1;
if (Tcl_SplitList(interp, value, &argc, &argv) == TCL_ERROR) {
return TCL_ERROR;
}
if (argc == 1) {
inSize = atoi(argv[0]);
outSize = infoPtr->sysBufWrite;
} else if (argc == 2) {
inSize = atoi(argv[0]);
outSize = atoi(argv[1]);
}
Tcl_Free((void *)argv);
if ((argc < 1) || (argc > 2) || (inSize <= 0) || (outSize <= 0)) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad value \"%s\" for -sysbuffer: should be "
"a list of one or two integers > 0", value));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "SYS_BUFFER", NULL);
|
| ︙ | ︙ | |||
1934 1935 1936 1937 1938 1939 1940 |
return TCL_ERROR;
}
return TCL_OK;
}
return Tcl_BadChannelOption(interp, optionName,
| | > | 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 |
return TCL_ERROR;
}
return TCL_OK;
}
return Tcl_BadChannelOption(interp, optionName,
"closemode mode handshake pollinterval sysbuffer timeout "
"ttycontrol xchar");
getStateFailed:
if (interp != NULL) {
TclWinConvertError(GetLastError());
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't get comm state: %s", Tcl_PosixError(interp)));
}
|
| ︙ | ︙ | |||
1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 |
infoPtr = (SerialInfo *) instanceData;
if (optionName == NULL) {
len = 0;
} else {
len = strlen(optionName);
}
/*
* Get option -mode
*/
if (len == 0) {
Tcl_DStringAppendElement(dsPtr, "-mode");
| > > > > > > > > > > > > > > > > > > > > > | 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 |
infoPtr = (SerialInfo *) instanceData;
if (optionName == NULL) {
len = 0;
} else {
len = strlen(optionName);
}
/*
* Get option -closemode
*/
if (len == 0) {
Tcl_DStringAppendElement(dsPtr, "-closemode");
}
if (len==0 || (len>1 && strncmp(optionName, "-closemode", len)==0)) {
switch (infoPtr->flags & SERIAL_CLOSE_MASK) {
case SERIAL_CLOSE_DRAIN:
Tcl_DStringAppendElement(dsPtr, "drain");
break;
case SERIAL_CLOSE_DISCARD:
Tcl_DStringAppendElement(dsPtr, "discard");
break;
default:
Tcl_DStringAppendElement(dsPtr, "default");
break;
}
}
/*
* Get option -mode
*/
if (len == 0) {
Tcl_DStringAppendElement(dsPtr, "-mode");
|
| ︙ | ︙ | |||
2073 2074 2075 2076 2077 2078 2079 |
*/
if (len == 0) {
Tcl_DStringAppendElement(dsPtr, "-xchar");
Tcl_DStringStartSublist(dsPtr);
}
if (len==0 || (len>1 && strncmp(optionName, "-xchar", len) == 0)) {
| | | | | 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 |
*/
if (len == 0) {
Tcl_DStringAppendElement(dsPtr, "-xchar");
Tcl_DStringStartSublist(dsPtr);
}
if (len==0 || (len>1 && strncmp(optionName, "-xchar", len) == 0)) {
char buf[TCL_UTF_MAX];
valid = 1;
if (!GetCommState(infoPtr->handle, &dcb)) {
if (interp != NULL) {
TclWinConvertError(GetLastError());
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't get comm state: %s", Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
buf[Tcl_UniCharToUtf(UCHAR(dcb.XonChar), buf)] = '\0';
Tcl_DStringAppendElement(dsPtr, buf);
buf[Tcl_UniCharToUtf(UCHAR(dcb.XoffChar), buf)] = '\0';
Tcl_DStringAppendElement(dsPtr, buf);
}
if (len == 0) {
Tcl_DStringEndSublist(dsPtr);
}
/*
|
| ︙ | ︙ | |||
2170 2171 2172 2173 2174 2175 2176 |
SerialModemStatusStr(status, dsPtr);
}
if (valid) {
return TCL_OK;
}
return Tcl_BadChannelOption(interp, optionName,
| | > | 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 |
SerialModemStatusStr(status, dsPtr);
}
if (valid) {
return TCL_OK;
}
return Tcl_BadChannelOption(interp, optionName,
"closemode mode pollinterval lasterror queue sysbuffer ttystatus "
"xchar");
}
/*
*----------------------------------------------------------------------
*
* SerialThreadActionProc --
*
|
| ︙ | ︙ |
Changes to win/tclWinSock.c.
| ︙ | ︙ | |||
78 79 80 81 82 83 84 | /* * The following variable is used to tell whether this module has been * initialized. If 1, initialization of sockets was successful, if -1 then * socket initialization failed (WSAStartup failed). */ static int initialized = 0; | | | 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 | /* * The following variable is used to tell whether this module has been * initialized. If 1, initialization of sockets was successful, if -1 then * socket initialization failed (WSAStartup failed). */ static int initialized = 0; static const WCHAR className[] = L"TclSocket"; TCL_DECLARE_MUTEX(socketMutex) /* * The following defines declare the messages used on socket windows. */ #define SOCKET_MESSAGE WM_USER+1 |
| ︙ | ︙ | |||
359 360 361 362 363 364 365 |
void
InitializeHostName(
char **valuePtr,
size_t *lengthPtr,
Tcl_Encoding *encodingPtr)
{
| | | 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 |
void
InitializeHostName(
char **valuePtr,
size_t *lengthPtr,
Tcl_Encoding *encodingPtr)
{
WCHAR tbuf[MAX_COMPUTERNAME_LENGTH + 1];
DWORD length = MAX_COMPUTERNAME_LENGTH + 1;
Tcl_DString ds;
if (GetComputerName(tbuf, &length) != 0) {
/*
* Convert string from native to UTF then change to lowercase.
*/
|
| ︙ | ︙ | |||
393 394 395 396 397 398 399 |
}
Tcl_DStringFree(&inDs);
}
}
*encodingPtr = Tcl_GetEncoding(NULL, "utf-8");
*lengthPtr = Tcl_DStringLength(&ds);
| | | 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 |
}
Tcl_DStringFree(&inDs);
}
}
*encodingPtr = Tcl_GetEncoding(NULL, "utf-8");
*lengthPtr = Tcl_DStringLength(&ds);
*valuePtr = Tcl_Alloc(*lengthPtr + 1);
memcpy(*valuePtr, Tcl_DStringValue(&ds), *lengthPtr + 1);
Tcl_DStringFree(&ds);
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
734 735 736 737 738 739 740 |
*/
if (errorCodePtr == NULL) {
return -1;
}
/*
| | | | 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 |
*/
if (errorCodePtr == NULL) {
return -1;
}
/*
* A non blocking socket waiting for an asynchronous connect
* returns directly the error EWOULDBLOCK
*/
if (GOT_BITS(statePtr->flags, TCP_NONBLOCKING)) {
*errorCodePtr = EWOULDBLOCK;
return -1;
}
|
| ︙ | ︙ | |||
1062 1063 1064 1065 1066 1067 1068 |
TcpFdList *thisfd = statePtr->sockets;
statePtr->sockets = thisfd->next;
if (closesocket(thisfd->fd) == SOCKET_ERROR) {
TclWinConvertError((DWORD) WSAGetLastError());
errorCode = Tcl_GetErrno();
}
| | | 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 |
TcpFdList *thisfd = statePtr->sockets;
statePtr->sockets = thisfd->next;
if (closesocket(thisfd->fd) == SOCKET_ERROR) {
TclWinConvertError((DWORD) WSAGetLastError());
errorCode = Tcl_GetErrno();
}
Tcl_Free(thisfd);
}
}
if (statePtr->addrlist != NULL) {
freeaddrinfo(statePtr->addrlist);
}
if (statePtr->myaddrlist != NULL) {
|
| ︙ | ︙ | |||
1104 1105 1106 1107 1108 1109 1110 |
/*
* TIP #218. Removed the code removing the structure from the global
* socket list. This is now done by the thread action callbacks, and only
* there. This happens before this code is called. We can free without
* fear of damaging the list.
*/
| | | 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 |
/*
* TIP #218. Removed the code removing the structure from the global
* socket list. This is now done by the thread action callbacks, and only
* there. This happens before this code is called. We can free without
* fear of damaging the list.
*/
Tcl_Free(statePtr);
return errorCode;
}
/*
*----------------------------------------------------------------------
*
* TcpClose2Proc --
|
| ︙ | ︙ | |||
1686 1687 1688 1689 1690 1691 1692 | * * TcpConnect -- * * This function opens a new socket in client mode. * * This might be called in 3 circumstances: * - By a regular socket command | | | | | | 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 |
*
* TcpConnect --
*
* This function opens a new socket in client mode.
*
* This might be called in 3 circumstances:
* - By a regular socket command
* - By the event handler to continue an asynchronously connect
* - By a blocking socket function (gets/puts) to terminate the
* connect synchronously
*
* Results:
* TCL_OK, if the socket was successfully connected or an asynchronous
* connection is in progress. If an error occurs, TCL_ERROR is returned
* and an error message is left in interp.
*
* Side effects:
* Opens a socket.
*
* Remarks:
* A single host name may resolve to more than one IP address, e.g. for
* an IPv4/IPv6 dual stack host. For handling asynchronously connecting
* sockets in the background for such hosts, this function can act as a
* coroutine. On the first call, it sets up the control variables for the
* two nested loops over the local and remote addresses. Once the first
* connection attempt is in progress, it sets up itself as a writable
* event handler for that socket, and returns. When the callback occurs,
* control is transferred to the "reenter" label, right after the initial
* return and the loops resume as if they had never been interrupted.
* For synchronously connecting sockets, the loops work the usual way.
*
*----------------------------------------------------------------------
*/
static int
TcpConnect(
Tcl_Interp *interp, /* For error reporting; can be NULL. */
|
| ︙ | ︙ | |||
1812 1813 1814 1815 1816 1817 1818 |
if (bind(statePtr->sockets->fd, statePtr->myaddr->ai_addr,
statePtr->myaddr->ai_addrlen) == SOCKET_ERROR) {
TclWinConvertError((DWORD) WSAGetLastError());
continue;
}
/*
| | | 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 |
if (bind(statePtr->sockets->fd, statePtr->myaddr->ai_addr,
statePtr->myaddr->ai_addrlen) == SOCKET_ERROR) {
TclWinConvertError((DWORD) WSAGetLastError());
continue;
}
/*
* For asynchroneous connect set the socket in nonblocking mode
* and activate connect notification
*/
if (async_connect) {
TcpState *statePtr2;
int in_socket_list = 0;
|
| ︙ | ︙ | |||
1926 1927 1928 1929 1930 1931 1932 |
* Free list lock.
*/
SetEvent(tsdPtr->socketListLock);
}
/*
| | | | 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 |
* Free list lock.
*/
SetEvent(tsdPtr->socketListLock);
}
/*
* Clear the tsd socket list pointer if we did not wait for
* the FD_CONNECT asynchroneously
*/
tsdPtr->pendingTcpState = NULL;
if (Tcl_GetErrno() == 0) {
goto out;
}
|
| ︙ | ︙ | |||
2010 2011 2012 2013 2014 2015 2016 |
* Free list lock.
*/
SetEvent(tsdPtr->socketListLock);
}
/*
| | | 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 |
* Free list lock.
*/
SetEvent(tsdPtr->socketListLock);
}
/*
* Error message on synchroneous connect
*/
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't open socket: %s", Tcl_PosixError(interp)));
}
return TCL_ERROR;
|
| ︙ | ︙ | |||
2718 2719 2720 2721 2722 2723 2724 |
WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
for (statePtr = tsdPtr->socketList; statePtr != NULL;
statePtr = statePtr->nextPtr) {
if (GOT_BITS(statePtr->readyEvents,
statePtr->watchEvents | FD_CONNECT | FD_ACCEPT)
&& !GOT_BITS(statePtr->flags, SOCKET_PENDING)) {
SET_BITS(statePtr->flags, SOCKET_PENDING);
| | | 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 |
WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
for (statePtr = tsdPtr->socketList; statePtr != NULL;
statePtr = statePtr->nextPtr) {
if (GOT_BITS(statePtr->readyEvents,
statePtr->watchEvents | FD_CONNECT | FD_ACCEPT)
&& !GOT_BITS(statePtr->flags, SOCKET_PENDING)) {
SET_BITS(statePtr->flags, SOCKET_PENDING);
evPtr = Tcl_Alloc(sizeof(SocketEvent));
evPtr->header.proc = SocketEventProc;
evPtr->socket = statePtr->sockets->fd;
Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL);
}
}
SetEvent(tsdPtr->socketListLock);
}
|
| ︙ | ︙ | |||
2993 2994 2995 2996 2997 2998 2999 |
TcpFdList *fds = statePtr->sockets;
if (fds == NULL) {
/*
* Add the first FD.
*/
| | | | 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 |
TcpFdList *fds = statePtr->sockets;
if (fds == NULL) {
/*
* Add the first FD.
*/
statePtr->sockets = Tcl_Alloc(sizeof(TcpFdList));
fds = statePtr->sockets;
} else {
/*
* Find end of list and append FD.
*/
while (fds->next != NULL) {
fds = fds->next;
}
fds->next = Tcl_Alloc(sizeof(TcpFdList));
fds = fds->next;
}
/*
* Populate new FD.
*/
|
| ︙ | ︙ | |||
3037 3038 3039 3040 3041 3042 3043 |
*
*----------------------------------------------------------------------
*/
static TcpState *
NewSocketInfo(SOCKET socket)
{
| | | 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 |
*
*----------------------------------------------------------------------
*/
static TcpState *
NewSocketInfo(SOCKET socket)
{
TcpState *statePtr = Tcl_Alloc(sizeof(TcpState));
memset(statePtr, 0, sizeof(TcpState));
/*
* TIP #218. Removed the code inserting the new structure into the global
* list. This is now handled in the thread action callbacks, and only
* there.
|
| ︙ | ︙ |
Changes to win/tclWinTest.c.
| ︙ | ︙ | |||
272 273 274 275 276 277 278 |
t2.HighPart = sysTime.dwHighDateTime;
t2.QuadPart -= t1.QuadPart;
QueryPerformanceCounter(&p2);
result = Tcl_NewObj();
Tcl_ListObjAppendElement(interp, result,
| | | | | | 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 |
t2.HighPart = sysTime.dwHighDateTime;
t2.QuadPart -= t1.QuadPart;
QueryPerformanceCounter(&p2);
result = Tcl_NewObj();
Tcl_ListObjAppendElement(interp, result,
Tcl_NewWideIntObj(t2.QuadPart / 10000000));
Tcl_ListObjAppendElement(interp, result,
Tcl_NewWideIntObj((t2.QuadPart / 10) % 1000000));
Tcl_ListObjAppendElement(interp, result, Tcl_NewWideIntObj(tclTime.sec));
Tcl_ListObjAppendElement(interp, result, Tcl_NewWideIntObj(tclTime.usec));
Tcl_ListObjAppendElement(interp, result, Tcl_NewWideIntObj(p1.QuadPart));
Tcl_ListObjAppendElement(interp, result, Tcl_NewWideIntObj(p2.QuadPart));
Tcl_SetObjResult(interp, result);
return TCL_OK;
|
| ︙ | ︙ | |||
395 396 397 398 399 400 401 402 403 |
static int
TestplatformChmod(
const char *nativePath,
int pmode)
{
static const SECURITY_INFORMATION infoBits = OWNER_SECURITY_INFORMATION
| GROUP_SECURITY_INFORMATION | DACL_SECURITY_INFORMATION;
static const DWORD readOnlyMask = FILE_DELETE_CHILD | FILE_ADD_FILE
| FILE_ADD_SUBDIRECTORY | FILE_WRITE_EA | FILE_APPEND_DATA
| > | > | 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 |
static int
TestplatformChmod(
const char *nativePath,
int pmode)
{
static const SECURITY_INFORMATION infoBits = OWNER_SECURITY_INFORMATION
| GROUP_SECURITY_INFORMATION | DACL_SECURITY_INFORMATION;
/* don't reset change permissions mask (WRITE_DAC, allow test-cases restore it to cleanup) */
static const DWORD readOnlyMask = FILE_DELETE_CHILD | FILE_ADD_FILE
| FILE_ADD_SUBDIRECTORY | FILE_WRITE_EA | FILE_APPEND_DATA
| FILE_WRITE_DATA
| DELETE;
/*
* References to security functions (only available on NT and later).
*/
const BOOL set_readOnly = !(pmode & 0222);
BOOL acl_readOnly_found = FALSE, curAclPresent, curAclDefaulted;
|
| ︙ | ︙ | |||
459 460 461 462 463 464 465 |
if (!GetFileSecurityA(nativePath, infoBits, NULL, 0, &secDescLen)) {
DWORD secDescLen2 = 0;
if (GetLastError() != ERROR_INSUFFICIENT_BUFFER) {
goto done;
}
| | | | 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 |
if (!GetFileSecurityA(nativePath, infoBits, NULL, 0, &secDescLen)) {
DWORD secDescLen2 = 0;
if (GetLastError() != ERROR_INSUFFICIENT_BUFFER) {
goto done;
}
secDesc = Tcl_Alloc(secDescLen);
if (!GetFileSecurityA(nativePath, infoBits,
(PSECURITY_DESCRIPTOR) secDesc, secDescLen, &secDescLen2)
|| (secDescLen < secDescLen2)) {
goto done;
}
}
/*
* Get the World SID.
*/
userSid = Tcl_Alloc(GetSidLengthRequired((UCHAR) 1));
InitializeSid(userSid, &userSidAuthority, (BYTE) 1);
*(GetSidSubAuthority(userSid, 0)) = SECURITY_WORLD_RID;
/*
* If curAclPresent == false then curAcl and curAclDefaulted not valid.
*/
|
| ︙ | ︙ | |||
497 498 499 500 501 502 503 |
/*
* Allocate memory for the new ACL.
*/
newAclSize = ACLSize.AclBytesInUse + sizeof(ACCESS_DENIED_ACE)
+ GetLengthSid(userSid) - sizeof(DWORD);
| | | 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 |
/*
* Allocate memory for the new ACL.
*/
newAclSize = ACLSize.AclBytesInUse + sizeof(ACCESS_DENIED_ACE)
+ GetLengthSid(userSid) - sizeof(DWORD);
newAcl = Tcl_Alloc(newAclSize);
/*
* Initialize the new ACL.
*/
if (!InitializeAcl(newAcl, newAclSize, ACL_REVISION)) {
goto done;
|
| ︙ | ︙ | |||
561 562 563 564 565 566 567 |
if (!AddAce(newAcl, ACL_REVISION, MAXDWORD, (PACL *) pACE2,
((PACE_HEADER) pACE2)->AceSize)) {
goto done;
}
}
/*
| | > | > | | | | | 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 |
if (!AddAce(newAcl, ACL_REVISION, MAXDWORD, (PACL *) pACE2,
((PACE_HEADER) pACE2)->AceSize)) {
goto done;
}
}
/*
* Apply the new ACL. Note PROTECTED_DACL_SECURITY_INFORMATION can be used
* to remove inherited ACL (we need to overwrite the default ACL's in this case)
*/
if (set_readOnly == acl_readOnly_found || SetNamedSecurityInfoA(
(LPSTR) nativePath, SE_FILE_OBJECT,
DACL_SECURITY_INFORMATION /*| PROTECTED_DACL_SECURITY_INFORMATION*/,
NULL, NULL, newAcl, NULL) == ERROR_SUCCESS) {
res = 0;
}
done:
if (secDesc) {
Tcl_Free(secDesc);
}
if (newAcl) {
Tcl_Free(newAcl);
}
if (userSid) {
Tcl_Free(userSid);
}
if (userDomain) {
Tcl_Free(userDomain);
}
if (res != 0) {
return res;
}
/*
|
| ︙ | ︙ |
Changes to win/tclWinThrd.c.
| ︙ | ︙ | |||
37 38 39 40 41 42 43 | static CRITICAL_SECTION initLock; /* * allocLock is used by Tcl's version of malloc for synchronization. For * obvious reasons, cannot use any dyamically allocated storage. */ | | | 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 |
static CRITICAL_SECTION initLock;
/*
* allocLock is used by Tcl's version of malloc for synchronization. For
* obvious reasons, cannot use any dyamically allocated storage.
*/
#if TCL_THREADS
static struct Tcl_Mutex_ {
CRITICAL_SECTION crit;
} allocLock;
static Tcl_Mutex allocLockPtr = &allocLock;
static int allocOnce = 0;
|
| ︙ | ︙ | |||
72 73 74 75 76 77 78 | * Condition Variable implementation. */ /* * The per-thread event and queue pointers. */ | | | 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 |
* Condition Variable implementation.
*/
/*
* The per-thread event and queue pointers.
*/
#if TCL_THREADS
typedef struct ThreadSpecificData {
HANDLE condEvent; /* Per-thread condition event */
struct ThreadSpecificData *nextPtr; /* Queue pointers */
struct ThreadSpecificData *prevPtr;
int flags; /* See flags below */
} ThreadSpecificData;
|
| ︙ | ︙ | |||
174 175 176 177 178 179 180 |
| _MCW_PC
#endif
);
lpOrigStartAddress = winThreadPtr->lpStartAddress;
lpOrigParameter = winThreadPtr->lpParameter;
| | | 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 |
| _MCW_PC
#endif
);
lpOrigStartAddress = winThreadPtr->lpStartAddress;
lpOrigParameter = winThreadPtr->lpParameter;
Tcl_Free(winThreadPtr);
return lpOrigStartAddress(lpOrigParameter);
}
/*
*----------------------------------------------------------------------
*
* TclpThreadCreate --
|
| ︙ | ︙ | |||
200 201 202 203 204 205 206 |
*/
int
TclpThreadCreate(
Tcl_ThreadId *idPtr, /* Return, the ID of the thread. */
Tcl_ThreadCreateProc *proc, /* Main() function of the thread. */
ClientData clientData, /* The one argument to Main(). */
| | | | 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 |
*/
int
TclpThreadCreate(
Tcl_ThreadId *idPtr, /* Return, the ID of the thread. */
Tcl_ThreadCreateProc *proc, /* Main() function of the thread. */
ClientData clientData, /* The one argument to Main(). */
size_t stackSize, /* Size of stack for the new thread. */
int flags) /* Flags controlling behaviour of the new
* thread. */
{
WinThread *winThreadPtr; /* Per-thread startup info */
HANDLE tHandle;
winThreadPtr = (WinThread *)Tcl_Alloc(sizeof(WinThread));
winThreadPtr->lpStartAddress = (LPTHREAD_START_ROUTINE) proc;
winThreadPtr->lpParameter = clientData;
winThreadPtr->fpControl = _controlfp(0, 0);
EnterCriticalSection(&joinLock);
*idPtr = 0; /* must initialize as Tcl_Thread is a pointer and
|
| ︙ | ︙ | |||
237 238 239 240 241 242 243 |
} else {
if (flags & TCL_THREAD_JOINABLE) {
TclRememberJoinableThread(*idPtr);
}
/*
* The only purpose of this is to decrement the reference count so the
| | | 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 |
} else {
if (flags & TCL_THREAD_JOINABLE) {
TclRememberJoinableThread(*idPtr);
}
/*
* The only purpose of this is to decrement the reference count so the
* OS resources will be reacquired when the thread closes.
*/
CloseHandle(tHandle);
LeaveCriticalSection(&joinLock);
return TCL_OK;
}
}
|
| ︙ | ︙ | |||
395 396 397 398 399 400 401 | * * TclpMasterLock * * This procedure is used to grab a lock that serializes creation of * mutexes, condition variables, and thread local storage keys. * * This lock must be different than the initLock because the initLock is | | | 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 | * * TclpMasterLock * * This procedure is used to grab a lock that serializes creation of * mutexes, condition variables, and thread local storage keys. * * This lock must be different than the initLock because the initLock is * held during creation of synchronization objects. * * Results: * None. * * Side effects: * Acquire the master mutex. * |
| ︙ | ︙ | |||
470 471 472 473 474 475 476 |
*
*----------------------------------------------------------------------
*/
Tcl_Mutex *
Tcl_GetAllocMutex(void)
{
| | | 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 |
*
*----------------------------------------------------------------------
*/
Tcl_Mutex *
Tcl_GetAllocMutex(void)
{
#if TCL_THREADS
if (!allocOnce) {
InitializeCriticalSection(&allocLock.crit);
allocOnce = 1;
}
return &allocLockPtr;
#else
return NULL;
|
| ︙ | ︙ | |||
512 513 514 515 516 517 518 |
/*
* Destroy the critical section that we are holding!
*/
DeleteCriticalSection(&masterLock);
initialized = 0;
| | | | | | 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 |
/*
* Destroy the critical section that we are holding!
*/
DeleteCriticalSection(&masterLock);
initialized = 0;
#if TCL_THREADS
if (allocOnce) {
DeleteCriticalSection(&allocLock.crit);
allocOnce = 0;
}
#endif
LeaveCriticalSection(&initLock);
/*
* Destroy the critical section that we were holding.
*/
DeleteCriticalSection(&initLock);
}
#if TCL_THREADS
/* locally used prototype */
static void FinalizeConditionEvent(ClientData data);
/*
*----------------------------------------------------------------------
*
* Tcl_MutexLock --
*
* This procedure is invoked to lock a mutex. This is a self initializing
* mutex that is automatically finalized during Tcl_Finalize.
*
* Results:
* None.
*
* Side effects:
* May block the current thread. The mutex is acquired when this returns.
*
*----------------------------------------------------------------------
*/
void
Tcl_MutexLock(
Tcl_Mutex *mutexPtr) /* The lock */
{
CRITICAL_SECTION *csPtr;
if (*mutexPtr == NULL) {
TclpMasterLock();
/*
* Double inside master lock check to avoid a race.
*/
if (*mutexPtr == NULL) {
csPtr = Tcl_Alloc(sizeof(CRITICAL_SECTION));
InitializeCriticalSection(csPtr);
*mutexPtr = (Tcl_Mutex)csPtr;
TclRememberMutex(mutexPtr);
}
TclpMasterUnlock();
}
csPtr = *((CRITICAL_SECTION **)mutexPtr);
|
| ︙ | ︙ | |||
625 626 627 628 629 630 631 |
TclpFinalizeMutex(
Tcl_Mutex *mutexPtr)
{
CRITICAL_SECTION *csPtr = *(CRITICAL_SECTION **)mutexPtr;
if (csPtr != NULL) {
DeleteCriticalSection(csPtr);
| | | | 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 |
TclpFinalizeMutex(
Tcl_Mutex *mutexPtr)
{
CRITICAL_SECTION *csPtr = *(CRITICAL_SECTION **)mutexPtr;
if (csPtr != NULL) {
DeleteCriticalSection(csPtr);
Tcl_Free(csPtr);
*mutexPtr = NULL;
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_ConditionWait --
*
* This procedure is invoked to wait on a condition variable. The mutex
* is atomically released as part of the wait, and automatically grabbed
* when the condition is signaled.
*
* The mutex must be held when this procedure is called.
*
* Results:
* None.
*
* Side effects:
* May block the current thread. The mutex is acquired when this returns.
* Will allocate memory for a HANDLE and initialize this the first time
* this Tcl_Condition is used.
*
*----------------------------------------------------------------------
*/
void
|
| ︙ | ︙ | |||
707 708 709 710 711 712 713 |
TclpMasterLock();
/*
* Initialize the per-condition queue pointers and Mutex.
*/
if (*condPtr == NULL) {
| | | 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 |
TclpMasterLock();
/*
* Initialize the per-condition queue pointers and Mutex.
*/
if (*condPtr == NULL) {
winCondPtr = Tcl_Alloc(sizeof(WinCondition));
InitializeCriticalSection(&winCondPtr->condLock);
winCondPtr->firstPtr = NULL;
winCondPtr->lastPtr = NULL;
*condPtr = (Tcl_Condition) winCondPtr;
TclRememberCondition(condPtr);
}
TclpMasterUnlock();
|
| ︙ | ︙ | |||
918 919 920 921 922 923 924 |
* The per-thread condition waiting event is reclaimed earlier in a
* per-thread exit handler, which is called before thread local storage is
* reclaimed.
*/
if (winCondPtr != NULL) {
DeleteCriticalSection(&winCondPtr->condLock);
| | | 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 |
* The per-thread condition waiting event is reclaimed earlier in a
* per-thread exit handler, which is called before thread local storage is
* reclaimed.
*/
if (winCondPtr != NULL) {
DeleteCriticalSection(&winCondPtr->condLock);
Tcl_Free(winCondPtr);
*condPtr = NULL;
}
}
|
| ︙ | ︙ |
Changes to win/tclWinTime.c.
| ︙ | ︙ | |||
24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 |
typedef struct {
CRITICAL_SECTION cs; /* Mutex guarding this structure. */
int initialized; /* Flag == 1 if this structure is
* initialized. */
int perfCounterAvailable; /* Flag == 1 if the hardware has a performance
* counter. */
HANDLE calibrationThread; /* Handle to the thread that keeps the virtual
* clock calibrated. */
HANDLE readyEvent; /* System event used to trigger the requesting
* thread when the clock calibration procedure
* is initialized for the first time. */
HANDLE exitEvent; /* Event to signal out of an exit handler to
* tell the calibration loop to terminate. */
LARGE_INTEGER nominalFreq; /* Nominal frequency of the system performance
* counter, that is, the value returned from
* QueryPerformanceFrequency. */
| > < > > > > | | | | > > > > > > > > > > > > > | 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 |
typedef struct {
CRITICAL_SECTION cs; /* Mutex guarding this structure. */
int initialized; /* Flag == 1 if this structure is
* initialized. */
int perfCounterAvailable; /* Flag == 1 if the hardware has a performance
* counter. */
DWORD calibrationInterv; /* Calibration interval in seconds (start 1 sec) */
HANDLE calibrationThread; /* Handle to the thread that keeps the virtual
* clock calibrated. */
HANDLE readyEvent; /* System event used to trigger the requesting
* thread when the clock calibration procedure
* is initialized for the first time. */
HANDLE exitEvent; /* Event to signal out of an exit handler to
* tell the calibration loop to terminate. */
LARGE_INTEGER nominalFreq; /* Nominal frequency of the system performance
* counter, that is, the value returned from
* QueryPerformanceFrequency. */
/*
* The following values are used for calculating virtual time. Virtual
* time is always equal to:
* lastFileTime + (current perf counter - lastCounter)
* * 10000000 / curCounterFreq
* and lastFileTime and lastCounter are updated any time that virtual time
* is returned to a caller.
*/
ULARGE_INTEGER fileTimeLastCall;
LARGE_INTEGER perfCounterLastCall;
LARGE_INTEGER curCounterFreq;
LARGE_INTEGER posixEpoch; /* Posix epoch expressed as 100-ns ticks since
* the windows epoch. */
/*
* Data used in developing the estimate of performance counter frequency
*/
Tcl_WideUInt fileTimeSample[SAMPLES];
/* Last 64 samples of system time. */
Tcl_WideInt perfCounterSample[SAMPLES];
/* Last 64 samples of performance counter. */
int sampleNo; /* Current sample number. */
} TimeInfo;
static TimeInfo timeInfo = {
{ NULL, 0, 0, NULL, NULL, 0 },
0,
0,
1,
(HANDLE) NULL,
(HANDLE) NULL,
(HANDLE) NULL,
#ifdef HAVE_CAST_TO_UNION
(LARGE_INTEGER) (Tcl_WideInt) 0,
(ULARGE_INTEGER) (DWORDLONG) 0,
(LARGE_INTEGER) (Tcl_WideInt) 0,
(LARGE_INTEGER) (Tcl_WideInt) 0,
(LARGE_INTEGER) (Tcl_WideInt) 0,
#else
{0, 0},
{0, 0},
{0, 0},
{0, 0},
{0, 0},
#endif
{ 0 },
{ 0 },
0
};
/*
* Scale to convert wide click values from the TclpGetWideClicks native
* resolution to microsecond resolution and back.
*/
static struct {
int initialized; /* 1 if initialized, 0 otherwise */
int perfCounter; /* 1 if performance counter usable for wide clicks */
double microsecsScale; /* Denominator scale between clock / microsecs */
} wideClick = {0, 0.0};
/*
* Declarations for functions defined later in this file.
*/
static void StopCalibration(ClientData clientData);
static DWORD WINAPI CalibrationThread(LPVOID arg);
static void UpdateTimeEachSecond(void);
static void ResetCounterSamples(Tcl_WideUInt fileTime,
Tcl_WideInt perfCounter, Tcl_WideInt perfFreq);
static Tcl_WideInt AccumulateSample(Tcl_WideInt perfCounter,
Tcl_WideUInt fileTime);
static void NativeScaleTime(Tcl_Time* timebuf,
ClientData clientData);
static Tcl_WideInt NativeGetMicroseconds(void);
static void NativeGetTime(Tcl_Time* timebuf,
ClientData clientData);
/*
* TIP #233 (Virtualized Time): Data for the time hooks, if any.
*/
|
| ︙ | ︙ | |||
123 124 125 126 127 128 129 | * * Side effects: * None. * *---------------------------------------------------------------------- */ | | > > > > > > > > | | | > | 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 |
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_WideUInt
TclpGetSeconds(void)
{
Tcl_WideInt usecSincePosixEpoch;
/* Try to use high resolution timer */
if ( tclGetTimeProcPtr == NativeGetTime
&& (usecSincePosixEpoch = NativeGetMicroseconds())
) {
return usecSincePosixEpoch / 1000000;
} else {
Tcl_Time t;
tclGetTimeProcPtr(&t, tclTimeClientData); /* Tcl_GetTime inlined. */
return t.sec;
}
}
/*
*----------------------------------------------------------------------
*
* TclpGetClicks --
*
|
| ︙ | ︙ | |||
151 152 153 154 155 156 157 | * * Side effects: * None. * *---------------------------------------------------------------------- */ | | > > > > > > > > | | | | | < | > | > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > | 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 |
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_WideUInt
TclpGetClicks(void)
{
Tcl_WideInt usecSincePosixEpoch;
/* Try to use high resolution timer */
if ( tclGetTimeProcPtr == NativeGetTime
&& (usecSincePosixEpoch = NativeGetMicroseconds())
) {
return (Tcl_WideUInt)usecSincePosixEpoch;
} else {
/*
* Use the Tcl_GetTime abstraction to get the time in microseconds, as
* nearly as we can, and return it.
*/
Tcl_Time now; /* Current Tcl time */
tclGetTimeProcPtr(&now, tclTimeClientData); /* Tcl_GetTime inlined */
return (Tcl_WideUInt)(now.sec * 1000000) + now.usec;
}
}
/*
*----------------------------------------------------------------------
*
* TclpGetWideClicks --
*
* This procedure returns a WideInt value that represents the highest
* resolution clock in microseconds available on the system.
*
* Results:
* Number of microseconds (from some start time).
*
* Side effects:
* This should be used for time-delta resp. for measurement purposes
* only, because on some platforms can return microseconds from some
* start time (not from the epoch).
*
*----------------------------------------------------------------------
*/
Tcl_WideInt
TclpGetWideClicks(void)
{
LARGE_INTEGER curCounter;
if (!wideClick.initialized) {
LARGE_INTEGER perfCounterFreq;
/*
* The frequency of the performance counter is fixed at system boot and
* is consistent across all processors. Therefore, the frequency need
* only be queried upon application initialization.
*/
if (QueryPerformanceFrequency(&perfCounterFreq)) {
wideClick.perfCounter = 1;
wideClick.microsecsScale = 1000000.0 / perfCounterFreq.QuadPart;
} else {
/* fallback using microseconds */
wideClick.perfCounter = 0;
wideClick.microsecsScale = 1;
}
wideClick.initialized = 1;
}
if (wideClick.perfCounter) {
if (QueryPerformanceCounter(&curCounter)) {
return (Tcl_WideInt)curCounter.QuadPart;
}
/* fallback using microseconds */
wideClick.perfCounter = 0;
wideClick.microsecsScale = 1;
return TclpGetMicroseconds();
} else {
return TclpGetMicroseconds();
}
}
/*
*----------------------------------------------------------------------
*
* TclpWideClickInMicrosec --
*
* This procedure return scale to convert wide click values from the
* TclpGetWideClicks native resolution to microsecond resolution
* and back.
*
* Results:
* 1 click in microseconds as double.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
double
TclpWideClickInMicrosec(void)
{
if (!wideClick.initialized) {
(void)TclpGetWideClicks(); /* initialize */
}
return wideClick.microsecsScale;
}
/*
*----------------------------------------------------------------------
*
* TclpGetMicroseconds --
*
* This procedure returns a WideInt value that represents the highest
* resolution clock in microseconds available on the system.
*
* Results:
* Number of microseconds (from the epoch).
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_WideInt
TclpGetMicroseconds(void)
{
Tcl_WideInt usecSincePosixEpoch;
/* Try to use high resolution timer */
if ( tclGetTimeProcPtr == NativeGetTime
&& (usecSincePosixEpoch = NativeGetMicroseconds())
) {
return usecSincePosixEpoch;
} else {
/*
* Use the Tcl_GetTime abstraction to get the time in microseconds, as
* nearly as we can, and return it.
*/
Tcl_Time now;
tclGetTimeProcPtr(&now, tclTimeClientData); /* Tcl_GetTime inlined */
return (((Tcl_WideInt)now.sec) * 1000000) + now.usec;
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetTime --
*
|
| ︙ | ︙ | |||
195 196 197 198 199 200 201 |
*----------------------------------------------------------------------
*/
void
Tcl_GetTime(
Tcl_Time *timePtr) /* Location to store time information. */
{
| > > > > > > > > > | > | 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 |
*----------------------------------------------------------------------
*/
void
Tcl_GetTime(
Tcl_Time *timePtr) /* Location to store time information. */
{
Tcl_WideInt usecSincePosixEpoch;
/* Try to use high resolution timer */
if ( tclGetTimeProcPtr == NativeGetTime
&& (usecSincePosixEpoch = NativeGetMicroseconds())
) {
timePtr->sec = (long) (usecSincePosixEpoch / 1000000);
timePtr->usec = (unsigned long) (usecSincePosixEpoch % 1000000);
} else {
tclGetTimeProcPtr(timePtr, tclTimeClientData);
}
}
/*
*----------------------------------------------------------------------
*
* NativeScaleTime --
*
|
| ︙ | ︙ | |||
228 229 230 231 232 233 234 |
* Native scale is 1:1. Nothing is done.
*/
}
/*
*----------------------------------------------------------------------
*
| | | | | > | | | > > | > > > > | | > | > > > > | 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 |
* Native scale is 1:1. Nothing is done.
*/
}
/*
*----------------------------------------------------------------------
*
* NativeGetMicroseconds --
*
* Gets the current system time in microseconds since the beginning
* of the epoch: 00:00 UCT, January 1, 1970.
*
* Results:
* Returns the wide integer with number of microseconds from the epoch, or
* 0 if high resolution timer is not available.
*
* Side effects:
* On the first call, initializes a set of static variables to keep track
* of the base value of the performance counter, the corresponding wall
* clock (obtained through ftime) and the frequency of the performance
* counter. Also spins a thread whose function is to wake up periodically
* and monitor these values, adjusting them as necessary to correct for
* drift in the performance counter's oscillator.
*
*----------------------------------------------------------------------
*/
static inline Tcl_WideInt
NativeCalc100NsTicks(
ULONGLONG fileTimeLastCall,
LONGLONG perfCounterLastCall,
LONGLONG curCounterFreq,
LONGLONG curCounter
) {
return fileTimeLastCall +
((curCounter - perfCounterLastCall) * 10000000 / curCounterFreq);
}
static Tcl_WideInt
NativeGetMicroseconds(void)
{
/*
* Initialize static storage on the first trip through.
*
* Note: Outer check for 'initialized' is a performance win since it
* avoids an extra mutex lock in the common case.
*/
if (!timeInfo.initialized) {
TclpInitLock();
if (!timeInfo.initialized) {
timeInfo.posixEpoch.LowPart = 0xD53E8000;
timeInfo.posixEpoch.HighPart = 0x019DB1DE;
timeInfo.perfCounterAvailable =
QueryPerformanceFrequency(&timeInfo.nominalFreq);
/*
* Some hardware abstraction layers use the CPU clock in place of
* the real-time clock as a performance counter reference. This
* results in:
|
| ︙ | ︙ | |||
368 369 370 371 372 373 374 |
if (timeInfo.perfCounterAvailable && timeInfo.curCounterFreq.QuadPart!=0) {
/*
* Query the performance counter and use it to calculate the current
* time.
*/
| | | < < < < < < < < < < | | | | | < < < | | | > | | < | > | < < > > > | | | > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | > > | | | > > > | 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 |
if (timeInfo.perfCounterAvailable && timeInfo.curCounterFreq.QuadPart!=0) {
/*
* Query the performance counter and use it to calculate the current
* time.
*/
ULONGLONG fileTimeLastCall;
LONGLONG perfCounterLastCall, curCounterFreq;
/* Copy with current data of calibration cycle */
LARGE_INTEGER curCounter;
/* Current performance counter. */
QueryPerformanceCounter(&curCounter);
/*
* Hold time section locked as short as possible
*/
EnterCriticalSection(&timeInfo.cs);
fileTimeLastCall = timeInfo.fileTimeLastCall.QuadPart;
perfCounterLastCall = timeInfo.perfCounterLastCall.QuadPart;
curCounterFreq = timeInfo.curCounterFreq.QuadPart;
LeaveCriticalSection(&timeInfo.cs);
/*
* If calibration cycle occurred after we get curCounter
*/
if (curCounter.QuadPart <= perfCounterLastCall) {
/* Calibrated file-time is saved from posix in 100-ns ticks */
return fileTimeLastCall / 10;
}
/*
* If it appears to be more than 1.1 seconds since the last trip
* through the calibration loop, the performance counter may have
* jumped forward. (See MSDN Knowledge Base article Q274323 for a
* description of the hardware problem that makes this test
* necessary.) If the counter jumps, we don't want to use it directly.
* Instead, we must return system time. Eventually, the calibration
* loop should recover.
*/
if (curCounter.QuadPart - perfCounterLastCall <
11 * curCounterFreq * timeInfo.calibrationInterv / 10
) {
/* Calibrated file-time is saved from posix in 100-ns ticks */
return NativeCalc100NsTicks(fileTimeLastCall,
perfCounterLastCall, curCounterFreq, curCounter.QuadPart) / 10;
}
}
/*
* High resolution timer is not available.
*/
return 0;
}
/*
*----------------------------------------------------------------------
*
* NativeGetTime --
*
* TIP #233: Gets the current system time in seconds and microseconds
* since the beginning of the epoch: 00:00 UCT, January 1, 1970.
*
* Results:
* Returns the current time in timePtr.
*
* Side effects:
* See NativeGetMicroseconds for more information.
*
*----------------------------------------------------------------------
*/
static void
NativeGetTime(
Tcl_Time *timePtr,
ClientData clientData)
{
Tcl_WideInt usecSincePosixEpoch;
/*
* Try to use high resolution timer.
*/
if ( (usecSincePosixEpoch = NativeGetMicroseconds()) ) {
timePtr->sec = (long) (usecSincePosixEpoch / 1000000);
timePtr->usec = (unsigned long) (usecSincePosixEpoch % 1000000);
} else {
/*
* High resolution timer is not available. Just use ftime.
*/
struct _timeb t;
_ftime(&t);
timePtr->sec = (long)t.time;
timePtr->usec = t.millitm * 1000;
}
}
/*
*----------------------------------------------------------------------
*
* StopCalibration --
*
* Turns off the calibration thread in preparation for exiting the
* process.
*
* Results:
* None.
*
* Side effects:
* Sets the 'exitEvent' event in the 'timeInfo' structure to ask the
* thread in question to exit, and waits for it to do so.
*
*----------------------------------------------------------------------
*/
void TclWinResetTimerResolution(void);
static void
StopCalibration(
ClientData unused) /* Client data is unused */
{
SetEvent(timeInfo.exitEvent);
|
| ︙ | ︙ | |||
518 519 520 521 522 523 524 525 526 527 528 529 530 531 |
*/
GetSystemTimeAsFileTime(&curFileTime);
QueryPerformanceCounter(&timeInfo.perfCounterLastCall);
QueryPerformanceFrequency(&timeInfo.curCounterFreq);
timeInfo.fileTimeLastCall.LowPart = curFileTime.dwLowDateTime;
timeInfo.fileTimeLastCall.HighPart = curFileTime.dwHighDateTime;
ResetCounterSamples(timeInfo.fileTimeLastCall.QuadPart,
timeInfo.perfCounterLastCall.QuadPart,
timeInfo.curCounterFreq.QuadPart);
/*
* Wake up the calling thread. When it wakes up, it will release the
| > > | 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 |
*/
GetSystemTimeAsFileTime(&curFileTime);
QueryPerformanceCounter(&timeInfo.perfCounterLastCall);
QueryPerformanceFrequency(&timeInfo.curCounterFreq);
timeInfo.fileTimeLastCall.LowPart = curFileTime.dwLowDateTime;
timeInfo.fileTimeLastCall.HighPart = curFileTime.dwHighDateTime;
/* Calibrated file-time will be saved from posix in 100-ns ticks */
timeInfo.fileTimeLastCall.QuadPart -= timeInfo.posixEpoch.QuadPart;
ResetCounterSamples(timeInfo.fileTimeLastCall.QuadPart,
timeInfo.perfCounterLastCall.QuadPart,
timeInfo.curCounterFreq.QuadPart);
/*
* Wake up the calling thread. When it wakes up, it will release the
|
| ︙ | ︙ | |||
577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 |
static void
UpdateTimeEachSecond(void)
{
LARGE_INTEGER curPerfCounter;
/* Current value returned from
* QueryPerformanceCounter. */
FILETIME curSysTime; /* Current system time. */
LARGE_INTEGER curFileTime; /* File time at the time this callback was
* scheduled. */
Tcl_WideInt estFreq; /* Estimated perf counter frequency. */
Tcl_WideInt vt0; /* Tcl time right now. */
Tcl_WideInt vt1; /* Tcl time one second from now. */
Tcl_WideInt tdiff; /* Difference between system clock and Tcl
* time. */
Tcl_WideInt driftFreq; /* Frequency needed to drift virtual time into
* step over 1 second. */
/*
| > | < > > > > > > > > | > | > < | 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 |
static void
UpdateTimeEachSecond(void)
{
LARGE_INTEGER curPerfCounter;
/* Current value returned from
* QueryPerformanceCounter. */
FILETIME curSysTime; /* Current system time. */
static LARGE_INTEGER lastFileTime; /* File time of the previous calibration */
LARGE_INTEGER curFileTime; /* File time at the time this callback was
* scheduled. */
Tcl_WideInt estFreq; /* Estimated perf counter frequency. */
Tcl_WideInt vt0; /* Tcl time right now. */
Tcl_WideInt vt1; /* Tcl time one second from now. */
Tcl_WideInt tdiff; /* Difference between system clock and Tcl
* time. */
Tcl_WideInt driftFreq; /* Frequency needed to drift virtual time into
* step over 1 second. */
/*
* Sample performance counter and system time (from posix epoch).
*/
GetSystemTimeAsFileTime(&curSysTime);
curFileTime.LowPart = curSysTime.dwLowDateTime;
curFileTime.HighPart = curSysTime.dwHighDateTime;
curFileTime.QuadPart -= timeInfo.posixEpoch.QuadPart;
/* If calibration still not needed (check for possible time switch) */
if ( curFileTime.QuadPart > lastFileTime.QuadPart
&& curFileTime.QuadPart < lastFileTime.QuadPart +
(timeInfo.calibrationInterv * 10000000)
) {
/* again in next one second */
return;
}
QueryPerformanceCounter(&curPerfCounter);
lastFileTime.QuadPart = curFileTime.QuadPart;
/*
* We devide by timeInfo.curCounterFreq.QuadPart in several places. That
* value should always be positive on a correctly functioning system. But
* it is good to be defensive about such matters. So if something goes
* wrong and the value does goes to zero, we clear the
* timeInfo.perfCounterAvailable in order to cause the calibration thread
* to shut itself down, then return without additional processing.
*/
if (timeInfo.curCounterFreq.QuadPart == 0){
timeInfo.perfCounterAvailable = 0;
return;
}
/*
* Several things may have gone wrong here that have to be checked for.
* (1) The performance counter may have jumped.
|
| ︙ | ︙ | |||
647 648 649 650 651 652 653 |
*
* vt1 = 20000000 + curFileTime
*
* The frequency that we need to use to drift the counter back into place
* is estFreq * 20000000 / (vt1 - vt0)
*/
| < | | < < | > | < > > | > > > > > > > > > > > > > | > > | > > > > | > > > > > > > | > > > > > > > > > > > > > > > | | > | > > | > > > > > > > > | 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 |
*
* vt1 = 20000000 + curFileTime
*
* The frequency that we need to use to drift the counter back into place
* is estFreq * 20000000 / (vt1 - vt0)
*/
vt0 = NativeCalc100NsTicks(timeInfo.fileTimeLastCall.QuadPart,
timeInfo.perfCounterLastCall.QuadPart, timeInfo.curCounterFreq.QuadPart,
curPerfCounter.QuadPart);
/*
* If we've gotten more than a second away from system time, then drifting
* the clock is going to be pretty hopeless. Just let it jump. Otherwise,
* compute the drift frequency and fill in everything.
*/
tdiff = vt0 - curFileTime.QuadPart;
if (tdiff > 10000000 || tdiff < -10000000) {
/* jump to current system time, use curent estimated frequency */
vt0 = curFileTime.QuadPart;
} else {
/* calculate new frequency and estimate drift to the next second */
vt1 = 20000000 + curFileTime.QuadPart;
driftFreq = (estFreq * 20000000 / (vt1 - vt0));
/*
* Avoid too large drifts (only half of the current difference),
* that allows also be more accurate (aspire to the smallest tdiff),
* so then we can prolong calibration interval by tdiff < 100000
*/
driftFreq = timeInfo.curCounterFreq.QuadPart +
(driftFreq - timeInfo.curCounterFreq.QuadPart) / 2;
/*
* Average between estimated, 2 current and 5 drifted frequencies,
* (do the soft drifting as possible)
*/
estFreq = (estFreq + 2 * timeInfo.curCounterFreq.QuadPart + 5 * driftFreq) / 8;
}
/* Avoid too large discrepancy from nominal frequency */
if (estFreq > 1003*timeInfo.nominalFreq.QuadPart/1000) {
estFreq = 1003*timeInfo.nominalFreq.QuadPart/1000;
vt0 = curFileTime.QuadPart;
} else if (estFreq < 997*timeInfo.nominalFreq.QuadPart/1000) {
estFreq = 997*timeInfo.nominalFreq.QuadPart/1000;
vt0 = curFileTime.QuadPart;
} else if (vt0 != curFileTime.QuadPart) {
/*
* Be sure the clock ticks never backwards (avoid it by negative drifting)
* just compare native time (in 100-ns) before and hereafter using
* new calibrated values) and do a small adjustment (short time freeze)
*/
LARGE_INTEGER newPerfCounter;
Tcl_WideInt nt0, nt1;
QueryPerformanceCounter(&newPerfCounter);
nt0 = NativeCalc100NsTicks(timeInfo.fileTimeLastCall.QuadPart,
timeInfo.perfCounterLastCall.QuadPart, timeInfo.curCounterFreq.QuadPart,
newPerfCounter.QuadPart);
nt1 = NativeCalc100NsTicks(vt0,
curPerfCounter.QuadPart, estFreq,
newPerfCounter.QuadPart);
if (nt0 > nt1) { /* drifted backwards, try to compensate with new base */
/* first adjust with a micro jump (short frozen time is acceptable) */
vt0 += nt0 - nt1;
/* if drift unavoidable (e. g. we had a time switch), then reset it */
vt1 = vt0 - curFileTime.QuadPart;
if (vt1 > 10000000 || vt1 < -10000000) {
/* larger jump resp. shift relative new file-time */
vt0 = curFileTime.QuadPart;
}
}
}
/* In lock commit new values to timeInfo (hold lock as short as possible) */
EnterCriticalSection(&timeInfo.cs);
/* grow calibration interval up to 10 seconds (if still precise enough) */
if (tdiff < -100000 || tdiff > 100000) {
/* too long drift - reset calibration interval to 1000 second */
timeInfo.calibrationInterv = 1;
} else if (timeInfo.calibrationInterv < 10) {
timeInfo.calibrationInterv++;
}
timeInfo.fileTimeLastCall.QuadPart = vt0;
timeInfo.curCounterFreq.QuadPart = estFreq;
timeInfo.perfCounterLastCall.QuadPart = curPerfCounter.QuadPart;
LeaveCriticalSection(&timeInfo.cs);
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ |
Changes to win/tclsh.rc.
1 2 3 4 5 6 7 8 9 10 | // // Version Resource Script // #include <winver.h> #include "tclWinInt.h" // // build-up the name suffix that defines the type of build this is. // | < < < < < < | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 | // // Version Resource Script // #include <winver.h> #include "tclWinInt.h" // // build-up the name suffix that defines the type of build this is. // #if STATIC_BUILD #define SUFFIX_STATIC "s" #else #define SUFFIX_STATIC "" #endif #if DEBUG && !UNCHECKED #define SUFFIX_DEBUG "g" #else #define SUFFIX_DEBUG "" #endif #define SUFFIX SUFFIX_STATIC SUFFIX_DEBUG LANGUAGE 0x9, 0x1 /* LANG_ENGLISH, SUBLANG_DEFAULT */ VS_VERSION_INFO VERSIONINFO FILEVERSION TCL_MAJOR_VERSION,TCL_MINOR_VERSION,TCL_RELEASE_LEVEL,TCL_RELEASE_SERIAL PRODUCTVERSION TCL_MAJOR_VERSION,TCL_MINOR_VERSION,TCL_RELEASE_LEVEL,TCL_RELEASE_SERIAL |
| ︙ | ︙ |