Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Overview
| Comment: | Merge 9.0 |
|---|---|
| Timelines: | family | ancestors | descendants | both | rfe-854941 | tip-596 |
| Files: | files | file ages | folders |
| SHA3-256: |
7a40e1f9d292545d5a74f2e1844cde8e |
| User & Date: | jan.nijtmans 2020-08-13 14:35:09.318 |
Context
|
2020-08-19
| ||
| 12:57 | Merge trunk check-in: 11e411820b user: jan.nijtmans tags: rfe-854941, tip-596 | |
|
2020-08-13
| ||
| 14:35 | Merge 9.0 check-in: 7a40e1f9d2 user: jan.nijtmans tags: rfe-854941, tip-596 | |
| 14:24 | Merge 8.7 check-in: 35e221aa02 user: jan.nijtmans tags: trunk | |
|
2020-03-17
| ||
| 17:00 | Merge trunk check-in: 297b775180 user: jan.nijtmans tags: rfe-854941, tip-596 | |
Changes
Changes to .fossil-settings/crlf-glob.
1 2 3 4 5 6 7 8 9 10 | compat/zlib/contrib/dotzlib/DotZLib/UnitTests.cs compat/zlib/contrib/vstudio/readme.txt compat/zlib/contrib/vstudio/*/zlib.rc compat/zlib/win32/*.txt compat/zlib/win64/*.txt libtommath/*.dsp libtommath/*.sln libtommath/*.vcproj tools/tcl.hpj.in tools/tcl.wse.in | > | 1 2 3 4 5 6 7 8 9 10 11 | compat/zlib/contrib/dotzlib/DotZLib/UnitTests.cs compat/zlib/contrib/vstudio/readme.txt compat/zlib/contrib/vstudio/*/zlib.rc compat/zlib/contrib/vstudio/*/*.sln compat/zlib/win32/*.txt compat/zlib/win64/*.txt libtommath/*.dsp libtommath/*.sln libtommath/*.vcproj tools/tcl.hpj.in tools/tcl.wse.in |
| ︙ | ︙ |
Changes to .fossil-settings/ignore-glob.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | *.a *.dll *.dylib *.exe *.exp *.la *.lib *.lo *.o *.obj *.pdb *.res *.sl *.so */Makefile */config.cache */config.log */config.status */tclConfig.sh */tclsh* */tcltest* */versions.vc | > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | *.a *.dll *.dylib *.dylib.E *.exe *.exp *.la *.lib *.lo *.o *.obj *.pdb *.res *.sl *.so */Makefile */autom4te.cache */config.cache */config.log */config.status */tclConfig.sh */tclsh* */tcltest* */versions.vc |
| ︙ | ︙ | |||
38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 | libtommath/pics/* libtommath/mtest/* libtommath/logs/* libtommath/etc/* libtommath/demo/* libtommath/*.out libtommath/*.tex unix/autoMkindex.tcl unix/dltest.marker unix/tcl.pc unix/tclIndex unix/pkgs/* win/Debug* win/Release* win/*.manifest win/pkgs/* win/coffbase.txt win/tcl.hpj win/nmhlp-out.txt | > > > > > > > > > | 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 | libtommath/pics/* libtommath/mtest/* libtommath/logs/* libtommath/etc/* libtommath/demo/* libtommath/*.out libtommath/*.tex macosx/configure unix/autoMkindex.tcl unix/dltest.marker unix/dltest/*.bundle unix/dltest/*.dll unix/dltest/*.dylib unix/dltest/*.o unix/dltest/*.sl unix/dltest/*.so unix/tcl.pc unix/tclIndex unix/Tcl-Info.plist unix/Tclsh-Info.plist unix/pkgs/* win/Debug* win/Release* win/*.manifest win/pkgs/* win/coffbase.txt win/tcl.hpj win/nmhlp-out.txt |
Added .fossil-settings/manifest.
> | 1 | u |
Changes to .gitignore.
1 2 3 4 5 6 7 8 9 10 11 12 | *.a *.dll *.dylib *.exe *.exp *.lib *.o *.obj *.pdb *.res *.sl *.so | > > > | > > > | | | > > > > < > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 | *.a *.bundle *.dll *.dylib *.dylib.E *.exe *.exp *.lib *.o *.obj *.pdb *.res *.sl *.so .fslckout Makefile Tcl-Info.plist Tclsh-Info.plist autom4te.cache config.cache config.log config.status config.status.lineno html manifest.uuid _FOSSIL_ */tclConfig.sh */tclsh* */tcltest* */versions.vc */version.vc */libtcl.vfs */libtcl_*.zip libtommath/bn.ilg libtommath/bn.ind libtommath/pretty.build libtommath/tommath.src libtommath/*.log libtommath/*.pdf libtommath/*.pl libtommath/*.sh libtommath/doc/* libtommath/tombc/* libtommath/pre_gen/* libtommath/pics/* libtommath/mtest/* libtommath/logs/* libtommath/etc/* libtommath/demo/* libtommath/*.out libtommath/*.tex macosx/configure unix/autoMkindex.tcl unix/dltest.marker unix/tcl.pc unix/tclIndex unix/pkgs/* win/Debug* win/Release* win/*.manifest win/pkgs/* win/coffbase.txt win/tcl.hpj win/nmakehlp.out win/nmhlp-out.txt |
Changes to .travis.yml.
|
| < | | > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
language: c
addons:
apt:
packages:
- binutils-mingw-w64-i686
- binutils-mingw-w64-x86-64
- gcc-mingw-w64
- gcc-mingw-w64-base
- gcc-mingw-w64-i686
- gcc-mingw-w64-x86-64
- gcc-multilib
jobs:
include:
# Testing on Linux with various compilers
- name: "Linux/GCC/Shared"
os: linux
dist: bionic
compiler: gcc
env:
|
| ︙ | ︙ | |||
34 35 36 37 38 39 40 41 42 43 44 45 46 47 |
- name: "Linux/GCC/Debug"
os: linux
dist: bionic
compiler: gcc
env:
- BUILD_DIR=unix
- CFGOPT="--enable-symbols"
# C++ build.
- name: "Linux/G++/Shared"
os: linux
dist: bionic
compiler: g++
env:
- BUILD_DIR=unix
| > > > > > > > | 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 |
- name: "Linux/GCC/Debug"
os: linux
dist: bionic
compiler: gcc
env:
- BUILD_DIR=unix
- CFGOPT="--enable-symbols"
- name: "Linux/GCC/Mem-Debug"
os: linux
dist: bionic
compiler: gcc
env:
- BUILD_DIR=unix
- CFGOPT="--enable-symbols=mem"
# C++ build.
- name: "Linux/G++/Shared"
os: linux
dist: bionic
compiler: g++
env:
- BUILD_DIR=unix
|
| ︙ | ︙ | |||
100 101 102 103 104 105 106 |
- name: "Linux/Clang/Debug"
os: linux
dist: bionic
compiler: clang
env:
- BUILD_DIR=unix
- CFGOPT="--enable-symbols"
| < | | | > > > | | < < < < | | | < < | | > > > > > > > > > | | > > > > > > > < < < < | | > | > | | > | < < < < < < < < < < < < < < < | 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 |
- name: "Linux/Clang/Debug"
os: linux
dist: bionic
compiler: clang
env:
- BUILD_DIR=unix
- CFGOPT="--enable-symbols"
- name: "Linux/Clang/Mem-Debug"
os: linux
dist: bionic
compiler: clang
env:
- BUILD_DIR=unix
- CFGOPT="--enable-symbols=mem"
# Testing on Mac, various styles
- name: "macOS/Clang/Xcode 11.5/Shared"
os: osx
osx_image: xcode11.5
env:
- BUILD_DIR=macosx
install: []
script: &mactest
- make all
# The styles=develop avoids some weird problems on OSX
- make test styles=develop
- name: "macOS/Clang/Xcode 11.5/Shared/Unix-like"
os: osx
osx_image: xcode11.5
env:
- BUILD_DIR=unix
- name: "macOS/Clang/Xcode 11.5/Shared/libtommath"
os: osx
osx_image: xcode11.5
env:
- BUILD_DIR=macosx
install: []
script: *mactest
addons:
homebrew:
packages:
- libtommath
- name: "macOS/Clang++/Xcode 11.5/Shared"
os: osx
osx_image: xcode11.5
env:
- BUILD_DIR=unix
- CFGOPT="CC=clang++ --enable-framework CFLAGS=-Dregister=dont+use+register CPPFLAGS=-D__private_extern__=extern"
script:
- make all tcltest
# Older MacOS versions
- name: "macOS/Clang/Xcode 11/Shared"
os: osx
osx_image: xcode11
env:
- BUILD_DIR=macosx
install: []
script: *mactest
- name: "macOS/Clang/Xcode 10/Shared"
os: osx
osx_image: xcode10.3
env:
- BUILD_DIR=macosx
install: []
script: *mactest
- name: "macOS/Clang/Xcode 9/Shared"
os: osx
osx_image: xcode9.2
env:
- BUILD_DIR=macosx
install: []
script: *mactest
- name: "macOS/Clang/Xcode 8/Shared"
os: osx
osx_image: xcode8.3
env:
- BUILD_DIR=macosx
install: []
script: *mactest
# Test with mingw-w64 cross-compile
# Doesn't run tests because wine is only an imperfect Windows emulation
- name: "Linux-cross-Windows/GCC/Shared/no test"
os: linux
dist: bionic
compiler: x86_64-w64-mingw32-gcc
env:
- BUILD_DIR=win
- CFGOPT="--host=x86_64-w64-mingw32 --enable-64bit"
script: &crosstest
- make all tcltest
# Include a high visibility marker that tests are skipped outright
- >
echo "`tput setaf 3`SKIPPED TEST: CROSS COMPILING`tput sgr0`"
# Test with mingw-w64 (32 bit) cross-compile
# Doesn't run tests because wine is only an imperfect Windows emulation
- name: "Linux-cross-Windows-32/GCC/Shared/no test"
os: linux
dist: bionic
compiler: i686-w64-mingw32-gcc
env:
- BUILD_DIR=win
- CFGOPT=--host=i686-w64-mingw32
script: *crosstest
# Test on Windows with MSVC native
- name: "Windows/MSVC/Shared"
os: windows
|
| ︙ | ︙ | |||
240 241 242 243 244 245 246 247 248 249 250 251 252 253 |
compiler: cl
env: *vcenv
before_install: *vcpreinst
install: []
script:
- cmd.exe //C vcvarsall.bat x64 '&&' nmake 'OPTS=symbols' '-f' makefile.vc all tcltest
- cmd.exe //C vcvarsall.bat x64 '&&' nmake 'OPTS=symbols' '-f' makefile.vc test
# Test on Windows with MSVC native (32-bit)
- name: "Windows/MSVC-x86/Shared"
os: windows
compiler: cl
env: *vcenv
before_install: *vcpreinst
install: []
| > > > > > > > > > | 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 |
compiler: cl
env: *vcenv
before_install: *vcpreinst
install: []
script:
- cmd.exe //C vcvarsall.bat x64 '&&' nmake 'OPTS=symbols' '-f' makefile.vc all tcltest
- cmd.exe //C vcvarsall.bat x64 '&&' nmake 'OPTS=symbols' '-f' makefile.vc test
- name: "Windows/MSVC/Mem-Debug"
os: windows
compiler: cl
env: *vcenv
before_install: *vcpreinst
install: []
script:
- cmd.exe //C vcvarsall.bat x64 '&&' nmake 'STATS=memdbg' '-f' makefile.vc all tcltest
- cmd.exe //C vcvarsall.bat x64 '&&' nmake 'STATS=memdbg' '-f' makefile.vc test
# Test on Windows with MSVC native (32-bit)
- name: "Windows/MSVC-x86/Shared"
os: windows
compiler: cl
env: *vcenv
before_install: *vcpreinst
install: []
|
| ︙ | ︙ | |||
277 278 279 280 281 282 283 284 285 286 287 288 289 290 |
compiler: cl
env: *vcenv
before_install: *vcpreinst
install: []
script:
- cmd.exe //C vcvarsall.bat x86 '&&' nmake 'OPTS=symbols' '-f' makefile.vc all tcltest
- cmd.exe //C vcvarsall.bat x86 '&&' nmake 'OPTS=symbols' '-f' makefile.vc test
# Test on Windows with GCC native
- name: "Windows/GCC/Shared"
os: windows
compiler: gcc
env:
- BUILD_DIR=win
- CFGOPT="--enable-64bit"
| > > > > > > > > > | 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 |
compiler: cl
env: *vcenv
before_install: *vcpreinst
install: []
script:
- cmd.exe //C vcvarsall.bat x86 '&&' nmake 'OPTS=symbols' '-f' makefile.vc all tcltest
- cmd.exe //C vcvarsall.bat x86 '&&' nmake 'OPTS=symbols' '-f' makefile.vc test
- name: "Windows/MSVC-x86/Mem-Debug"
os: windows
compiler: cl
env: *vcenv
before_install: *vcpreinst
install: []
script:
- cmd.exe //C vcvarsall.bat x86 '&&' nmake 'STATS=memdbg' '-f' makefile.vc all tcltest
- cmd.exe //C vcvarsall.bat x86 '&&' nmake 'STATS=memdbg' '-f' makefile.vc test
# Test on Windows with GCC native
- name: "Windows/GCC/Shared"
os: windows
compiler: gcc
env:
- BUILD_DIR=win
- CFGOPT="--enable-64bit"
|
| ︙ | ︙ | |||
324 325 326 327 328 329 330 331 332 333 334 335 336 337 |
- name: "Windows/GCC/Debug"
os: windows
compiler: gcc
env:
- BUILD_DIR=win
- CFGOPT="--enable-64bit --enable-symbols"
before_install: *makepreinst
# Test on Windows with GCC native (32-bit)
- name: "Windows/GCC-x86/Shared"
os: windows
compiler: gcc
env:
- BUILD_DIR=win
before_install: *makepreinst
| > > > > > > > | 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 |
- name: "Windows/GCC/Debug"
os: windows
compiler: gcc
env:
- BUILD_DIR=win
- CFGOPT="--enable-64bit --enable-symbols"
before_install: *makepreinst
- name: "Windows/GCC/Mem-Debug"
os: windows
compiler: gcc
env:
- BUILD_DIR=win
- CFGOPT="--enable-64bit --enable-symbols=mem"
before_install: *makepreinst
# Test on Windows with GCC native (32-bit)
- name: "Windows/GCC-x86/Shared"
os: windows
compiler: gcc
env:
- BUILD_DIR=win
before_install: *makepreinst
|
| ︙ | ︙ | |||
368 369 370 371 372 373 374 375 376 377 |
- name: "Windows/GCC-x86/Debug"
os: windows
compiler: gcc
env:
- BUILD_DIR=win
- CFGOPT="--enable-symbols"
before_install: *makepreinst
before_install:
- cd ${BUILD_DIR}
install:
| > > > > > > > > > > > > > > > > > | > | 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 |
- name: "Windows/GCC-x86/Debug"
os: windows
compiler: gcc
env:
- BUILD_DIR=win
- CFGOPT="--enable-symbols"
before_install: *makepreinst
- name: "Windows/GCC-x86/Mem-Debug"
os: windows
compiler: gcc
env:
- BUILD_DIR=win
- CFGOPT="--enable-symbols=mem"
before_install: *makepreinst
# "make dist" only
- name: "Linux: make dist"
os: linux
dist: bionic
compiler: gcc
env:
- BUILD_DIR=unix
script:
- make dist
before_install:
- cd ${BUILD_DIR}
install:
- mkdir "$HOME/install dir"
- ./configure ${CFGOPT} "--prefix=$HOME/install dir" || (cat config.log && exit 1)
before_script:
- export ERROR_ON_FAILURES=1
script:
- make all tcltest
- make test
- make install
|
Changes to ChangeLog.2000.
| ︙ | ︙ | |||
1775 1776 1777 1778 1779 1780 1781 | * tests/regexp.test: Added tests for infinite looping in [regexp -all]. * generic/tclCmdMZ.c: Fixed infinite loop bug with [regexp -all] [Bug: 4981]. | | | 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 | * tests/regexp.test: Added tests for infinite looping in [regexp -all]. * generic/tclCmdMZ.c: Fixed infinite loop bug with [regexp -all] [Bug: 4981]. * tests/*.test: Changed all occurrences of "namespace import ::tcltest" to "namespace import -force ::tcltest" [Bug: 3948]. 2000-04-09 Brent Welch <welch@scriptics.com> * lib/httpd2.1/http.tcl: Worked on the "server closes before reading post data" case, which unfortunately causes different error cases on Solaris, which can read the reply, and Linux and Windows, which cannot |
| ︙ | ︙ |
Changes to compat/fake-rfc2553.c.
| ︙ | ︙ | |||
214 215 216 217 218 219 220 |
*res = malloc_ai(port, addr, hints);
if (*res == NULL)
return (EAI_MEMORY);
return (0);
}
if (!hostname) {
| | | 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 |
*res = malloc_ai(port, addr, hints);
if (*res == NULL)
return (EAI_MEMORY);
return (0);
}
if (!hostname) {
*res = malloc_ai(port, htonl(0x7F000001), hints);
if (*res == NULL)
return (EAI_MEMORY);
return (0);
}
if (inet_aton(hostname, &in)) {
*res = malloc_ai(port, in.s_addr, hints);
|
| ︙ | ︙ |
Changes to compat/strstr.c.
| ︙ | ︙ | |||
32 33 34 35 36 37 38 | * None. * *---------------------------------------------------------------------- */ char * strstr( | | | | | | | 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 |
* None.
*
*----------------------------------------------------------------------
*/
char *
strstr(
const char *string, /* String to search. */
const char *substring) /* Substring to try to find in string. */
{
const char *a, *b;
/*
* First scan quickly through the two strings looking for a
* single-character match. When it's found, then compare the rest of the
* substring.
*/
b = substring;
if (*b == 0) {
return (char *)string;
}
for ( ; *string != 0; string += 1) {
if (*string != *b) {
continue;
}
a = string;
while (1) {
if (*b == 0) {
return (char *)string;
}
if (*a++ != *b++) {
break;
}
}
b = substring;
}
|
| ︙ | ︙ |
Changes to compat/zlib/contrib/minizip/crypt.h.
| ︙ | ︙ | |||
25 26 27 28 29 30 31 | The new AES encryption added on Zip format by Winzip (see the page http://www.winzip.com/aes_info.htm ) and PKWare PKZip 5.x Strong Encryption is not supported. */ #define CRC32(c, b) ((*(pcrc_32_tab+(((int)(c) ^ (b)) & 0xff))) ^ ((c) >> 8)) | < < < < < < | 25 26 27 28 29 30 31 32 33 34 35 36 37 38 |
The new AES encryption added on Zip format by Winzip (see the page
http://www.winzip.com/aes_info.htm ) and PKWare PKZip 5.x Strong
Encryption is not supported.
*/
#define CRC32(c, b) ((*(pcrc_32_tab+(((int)(c) ^ (b)) & 0xff))) ^ ((c) >> 8))
/***********************************************************************
* Return the next byte in the pseudo-random sequence
*/
static int decrypt_byte(unsigned long* pkeys, const z_crc_t* pcrc_32_tab)
{
unsigned temp; /* POTENTIAL BUG: temp*(temp^1) may overflow in an
* unpredictable manner on 16-bit systems; not a problem
|
| ︙ | ︙ |
Changes to compat/zlib/contrib/vstudio/vc10/zlibvc.sln.
| ︙ | ︙ |
Changes to compat/zlib/contrib/vstudio/vc11/zlibvc.sln.
| ︙ | ︙ |
Changes to compat/zlib/contrib/vstudio/vc12/zlibvc.sln.
| ︙ | ︙ |
Changes to compat/zlib/contrib/vstudio/vc14/zlibvc.sln.
| ︙ | ︙ |
Changes to compat/zlib/contrib/vstudio/vc9/zlibvc.sln.
| ︙ | ︙ |
Changes to doc/AddErrInfo.3.
| ︙ | ︙ | |||
57 58 59 60 61 62 63 | 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. | | | 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 | 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_INDEX_NONE, 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 |
| ︙ | ︙ |
Name change from doc/CrtSlave.3 to doc/CrtAlias.3.
1 2 3 4 5 6 | '\" '\" Copyright (c) 1995-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 |
'\"
'\" Copyright (c) 1995-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.TH Tcl_CreateAlias 3 7.6 Tcl "Tcl Library Procedures"
.so man.macros
.BS
.SH NAME
Tcl_IsSafe, Tcl_MakeSafe, Tcl_CreateSlave, Tcl_GetSlave, Tcl_GetMaster, Tcl_GetInterpPath, Tcl_CreateAlias, Tcl_CreateAliasObj, Tcl_GetAlias, Tcl_GetAliasObj, Tcl_ExposeCommand, Tcl_HideCommand \- manage multiple Tcl interpreters, aliases and hidden commands
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
.sp
int
\fBTcl_IsSafe\fR(\fIinterp\fR)
.sp
int
\fBTcl_MakeSafe\fR(\fIinterp\fR)
.sp
Tcl_Interp *
\fBTcl_CreateSlave\fR(\fIinterp, name, isSafe\fR)
.sp
Tcl_Interp *
\fBTcl_GetSlave\fR(\fIinterp, name\fR)
.sp
Tcl_Interp *
\fBTcl_GetMaster\fR(\fIinterp\fR)
.sp
int
\fBTcl_GetInterpPath\fR(\fIinterp, slaveInterp\fR)
.sp
int
\fBTcl_CreateAlias\fR(\fIslaveInterp, slaveCmd, targetInterp, targetCmd,
argc, argv\fR)
.sp
int
\fBTcl_CreateAliasObj\fR(\fIslaveInterp, slaveCmd, targetInterp, targetCmd,
|
| ︙ | ︙ | |||
52 53 54 55 56 57 58 | .sp int \fBTcl_HideCommand\fR(\fIinterp, cmdName, hiddenCmdName\fR) .SH ARGUMENTS .AS "const char *const" **targetInterpPtr out .AP Tcl_Interp *interp in Interpreter in which to execute the specified command. | | | 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 | .sp int \fBTcl_HideCommand\fR(\fIinterp, cmdName, hiddenCmdName\fR) .SH ARGUMENTS .AS "const char *const" **targetInterpPtr out .AP Tcl_Interp *interp in Interpreter in which to execute the specified command. .AP "const char" *name in Name of slave interpreter to create or manipulate. .AP int isSafe in If non-zero, a .QW safe slave that is suitable for running untrusted code is created, otherwise a trusted slave is created. .AP Tcl_Interp *slaveInterp in |
| ︙ | ︙ | |||
154 155 156 157 158 159 160 | \fIinterp\fR. The slave interpreter is identified by \fIslaveName\fR. If no such slave interpreter exists, \fBNULL\fR is returned. .PP \fBTcl_GetMaster\fR returns a pointer to the master interpreter of \fIinterp\fR. If \fIinterp\fR has no master (it is a top-level interpreter) then \fBNULL\fR is returned. .PP | | | | | | 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 | \fIinterp\fR. The slave interpreter is identified by \fIslaveName\fR. If no such slave interpreter exists, \fBNULL\fR is returned. .PP \fBTcl_GetMaster\fR returns a pointer to the master interpreter of \fIinterp\fR. If \fIinterp\fR has no master (it is a top-level interpreter) then \fBNULL\fR is returned. .PP \fBTcl_GetInterpPath\fR stores in the result of \fIinterp\fR the relative path between \fIinterp\fR and \fIslaveInterp\fR; \fIslaveInterp\fR must be a slave of \fIinterp\fR. If the computation of the relative path succeeds, \fBTCL_OK\fR is returned, else \fBTCL_ERROR\fR is returned and an error message is stored as the result of \fIinterp\fR. .PP \fBTcl_CreateAlias\fR creates a command named \fIslaveCmd\fR in \fIslaveInterp\fR that when invoked, will cause the command \fItargetCmd\fR to be invoked in \fItargetInterp\fR. The arguments specified by the strings contained in \fIargv\fR are always prepended to any arguments supplied in the invocation of \fIslaveCmd\fR and passed to \fItargetCmd\fR. This operation returns \fBTCL_OK\fR if it succeeds, or \fBTCL_ERROR\fR if |
| ︙ | ︙ |
Changes to doc/DString.3.
| ︙ | ︙ | |||
44 45 46 47 48 49 50 | .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 | | | 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 | .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_INDEX_NONE, 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. |
| ︙ | ︙ |
Changes to doc/ListObj.3.
| ︙ | ︙ | |||
134 135 136 137 138 139 140 | the two procedures return \fBTCL_OK\fR after appending the values. .PP \fBTcl_NewListObj\fR and \fBTcl_SetListObj\fR create a new value or modify an existing value to hold the \fIobjc\fR elements of the array referenced by \fIobjv\fR where each element is a pointer to a Tcl value. If \fIobjc\fR is less than or equal to zero, | | > > | 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 | the two procedures return \fBTCL_OK\fR after appending the values. .PP \fBTcl_NewListObj\fR and \fBTcl_SetListObj\fR create a new value or modify an existing value to hold the \fIobjc\fR elements of the array referenced by \fIobjv\fR where each element is a pointer to a Tcl value. If \fIobjc\fR is less than or equal to zero, they return an empty value. If \fIobjv\fR is NULL, the resulting list contains 0 elements, with reserved space in an internal representation for \fIobjc\fR more elements (to avoid its reallocation later). The new value's string representation is left invalid. The two procedures increment the reference counts of the elements in \fIobjc\fR since the list value now refers to them. The new list value returned by \fBTcl_NewListObj\fR has reference count zero. .PP \fBTcl_ListObjGetElements\fR returns a count and a pointer to an array of |
| ︙ | ︙ |
Changes to doc/StringObj.3.
| ︙ | ︙ | |||
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 | \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_INDEX_NONE. (Applications needing null bytes should represent them as the two-byte sequence \fI\e300\e200\fR, use \fBTcl_ExternalToUtf\fR to convert, or \fBTcl_NewByteArrayObj\fR if the string is a collection of uninterpreted bytes.) .AP size_t length in The number of bytes to copy from \fIbytes\fR when initializing, setting, or appending to a string value. If TCL_INDEX_NONE, all bytes up to the first null are used. .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_INDEX_NONE, 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 |
| ︙ | ︙ |
Changes to doc/Tcl.n.
| ︙ | ︙ | |||
219 220 221 222 223 224 225 | The hexadecimal digits \fIhhhhhhhh\fR (one up to eight of them) give a twenty-one-bit hexadecimal value for the Unicode character that will be inserted, in the range U+000000\(enU+10FFFF. The parser will stop just before this range overflows, or when the maximum of eight digits is reached. The upper bits of the Unicode character will be 0. .RS .PP | | > > > | 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 | The hexadecimal digits \fIhhhhhhhh\fR (one up to eight of them) give a twenty-one-bit hexadecimal value for the Unicode character that will be inserted, in the range U+000000\(enU+10FFFF. The parser will stop just before this range overflows, or when the maximum of eight digits is reached. The upper bits of the Unicode character will be 0. .RS .PP The range U+00D800\(enU+00DFFF is reserved for surrogates, which are illegal on its own. Therefore, such sequences will result in the replacement character U+FFFD. Surrogate pairs should be encoded as single \e\fBU\fIhhhhhhhh\fR character. .RE .PP Backslash substitution is not performed on words enclosed in braces, except for backslash-newline as described above. .RE .IP "[10] \fBComments.\fR" If a hash character |
| ︙ | ︙ |
Changes to doc/TclZlib.3.
| ︙ | ︙ | |||
104 105 106 107 108 109 110 | 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 | | | 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 | of: \fBTCL_ZLIB_NO_FLUSH\fR if no flushing is to be done, \fBTCL_ZLIB_FLUSH\fR if the currently compressed data must be made available for access using \fBTcl_ZlibStreamGet\fR, \fBTCL_ZLIB_FULLFLUSH\fR if the stream must be put into a state where the decompressor can recover from on corruption, or \fBTCL_ZLIB_FINALIZE\fR to ensure that the stream is finished and that any trailer demanded by the format is written. .AP size_t count in The maximum number of bytes to get from the stream, or TCL_INDEX_NONE to get all remaining bytes from the stream's buffers. .AP Tcl_Obj *compDict in A byte array value that is the compression dictionary to use with the stream. Note that this is \fInot a Tcl dictionary\fR, and it is recommended that this only ever be used with streams that were created with their \fIformat\fR set to \fBTCL_ZLIB_FORMAT_ZLIB\fR because the other formats have no mechanism to indicate whether a compression dictionary was present other than to fail on |
| ︙ | ︙ |
Changes to doc/Utf.3.
| ︙ | ︙ | |||
253 254 255 256 257 258 259 | .PP Given \fIsrc\fR, a pointer to some location in a UTF-8 string, \fBTcl_UtfNext\fR returns a pointer to the next UTF-8 character in the string. The caller must not ask for the next character after the last character in the string if the string is not terminated by a null character. .PP | > | > > | | | > > | | > > | > > > > > > > | | > | | 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 | .PP Given \fIsrc\fR, a pointer to some location in a UTF-8 string, \fBTcl_UtfNext\fR returns a pointer to the next UTF-8 character in the string. The caller must not ask for the next character after the last character in the string if the string is not terminated by a null character. .PP \fBTcl_UtfPrev\fR is used to step backward through but not beyond the UTF-8 string that begins at \fIstart\fR. If the UTF-8 string is made up entirely of complete and well-formed characters, and \fIsrc\fR points to the lead byte of one of those characters (or to the location one byte past the end of the string), then repeated calls of \fBTcl_UtfPrev\fR will return pointers to the lead bytes of each character in the string, one character at a time, terminating when it returns \fIstart\fR. .PP When the conditions of completeness and well-formedness may not be satisfied, a more precise description of the function of \fBTcl_UtfPrev\fR is necessary. It always returns a pointer greater than or equal to \fIstart\fR; that is, always a pointer to a location in the string. It always returns a pointer to a byte that begins a character when scanning for characters beginning from \fIstart\fR. When \fIsrc\fR is greater than \fIstart\fR, it always returns a pointer less than \fIsrc\fR and greater than or equal to (\fIsrc\fR - \fBTCL_UTF_MAX\fR). The character that begins at the returned pointer is the first one that either includes the byte \fIsrc[-1]\fR, or might include it if the right trail bytes are present at \fIsrc\fR and greater. \fBTcl_UtfPrev\fR never reads the byte \fIsrc[0]\fR nor the byte \fIstart[-1]\fR nor the byte \fIsrc[-\fBTCL_UTF_MAX\fI-1]\fR. .PP \fBTcl_UniCharAtIndex\fR corresponds to a C string array dereference or the Pascal Ord() function. It returns the Unicode character represented at the specified character (not byte) \fIindex\fR in the UTF-8 string \fIsrc\fR. The source string must contain at least \fIindex\fR characters. If \fIindex\fR is TCL_INDEX_NONE or \fIindex\fR points to the second half of a surrogate pair, it returns -1. .PP \fBTcl_UtfAtIndex\fR returns a pointer to the specified character (not byte) \fIindex\fR in the UTF-8 string \fIsrc\fR. The source string must contain at least \fIindex\fR characters. This is equivalent to calling \fBTcl_UtfToUniChar\fR \fIindex\fR times. 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 4 bytes are stored in the buffer. \fBTcl_UtfBackslash\fR modifies \fI*readPtr\fR to contain the number |
| ︙ | ︙ |
Changes to doc/binary.n.
| ︙ | ︙ | |||
69 70 71 72 73 74 75 | newline character, .QW \en . .PP During decoding, the following options are supported: .TP \fB\-strict\fR . | | > > | > | | | | | > > > | < | > > | | 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 |
newline character,
.QW \en .
.PP
During decoding, the following options are supported:
.TP
\fB\-strict\fR
.
Instructs the decoder to throw an error if it encounters any characters
that are not strictly part of the encoding itself. Otherwise it ignores them.
RFC 2045 calls for base64 decoders to be non-strict.
.RE
.TP
\fBhex\fR
.
The \fBhex\fR binary encoding converts each byte to a pair of hexadecimal
digits in big-endian form.
.RS
.PP
No options are supported during encoding. During decoding, the following
options are supported:
.TP
\fB\-strict\fR
.
Instructs the decoder to throw an error if it encounters whitespace characters.
Otherwise it ignores them.
.RE
.TP
\fBuuencode\fR
.
The \fBuuencode\fR binary encoding used to be common for transfer of data
between Unix systems and on USENET, but is less common these days, having been
largely superseded by the \fBbase64\fR binary encoding.
.RS
.PP
During encoding, the following options are supported (though changing them may
produce files that other implementations of decoders cannot process):
.TP
\fB\-maxlen \fIlength\fR
.
Indicates the maximum number of characters to produce for each encoded line.
The valid range is 5 to 85. Line lengths outside that range cannot be
accommodated by the encoding format. The default value is 61.
.TP
\fB\-wrapchar \fIcharacter\fR
.
Indicates the character(s) to use to mark the end of each encoded line.
Acceptable values are a sequence of zero or more characters from the
set { \\x09 (TAB), \\x0B (VT), \\x0C (FF), \\x0D (CR) } followed
by zero or one newline \\x0A (LF). Any other values are rejected because
they would generate encoded text that could not be decoded. The default value
is a single newline.
.PP
During decoding, the following options are supported:
.TP
\fB\-strict\fR
.
Instructs the decoder to throw an error if it encounters anything
outside of the standard encoding format. Without this option, the
decoder tolerates some deviations, mostly to forgive reflows of lines
between the encoder and decoder.
.PP
Note that neither the encoder nor the decoder handle the header and footer of
the uuencode format.
.RE
.SH "BINARY FORMAT"
.PP
The \fBbinary format\fR command generates a binary string whose layout
|
| ︙ | ︙ |
Changes to doc/clock.n.
| ︙ | ︙ | |||
467 468 469 470 471 472 473 | if the clock had not changed. .SH "FORMAT GROUPS" .PP The following format groups are recognized by the \fBclock scan\fR and \fBclock format\fR commands. .TP \fB%a\fR | | | | | | | | 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 | if the clock had not changed. .SH "FORMAT GROUPS" .PP The following format groups are recognized by the \fBclock scan\fR and \fBclock format\fR commands. .TP \fB%a\fR On output, produces an abbreviation (\fIe.g.,\fR \fBMon\fR) for the day of the week in the given locale. On input, matches the name of the day of the week in the given locale (in either abbreviated or full form, or any unique prefix of either form). .TP \fB%A\fR On output, produces the full name (\fIe.g.,\fR \fBMonday\fR) of the day of the week in the given locale. On input, matches the name of the day of the week in the given locale (in either abbreviated or full form, or any unique prefix of either form). .TP \fB%b\fR On output, produces an abbreviation (\fIe.g.,\fR \fBJan\fR) for the name of the month in the given locale. On input, matches the name of the month in the given locale (in either abbreviated or full form, or any unique prefix of either form). .TP \fB%B\fR On output, produces the full name (\fIe.g.,\fR \fBJanuary\fR) of the month in the given locale. On input, matches the name of the month in the given locale (in either abbreviated or full form, or any unique prefix of either form). .TP \fB%c\fR On output, produces a localized representation of date and time of day; the localized representation is expected to use the Gregorian calendar. On input, matches whatever \fB%c\fR produces. .TP \fB%C\fR On output, produces the number of the century in Indo-Arabic numerals. On input, matches one or two digits, possibly with leading whitespace, that are expected to be the number of the century. .TP \fB%d\fR On output, produces the number of the day of the month, as two decimal digits. On input, matches one or two digits, possibly with leading whitespace, that are expected to be the number of the day of the month. |
| ︙ | ︙ | |||
909 910 911 912 913 914 915 | than 100, we treat the years 00-68 as 2000-2068 and the years 69-99 as 1969-1999. Not all platforms can represent the years 38-70, so an error may result if these years are used. .TP \fIISO 8601 point-in-time\fR . An ISO 8601 point-in-time specification, such as | | > | | | 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 | than 100, we treat the years 00-68 as 2000-2068 and the years 69-99 as 1969-1999. Not all platforms can represent the years 38-70, so an error may result if these years are used. .TP \fIISO 8601 point-in-time\fR . An ISO 8601 point-in-time specification, such as .QW "\fICCyymmdd\fBT\fIhhmmss\fR", where \fBT\fR is the literal .QW T , .QW "\fICCyymmdd hhmmss\fR" , .QW "\fICCyymmdd\fBT\fIhh:mm:ss\fR" , or .QW "\fICCyy-mm-dd\fBT\fIhh\fB:\fImm\fB:\fIss\fR". Note that only these four formats are accepted. The command does \fInot\fR accept the full range of point-in-time specifications specified in ISO8601. Other formats can be recognized by giving an explicit \fB\-format\fR option to the \fBclock scan\fR command. .TP \fIrelative time\fR . A specification relative to the current time. The format is \fBnumber |
| ︙ | ︙ |
Changes to doc/dict.n.
| ︙ | ︙ | |||
24 25 26 27 28 29 30 | . This appends the given string (or strings) to the value that the given key maps to in the dictionary value contained in the given variable, writing the resulting dictionary value back to that variable. Non-existent keys are treated as if they map to an empty string. The updated dictionary value is returned. .VS TIP508 | | | 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 | . This appends the given string (or strings) to the value that the given key maps to in the dictionary value contained in the given variable, writing the resulting dictionary value back to that variable. Non-existent keys are treated as if they map to an empty string. The updated dictionary value is returned. .VS TIP508 If \fIdictionaryVariable\fR indicates an element that does not exist of an array that has a default value set, the default value and will be used as the value of the dictionary prior to the appending operation. .VE TIP508 .TP \fBdict create \fR?\fIkey value ...\fR? . Return a new dictionary that contains each of the key/value mappings |
| ︙ | ︙ | |||
138 139 140 141 142 143 144 | not specified) to the value that the given key maps to in the dictionary value contained in the given variable, writing the resulting dictionary value back to that variable. Non-existent keys are treated as if they map to 0. It is an error to increment a value for an existing key if that value is not an integer. The updated dictionary value is returned. .VS TIP508 | | | 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 | not specified) to the value that the given key maps to in the dictionary value contained in the given variable, writing the resulting dictionary value back to that variable. Non-existent keys are treated as if they map to 0. It is an error to increment a value for an existing key if that value is not an integer. The updated dictionary value is returned. .VS TIP508 If \fIdictionaryVariable\fR indicates an element that does not exist of an array that has a default value set, the default value and will be used as the value of the dictionary prior to the incrementing operation. .VE TIP508 .TP \fBdict info \fIdictionaryValue\fR . This returns information (intended for display to people) about the |
| ︙ | ︙ | |||
168 169 170 171 172 173 174 | to in the dictionary value contained in the given variable, writing the resulting dictionary value back to that variable. Non-existent keys are treated as if they map to an empty list, and it is legal for there to be no items to append to the list. It is an error for the value that the key maps to to not be representable as a list. The updated dictionary value is returned. .VS TIP508 | | | 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 |
to in the dictionary value contained in the given variable, writing
the resulting dictionary value back to that variable. Non-existent
keys are treated as if they map to an empty list, and it is legal for
there to be no items to append to the list. It is an error for the
value that the key maps to to not be representable as a list. The
updated dictionary value is returned.
.VS TIP508
If \fIdictionaryVariable\fR indicates an element that does not exist of an
array that has a default value set, the default value and will be used as the
value of the dictionary prior to the list-appending operation.
.VE TIP508
.TP
\fBdict map \fR{\fIkeyVariable valueVariable\fR} \fIdictionaryValue body\fR
.
This command applies a transformation to each element of a dictionary,
|
| ︙ | ︙ | |||
230 231 232 233 234 235 236 | . This operation takes the name of a variable containing a dictionary value and places an updated dictionary value in that variable containing a mapping from the given key to the given value. When multiple keys are present, this operation creates or updates a chain of nested dictionaries. The updated dictionary value is returned. .VS TIP508 | | | | | 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 | . This operation takes the name of a variable containing a dictionary value and places an updated dictionary value in that variable containing a mapping from the given key to the given value. When multiple keys are present, this operation creates or updates a chain of nested dictionaries. The updated dictionary value is returned. .VS TIP508 If \fIdictionaryVariable\fR indicates an element that does not exist of an array that has a default value set, the default value and will be used as the value of the dictionary prior to the value insert/update operation. .VE TIP508 .TP \fBdict size \fIdictionaryValue\fR . Return the number of key/value mappings in the given dictionary value. .TP \fBdict unset \fIdictionaryVariable key \fR?\fIkey ...\fR? . This operation (the companion to \fBdict set\fR) takes the name of a variable containing a dictionary value and places an updated dictionary value in that variable that does not contain a mapping for the given key. Where multiple keys are present, this describes a path through nested dictionaries to the mapping to remove. At least one key must be specified, but the last key on the key-path need not exist. All other components on the path must exist. The updated dictionary value is returned. .VS TIP508 If \fIdictionaryVariable\fR indicates an element that does not exist of an array that has a default value set, the default value and will be used as the value of the dictionary prior to the value remove operation. .VE TIP508 .TP \fBdict update \fIdictionaryVariable key varName \fR?\fIkey varName ...\fR? \fIbody\fR . Execute the Tcl script in \fIbody\fR with the value for each \fIkey\fR (as found by reading the dictionary value in \fIdictionaryVariable\fR) mapped to the variable \fIvarName\fR. There may be multiple \fIkey\fR/\fIvarName\fR pairs. If a \fIkey\fR does not have a mapping, that corresponds to an unset \fIvarName\fR. When \fIbody\fR terminates, any changes made to the \fIvarName\fRs is reflected back to the dictionary within \fIdictionaryVariable\fR (unless \fIdictionaryVariable\fR itself becomes unreadable, when all updates are silently discarded), even if the result of \fIbody\fR is an error or some other kind of exceptional exit. The result of \fBdict update\fR is (unless some kind of error occurs) the result of the evaluation of \fIbody\fR. .VS TIP508 If \fIdictionaryVariable\fR indicates an element that does not exist of an array that has a default value set, the default value and will be used as the value of the dictionary prior to the update operation. .VE TIP508 .RS .PP Each \fIvarName\fR is mapped in the scope enclosing the \fBdict update\fR; it is recommended that this command only be used in a local scope |
| ︙ | ︙ | |||
309 310 311 312 313 314 315 | \fIdictionaryVariable\fR unreadable will make the updates to the dictionary be discarded, and this also happens if the contents of \fIdictionaryVariable\fR are adjusted so that the chain of dictionaries no longer exists. The result of \fBdict with\fR is (unless some kind of error occurs) the result of the evaluation of \fIbody\fR. .VS TIP508 | | | 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 | \fIdictionaryVariable\fR unreadable will make the updates to the dictionary be discarded, and this also happens if the contents of \fIdictionaryVariable\fR are adjusted so that the chain of dictionaries no longer exists. The result of \fBdict with\fR is (unless some kind of error occurs) the result of the evaluation of \fIbody\fR. .VS TIP508 If \fIdictionaryVariable\fR indicates an element that does not exist of an array that has a default value set, the default value and will be used as the value of the dictionary prior to the updating operation. .VE TIP508 .RS .PP The variables are mapped in the scope enclosing the \fBdict with\fR; it is recommended that this command only be used in a local scope |
| ︙ | ︙ |
Changes to doc/expr.n.
| ︙ | ︙ | |||
13 14 15 16 17 18 19 | .SH NAME expr \- Evaluate an expression .SH SYNOPSIS \fBexpr \fIarg \fR?\fIarg arg ...\fR? .BE .SH DESCRIPTION .PP | | | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 | .SH NAME expr \- Evaluate an expression .SH SYNOPSIS \fBexpr \fIarg \fR?\fIarg arg ...\fR? .BE .SH DESCRIPTION .PP The \fIexpr\fR command concatenates \fIarg\fRs, separated by a space, into an expression, and evaluates that expression, returning its value. The operators permitted in an expression include a subset of the operators permitted in C expressions. For those operators common to both Tcl and C, Tcl applies the same meaning and precedence as the corresponding C operators. The value of an expression is often a numeric result, either an integer or a floating-point value, but may also be a non-numeric value. |
| ︙ | ︙ | |||
42 43 44 45 46 47 48 | value is the form produced by the \fB%g\fR format specifier of Tcl's \fBformat\fR command. .SS OPERANDS .PP An expression consists of a combination of operands, operators, parentheses and commas, possibly with whitespace between any of these elements, which is ignored. | < < < < < < < < < < < < < < | 42 43 44 45 46 47 48 49 50 51 52 53 54 55 | value is the form produced by the \fB%g\fR format specifier of Tcl's \fBformat\fR command. .SS OPERANDS .PP An expression consists of a combination of operands, operators, parentheses and commas, possibly with whitespace between any of these elements, which is ignored. .PP An operand may be specified in any of the following ways: .IP [1] As a numeric value, either integer or floating-point. .IP [2] As a boolean value, using any form understood by \fBstring is\fR \fBboolean\fR. |
| ︙ | ︙ | |||
97 98 99 100 101 102 103 104 105 106 107 108 109 110 |
.CS
.ta 9c
\fBexpr\fR 3.1 + $a \fI6.1\fR
\fBexpr\fR 2 + "$a.$b" \fI5.6\fR
\fBexpr\fR 4*[llength "6 2"] \fI8\fR
\fBexpr\fR {{word one} < "word $a"} \fI0\fR
.CE
.SS OPERATORS
.PP
For operators having both a numeric mode and a string mode, the numeric mode is
chosen when all operands have a numeric interpretation. The integer
interpretation of an operand is preferred over the floating-point
interpretation. To ensure string operations on arbitrary values it is generally a
good idea to use \fBeq\fR, \fBne\fR, or the \fBstring\fR command instead of
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 |
.CS
.ta 9c
\fBexpr\fR 3.1 + $a \fI6.1\fR
\fBexpr\fR 2 + "$a.$b" \fI5.6\fR
\fBexpr\fR 4*[llength "6 2"] \fI8\fR
\fBexpr\fR {{word one} < "word $a"} \fI0\fR
.CE
.PP
\fBInteger value\fR
.PP
An integer operand may be specified in decimal (the normal case, the optional
first two characters are \fB0d\fR), binary
(the first two characters are \fB0b\fR), octal
(the first two characters are \fB0o\fR), or hexadecimal
(the first two characters are \fB0x\fR) form. For
.PP
\fBFloating-point value\fR
.PP
A floating-point number may be specified in any of several
common decimal formats, and may use the decimal point \fB.\fR,
\fBe\fR or \fBE\fR for scientific notation, and
the sign characters \fB+\fR and \fB\-\fR. The
following are all valid floating-point numbers: 2.1, 3., 6e4, 7.91e+16.
The strings \fBInf\fR
and \fBNaN\fR, in any combination of case, are also recognized as floating point
values. An operand that doesn't have a numeric interpretation must be quoted
with either braces or with double quotes.
.PP
\fBBoolean value\fR
.PP
A boolean value may be represented by any of the values \fB0\fR, \fBfalse\fR, \fBno\fR,
or \fBoff\fR and any of the values \fB1\fR, \fBtrue\fR, \fByes\fR, or \fBon\fR.
.PP
\fBDigit Separator\fR
.PP
Digits in any numeric value may be separated with one or more underscore
characters, "\fB_\fR", to improve readability. These separators may only
appear between digits. The separator may not appear at the start of a
numeric value, between the leading 0 and radix specifier, or at the
end of a numeric value. Here are some examples:
.PP
.CS
.ta 9c
\fBexpr\fR 100_000_000 \fI100000000\fR
\fBexpr\fR 0xffff_ffff \fI4294967295\fR
\fBformat\fR 0x%x 0b1111_1110_1101_1011 \fI0xfedb\fR
.CE
.PP
.SS OPERATORS
.PP
For operators having both a numeric mode and a string mode, the numeric mode is
chosen when all operands have a numeric interpretation. The integer
interpretation of an operand is preferred over the floating-point
interpretation. To ensure string operations on arbitrary values it is generally a
good idea to use \fBeq\fR, \fBne\fR, or the \fBstring\fR command instead of
|
| ︙ | ︙ | |||
468 469 470 471 472 473 474 |
.CS
set randNum [\fBexpr\fR { int(100 * rand()) }]
.CE
.SH "SEE ALSO"
array(n), for(n), if(n), mathfunc(n), mathop(n), namespace(n), proc(n),
string(n), Tcl(n), while(n)
.SH KEYWORDS
| | | 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 |
.CS
set randNum [\fBexpr\fR { int(100 * rand()) }]
.CE
.SH "SEE ALSO"
array(n), for(n), if(n), mathfunc(n), mathop(n), namespace(n), proc(n),
string(n), Tcl(n), while(n)
.SH KEYWORDS
arithmetic, boolean, compare, expression, fuzzy comparison, integer value
.SH COPYRIGHT
.nf
Copyright \(co 1993 The Regents of the University of California.
Copyright \(co 1994-2000 Sun Microsystems Incorporated.
Copyright \(co 2005 by Kevin B. Kenny <kennykb@acm.org>. All rights reserved.
.fi
'\" Local Variables:
'\" mode: nroff
'\" End:
|
Changes to doc/http.n.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 | .TH "http" n 2.9 http "Tcl Bundled Packages" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME http \- Client-side implementation of the HTTP/1.1 protocol .SH SYNOPSIS | | | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 | .TH "http" n 2.9 http "Tcl Bundled Packages" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME http \- Client-side implementation of the HTTP/1.1 protocol .SH SYNOPSIS \fBpackage require http\fI ?\fB2.9\fR? .\" See Also -useragent option documentation in body! .sp \fB::http::config\fR ?\fI\-option value\fR ...? .sp \fB::http::geturl \fIurl\fR ?\fI\-option value\fR ...? .sp \fB::http::formatQuery\fR \fIkey value\fR ?\fIkey value\fR ...? |
| ︙ | ︙ | |||
166 167 168 169 170 171 172 | throwing an error processing non-latin-1 characters. .TP \fB\-useragent\fR \fIstring\fR . The value of the User-Agent header in the HTTP request. In an unsafe interpreter, the default value depends upon the operating system, and the version numbers of \fBhttp\fR and \fBTcl\fR, and is (for example) | | | 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 | throwing an error processing non-latin-1 characters. .TP \fB\-useragent\fR \fIstring\fR . The value of the User-Agent header in the HTTP request. In an unsafe interpreter, the default value depends upon the operating system, and the version numbers of \fBhttp\fR and \fBTcl\fR, and is (for example) .QW "\fBMozilla/5.0 (Windows; U; Windows NT 10.0) http/2.9.0 Tcl/8.6.9\fR" . A safe interpreter cannot determine its operating system, and so the default in a safe interpreter is to use a Windows 10 value with the current version numbers of \fBhttp\fR and \fBTcl\fR. .TP \fB\-zip\fR \fIboolean\fR . If the value is boolean \fBtrue\fR, then by default requests will send a header |
| ︙ | ︙ |
Changes to doc/info.n.
| ︙ | ︙ | |||
60 61 62 63 64 65 66 | \fIcommandName\fR is the public command that represents an instance of \fBoo::object\fR or one of its subclasses. .IP \fBprivateObject\fR \fIcommandName\fR is the private command, \fBmy\fR by default, that represents an instance of \fBoo::object\fR or one of its subclasses. .IP \fBproc\fR \fIcommandName\fR was created by \fBproc\fR. | | | 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 | \fIcommandName\fR is the public command that represents an instance of \fBoo::object\fR or one of its subclasses. .IP \fBprivateObject\fR \fIcommandName\fR is the private command, \fBmy\fR by default, that represents an instance of \fBoo::object\fR or one of its subclasses. .IP \fBproc\fR \fIcommandName\fR was created by \fBproc\fR. .IP \fBinterp\fR \fIcommandName\fR was created by \fBinterp create\fR. .IP \fBzlibStream\fR \fIcommandName\fR was created by \fBzlib stream\fR. .PP Other types may be also registered as well. See \fBTcl_RegisterCommandTypeName\fR. .RE .VE TIP426 |
| ︙ | ︙ | |||
274 275 276 277 278 279 280 | .TP \fBinfo loaded \fR?\fIinterp\fR? ?\fIpackage\fR? . Returns the name of each file loaded in \fIinterp\fR va \fBload\fR as part of \fIpackage\fR . If \fIpackage\fR is not given, returns a list where each item is the name of the loaded file and the name of the package for which the file was loaded. For a statically-loaded package the name of the file is the empty | | | 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 | .TP \fBinfo loaded \fR?\fIinterp\fR? ?\fIpackage\fR? . Returns the name of each file loaded in \fIinterp\fR va \fBload\fR as part of \fIpackage\fR . If \fIpackage\fR is not given, returns a list where each item is the name of the loaded file and the name of the package for which the file was loaded. For a statically-loaded package the name of the file is the empty string. For \fIinterp\fR, the empty string is the current interpreter. .TP \fBinfo locals \fR?\fIpattern\fR? . If \fIpattern\fR is given, returns the name of each local variable matching \fIpattern\fR according to \fBstring match\fR. Otherwise, returns the name of each local variable. A variables defined with the \fBglobal\fR, \fBupvar\fR or \fBvariable\fR is not local. |
| ︙ | ︙ |
Changes to doc/library.n.
| ︙ | ︙ | |||
295 296 297 298 299 300 301 | \fBtcl_startOfNextWord\fR, \fBtcl_startOfPreviousWord\fR, \fBtcl_wordBreakAfter\fR, and \fBtcl_wordBreakBefore\fR commands. .TP \fBtcl_nonwordchars\fR This variable contains a regular expression that is used by routines like \fBtcl_endOfWord\fR to identify whether a character is part of a word or not. If the pattern matches a character, the character is | | < < < | < < | 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 | \fBtcl_startOfNextWord\fR, \fBtcl_startOfPreviousWord\fR, \fBtcl_wordBreakAfter\fR, and \fBtcl_wordBreakBefore\fR commands. .TP \fBtcl_nonwordchars\fR This variable contains a regular expression that is used by routines like \fBtcl_endOfWord\fR to identify whether a character is part of a word or not. If the pattern matches a character, the character is considered to be a non-word character. The default is "\\W". .TP \fBtcl_wordchars\fR This variable contains a regular expression that is used by routines like \fBtcl_endOfWord\fR to identify whether a character is part of a word or not. If the pattern matches a character, the character is considered to be a word character. The default is "\\w". .SH "SEE ALSO" env(n), info(n), re_syntax(n) .SH KEYWORDS auto-exec, auto-load, library, unknown, word, whitespace '\"Local Variables: '\"mode: nroff '\"End: |
Changes to doc/lsearch.n.
| ︙ | ︙ | |||
18 19 20 21 22 23 24 | .BE .SH DESCRIPTION .PP This command searches the elements of \fIlist\fR to see if one of them matches \fIpattern\fR. If so, the command returns the index of the first matching element (unless the options \fB\-all\fR or \fB\-inline\fR are specified.) | | > | 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 | .BE .SH DESCRIPTION .PP This command searches the elements of \fIlist\fR to see if one of them matches \fIpattern\fR. If so, the command returns the index of the first matching element (unless the options \fB\-all\fR or \fB\-inline\fR are specified.) If not, the command returns \fB\-1\fR or (if options \fB\-all\fR or \fB\-inline\fR are specified) the empty string. The \fIoption\fR arguments indicates how the elements of the list are to be matched against \fIpattern\fR and must have one of the values below: .SS "MATCHING STYLE OPTIONS" .PP If all matching style options are omitted, the default matching style is \fB\-glob\fR. If more than one matching style is specified, the last matching style given takes precedence. |
| ︙ | ︙ | |||
60 61 62 63 64 65 66 | .PP These options may be given with all matching styles. .TP \fB\-all\fR . Changes the result to be the list of all matching indices (or all matching values if \fB\-inline\fR is specified as well.) If indices are returned, the | | | | 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 | .PP These options may be given with all matching styles. .TP \fB\-all\fR . Changes the result to be the list of all matching indices (or all matching values if \fB\-inline\fR is specified as well.) If indices are returned, the indices will be in ascending numeric order. If values are returned, the order of the values will be the order of those values within the input \fIlist\fR. .TP \fB\-inline\fR . The matching value is returned instead of its index (or an empty string if no value matches.) If \fB\-all\fR is also specified, then the result of the command is the list of all values that matched. .TP |
| ︙ | ︙ |
Changes to doc/lset.n.
| ︙ | ︙ | |||
112 113 114 115 116 117 118 119 120 121 122 123 124 125 |
\fBlset\fR x end-1 j
\fI\(-> {a b c} j {g h i}\fR
\fBlset\fR x 2 1 j
\fI\(-> {a b c} {d e f} {g j i}\fR
\fBlset\fR x {2 1} j
\fI\(-> {a b c} {d e f} {g j i}\fR
\fBlset\fR x {2 3} j
\fI\(-> 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
| > > | 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 |
\fBlset\fR x end-1 j
\fI\(-> {a b c} j {g h i}\fR
\fBlset\fR x 2 1 j
\fI\(-> {a b c} {d e f} {g j i}\fR
\fBlset\fR x {2 1} j
\fI\(-> {a b c} {d e f} {g j i}\fR
\fBlset\fR x {2 3} j
\fI\(-> {a b c} {d e f} {g h i j}\fR
\fBlset\fR x {2 4} j
\fI\(-> list index out of range\fR
.CE
.PP
In the following examples, the initial value of \fIx\fR is:
.PP
.CS
set x [list [list [list a b] [list c d]] \e
|
| ︙ | ︙ |
Changes to doc/string.n.
| ︙ | ︙ | |||
501 502 503 504 505 506 507 |
} else {
set isPrefix [\fBstring equal\fR \-length $length $string "foobar"]
}
.CE
.SH "SEE ALSO"
expr(n), list(n)
.SH KEYWORDS
| | | 501 502 503 504 505 506 507 508 509 510 511 512 |
} else {
set isPrefix [\fBstring equal\fR \-length $length $string "foobar"]
}
.CE
.SH "SEE ALSO"
expr(n), list(n)
.SH KEYWORDS
case conversion, compare, index, integer value, match, pattern, string, word, equal,
ctype, character, reverse
.\" Local Variables:
.\" mode: nroff
.\" End:
|
Changes to doc/zlib.n.
| ︙ | ︙ | |||
189 190 191 192 193 194 195 | \fB\-level\fI compressionLevel\fR . How hard to compress the data. Must be an integer from 0 (uncompressed) to 9 (maximally compressed). .TP \fB\-limit\fI readaheadLimit\fR . | | > > > | > > > > | > | | 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 | \fB\-level\fI compressionLevel\fR . How hard to compress the data. Must be an integer from 0 (uncompressed) to 9 (maximally compressed). .TP \fB\-limit\fI readaheadLimit\fR . The maximum number of bytes ahead to read when decompressing. .RS .PP This option has become \fBirrelevant\fR. It was originally introduced to prevent Tcl from reading beyond the end of a compressed stream in multi-stream channels to ensure that the data after was left alone for further reading, at the cost of speed. .PP Tcl now automatically returns any bytes it has read beyond the end of a compressed stream back to the channel, making them appear as unread to further readers. .RE .PP Both compressing and decompressing channel transformations add extra configuration options that may be accessed through \fBchan configure\fR. The options are: .TP \fB\-checksum\fI checksum\fR . |
| ︙ | ︙ | |||
234 235 236 237 238 239 240 | This read-only option, only valid for decompressing transforms that are processing gzip-format data, returns the dictionary describing the header read off the data stream. .TP \fB\-limit\fI readaheadLimit\fR . This read-write option is used by decompressing channels to control the | | < | < | 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 | This read-only option, only valid for decompressing transforms that are processing gzip-format data, returns the dictionary describing the header read off the data stream. .TP \fB\-limit\fI readaheadLimit\fR . This read-write option is used by decompressing channels to control the maximum number of bytes ahead to read from the underlying data source. See above for more information. .RE .SS "STREAMING SUBCOMMAND" .TP \fBzlib stream\fI mode\fR ?\fIoptions\fR? . Creates a streaming compression or decompression command based on the \fImode\fR, and return the name of the command. For a description of how that |
| ︙ | ︙ |
Changes to generic/regcustom.h.
| ︙ | ︙ | |||
83 84 85 86 87 88 89 | typedef int celt; /* Type to hold chr, or NOCELT */ #define NOCELT (-1) /* Celt value which is not valid chr */ #define CHR(c) (UCHAR(c)) /* Turn char literal into chr literal */ #define DIGITVAL(c) ((c)-'0') /* Turn chr digit into its value */ #if TCL_UTF_MAX > 3 #define CHRBITS 32 /* Bits in a chr; must not use sizeof */ #define CHR_MIN 0x00000000 /* Smallest and largest chr; the value */ | | | | 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 | typedef int celt; /* Type to hold chr, or NOCELT */ #define NOCELT (-1) /* Celt value which is not valid chr */ #define CHR(c) (UCHAR(c)) /* Turn char literal into chr literal */ #define DIGITVAL(c) ((c)-'0') /* Turn chr digit into its value */ #if TCL_UTF_MAX > 3 #define CHRBITS 32 /* Bits in a chr; must not use sizeof */ #define CHR_MIN 0x00000000 /* Smallest and largest chr; the value */ #define CHR_MAX 0x10FFFF /* CHR_MAX-CHR_MIN+1 should fit in uchr */ #else #define CHRBITS 16 /* Bits in a chr; must not use sizeof */ #define CHR_MIN 0x0000 /* Smallest and largest chr; the value */ #define CHR_MAX 0xFFFF /* CHR_MAX-CHR_MIN+1 should fit in uchr */ #endif /* * Functions operating on chr. */ #define iscalnum(x) Tcl_UniCharIsAlnum(x) |
| ︙ | ︙ |
Changes to generic/regguts.h.
| ︙ | ︙ | |||
70 71 72 73 74 75 76 | */ #define NOTREACHED 0 #define DUPMAX _POSIX2_RE_DUP_MAX #define DUPINF (DUPMAX+1) | | | 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 |
*/
#define NOTREACHED 0
#define DUPMAX _POSIX2_RE_DUP_MAX
#define DUPINF (DUPMAX+1)
#define REMAGIC 0xFED7 /* magic number for main struct */
/*
* debugging facilities
*/
#ifdef REG_DEBUG
/* FDEBUG does finite-state tracing */
#define FDEBUG(arglist) { if (v->eflags®_FTRACE) printf arglist; }
|
| ︙ | ︙ | |||
386 387 388 389 390 391 392 |
/*
* the insides of a regex_t, hidden behind a void *
*/
struct guts {
int magic;
| | | 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 |
/*
* the insides of a regex_t, hidden behind a void *
*/
struct guts {
int magic;
#define GUTSMAGIC 0xFED9
int cflags; /* copy of compile flags */
long info; /* copy of re_info */
size_t nsub; /* copy of re_nsub */
struct subre *tree;
struct cnfa search; /* for fast preliminary search */
int ntree; /* number of subre's, plus one */
struct colormap cmap;
|
| ︙ | ︙ |
Changes to generic/tcl.decls.
| ︙ | ︙ | |||
597 598 599 600 601 602 603 |
declare 161 {
int Tcl_GetErrno(void)
}
declare 162 {
const char *Tcl_GetHostName(void)
}
declare 163 {
| | | | 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 |
declare 161 {
int Tcl_GetErrno(void)
}
declare 162 {
const char *Tcl_GetHostName(void)
}
declare 163 {
int Tcl_GetInterpPath(Tcl_Interp *interp, Tcl_Interp *slaveInterp)
}
declare 164 {
Tcl_Interp *Tcl_GetMaster(Tcl_Interp *interp)
}
declare 165 {
const char *Tcl_GetNameOfExecutable(void)
}
declare 166 {
Tcl_Obj *Tcl_GetObjResult(Tcl_Interp *interp)
}
# Tcl_GetOpenFile is only available on unix, but it is a part of the old
# generic interface, so we include it here for compatibility reasons.
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.
|
| ︙ | ︙ | |||
2489 2490 2491 2492 2493 2494 2495 |
#declare 1 win {
# char *Tcl_WinTCharToUtf(const TCHAR *str, size_t len, Tcl_DString *dsPtr)
#}
################################
# Mac OS X specific functions
| > | | | | < > | 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 |
#declare 1 win {
# char *Tcl_WinTCharToUtf(const TCHAR *str, size_t len, Tcl_DString *dsPtr)
#}
################################
# Mac OS X specific functions
# Removed in 9.0
#declare 0 macosx {
# int Tcl_MacOSXOpenBundleResources(Tcl_Interp *interp,
# const char *bundleName, int hasResourceFile,
# size_t maxPathLen, char *libraryPath)
#}
declare 1 macosx {
int Tcl_MacOSXOpenVersionedBundleResources(Tcl_Interp *interp,
const char *bundleName, const char *bundleVersion,
int hasResourceFile, size_t maxPathLen, char *libraryPath)
}
##############################################################################
|
| ︙ | ︙ |
Changes to generic/tcl.h.
| ︙ | ︙ | |||
1912 1913 1914 1915 1916 1917 1918 | #define TCL_CONVERT_NOSPACE (-4) /* * The maximum number of bytes that are necessary to represent a single * Unicode character in UTF-8. The valid values are 3 and 4 * (or perhaps 1 if we want to support a non-unicode enabled core). If > 3, * then Tcl_UniChar must be 4-bytes in size (UCS-4) (the default). If == 3, | | | 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 | #define TCL_CONVERT_NOSPACE (-4) /* * The maximum number of bytes that are necessary to represent a single * Unicode character in UTF-8. The valid values are 3 and 4 * (or perhaps 1 if we want to support a non-unicode enabled core). If > 3, * then Tcl_UniChar must be 4-bytes in size (UCS-4) (the default). If == 3, * then Tcl_UniChar must be 2-bytes in size (UTF-16). Since Tcl 9.0, UCS-4 * mode is the default and recommended mode. */ #ifndef TCL_UTF_MAX #define TCL_UTF_MAX 4 #endif |
| ︙ | ︙ |
Changes to generic/tclAlloc.c.
| ︙ | ︙ | |||
64 65 66 67 68 69 70 | #define overMagic1 ovu.magic1 #define bucketIndex ovu.index #define rangeCheckMagic ovu.rmagic #define realBlockSize ovu.size }; | | | 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 | #define overMagic1 ovu.magic1 #define bucketIndex ovu.index #define rangeCheckMagic ovu.rmagic #define realBlockSize ovu.size }; #define MAGIC 0xEF /* magic # on accounting info */ #define RMAGIC 0x5555 /* magic # on range info */ #ifndef NDEBUG #define RSLOP sizeof(unsigned short) #else #define RSLOP 0 #endif |
| ︙ | ︙ | |||
284 285 286 287 288 289 290 | bigBlockPtr->nextPtr = bigBlocks.nextPtr; bigBlocks.nextPtr = bigBlockPtr; bigBlockPtr->prevPtr = &bigBlocks; bigBlockPtr->nextPtr->prevPtr = bigBlockPtr; overPtr = (union overhead *) (bigBlockPtr + 1); overPtr->overMagic0 = overPtr->overMagic1 = MAGIC; | | | 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 | bigBlockPtr->nextPtr = bigBlocks.nextPtr; bigBlocks.nextPtr = bigBlockPtr; bigBlockPtr->prevPtr = &bigBlocks; bigBlockPtr->nextPtr->prevPtr = bigBlockPtr; overPtr = (union overhead *) (bigBlockPtr + 1); overPtr->overMagic0 = overPtr->overMagic1 = MAGIC; overPtr->bucketIndex = 0xFF; #ifdef MSTATS numMallocs[NBUCKETS]++; #endif #ifndef NDEBUG /* * Record allocated size of block and bound space with magic numbers. |
| ︙ | ︙ | |||
341 342 343 344 345 346 347 |
/*
* Remove from linked list
*/
nextf[bucket] = overPtr->next;
overPtr->overMagic0 = overPtr->overMagic1 = MAGIC;
| | | 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 |
/*
* Remove from linked list
*/
nextf[bucket] = overPtr->next;
overPtr->overMagic0 = overPtr->overMagic1 = MAGIC;
overPtr->bucketIndex = UCHAR(bucket);
#ifdef MSTATS
numMallocs[bucket]++;
#endif
#ifndef NDEBUG
/*
|
| ︙ | ︙ | |||
464 465 466 467 468 469 470 |
Tcl_MutexUnlock(allocMutexPtr);
return;
}
RANGE_ASSERT(overPtr->rangeCheckMagic == RMAGIC);
RANGE_ASSERT(BLOCK_END(overPtr) == RMAGIC);
size = overPtr->bucketIndex;
| | | 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 |
Tcl_MutexUnlock(allocMutexPtr);
return;
}
RANGE_ASSERT(overPtr->rangeCheckMagic == RMAGIC);
RANGE_ASSERT(BLOCK_END(overPtr) == RMAGIC);
size = overPtr->bucketIndex;
if (size == 0xFF) {
#ifdef MSTATS
numMallocs[NBUCKETS]--;
#endif
bigBlockPtr = (struct block *) overPtr - 1;
bigBlockPtr->prevPtr->nextPtr = bigBlockPtr->nextPtr;
bigBlockPtr->nextPtr->prevPtr = bigBlockPtr->prevPtr;
|
| ︙ | ︙ | |||
538 539 540 541 542 543 544 |
RANGE_ASSERT(BLOCK_END(overPtr) == RMAGIC);
i = overPtr->bucketIndex;
/*
* If the block isn't in a bin, just realloc it.
*/
| | | 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 |
RANGE_ASSERT(BLOCK_END(overPtr) == RMAGIC);
i = overPtr->bucketIndex;
/*
* If the block isn't in a bin, just realloc it.
*/
if (i == 0xFF) {
struct block *prevPtr, *nextPtr;
bigBlockPtr = (struct block *) overPtr - 1;
prevPtr = bigBlockPtr->prevPtr;
nextPtr = bigBlockPtr->nextPtr;
bigBlockPtr = (struct block *) TclpSysRealloc(bigBlockPtr,
sizeof(struct block) + OVERHEAD + numBytes);
if (bigBlockPtr == NULL) {
|
| ︙ | ︙ |
Changes to generic/tclAssembly.c.
| ︙ | ︙ | |||
670 671 672 673 674 675 676 |
int tblIdx, /* Table index in TalInstructionTable of op */
int count) /* Operand count for variadic ops */
{
CompileEnv* envPtr = assemEnvPtr->envPtr;
/* Compilation environment */
BasicBlock* bbPtr = assemEnvPtr->curr_bb;
/* Current basic block */
| | | 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 |
int tblIdx, /* Table index in TalInstructionTable of op */
int count) /* Operand count for variadic ops */
{
CompileEnv* envPtr = assemEnvPtr->envPtr;
/* Compilation environment */
BasicBlock* bbPtr = assemEnvPtr->curr_bb;
/* Current basic block */
int op = TalInstructionTable[tblIdx].tclInstCode & 0xFF;
/*
* If this is the first instruction in a basic block, record its line
* number.
*/
if (bbPtr->startOffset == envPtr->codeNext - envPtr->codeStart) {
|
| ︙ | ︙ | |||
732 733 734 735 736 737 738 |
{
CompileEnv* envPtr = assemEnvPtr->envPtr;
/* Compilation environment */
BasicBlock* bbPtr = assemEnvPtr->curr_bb;
/* Current basic block */
int op = TalInstructionTable[tblIdx].tclInstCode;
| | | | | 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 |
{
CompileEnv* envPtr = assemEnvPtr->envPtr;
/* Compilation environment */
BasicBlock* bbPtr = assemEnvPtr->curr_bb;
/* Current basic block */
int op = TalInstructionTable[tblIdx].tclInstCode;
if (param <= 0xFF) {
op >>= 8;
} else {
op &= 0xFF;
}
TclEmitInt1(op, envPtr);
if (param <= 0xFF) {
TclEmitInt1(param, envPtr);
} else {
TclEmitInt4(param, envPtr);
}
TclUpdateAtCmdStart(op, envPtr);
BBUpdateStackReqs(bbPtr, tblIdx, count);
}
|
| ︙ | ︙ | |||
2227 2228 2229 2230 2231 2232 2233 | * Gets the value of an operand intended to serve as a list index. * * Results: * Returns a standard Tcl result: TCL_OK if the parse is successful and * TCL_ERROR (with an appropriate error message) if the parse fails. * * Side effects: | | | 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 | * Gets the value of an operand intended to serve as a list index. * * Results: * Returns a standard Tcl result: TCL_OK if the parse is successful and * TCL_ERROR (with an appropriate error message) if the parse fails. * * Side effects: * Stores the list index at '*index'. Values between -1 and 0x7FFFFFFF * have their natural meaning; values between -2 and -0x80000000 * represent 'end-2-N'. * *----------------------------------------------------------------------------- */ static int |
| ︙ | ︙ | |||
2390 2391 2392 2393 2394 2395 2396 |
static int
CheckOneByte(
Tcl_Interp* interp, /* Tcl interpreter for error reporting */
int value) /* Value to check */
{
Tcl_Obj* result; /* Error message */
| | | 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 |
static int
CheckOneByte(
Tcl_Interp* interp, /* Tcl interpreter for error reporting */
int value) /* Value to check */
{
Tcl_Obj* result; /* Error message */
if (value < 0 || value > 0xFF) {
result = Tcl_NewStringObj("operand does not fit in one byte", -1);
Tcl_SetObjResult(interp, result);
Tcl_SetErrorCode(interp, "TCL", "ASSEM", "1BYTE", NULL);
return TCL_ERROR;
}
return TCL_OK;
}
|
| ︙ | ︙ | |||
2425 2426 2427 2428 2429 2430 2431 |
static int
CheckSignedOneByte(
Tcl_Interp* interp, /* Tcl interpreter for error reporting */
int value) /* Value to check */
{
Tcl_Obj* result; /* Error message */
| | | 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 |
static int
CheckSignedOneByte(
Tcl_Interp* interp, /* Tcl interpreter for error reporting */
int value) /* Value to check */
{
Tcl_Obj* result; /* Error message */
if (value > 0x7F || value < -0x80) {
result = Tcl_NewStringObj("operand does not fit in one byte", -1);
Tcl_SetObjResult(interp, result);
Tcl_SetErrorCode(interp, "TCL", "ASSEM", "1BYTE", NULL);
return TCL_ERROR;
}
return TCL_OK;
}
|
| ︙ | ︙ | |||
2839 2840 2841 2842 2843 2844 2845 |
* target is out of range.
*/
jumpTarget = (BasicBlock*)Tcl_GetHashValue(entry);
if (bbPtr->flags & BB_JUMP1) {
offset = jumpTarget->startOffset
- (bbPtr->jumpOffset + motion);
| | | 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 |
* target is out of range.
*/
jumpTarget = (BasicBlock*)Tcl_GetHashValue(entry);
if (bbPtr->flags & BB_JUMP1) {
offset = jumpTarget->startOffset
- (bbPtr->jumpOffset + motion);
if (offset < -0x80 || offset > 0x7F) {
opcode = TclGetUInt1AtPtr(envPtr->codeStart
+ bbPtr->jumpOffset);
++opcode;
TclStoreInt1AtPtr(opcode,
envPtr->codeStart + bbPtr->jumpOffset);
motion += 3;
bbPtr->flags &= ~BB_JUMP1;
|
| ︙ | ︙ | |||
2906 2907 2908 2909 2910 2911 2912 |
for (symEntryPtr = Tcl_FirstHashEntry(symHash, &search);
symEntryPtr != NULL;
symEntryPtr = Tcl_NextHashEntry(&search)) {
symbolObj = (Tcl_Obj*)Tcl_GetHashValue(symEntryPtr);
valEntryPtr = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
TclGetString(symbolObj));
DEBUG_PRINT(" %s -> %s (%d)\n",
| | | 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 |
for (symEntryPtr = Tcl_FirstHashEntry(symHash, &search);
symEntryPtr != NULL;
symEntryPtr = Tcl_NextHashEntry(&search)) {
symbolObj = (Tcl_Obj*)Tcl_GetHashValue(symEntryPtr);
valEntryPtr = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
TclGetString(symbolObj));
DEBUG_PRINT(" %s -> %s (%d)\n",
(char *)Tcl_GetHashKey(symHash, symEntryPtr),
TclGetString(symbolObj), (valEntryPtr != NULL));
if (valEntryPtr == NULL) {
ReportUndefinedLabel(assemEnvPtr, bbPtr, symbolObj);
return TCL_ERROR;
}
}
DEBUG_PRINT("}\n");
|
| ︙ | ︙ | |||
3111 3112 3113 3114 3115 3116 3117 |
valEntryPtr = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
TclGetString(symbolObj));
jumpTargetBBPtr = (BasicBlock*)Tcl_GetHashValue(valEntryPtr);
realJumpEntryPtr = Tcl_CreateHashEntry(realJumpHashPtr,
Tcl_GetHashKey(symHash, symEntryPtr), &junk);
DEBUG_PRINT(" %s -> %s -> bb %p (pc %d) hash entry %p\n",
| | | 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 |
valEntryPtr = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
TclGetString(symbolObj));
jumpTargetBBPtr = (BasicBlock*)Tcl_GetHashValue(valEntryPtr);
realJumpEntryPtr = Tcl_CreateHashEntry(realJumpHashPtr,
Tcl_GetHashKey(symHash, symEntryPtr), &junk);
DEBUG_PRINT(" %s -> %s -> bb %p (pc %d) hash entry %p\n",
(char *)Tcl_GetHashKey(symHash, symEntryPtr),
TclGetString(symbolObj), jumpTargetBBPtr,
jumpTargetBBPtr->startOffset, realJumpEntryPtr);
Tcl_SetHashValue(realJumpEntryPtr,
INT2PTR(jumpTargetBBPtr->startOffset - bbPtr->jumpOffset));
}
DEBUG_PRINT("}\n");
|
| ︙ | ︙ |
Changes to generic/tclBasic.c.
| ︙ | ︙ | |||
658 659 660 661 662 663 664 |
}
if (commandTypeInit == 0) {
TclRegisterCommandTypeName(TclObjInterpProc, "proc");
TclRegisterCommandTypeName(TclEnsembleImplementationCmd, "ensemble");
TclRegisterCommandTypeName(TclAliasObjCmd, "alias");
TclRegisterCommandTypeName(TclLocalAliasObjCmd, "alias");
| | | 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 |
}
if (commandTypeInit == 0) {
TclRegisterCommandTypeName(TclObjInterpProc, "proc");
TclRegisterCommandTypeName(TclEnsembleImplementationCmd, "ensemble");
TclRegisterCommandTypeName(TclAliasObjCmd, "alias");
TclRegisterCommandTypeName(TclLocalAliasObjCmd, "alias");
TclRegisterCommandTypeName(TclSlaveObjCmd, "interp");
TclRegisterCommandTypeName(TclInvokeImportedCmd, "import");
TclRegisterCommandTypeName(TclOOPublicObjectCmd, "object");
TclRegisterCommandTypeName(TclOOPrivateObjectCmd, "privateObject");
TclRegisterCommandTypeName(TclOOMyClassObjCmd, "privateClass");
TclRegisterCommandTypeName(TclNRInterpCoroutine, "coroutine");
}
|
| ︙ | ︙ | |||
3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 |
* from a CmdName Tcl object in some ByteCode code sequence. In that case,
* delay the cleanup until all references are either discarded (when a
* ByteCode is freed) or replaced by a new reference (when a cached
* CmdName Command reference is found to be invalid and
* TclNRExecuteByteCode looks up the command in the command hashtable).
*/
TclCleanupCommandMacro(cmdPtr);
return 0;
}
/*
*----------------------------------------------------------------------
*
| > | 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 |
* from a CmdName Tcl object in some ByteCode code sequence. In that case,
* delay the cleanup until all references are either discarded (when a
* ByteCode is freed) or replaced by a new reference (when a cached
* CmdName Command reference is found to be invalid and
* TclNRExecuteByteCode looks up the command in the command hashtable).
*/
cmdPtr->flags |= CMD_DEAD;
TclCleanupCommandMacro(cmdPtr);
return 0;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
3713 3714 3715 3716 3717 3718 3719 | TclSetCancelFlags(iPtr, cancelInfo->flags | CANCELED); /* * Now, we must set the script cancellation flags on all the slave * interpreters belonging to this one. */ | | | 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 | TclSetCancelFlags(iPtr, cancelInfo->flags | CANCELED); /* * Now, we must set the script cancellation flags on all the slave * interpreters belonging to this one. */ TclSetChildCancelFlags((Tcl_Interp *) iPtr, cancelInfo->flags | CANCELED, 0); /* * Create the result object now so that Tcl_Canceled can avoid * locking the cancelLock mutex. */ |
| ︙ | ︙ | |||
4242 4243 4244 4245 4246 4247 4248 |
reresolve:
assert(cmdPtr == NULL);
if (preCmdPtr) {
/*
* Caller gave it to us.
*/
| | | 4243 4244 4245 4246 4247 4248 4249 4250 4251 4252 4253 4254 4255 4256 4257 |
reresolve:
assert(cmdPtr == NULL);
if (preCmdPtr) {
/*
* Caller gave it to us.
*/
if (!(preCmdPtr->flags & CMD_DEAD)) {
/*
* So long as it exists, use it.
*/
cmdPtr = preCmdPtr;
} else if (flags & TCL_EVAL_NORESOLVE) {
/*
|
| ︙ | ︙ | |||
4940 4941 4942 4943 4944 4945 4946 |
if (clNextOuter) {
clNext = clNextOuter;
} else {
clNext = &iPtr->scriptCLLocPtr->loc[0];
}
}
| | | 4941 4942 4943 4944 4945 4946 4947 4948 4949 4950 4951 4952 4953 4954 4955 |
if (clNextOuter) {
clNext = clNextOuter;
} else {
clNext = &iPtr->scriptCLLocPtr->loc[0];
}
}
if (numBytes == TCL_INDEX_NONE) {
numBytes = strlen(script);
}
Tcl_ResetResult(interp);
savedVarFramePtr = iPtr->varFramePtr;
if (flags & TCL_EVAL_GLOBAL) {
iPtr->varFramePtr = iPtr->rootFramePtr;
|
| ︙ | ︙ | |||
7422 7423 7424 7425 7426 7427 7428 | iPtr->randSeed = TclpGetClicks() + (PTR2INT(Tcl_GetCurrentThread())<<12); /* * Make sure 1 <= randSeed <= (2^31) - 2. See below. */ | | | | 7423 7424 7425 7426 7427 7428 7429 7430 7431 7432 7433 7434 7435 7436 7437 7438 |
iPtr->randSeed = TclpGetClicks() + (PTR2INT(Tcl_GetCurrentThread())<<12);
/*
* Make sure 1 <= randSeed <= (2^31) - 2. See below.
*/
iPtr->randSeed &= 0x7FFFFFFF;
if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7FFFFFFF)) {
iPtr->randSeed ^= 123459876;
}
}
/*
* Generate the random number using the linear congruential generator
* defined by the following recurrence:
|
| ︙ | ︙ | |||
7591 7592 7593 7594 7595 7596 7597 |
/*
* Reset the seed. Make sure 1 <= randSeed <= 2^31 - 2. See comments in
* ExprRandFunc for more details.
*/
iPtr->flags |= RAND_SEED_INITIALIZED;
| | | | 7592 7593 7594 7595 7596 7597 7598 7599 7600 7601 7602 7603 7604 7605 7606 7607 |
/*
* Reset the seed. Make sure 1 <= randSeed <= 2^31 - 2. See comments in
* ExprRandFunc for more details.
*/
iPtr->flags |= RAND_SEED_INITIALIZED;
iPtr->randSeed = (long) w & 0x7FFFFFFF;
if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7FFFFFFF)) {
iPtr->randSeed ^= 123459876;
}
/*
* To avoid duplicating the random number generation code we simply clean
* up our state and call the real random number function. That function
* will always succeed.
|
| ︙ | ︙ | |||
7685 7686 7687 7688 7689 7690 7691 |
/* The pieces extracted from the double. */
int zeroMantissa; /* Was the mantissa zero? That's special. */
/*
* Shifts and masks to use with the doubleMeaning variable above.
*/
| | | | 7686 7687 7688 7689 7690 7691 7692 7693 7694 7695 7696 7697 7698 7699 7700 7701 7702 |
/* The pieces extracted from the double. */
int zeroMantissa; /* Was the mantissa zero? That's special. */
/*
* Shifts and masks to use with the doubleMeaning variable above.
*/
#define EXPONENT_MASK 0x7FF /* 11 bits (after shifting) */
#define EXPONENT_SHIFT 20 /* Moves exponent to bottom of word */
#define MANTISSA_MASK 0xFFFFF /* 20 bits (plus 32 from other word) */
/*
* Extract the exponent (11 bits) and mantissa (52 bits). Note that we
* totally ignore the sign bit.
*/
doubleMeaning.d = d;
|
| ︙ | ︙ |
Changes to generic/tclBinary.c.
| ︙ | ︙ | |||
263 264 265 266 267 268 269 270 271 272 273 274 275 276 |
* 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. */
| > > > | 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 |
* 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 bad; /* Index of the character that is a nonbyte.
* If all characters are bytes, bad = used,
* though then we should never read it. */
size_t used; /* The number of bytes used in the byte
* 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. */
|
| ︙ | ︙ | |||
413 414 415 416 417 418 419 420 421 422 423 424 425 426 |
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_SetByteArrayObj");
}
TclInvalidateStringRep(objPtr);
byteArrayPtr = (ByteArray *)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);
| > | 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 |
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_SetByteArrayObj");
}
TclInvalidateStringRep(objPtr);
byteArrayPtr = (ByteArray *)Tcl_Alloc(BYTEARRAY_SIZE(length));
byteArrayPtr->bad = length;
byteArrayPtr->used = length;
byteArrayPtr->allocated = length;
if ((bytes != NULL) && (length > 0)) {
memcpy(byteArrayPtr->bytes, bytes, length);
}
SET_BYTEARRAY(&ir, byteArrayPtr);
|
| ︙ | ︙ | |||
445 446 447 448 449 450 451 |
*----------------------------------------------------------------------
*/
unsigned char *
TclGetBytesFromObj(
Tcl_Interp *interp, /* For error reporting */
Tcl_Obj *objPtr, /* Value to extract from */
| | > > > > > > > > | > | 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 |
*----------------------------------------------------------------------
*/
unsigned char *
TclGetBytesFromObj(
Tcl_Interp *interp, /* For error reporting */
Tcl_Obj *objPtr, /* Value to extract from */
size_t *lengthPtr) /* If non-NULL, filled with length of the
* array of bytes in the ByteArray object. */
{
ByteArray *baPtr;
const Tcl_ObjIntRep *irPtr = TclFetchIntRep(objPtr, &properByteArrayType);
if (irPtr == NULL) {
SetByteArrayFromAny(NULL, objPtr);
irPtr = TclFetchIntRep(objPtr, &properByteArrayType);
if (irPtr == NULL) {
if (interp) {
const char *nonbyte;
int ucs4;
irPtr = TclFetchIntRep(objPtr, &tclByteArrayType);
baPtr = GET_BYTEARRAY(irPtr);
nonbyte = Tcl_UtfAtIndex(Tcl_GetString(objPtr), baPtr->bad);
TclUtfToUCS4(nonbyte, &ucs4);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"expected byte sequence but character %" TCL_Z_MODIFIER "u "
"was '%1s' (U+%06X)", baPtr->bad, nonbyte, ucs4));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "BYTES", NULL);
}
return NULL;
}
}
baPtr = GET_BYTEARRAY(irPtr);
|
| ︙ | ︙ | |||
495 496 497 498 499 500 501 |
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. */
{
| | < | | < < | | > | | > > | > > > | > > > > > | > > > | > | | 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 |
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. */
{
size_t numBytes = 0;
unsigned char *bytes = TclGetBytesFromObj(NULL, objPtr, &numBytes);
if (bytes == NULL) {
ByteArray *baPtr;
const Tcl_ObjIntRep *irPtr = TclFetchIntRep(objPtr, &tclByteArrayType);
assert(irPtr != NULL);
baPtr = GET_BYTEARRAY(irPtr);
bytes = baPtr->bytes;
numBytes = baPtr->used;
}
/* Macro TclGetByteArrayFromObj passes NULL for lengthPtr as
* a trick to get around changing size. */
if (lengthPtr) {
if (numBytes > INT_MAX) {
/* Caller asked for an int length, but true length is outside
* the int range. This case will be developed out of existence
* in Tcl 9. As interim measure, fail. */
*lengthPtr = 0;
return NULL;
} else {
*lengthPtr = (int) numBytes;
}
}
return bytes;
}
/*
*----------------------------------------------------------------------
*
* Tcl_SetByteArrayLength --
*
|
| ︙ | ︙ | |||
539 540 541 542 543 544 545 |
*
*----------------------------------------------------------------------
*/
unsigned char *
Tcl_SetByteArrayLength(
Tcl_Obj *objPtr, /* The ByteArray object. */
| | | 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 |
*
*----------------------------------------------------------------------
*/
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");
}
|
| ︙ | ︙ | |||
568 569 570 571 572 573 574 575 576 577 578 579 580 581 |
if (length > byteArrayPtr->allocated) {
byteArrayPtr = (ByteArray *)Tcl_Realloc(byteArrayPtr, BYTEARRAY_SIZE(length));
byteArrayPtr->allocated = length;
SET_BYTEARRAY(irPtr, byteArrayPtr);
}
TclInvalidateStringRep(objPtr);
objPtr->typePtr = &properByteArrayType;
byteArrayPtr->used = length;
return byteArrayPtr->bytes;
}
/*
*----------------------------------------------------------------------
*
| > | 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 |
if (length > byteArrayPtr->allocated) {
byteArrayPtr = (ByteArray *)Tcl_Realloc(byteArrayPtr, BYTEARRAY_SIZE(length));
byteArrayPtr->allocated = length;
SET_BYTEARRAY(irPtr, byteArrayPtr);
}
TclInvalidateStringRep(objPtr);
objPtr->typePtr = &properByteArrayType;
byteArrayPtr->bad = length;
byteArrayPtr->used = length;
return byteArrayPtr->bytes;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
593 594 595 596 597 598 599 |
*/
static int
SetByteArrayFromAny(
TCL_UNUSED(Tcl_Interp *),
Tcl_Obj *objPtr) /* The object to convert to type ByteArray. */
{
| | < > | > > | > > > > > | | > | | 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 |
*/
static int
SetByteArrayFromAny(
TCL_UNUSED(Tcl_Interp *),
Tcl_Obj *objPtr) /* The object to convert to type ByteArray. */
{
size_t length, bad;
const char *src, *srcEnd;
unsigned char *dst;
Tcl_UniChar ch = 0;
ByteArray *byteArrayPtr;
Tcl_ObjIntRep ir;
if (TclHasIntRep(objPtr, &properByteArrayType)) {
return TCL_OK;
}
if (TclHasIntRep(objPtr, &tclByteArrayType)) {
return TCL_OK;
}
src = TclGetStringFromObj(objPtr, &length);
bad = length;
srcEnd = src + length;
byteArrayPtr = (ByteArray *)Tcl_Alloc(BYTEARRAY_SIZE(length));
for (dst = byteArrayPtr->bytes; src < srcEnd; ) {
src += TclUtfToUniChar(src, &ch);
if ((bad == length) && (ch > 255)) {
bad = dst - byteArrayPtr->bytes;
}
*dst++ = UCHAR(ch);
}
SET_BYTEARRAY(&ir, byteArrayPtr);
byteArrayPtr->allocated = length;
byteArrayPtr->used = dst - byteArrayPtr->bytes;
if (bad == length) {
byteArrayPtr->bad = byteArrayPtr->used;
Tcl_StoreIntRep(objPtr, &properByteArrayType, &ir);
} else {
byteArrayPtr->bad = bad;
Tcl_StoreIntRep(objPtr, &tclByteArrayType, &ir);
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* FreeByteArrayInternalRep --
|
| ︙ | ︙ | |||
688 689 690 691 692 693 694 695 696 697 698 699 700 701 |
ByteArray *srcArrayPtr, *copyArrayPtr;
Tcl_ObjIntRep ir;
srcArrayPtr = GET_BYTEARRAY(TclFetchIntRep(srcPtr, &tclByteArrayType));
length = srcArrayPtr->used;
copyArrayPtr = (ByteArray *)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);
}
| > | 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 |
ByteArray *srcArrayPtr, *copyArrayPtr;
Tcl_ObjIntRep ir;
srcArrayPtr = GET_BYTEARRAY(TclFetchIntRep(srcPtr, &tclByteArrayType));
length = srcArrayPtr->used;
copyArrayPtr = (ByteArray *)Tcl_Alloc(BYTEARRAY_SIZE(length));
copyArrayPtr->bad = srcArrayPtr->bad;
copyArrayPtr->used = length;
copyArrayPtr->allocated = length;
memcpy(copyArrayPtr->bytes, srcArrayPtr->bytes, length);
SET_BYTEARRAY(&ir, copyArrayPtr);
Tcl_StoreIntRep(copyPtr, &tclByteArrayType, &ir);
}
|
| ︙ | ︙ | |||
709 710 711 712 713 714 715 716 717 718 719 720 721 722 |
ByteArray *srcArrayPtr, *copyArrayPtr;
Tcl_ObjIntRep ir;
srcArrayPtr = GET_BYTEARRAY(TclFetchIntRep(srcPtr, &properByteArrayType));
length = srcArrayPtr->used;
copyArrayPtr = (ByteArray *)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);
}
| > | 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 |
ByteArray *srcArrayPtr, *copyArrayPtr;
Tcl_ObjIntRep ir;
srcArrayPtr = GET_BYTEARRAY(TclFetchIntRep(srcPtr, &properByteArrayType));
length = srcArrayPtr->used;
copyArrayPtr = (ByteArray *)Tcl_Alloc(BYTEARRAY_SIZE(length));
copyArrayPtr->bad = length;
copyArrayPtr->used = length;
copyArrayPtr->allocated = length;
memcpy(copyArrayPtr->bytes, srcArrayPtr->bytes, length);
SET_BYTEARRAY(&ir, copyArrayPtr);
Tcl_StoreIntRep(copyPtr, &properByteArrayType, &ir);
}
|
| ︙ | ︙ | |||
802 803 804 805 806 807 808 |
ByteArray *byteArrayPtr;
size_t needed;
Tcl_ObjIntRep *irPtr;
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object","TclAppendBytesToByteArray");
}
| | | 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 |
ByteArray *byteArrayPtr;
size_t needed;
Tcl_ObjIntRep *irPtr;
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object","TclAppendBytesToByteArray");
}
if (len == TCL_INDEX_NONE) {
Tcl_Panic("%s must be called with definite number of bytes to append",
"TclAppendBytesToByteArray");
}
if (len == 0) {
/*
* Append zero bytes is a no-op.
*/
|
| ︙ | ︙ | |||
1263 1264 1265 1266 1267 1268 1269 |
c = str[offset] - '0';
if (c > 9) {
c += ('0' - 'A') + 10;
}
if (c > 16) {
c += ('A' - 'a');
}
| | | 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 |
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++) {
|
| ︙ | ︙ | |||
1285 1286 1287 1288 1289 1290 1291 |
c = str[offset] - '0';
if (c > 9) {
c += ('0' - 'A') + 10;
}
if (c > 16) {
c += ('A' - 'a');
}
| | | | 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 |
c = str[offset] - '0';
if (c > 9) {
c += ('0' - 'A') + 10;
}
if (c > 16) {
c += ('A' - 'a');
}
value |= ((c << 4) & 0xF0);
if (offset % 2) {
*cursor++ = UCHAR(value & 0xFF);
value = 0;
}
}
}
if (offset % 2) {
if (cmd == 'H') {
value <<= 4;
|
| ︙ | ︙ | |||
1621 1622 1623 1624 1625 1626 1627 |
if (cmd == 'h') {
for (i = 0; (size_t)i < count; i++) {
if (i % 2) {
value >>= 4;
} else {
value = *src++;
}
| | | | 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 |
if (cmd == 'h') {
for (i = 0; (size_t)i < count; i++) {
if (i % 2) {
value >>= 4;
} else {
value = *src++;
}
*dest++ = hexdigit[value & 0xF];
}
} else {
for (i = 0; (size_t)i < count; i++) {
if (i % 2) {
value <<= 4;
} else {
value = *src++;
}
*dest++ = hexdigit[(value >> 4) & 0xF];
}
}
resultPtr = Tcl_ObjSetVar2(interp, objv[arg], NULL, valuePtr,
TCL_LEAVE_ERR_MSG);
arg++;
if (resultPtr == NULL) {
|
| ︙ | ︙ | |||
2521 2522 2523 2524 2525 2526 2527 |
return TCL_ERROR;
}
TclNewObj(resultObj);
data = TclGetByteArrayFromObj(objv[1], &count);
cursor = Tcl_SetByteArrayLength(resultObj, count * 2);
for (offset = 0; offset < count; ++offset) {
| | | | 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 |
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;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
2554 2555 2556 2557 2558 2559 2560 |
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *resultObj = NULL;
unsigned char *data, *datastart, *dataend;
unsigned char *begin, *cursor, c;
| | | > > | > | > > | 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 |
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *resultObj = NULL;
unsigned char *data, *datastart, *dataend;
unsigned char *begin, *cursor, c;
int i, index, value, pure = 1, strict = 0;
size_t size, cut = 0, count = 0;
int ucs4;
enum {OPT_STRICT };
static const char *const optStrings[] = { "-strict", NULL };
if (objc < 2 || objc > 3) {
Tcl_WrongNumArgs(interp, 1, objv, "?options? data");
return TCL_ERROR;
}
for (i = 1; i < objc - 1; ++i) {
if (Tcl_GetIndexFromObj(interp, objv[i], optStrings, "option",
TCL_EXACT, &index) != TCL_OK) {
return TCL_ERROR;
}
switch (index) {
case OPT_STRICT:
strict = 1;
break;
}
}
TclNewObj(resultObj);
data = TclGetBytesFromObj(NULL, objv[objc - 1], &count);
if (data == NULL) {
pure = 0;
data = (unsigned char *) TclGetStringFromObj(objv[objc - 1], &count);
}
datastart = data;
dataend = data + count;
size = (count + 1) / 2;
begin = cursor = Tcl_SetByteArrayLength(resultObj, size);
while (data < dataend) {
value = 0;
for (i = 0 ; i < 2 ; i++) {
if (data >= dataend) {
|
| ︙ | ︙ | |||
2606 2607 2608 2609 2610 2611 2612 |
c -= '0';
if (c > 9) {
c += ('0' - 'A') + 10;
}
if (c > 16) {
c += ('A' - 'a');
}
| | > > > > > | | > < < < | | < < < | 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 |
c -= '0';
if (c > 9) {
c += ('0' - 'A') + 10;
}
if (c > 16) {
c += ('A' - 'a');
}
value |= c & 0xF;
}
if (i < 2) {
cut++;
}
*cursor++ = UCHAR(value);
value = 0;
}
if (cut > size) {
cut = size;
}
Tcl_SetByteArrayLength(resultObj, cursor - begin - cut);
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
badChar:
if (pure) {
ucs4 = c;
} else {
TclUtfToUCS4((const char *)(data - 1), &ucs4);
}
TclDecrRefCount(resultObj);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"invalid hexadecimal digit \"%c\" (U+%06X) at position %"
TCL_Z_MODIFIER "u", ucs4, ucs4, data - datastart - 1));
Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "INVALID", NULL);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* BinaryEncode64 --
*
* This procedure implements the "binary encode base64" Tcl command.
*
* Results:
* The base64 encoded value prescribed by the input arguments.
*
*----------------------------------------------------------------------
*/
#define OUTPUT(c) \
do { \
*cursor++ = (c); \
|
| ︙ | ︙ | |||
2672 2673 2674 2675 2676 2677 2678 |
BinaryEncode64(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *resultObj;
| | | | 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 |
BinaryEncode64(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *resultObj;
unsigned char *data, *limit;
int maxlen = 0;
const char *wrapchar = "\n";
size_t wrapcharlen = 1;
int i, index, size, outindex = 0, purewrap = 1;
size_t offset, count = 0;
enum { OPT_MAXLEN, OPT_WRAPCHAR };
static const char *const optStrings[] = { "-maxlen", "-wrapchar", NULL };
if (objc < 2 || objc % 2 != 0) {
Tcl_WrongNumArgs(interp, 1, objv,
"?-maxlen len? ?-wrapchar char? data");
|
| ︙ | ︙ | |||
2705 2706 2707 2708 2709 2710 2711 | "line length out of range", -1)); Tcl_SetErrorCode(interp, "TCL", "BINARY", "ENCODE", "LINE_LENGTH", NULL); return TCL_ERROR; } break; case OPT_WRAPCHAR: | > | | | > > > > > > | > > > > > > > > | > | | | 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 |
"line length out of range", -1));
Tcl_SetErrorCode(interp, "TCL", "BINARY", "ENCODE",
"LINE_LENGTH", NULL);
return TCL_ERROR;
}
break;
case OPT_WRAPCHAR:
wrapchar = (const char *)TclGetBytesFromObj(NULL,
objv[i + 1], &wrapcharlen);
if (wrapchar == NULL) {
purewrap = 0;
wrapchar = TclGetStringFromObj(objv[i + 1], &wrapcharlen);
}
break;
}
}
if (wrapcharlen == 0) {
maxlen = 0;
}
resultObj = Tcl_NewObj();
data = TclGetByteArrayFromObj(objv[objc - 1], &count);
if (count > 0) {
unsigned char *cursor = NULL;
size = (((count * 4) / 3) + 3) & ~3; /* ensure 4 byte chunks */
if (maxlen > 0 && size > maxlen) {
int adjusted = size + (wrapcharlen * (size / maxlen));
if (size % maxlen == 0) {
adjusted -= wrapcharlen;
}
size = adjusted;
if (purewrap == 0) {
/* Wrapchar is (possibly) non-byte, so build result as
* general string, not bytearray */
Tcl_SetObjLength(resultObj, size);
cursor = (unsigned char *) TclGetString(resultObj);
}
}
if (cursor == NULL) {
cursor = Tcl_SetByteArrayLength(resultObj, size);
}
limit = cursor + size;
for (offset = 0; offset < count; offset += 3) {
unsigned char d[3] = {0, 0, 0};
for (i = 0; i < 3 && offset + i < count; ++i) {
d[i] = data[offset + i];
}
OUTPUT(B64Digits[d[0] >> 2]);
OUTPUT(B64Digits[((d[0] & 0x03) << 4) | (d[1] >> 4)]);
if (offset + 1 < count) {
OUTPUT(B64Digits[((d[1] & 0x0F) << 2) | (d[2] >> 6)]);
} else {
OUTPUT(B64Digits[64]);
}
if (offset+2 < count) {
OUTPUT(B64Digits[d[2] & 0x3F]);
} else {
OUTPUT(B64Digits[64]);
}
}
}
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
|
| ︙ | ︙ | |||
2782 2783 2784 2785 2786 2787 2788 |
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *resultObj;
unsigned char *data, *start, *cursor;
int rawLength, n, i, bits, index;
int lineLength = 61;
| | | 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 |
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *resultObj;
unsigned char *data, *start, *cursor;
int rawLength, n, i, bits, index;
int lineLength = 61;
const unsigned char SingleNewline[] = { UCHAR('\n') };
const unsigned char *wrapchar = SingleNewline;
size_t j, offset, count = 0, wrapcharlen = sizeof(SingleNewline);
enum { OPT_MAXLEN, OPT_WRAPCHAR };
static const char *const optStrings[] = { "-maxlen", "-wrapchar", NULL };
if (objc < 2 || objc % 2 != 0) {
Tcl_WrongNumArgs(interp, 1, objv,
|
| ︙ | ︙ | |||
2804 2805 2806 2807 2808 2809 2810 |
}
switch (index) {
case OPT_MAXLEN:
if (Tcl_GetIntFromObj(interp, objv[i + 1],
&lineLength) != TCL_OK) {
return TCL_ERROR;
}
| | > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
}
switch (index) {
case OPT_MAXLEN:
if (Tcl_GetIntFromObj(interp, objv[i + 1],
&lineLength) != TCL_OK) {
return TCL_ERROR;
}
if (lineLength < 5 || lineLength > 85) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"line length out of range", -1));
Tcl_SetErrorCode(interp, "TCL", "BINARY", "ENCODE",
"LINE_LENGTH", NULL);
return TCL_ERROR;
}
lineLength = ((lineLength - 1) & -4) + 1; /* 5, 9, 13 ... */
break;
case OPT_WRAPCHAR:
wrapchar = (const unsigned char *) TclGetStringFromObj(
objv[i + 1], &wrapcharlen);
{
const unsigned char *p = wrapchar;
size_t numBytes = wrapcharlen;
while (numBytes) {
switch (*p) {
case '\t':
case '\v':
case '\f':
case '\r':
p++; numBytes--;
continue;
case '\n':
numBytes--;
break;
default:
badwrap:
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"invalid wrapchar; will defeat decoding",
-1));
Tcl_SetErrorCode(interp, "TCL", "BINARY",
"ENCODE", "WRAPCHAR", NULL);
return TCL_ERROR;
}
}
if (numBytes) {
goto badwrap;
}
}
break;
}
}
/*
* Allocate the buffer. This is a little bit too long, but is "good
* enough".
|
| ︙ | ︙ | |||
2850 2851 2852 2853 2854 2855 2856 |
lineLen = rawLength;
}
*cursor++ = UueDigits[lineLen];
for (i = 0 ; i < lineLen ; i++) {
n <<= 8;
n |= data[offset++];
for (bits += 8; bits > 6 ; bits -= 6) {
| | | | 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 |
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];
}
}
|
| ︙ | ︙ | |||
2898 2899 2900 2901 2902 2903 2904 |
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *resultObj = NULL;
unsigned char *data, *datastart, *dataend;
unsigned char *begin, *cursor;
| | | > > | > | > > | 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 |
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *resultObj = NULL;
unsigned char *data, *datastart, *dataend;
unsigned char *begin, *cursor;
int i, index, pure = 1, strict = 0, lineLen;
size_t size, count = 0;
unsigned char c;
int ucs4;
enum { OPT_STRICT };
static const char *const optStrings[] = { "-strict", NULL };
if (objc < 2 || objc > 3) {
Tcl_WrongNumArgs(interp, 1, objv, "?options? data");
return TCL_ERROR;
}
for (i = 1; i < objc - 1; ++i) {
if (Tcl_GetIndexFromObj(interp, objv[i], optStrings, "option",
TCL_EXACT, &index) != TCL_OK) {
return TCL_ERROR;
}
switch (index) {
case OPT_STRICT:
strict = 1;
break;
}
}
TclNewObj(resultObj);
data = TclGetBytesFromObj(NULL, objv[objc - 1], &count);
if (data == NULL) {
pure = 0;
data = (unsigned char *) TclGetStringFromObj(objv[objc - 1], &count);
}
datastart = data;
dataend = data + count;
size = ((count + 3) & ~3) * 3 / 4;
begin = cursor = Tcl_SetByteArrayLength(resultObj, size);
lineLen = -1;
/*
* The decoding loop. First, we get the length of line (strictly, the
|
| ︙ | ︙ | |||
2947 2948 2949 2950 2951 2952 2953 |
if (c < 32 || c > 96) {
if (strict || !TclIsSpaceProc(c)) {
goto badUu;
}
i--;
continue;
}
| | | 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 |
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++) {
|
| ︙ | ︙ | |||
2976 2977 2978 2979 2980 2981 2982 |
}
/*
* Translate that grouping into (up to) three binary bytes output.
*/
if (lineLen > 0) {
| | | | | | | | 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 |
}
/*
* Translate that grouping into (up to) three binary bytes output.
*/
if (lineLen > 0) {
*cursor++ = (((d[0] - 0x20) & 0x3F) << 2)
| (((d[1] - 0x20) & 0x3F) >> 4);
if (--lineLen > 0) {
*cursor++ = (((d[1] - 0x20) & 0x3F) << 4)
| (((d[2] - 0x20) & 0x3F) >> 2);
if (--lineLen > 0) {
*cursor++ = (((d[2] - 0x20) & 0x3F) << 6)
| (((d[3] - 0x20) & 0x3F));
lineLen--;
}
}
}
/*
* If we've reached the end of the line, skip until we process a
|
| ︙ | ︙ | |||
3028 3029 3030 3031 3032 3033 3034 3035 |
shortUu:
Tcl_SetObjResult(interp, Tcl_ObjPrintf("short uuencode data"));
Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "SHORT", NULL);
TclDecrRefCount(resultObj);
return TCL_ERROR;
badUu:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
| > > > > > | | | 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 |
shortUu:
Tcl_SetObjResult(interp, Tcl_ObjPrintf("short uuencode data"));
Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "SHORT", NULL);
TclDecrRefCount(resultObj);
return TCL_ERROR;
badUu:
if (pure) {
ucs4 = c;
} else {
TclUtfToUCS4((const char *)(data - 1), &ucs4);
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"invalid uuencode character \"%c\" (U+%06X) at position %"
TCL_Z_MODIFIER "u", ucs4, ucs4, data - datastart - 1));
Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "INVALID", NULL);
TclDecrRefCount(resultObj);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
3063 3064 3065 3066 3067 3068 3069 |
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *resultObj = NULL;
unsigned char *data, *datastart, *dataend, c = '\0';
unsigned char *begin = NULL;
unsigned char *cursor = NULL;
| | | | > > | > | > > | 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 |
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *resultObj = NULL;
unsigned char *data, *datastart, *dataend, c = '\0';
unsigned char *begin = NULL;
unsigned char *cursor = NULL;
int pure = 1, strict = 0;
int i, index, cut = 0;
size_t size, count = 0;
int ucs4;
enum { OPT_STRICT };
static const char *const optStrings[] = { "-strict", NULL };
if (objc < 2 || objc > 3) {
Tcl_WrongNumArgs(interp, 1, objv, "?options? data");
return TCL_ERROR;
}
for (i = 1; i < objc - 1; ++i) {
if (Tcl_GetIndexFromObj(interp, objv[i], optStrings, "option",
TCL_EXACT, &index) != TCL_OK) {
return TCL_ERROR;
}
switch (index) {
case OPT_STRICT:
strict = 1;
break;
}
}
TclNewObj(resultObj);
data = TclGetBytesFromObj(NULL, objv[objc - 1], &count);
if (data == NULL) {
pure = 0;
data = (unsigned char *) TclGetStringFromObj(objv[objc - 1], &count);
}
datastart = data;
dataend = data + count;
size = ((count + 3) & ~3) * 3 / 4;
begin = cursor = Tcl_SetByteArrayLength(resultObj, size);
while (data < dataend) {
unsigned long value = 0;
/*
|
| ︙ | ︙ | |||
3137 3138 3139 3140 3141 3142 3143 |
* input whitespace characters.
*/
if (cut) {
if (c == '=' && i > 1) {
value <<= 6;
cut++;
| | | | | | | | | | | < < < < < > > > > > > > > > > > | | > | 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 |
* input whitespace characters.
*/
if (cut) {
if (c == '=' && i > 1) {
value <<= 6;
cut++;
} else if (!strict) {
i--;
} else {
goto bad64;
}
} else if (c >= 'A' && c <= 'Z') {
value = (value << 6) | ((c - 'A') & 0x3F);
} else if (c >= 'a' && c <= 'z') {
value = (value << 6) | ((c - 'a' + 26) & 0x3F);
} else if (c >= '0' && c <= '9') {
value = (value << 6) | ((c - '0' + 52) & 0x3F);
} else if (c == '+') {
value = (value << 6) | 0x3E;
} else if (c == '/') {
value = (value << 6) | 0x3F;
} else if (c == '=' && (!strict || i > 1)) {
/*
* "=" and "a=" is rather bad64 error case in strict mode.
*/
value <<= 6;
if (i) {
cut++;
}
} else if (strict) {
goto bad64;
} else {
i--;
}
}
*cursor++ = UCHAR((value >> 16) & 0xFF);
*cursor++ = UCHAR((value >> 8) & 0xFF);
*cursor++ = UCHAR(value & 0xFF);
/*
* Since = is only valid within the final block, if it was encountered
* but there are still more input characters, confirm that strict mode
* is off and all subsequent characters are whitespace.
*/
if (cut && data < dataend) {
if (strict) {
goto bad64;
}
}
}
Tcl_SetByteArrayLength(resultObj, cursor - begin - cut);
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
bad64:
if (pure) {
ucs4 = c;
} else {
/* The decoder is byte-oriented. If we saw a byte that's not a
* valid member of the base64 alphabet, it could be the lead byte
* of a multi-byte character. */
/* Safe because we know data is NUL-terminated */
TclUtfToUCS4((const char *)(data - 1), &ucs4);
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"invalid base64 character \"%c\" (U+%06X) at position %"
TCL_Z_MODIFIER "u", ucs4, ucs4, data - datastart - 1));
Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "INVALID", NULL);
TclDecrRefCount(resultObj);
return TCL_ERROR;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclCkalloc.c.
| ︙ | ︙ | |||
16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 | */ #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 | > > | 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 | */ #include "tclInt.h" #define FALSE 0 #define TRUE 1 #undef Tcl_Alloc #undef Tcl_Free #undef Tcl_Realloc #undef Tcl_AttemptAlloc #undef Tcl_AttemptRealloc #ifdef TCL_MEM_DEBUG /* * One of the following structures is allocated each time the |
| ︙ | ︙ | |||
240 241 242 243 244 245 246 |
int byte;
for (idx = 0; idx < LOW_GUARD_SIZE; idx++) {
byte = *(memHeaderP->low_guard + idx);
if (byte != GUARD_VALUE) {
guard_failed = TRUE;
fflush(stdout);
| | | | 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 |
int byte;
for (idx = 0; idx < LOW_GUARD_SIZE; idx++) {
byte = *(memHeaderP->low_guard + idx);
if (byte != GUARD_VALUE) {
guard_failed = TRUE;
fflush(stdout);
byte &= 0xFF;
fprintf(stderr, "low guard byte %" 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);
|
| ︙ | ︙ | |||
686 687 688 689 690 691 692 |
memp = (struct mem_header *) (((size_t) ptr) - BODY_OFFSET);
copySize = size;
if (copySize > memp->length) {
copySize = memp->length;
}
| | | 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 |
memp = (struct mem_header *) (((size_t) ptr) - BODY_OFFSET);
copySize = size;
if (copySize > memp->length) {
copySize = memp->length;
}
newPtr = (char *)Tcl_DbCkalloc(size, file, line);
memcpy(newPtr, ptr, copySize);
Tcl_DbCkfree(ptr, file, line);
return newPtr;
}
void *
Tcl_AttemptDbCkrealloc(
|
| ︙ | ︙ | |||
717 718 719 720 721 722 723 |
memp = (struct mem_header *) (((size_t) ptr) - BODY_OFFSET);
copySize = size;
if (copySize > memp->length) {
copySize = memp->length;
}
| | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
memp = (struct mem_header *) (((size_t) ptr) - BODY_OFFSET);
copySize = size;
if (copySize > memp->length) {
copySize = memp->length;
}
newPtr = (char *)Tcl_AttemptDbCkalloc(size, file, line);
if (newPtr == NULL) {
return NULL;
}
memcpy(newPtr, ptr, copySize);
Tcl_DbCkfree(ptr, file, line);
return newPtr;
}
/*
*----------------------------------------------------------------------
*
* Tcl_Alloc, et al. --
*
* These functions are defined in terms of the debugging versions when
* TCL_MEM_DEBUG is set.
*
* Results:
* Same as the debug versions.
*
* Side effects:
* Same as the debug versions.
*
*----------------------------------------------------------------------
*/
void *
Tcl_Alloc(
size_t size)
{
return Tcl_DbCkalloc(size, "unknown", 0);
}
void *
Tcl_AttemptAlloc(
size_t size)
{
return Tcl_AttemptDbCkalloc(size, "unknown", 0);
}
void
Tcl_Free(
void *ptr)
{
Tcl_DbCkfree(ptr, "unknown", 0);
}
void *
Tcl_Realloc(
void *ptr,
size_t size)
{
return Tcl_DbCkrealloc(ptr, size, "unknown", 0);
}
void *
Tcl_AttemptRealloc(
void *ptr,
size_t size)
{
return Tcl_AttemptDbCkrealloc(ptr, size, "unknown", 0);
}
/*
*----------------------------------------------------------------------
*
* MemoryCmd --
*
* Implements the Tcl "memory" command, which provides Tcl-level control
|
| ︙ | ︙ | |||
751 752 753 754 755 756 757 | * Results: * Standard TCL results. * *---------------------------------------------------------------------- */ static int MemoryCmd( | | | 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 |
* Results:
* Standard TCL results.
*
*----------------------------------------------------------------------
*/
static int
MemoryCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Obj values of arguments. */
{
const char *fileName;
FILE *fileP;
Tcl_DString buffer;
|
| ︙ | ︙ | |||
988 989 990 991 992 993 994 | * * Interface to TclpAlloc when TCL_MEM_DEBUG is disabled. It does check * that memory was actually allocated. * *---------------------------------------------------------------------- */ | < | 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 |
*
* Interface to TclpAlloc when TCL_MEM_DEBUG is disabled. It does check
* that memory was actually allocated.
*
*----------------------------------------------------------------------
*/
void *
Tcl_Alloc(
size_t size)
{
void *result = TclpAlloc(size);
/*
|
| ︙ | ︙ | |||
1065 1066 1067 1068 1069 1070 1071 | * * Interface to TclpRealloc when TCL_MEM_DEBUG is disabled. It does check * that memory was actually allocated. * *---------------------------------------------------------------------- */ | < | 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 |
*
* Interface to TclpRealloc when TCL_MEM_DEBUG is disabled. It does check
* that memory was actually allocated.
*
*----------------------------------------------------------------------
*/
void *
Tcl_Realloc(
void *ptr,
size_t size)
{
void *result = TclpRealloc(ptr, size);
|
| ︙ | ︙ | |||
1137 1138 1139 1140 1141 1142 1143 | * 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. * *---------------------------------------------------------------------- */ | < | 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 |
* Interface to TclpFree when TCL_MEM_DEBUG is disabled. Done here rather
* in the macro to keep some modules from being compiled with
* TCL_MEM_DEBUG enabled and some with it disabled.
*
*----------------------------------------------------------------------
*/
void
Tcl_Free(
void *ptr)
{
TclpFree(ptr);
}
|
| ︙ | ︙ |
Changes to generic/tclCmdIL.c.
| ︙ | ︙ | |||
3305 3306 3307 3308 3309 3310 3311 |
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));
| | | 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 |
if (Tcl_GetWideIntFromObj(interp, objv[i+1], &wide) != TCL_OK) {
result = TCL_ERROR;
goto done;
}
if (wide < 1) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"stride length must be at least 1", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH",
"BADSTRIDE", NULL);
result = TCL_ERROR;
goto done;
}
groupSize = wide;
i++;
break;
|
| ︙ | ︙ | |||
3641 3642 3643 3644 3645 3646 3647 |
}
break;
}
if (match == 0) {
/*
* Normally, binary search is written to stop when it finds a
* match. If there are duplicates of an element in the list,
| | | | 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 3652 3653 3654 3655 3656 3657 3658 3659 |
}
break;
}
if (match == 0) {
/*
* Normally, binary search is written to stop when it finds a
* match. If there are duplicates of an element in the list,
* our first match might not be the first occurrence.
* Consider: 0 0 0 1 1 1 2 2 2
*
* To maintain consistancy with standard lsearch semantics, we
* must find the leftmost occurrence of the pattern in the
* list. Thus we don't just stop searching here. This
* variation means that a search always makes log n
* comparisons (normal binary search might "get lucky" with an
* early comparison).
*
* In bisect mode though, we want the last of equals.
*/
|
| ︙ | ︙ | |||
4700 4701 4702 4703 4704 4705 4706 |
*----------------------------------------------------------------------
*/
static int
DictionaryCompare(
const char *left, const char *right) /* The strings to compare. */
{
| | | 4700 4701 4702 4703 4704 4705 4706 4707 4708 4709 4710 4711 4712 4713 4714 |
*----------------------------------------------------------------------
*/
static int
DictionaryCompare(
const char *left, const char *right) /* The strings to compare. */
{
int uniLeft = 0, uniRight = 0, uniLeftLower, uniRightLower;
int diff, zeros;
int secondaryDiff = 0;
while (1) {
if (isdigit(UCHAR(*right)) /* INTL: digit */
&& isdigit(UCHAR(*left))) { /* INTL: digit */
/*
|
| ︙ | ︙ | |||
4769 4770 4771 4772 4773 4774 4775 |
/*
* Convert character to Unicode for comparison purposes. If either
* string is at the terminating null, do a byte-wise comparison and
* bail out immediately.
*/
if ((*left != '\0') && (*right != '\0')) {
| | | | 4769 4770 4771 4772 4773 4774 4775 4776 4777 4778 4779 4780 4781 4782 4783 4784 |
/*
* Convert character to Unicode for comparison purposes. If either
* string is at the terminating null, do a byte-wise comparison and
* bail out immediately.
*/
if ((*left != '\0') && (*right != '\0')) {
left += TclUtfToUCS4(left, &uniLeft);
right += TclUtfToUCS4(right, &uniRight);
/*
* Convert both chars to lower for the comparison, because
* dictionary sorts are case insensitve. Covert to lower, not
* upper, so chars between Z and a will sort before A (where most
* other interesting punctuations occur).
*/
|
| ︙ | ︙ |
Changes to generic/tclCmdMZ.c.
| ︙ | ︙ | |||
191 192 193 194 195 196 197 |
cflags |= TCL_REG_NLANCH;
break;
case REGEXP_START: {
size_t temp;
if (++i >= objc) {
goto endOfForLoop;
}
| | | 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 |
cflags |= TCL_REG_NLANCH;
break;
case REGEXP_START: {
size_t temp;
if (++i >= objc) {
goto endOfForLoop;
}
if (TclGetIntForIndexM(interp, objv[i], WIDE_MAX - 1, &temp) != TCL_OK) {
goto optionError;
}
if (startIndex) {
Tcl_DecrRefCount(startIndex);
}
startIndex = objv[i];
Tcl_IncrRefCount(startIndex);
|
| ︙ | ︙ | |||
547 548 549 550 551 552 553 |
cflags |= TCL_REG_NLANCH;
break;
case REGSUB_START: {
size_t temp;
if (++idx >= (size_t)objc) {
goto endOfForLoop;
}
| | | 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 |
cflags |= TCL_REG_NLANCH;
break;
case REGSUB_START: {
size_t temp;
if (++idx >= (size_t)objc) {
goto endOfForLoop;
}
if (TclGetIntForIndexM(interp, objv[idx], WIDE_MAX - 1, &temp) != TCL_OK) {
goto optionError;
}
if (startIndex) {
Tcl_DecrRefCount(startIndex);
}
startIndex = objv[idx];
Tcl_IncrRefCount(startIndex);
|
| ︙ | ︙ | |||
1171 1172 1173 1174 1175 1176 1177 |
int
Tcl_SplitObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
| | | 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 |
int
Tcl_SplitObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int ch = 0;
int len;
const char *splitChars;
const char *stringPtr;
const char *end;
size_t splitCharLen, stringLen;
Tcl_Obj *listPtr, *objPtr;
|
| ︙ | ︙ | |||
1214 1215 1216 1217 1218 1219 1220 |
* is a *major* win when splitting on a long string (especially in the
* megabyte range!) - DKF
*/
Tcl_InitHashTable(&charReuseTable, TCL_ONE_WORD_KEYS);
for ( ; stringPtr < end; stringPtr += len) {
| < | < < < < < < < < < < < < < | < | 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 |
* is a *major* win when splitting on a long string (especially in the
* megabyte range!) - DKF
*/
Tcl_InitHashTable(&charReuseTable, TCL_ONE_WORD_KEYS);
for ( ; stringPtr < end; stringPtr += len) {
len = TclUtfToUCS4(stringPtr, &ch);
hPtr = Tcl_CreateHashEntry(&charReuseTable, INT2PTR(ch), &isNew);
if (isNew) {
TclNewStringObj(objPtr, stringPtr, len);
/*
* Don't need to fiddle with refcount...
*/
|
| ︙ | ︙ | |||
1265 1266 1267 1268 1269 1270 1271 |
stringPtr = p + 1;
}
TclNewStringObj(objPtr, stringPtr, end - stringPtr);
Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
} else {
const char *element, *p, *splitEnd;
size_t splitLen;
| | | | | 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 |
stringPtr = p + 1;
}
TclNewStringObj(objPtr, stringPtr, end - stringPtr);
Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
} else {
const char *element, *p, *splitEnd;
size_t splitLen;
int splitChar;
/*
* Normal case: split on any of a given set of characters. Discard
* instances of the split characters.
*/
splitEnd = splitChars + splitCharLen;
for (element = stringPtr; stringPtr < end; stringPtr += len) {
len = TclUtfToUCS4(stringPtr, &ch);
for (p = splitChars; p < splitEnd; p += splitLen) {
splitLen = TclUtfToUCS4(p, &splitChar);
if (ch == splitChar) {
TclNewStringObj(objPtr, element, stringPtr - element);
Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
element = stringPtr + len;
break;
}
}
|
| ︙ | ︙ | |||
1334 1335 1336 1337 1338 1339 1340 |
if (objc == 4) {
size_t end = Tcl_GetCharLength(objv[2]) - 1;
if (TCL_OK != TclGetIntForIndexM(interp, objv[3], end, &start)) {
return TCL_ERROR;
}
}
| | < | 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 |
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, TclStringFirst(objv[1], objv[2], start));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* StringLastCmd --
|
| ︙ | ︙ | |||
1379 1380 1381 1382 1383 1384 1385 |
if (objc == 4) {
size_t end = Tcl_GetCharLength(objv[2]) - 1;
if (TCL_OK != TclGetIntForIndexM(interp, objv[3], end, &last)) {
return TCL_ERROR;
}
}
| | < | 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 |
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, TclStringLast(objv[1], objv[2], last));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* StringIndexCmd --
|
| ︙ | ︙ | |||
1438 1439 1440 1441 1442 1443 1444 |
/*
* If we have a ByteArray object, we're careful to generate a new
* bytearray for a result.
*/
if (TclIsPureByteArray(objv[1])) {
| | | 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 |
/*
* If we have a ByteArray object, we're careful to generate a new
* bytearray for a result.
*/
if (TclIsPureByteArray(objv[1])) {
unsigned char uch = UCHAR(ch);
Tcl_SetObjResult(interp, Tcl_NewByteArrayObj(&uch, 1));
} else {
char buf[4] = "";
end = Tcl_UniCharToUtf(ch, buf);
if ((ch >= 0xD800) && (end < 3)) {
|
| ︙ | ︙ | |||
1537 1538 1539 1540 1541 1542 1543 |
StringIsCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *string1, *end, *stop;
| < | 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 |
StringIsCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *string1, *end, *stop;
int (*chcomp)(int) = NULL; /* The UniChar comparison function. */
int i, result = 1, strict = 0, index, length3;
size_t failat = 0;
size_t length1, length2;
Tcl_Obj *objPtr, *failVarObj = NULL;
Tcl_WideInt w;
|
| ︙ | ︙ | |||
1862 1863 1864 1865 1866 1867 1868 | * 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. */ | | | 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 |
* the number of bytes when parsing strings with non-ASCII
* characters in them.
*
* Skip leading spaces first. This is only really an issue
* if it is the first "element" that has the failure.
*/
while (TclIsSpaceProcM(*p)) {
p++;
}
TclNewStringObj(tmpStr, string1, p-string1);
failat = Tcl_GetCharLength(tmpStr);
TclDecrRefCount(tmpStr);
break;
}
|
| ︙ | ︙ | |||
1907 1908 1909 1910 1911 1912 1913 |
if (strict) {
result = 0;
}
goto str_is_done;
}
end = string1 + length1;
for (; string1 < end; string1 += length2, failat++) {
| | < < < < < < | < > | | 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 |
if (strict) {
result = 0;
}
goto str_is_done;
}
end = string1 + length1;
for (; string1 < end; string1 += length2, failat++) {
int ucs4;
length2 = TclUtfToUCS4(string1, &ucs4);
if (!chcomp(ucs4)) {
result = 0;
break;
}
}
}
/*
|
| ︙ | ︙ | |||
2505 2506 2507 2508 2509 2510 2511 | /* *---------------------------------------------------------------------- * * StringStartCmd -- * * This procedure is invoked to process the "string wordstart" Tcl | | < < | > > > > | > | > > > > > | < | | 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 |
/*
*----------------------------------------------------------------------
*
* StringStartCmd --
*
* This procedure is invoked to process the "string wordstart" Tcl
* command. See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
StringStartCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int ch;
const char *p, *string;
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);
TclUtfToUCS4(p, &ch);
for (cur = index; cur != TCL_INDEX_NONE; cur--) {
int delta = 0;
const char *next;
if (!Tcl_UniCharIsWordChar(ch)) {
break;
}
next = TclUtfPrev(p, string);
do {
next += delta;
delta = TclUtfToUCS4(next, &ch);
} while (next + delta < p);
p = next;
}
if (cur != index) {
cur += 1;
}
}
Tcl_SetObjResult(interp, TclNewWideIntObjFromSize(cur));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* StringEndCmd --
*
* This procedure is invoked to process the "string wordend" Tcl command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
StringEndCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int ch;
const char *p, *end, *string;
size_t length, numChars, cur, index;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "string index");
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
2608 2609 2610 2611 2612 2613 2614 |
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++) {
| | | 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 |
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 += TclUtfToUCS4(p, &ch);
if (!Tcl_UniCharIsWordChar(ch)) {
break;
}
}
if (cur == index) {
cur++;
}
|
| ︙ | ︙ | |||
4335 4336 4337 4338 4339 4340 4341 |
}
if (maxms == 0) {
/*
* Reset last measurement overhead
*/
measureOverhead = 0;
| | | 4318 4319 4320 4321 4322 4323 4324 4325 4326 4327 4328 4329 4330 4331 4332 |
}
if (maxms == 0) {
/*
* Reset last measurement overhead
*/
measureOverhead = 0;
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(0));
return TCL_OK;
}
/*
* If time is negative, make current overhead more precise.
*/
|
| ︙ | ︙ |
Changes to generic/tclCompCmds.c.
| ︙ | ︙ | |||
122 123 124 125 126 127 128 129 130 |
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
Command *cmdPtr, /* Points to defintion of command being
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *varTokenPtr, *valueTokenPtr;
int isScalar, localIndex, numWords, i;
| > < | 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 |
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
Command *cmdPtr, /* Points to defintion of command being
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *varTokenPtr, *valueTokenPtr;
int isScalar, localIndex, numWords, i;
/* TODO: Consider support for compiling expanded args. */
numWords = parsePtr->numWords;
if (numWords == 1) {
return TCL_ERROR;
} else if (numWords == 2) {
/*
|
| ︙ | ︙ | |||
568 569 570 571 572 573 574 575 576 577 |
TclCompileCatchCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
JumpFixup jumpFixup;
Tcl_Token *cmdTokenPtr, *resultNameTokenPtr, *optsNameTokenPtr;
int resultIndex, optsIndex, range, dropScript = 0;
| > < | 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 |
TclCompileCatchCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
JumpFixup jumpFixup;
Tcl_Token *cmdTokenPtr, *resultNameTokenPtr, *optsNameTokenPtr;
int resultIndex, optsIndex, range, dropScript = 0;
int depth = TclGetStackDepth(envPtr);
/*
* If syntax does not match what we expect for [catch], do not compile.
* Let runtime checks determine if syntax has changed.
*/
|
| ︙ | ︙ | |||
1000 1001 1002 1003 1004 1005 1006 1007 1008 |
TclCompileDictSetCmd(
Tcl_Interp *interp, /* Used for looking up stuff. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *tokenPtr;
int i, dictVarIndex;
| > < | 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 |
TclCompileDictSetCmd(
Tcl_Interp *interp, /* Used for looking up stuff. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr;
int i, dictVarIndex;
Tcl_Token *varTokenPtr;
/*
* There must be at least one argument after the command.
*/
if (parsePtr->numWords < 4) {
|
| ︙ | ︙ | |||
1126 1127 1128 1129 1130 1131 1132 1133 1134 |
TclCompileDictGetCmd(
Tcl_Interp *interp, /* Used for looking up stuff. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *tokenPtr;
int i;
| > < | 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 |
TclCompileDictGetCmd(
Tcl_Interp *interp, /* Used for looking up stuff. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr;
int i;
/*
* There must be at least two arguments after the command (the single-arg
* case is legal, but too special and magic for us to deal with here).
*/
/* TODO: Consider support for compiling expanded args. */
|
| ︙ | ︙ | |||
1162 1163 1164 1165 1166 1167 1168 1169 1170 |
TclCompileDictGetWithDefaultCmd(
Tcl_Interp *interp, /* Used for looking up stuff. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *tokenPtr;
int i;
| > < | 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 |
TclCompileDictGetWithDefaultCmd(
Tcl_Interp *interp, /* Used for looking up stuff. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr;
int i;
/*
* There must be at least three arguments after the command.
*/
/* TODO: Consider support for compiling expanded args. */
if (parsePtr->numWords < 4) {
|
| ︙ | ︙ | |||
1193 1194 1195 1196 1197 1198 1199 1200 1201 |
TclCompileDictExistsCmd(
Tcl_Interp *interp, /* Used for looking up stuff. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *tokenPtr;
int i;
| > < | 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 |
TclCompileDictExistsCmd(
Tcl_Interp *interp, /* Used for looking up stuff. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr;
int i;
/*
* There must be at least two arguments after the command (the single-arg
* case is legal, but too special and magic for us to deal with here).
*/
/* TODO: Consider support for compiling expanded args. */
|
| ︙ | ︙ | |||
1230 1231 1232 1233 1234 1235 1236 |
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. */
{
| < > | 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 |
Tcl_Interp *interp, /* Used for looking up stuff. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
Command *cmdPtr, /* Points to defintion of command being
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr;
int i, dictVarIndex;
/*
* There must be at least one argument after the variable name for us to
* compile to bytecode.
*/
|
| ︙ | ︙ | |||
2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 |
TclCompileErrorCmd(
Tcl_Interp *interp, /* Used for context. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
/*
* General syntax: [error message ?errorInfo? ?errorCode?]
*/
| > > > < < < | 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 |
TclCompileErrorCmd(
Tcl_Interp *interp, /* Used for context. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr;
/*
* General syntax: [error message ?errorInfo? ?errorCode?]
*/
if (parsePtr->numWords < 2 || parsePtr->numWords > 4) {
return TCL_ERROR;
}
/*
* Handle the message.
*/
|
| ︙ | ︙ | |||
2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 |
TclCompileForCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *startTokenPtr, *testTokenPtr, *nextTokenPtr, *bodyTokenPtr;
JumpFixup jumpEvalCondFixup;
int bodyCodeOffset, nextCodeOffset, jumpDist;
int bodyRange, nextRange;
| > < | 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 |
TclCompileForCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *startTokenPtr, *testTokenPtr, *nextTokenPtr, *bodyTokenPtr;
JumpFixup jumpEvalCondFixup;
int bodyCodeOffset, nextCodeOffset, jumpDist;
int bodyRange, nextRange;
if (parsePtr->numWords != 5) {
return TCL_ERROR;
}
/*
* If the test expression requires substitutions, don't compile the for
|
| ︙ | ︙ | |||
2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 |
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr, /* Holds resulting instructions. */
int collect) /* Select collecting or accumulating mode
* (TCL_EACH_*) */
{
Proc *procPtr = envPtr->procPtr;
ForeachInfo *infoPtr=NULL; /* Points to the structure describing this
* foreach command. Stored in a AuxData
* record in the ByteCode. */
Tcl_Token *tokenPtr, *bodyTokenPtr;
int jumpBackOffset, infoIndex, range;
int numWords, numLists, i, j, code = TCL_OK;
Tcl_Obj *varListObj = NULL;
| > < | 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 |
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr, /* Holds resulting instructions. */
int collect) /* Select collecting or accumulating mode
* (TCL_EACH_*) */
{
DefineLineInformation; /* TIP #280 */
Proc *procPtr = envPtr->procPtr;
ForeachInfo *infoPtr=NULL; /* Points to the structure describing this
* foreach command. Stored in a AuxData
* record in the ByteCode. */
Tcl_Token *tokenPtr, *bodyTokenPtr;
int jumpBackOffset, infoIndex, range;
int numWords, numLists, i, j, code = TCL_OK;
Tcl_Obj *varListObj = NULL;
/*
* If the foreach command isn't in a procedure, don't compile it inline:
* the payoff is too small.
*/
if (procPtr == NULL) {
|
| ︙ | ︙ | |||
3449 3450 3451 3452 3453 3454 3455 |
name = varTokenPtr[1].start;
nameLen = varTokenPtr[1].size;
if (name[nameLen-1] == ')') {
/*
* last char is ')' => potential array reference.
*/
| | | | 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 |
name = varTokenPtr[1].start;
nameLen = varTokenPtr[1].size;
if (name[nameLen-1] == ')') {
/*
* last char is ')' => potential array reference.
*/
last = &name[nameLen-1];
if (*last == ')') {
for (p = name; p < last; p++) {
if (*p == '(') {
elName = p + 1;
elNameLen = last - elName;
nameLen = p - name;
break;
}
}
|
| ︙ | ︙ | |||
3480 3481 3482 3483 3484 3485 3486 |
elemTokenPtr->numComponents = 0;
elemTokenCount = 1;
}
}
} else if (interp && ((n = varTokenPtr->numComponents) > 1)
&& (varTokenPtr[1].type == TCL_TOKEN_TEXT)
&& (varTokenPtr[n].type == TCL_TOKEN_TEXT)
| | < | | 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 |
elemTokenPtr->numComponents = 0;
elemTokenCount = 1;
}
}
} else if (interp && ((n = varTokenPtr->numComponents) > 1)
&& (varTokenPtr[1].type == TCL_TOKEN_TEXT)
&& (varTokenPtr[n].type == TCL_TOKEN_TEXT)
&& (*(varTokenPtr[n].start + varTokenPtr[n].size - 1) == ')')) {
/*
* Check for parentheses inside first token.
*/
simpleVarName = 0;
for (p = varTokenPtr[1].start,
last = p + varTokenPtr[1].size; p < last; p++) {
if (*p == '(') {
simpleVarName = 1;
break;
}
}
if (simpleVarName) {
size_t remainingLen;
|
| ︙ | ︙ | |||
3556 3557 3558 3559 3560 3561 3562 |
if (simpleVarName) {
/*
* See whether name has any namespace separators (::'s).
*/
int hasNsQualifiers = 0;
| | | 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 |
if (simpleVarName) {
/*
* See whether name has any namespace separators (::'s).
*/
int hasNsQualifiers = 0;
for (p = name, last = p + nameLen-1; p < last; p++) {
if ((*p == ':') && (*(p+1) == ':')) {
hasNsQualifiers = 1;
break;
}
}
/*
|
| ︙ | ︙ |
Changes to generic/tclCompCmdsGR.c.
| ︙ | ︙ | |||
85 86 87 88 89 90 91 92 93 |
TclCompileGlobalCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *varTokenPtr;
int localIndex, numWords, i;
| > < | 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 |
TclCompileGlobalCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *varTokenPtr;
int localIndex, numWords, i;
/* TODO: Consider support for compiling expanded args. */
numWords = parsePtr->numWords;
if (numWords < 2) {
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 |
TclCompileIfCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
JumpFixupArray jumpFalseFixupArray;
/* Used to fix the ifFalse jump after each
* test when its target PC is determined. */
JumpFixupArray jumpEndFixupArray;
/* Used to fix the jump after each "then" body
* to the end of the "if" when that PC is
* determined. */
Tcl_Token *tokenPtr, *testTokenPtr;
int jumpIndex = 0; /* Avoid compiler warning. */
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;
| > < | 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 |
TclCompileIfCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
JumpFixupArray jumpFalseFixupArray;
/* Used to fix the ifFalse jump after each
* test when its target PC is determined. */
JumpFixupArray jumpEndFixupArray;
/* Used to fix the jump after each "then" body
* to the end of the "if" when that PC is
* determined. */
Tcl_Token *tokenPtr, *testTokenPtr;
int jumpIndex = 0; /* Avoid compiler warning. */
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;
/*
* Only compile the "if" command if all arguments are simple words, in
* order to insure correct substitution [Bug 219166]
*/
tokenPtr = parsePtr->tokenPtr;
|
| ︙ | ︙ | |||
469 470 471 472 473 474 475 476 477 |
TclCompileIncrCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *varTokenPtr, *incrTokenPtr;
int isScalar, localIndex, haveImmValue, immValue;
| > < | 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 |
TclCompileIncrCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *varTokenPtr, *incrTokenPtr;
int isScalar, localIndex, haveImmValue, immValue;
if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) {
return TCL_ERROR;
}
varTokenPtr = TokenAfter(parsePtr->tokenPtr);
|
| ︙ | ︙ | |||
664 665 666 667 668 669 670 671 672 |
TclCompileInfoExistsCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *tokenPtr;
int isScalar, localIndex;
| > < | 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 |
TclCompileInfoExistsCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr;
int isScalar, localIndex;
if (parsePtr->numWords != 2) {
return TCL_ERROR;
}
/*
* Decide if we can use a frame slot for the var/array name or if we need
|
| ︙ | ︙ | |||
837 838 839 840 841 842 843 844 845 |
TclCompileLappendCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *varTokenPtr, *valueTokenPtr;
int isScalar, localIndex, numWords, i;
| > < | 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 |
TclCompileLappendCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *varTokenPtr, *valueTokenPtr;
int isScalar, localIndex, numWords, i;
/* TODO: Consider support for compiling expanded args. */
numWords = parsePtr->numWords;
if (numWords < 3) {
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
952 953 954 955 956 957 958 959 960 |
TclCompileLassignCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *tokenPtr;
int isScalar, localIndex, numWords, idx;
| > < | 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 |
TclCompileLassignCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr;
int isScalar, localIndex, numWords, idx;
numWords = parsePtr->numWords;
/*
* Check for command syntax error, but we'll punt that to runtime.
*/
|
| ︙ | ︙ | |||
1055 1056 1057 1058 1059 1060 1061 1062 1063 |
TclCompileLindexCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *idxTokenPtr, *valTokenPtr;
int i, idx, numWords = parsePtr->numWords;
| > < | 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 |
TclCompileLindexCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *idxTokenPtr, *valTokenPtr;
int i, idx, numWords = parsePtr->numWords;
/*
* Quit if too few args.
*/
/* TODO: Consider support for compiling expanded args. */
if (numWords <= 1) {
|
| ︙ | ︙ | |||
1258 1259 1260 1261 1262 1263 1264 |
TclCompileLlengthCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
| < > | 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 |
TclCompileLlengthCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *varTokenPtr;
if (parsePtr->numWords != 2) {
return TCL_ERROR;
}
varTokenPtr = TokenAfter(parsePtr->tokenPtr);
CompileWord(envPtr, varTokenPtr, interp, 1);
|
| ︙ | ︙ | |||
1290 1291 1292 1293 1294 1295 1296 |
TclCompileLrangeCmd(
Tcl_Interp *interp, /* Tcl interpreter for context. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the
* command. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds the resulting instructions. */
{
| < > | 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 |
TclCompileLrangeCmd(
Tcl_Interp *interp, /* Tcl interpreter for context. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the
* command. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds the resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr, *listTokenPtr;
int idx1, idx2;
if (parsePtr->numWords != 4) {
return TCL_ERROR;
}
listTokenPtr = TokenAfter(parsePtr->tokenPtr);
|
| ︙ | ︙ | |||
1350 1351 1352 1353 1354 1355 1356 |
TclCompileLinsertCmd(
Tcl_Interp *interp, /* Tcl interpreter for context. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the
* command. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds the resulting instructions. */
{
| < > | 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 |
TclCompileLinsertCmd(
Tcl_Interp *interp, /* Tcl interpreter for context. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the
* command. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds the resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr, *listTokenPtr;
int idx, i;
if (parsePtr->numWords < 3) {
return TCL_ERROR;
}
listTokenPtr = TokenAfter(parsePtr->tokenPtr);
|
| ︙ | ︙ | |||
1452 1453 1454 1455 1456 1457 1458 |
TclCompileLreplaceCmd(
Tcl_Interp *interp, /* Tcl interpreter for context. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the
* command. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds the resulting instructions. */
{
| < > | 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 |
TclCompileLreplaceCmd(
Tcl_Interp *interp, /* Tcl interpreter for context. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the
* command. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds the resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr, *listTokenPtr;
int idx1, idx2, i;
int emptyPrefix=1, suffixStart = 0;
if (parsePtr->numWords < 4) {
return TCL_ERROR;
}
listTokenPtr = TokenAfter(parsePtr->tokenPtr);
|
| ︙ | ︙ | |||
1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 |
TclCompileLsetCmd(
Tcl_Interp *interp, /* Tcl interpreter for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the
* command. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds the resulting instructions. */
{
int tempDepth; /* Depth used for emitting one part of the
* code burst. */
Tcl_Token *varTokenPtr; /* Pointer to the Tcl_Token representing the
* parse of the variable name. */
int localIndex; /* Index of var in local var table. */
int isScalar; /* Flag == 1 if scalar, 0 if array. */
int i;
| > < | 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 |
TclCompileLsetCmd(
Tcl_Interp *interp, /* Tcl interpreter for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the
* command. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds the resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
int tempDepth; /* Depth used for emitting one part of the
* code burst. */
Tcl_Token *varTokenPtr; /* Pointer to the Tcl_Token representing the
* parse of the variable name. */
int localIndex; /* Index of var in local var table. */
int isScalar; /* Flag == 1 if scalar, 0 if array. */
int i;
/*
* Check argument count.
*/
/* TODO: Consider support for compiling expanded args. */
if (parsePtr->numWords < 3) {
|
| ︙ | ︙ | |||
1785 1786 1787 1788 1789 1790 1791 |
TclCompileNamespaceCodeCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
| < > | 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 |
TclCompileNamespaceCodeCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr;
if (parsePtr->numWords != 2) {
return TCL_ERROR;
}
tokenPtr = TokenAfter(parsePtr->tokenPtr);
/*
|
| ︙ | ︙ | |||
1834 1835 1836 1837 1838 1839 1840 |
TclCompileNamespaceOriginCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
| < > < > | 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 |
TclCompileNamespaceOriginCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr;
if (parsePtr->numWords != 2) {
return TCL_ERROR;
}
tokenPtr = TokenAfter(parsePtr->tokenPtr);
CompileWord(envPtr, tokenPtr, interp, 1);
TclEmitOpcode( INST_ORIGIN_COMMAND, envPtr);
return TCL_OK;
}
int
TclCompileNamespaceQualifiersCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
int off;
if (parsePtr->numWords != 2) {
return TCL_ERROR;
}
CompileWord(envPtr, tokenPtr, interp, 1);
|
| ︙ | ︙ | |||
1890 1891 1892 1893 1894 1895 1896 |
TclCompileNamespaceTailCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
| < > | 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 |
TclCompileNamespaceTailCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
JumpFixup jumpFixup;
if (parsePtr->numWords != 2) {
return TCL_ERROR;
}
/*
|
| ︙ | ︙ | |||
1926 1927 1928 1929 1930 1931 1932 1933 1934 |
TclCompileNamespaceUpvarCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *tokenPtr, *otherTokenPtr, *localTokenPtr;
int localIndex, numWords, i;
| > < | 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 |
TclCompileNamespaceUpvarCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr, *otherTokenPtr, *localTokenPtr;
int localIndex, numWords, i;
if (envPtr->procPtr == NULL) {
return TCL_ERROR;
}
/*
* Only compile [namespace upvar ...]: needs an even number of args, >=4
|
| ︙ | ︙ | |||
2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 |
TclCompileRegexpCmd(
Tcl_Interp *interp, /* Tcl interpreter for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the
* command. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds the resulting instructions. */
{
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;
| > < | 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 |
TclCompileRegexpCmd(
Tcl_Interp *interp, /* Tcl interpreter for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the
* command. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds the resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *varTokenPtr; /* Pointer to the Tcl_Token representing the
* parse of the RE or string. */
size_t len;
int i, nocase, exact, sawLast, simple;
const char *str;
/*
* We are only interested in compiling simple regexp cases. Currently
* supported compile cases are:
* regexp ?-nocase? ?--? staticString $var
* regexp ?-nocase? ?--? {^staticString$} $var
*/
|
| ︙ | ︙ | |||
2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 |
TclCompileReturnCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
/*
* General syntax: [return ?-option value ...? ?result?]
* An even number of words means an explicit result argument is present.
*/
int level, code, objc, size, status = TCL_OK;
int numWords = parsePtr->numWords;
int explicitResult = (0 == (numWords % 2));
int numOptionWords = numWords - 1 - explicitResult;
Tcl_Obj *returnOpts, **objv;
Tcl_Token *wordTokenPtr = TokenAfter(parsePtr->tokenPtr);
| > < | 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 |
TclCompileReturnCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
/*
* General syntax: [return ?-option value ...? ?result?]
* An even number of words means an explicit result argument is present.
*/
int level, code, objc, size, status = TCL_OK;
int numWords = parsePtr->numWords;
int explicitResult = (0 == (numWords % 2));
int numOptionWords = numWords - 1 - explicitResult;
Tcl_Obj *returnOpts, **objv;
Tcl_Token *wordTokenPtr = TokenAfter(parsePtr->tokenPtr);
/*
* Check for special case which can always be compiled:
* return -options <opts> <msg>
* Unlike the normal [return] compilation, this version does everything at
* runtime so it can handle arbitrary words and not just literals. Note
* that if INST_RETURN_STK wasn't already needed for something else
|
| ︙ | ︙ | |||
2640 2641 2642 2643 2644 2645 2646 2647 2648 |
TclCompileUpvarCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *tokenPtr, *otherTokenPtr, *localTokenPtr;
int localIndex, numWords, i;
| > < | 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 |
TclCompileUpvarCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr, *otherTokenPtr, *localTokenPtr;
int localIndex, numWords, i;
Tcl_Obj *objPtr;
if (envPtr->procPtr == NULL) {
return TCL_ERROR;
}
numWords = parsePtr->numWords;
|
| ︙ | ︙ | |||
2746 2747 2748 2749 2750 2751 2752 2753 2754 |
TclCompileVariableCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *varTokenPtr, *valueTokenPtr;
int localIndex, numWords, i;
| > < | 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 |
TclCompileVariableCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *varTokenPtr, *valueTokenPtr;
int localIndex, numWords, i;
numWords = parsePtr->numWords;
if (numWords < 2) {
return TCL_ERROR;
}
/*
|
| ︙ | ︙ |
Changes to generic/tclCompCmdsSZ.c.
| ︙ | ︙ | |||
125 126 127 128 129 130 131 132 133 |
TclCompileSetCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *varTokenPtr, *valueTokenPtr;
int isAssignment, isScalar, localIndex, numWords;
| > < | 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 |
TclCompileSetCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *varTokenPtr, *valueTokenPtr;
int isAssignment, isScalar, localIndex, numWords;
numWords = parsePtr->numWords;
if ((numWords != 2) && (numWords != 3)) {
return TCL_ERROR;
}
isAssignment = (numWords == 3);
|
| ︙ | ︙ | |||
218 219 220 221 222 223 224 225 226 227 |
TclCompileStringCatCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
int i, numWords = parsePtr->numWords, numArgs;
Tcl_Token *wordTokenPtr;
Tcl_Obj *obj, *folded;
| > < | 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 |
TclCompileStringCatCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
int i, numWords = parsePtr->numWords, numArgs;
Tcl_Token *wordTokenPtr;
Tcl_Obj *obj, *folded;
/* Trivial case, no arg */
if (numWords<2) {
PushStringLiteral(envPtr, "");
return TCL_OK;
}
|
| ︙ | ︙ | |||
440 441 442 443 444 445 446 |
TclCompileStringInsertCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
| < > | 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 |
TclCompileStringInsertCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr;
int idx;
if (parsePtr->numWords != 4) {
return TCL_ERROR;
}
/* Compute and push the string in which to insert */
|
| ︙ | ︙ | |||
1044 1045 1046 1047 1048 1049 1050 |
TclCompileStringReplaceCmd(
Tcl_Interp *interp, /* Tcl interpreter for context. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the
* command. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds the resulting instructions. */
{
| < > | 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 |
TclCompileStringReplaceCmd(
Tcl_Interp *interp, /* Tcl interpreter for context. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the
* command. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds the resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr, *valueTokenPtr;
int first, last;
if (parsePtr->numWords < 4 || parsePtr->numWords > 5) {
return TCL_ERROR;
}
/* Bytecode to compute/push string argument being replaced */
|
| ︙ | ︙ | |||
1413 1414 1415 1416 1417 1418 1419 |
{"lower", Tcl_UniCharIsLower},
{"print", Tcl_UniCharIsPrint},
{"punct", Tcl_UniCharIsPunct},
{"space", Tcl_UniCharIsSpace},
{"upper", Tcl_UniCharIsUpper},
{"word", Tcl_UniCharIsWordChar},
{"xdigit", UniCharIsHexDigit},
| | | 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 |
{"lower", Tcl_UniCharIsLower},
{"print", Tcl_UniCharIsPrint},
{"punct", Tcl_UniCharIsPunct},
{"space", Tcl_UniCharIsSpace},
{"upper", Tcl_UniCharIsUpper},
{"word", Tcl_UniCharIsWordChar},
{"xdigit", UniCharIsHexDigit},
{"", NULL}
};
/*
*----------------------------------------------------------------------
*
* TclCompileSubstCmd --
*
|
| ︙ | ︙ | |||
1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 |
TclCompileSubstCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
int numArgs = parsePtr->numWords - 1;
int numOpts = numArgs - 1;
int objc, flags = TCL_SUBST_ALL;
Tcl_Obj **objv/*, *toSubst = NULL*/;
Tcl_Token *wordTokenPtr = TokenAfter(parsePtr->tokenPtr);
int code = TCL_ERROR;
| > < | 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 |
TclCompileSubstCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
int numArgs = parsePtr->numWords - 1;
int numOpts = numArgs - 1;
int objc, flags = TCL_SUBST_ALL;
Tcl_Obj **objv/*, *toSubst = NULL*/;
Tcl_Token *wordTokenPtr = TokenAfter(parsePtr->tokenPtr);
int code = TCL_ERROR;
if (numArgs == 0) {
return TCL_ERROR;
}
objv = (Tcl_Obj **)TclStackAlloc(interp, /*numArgs*/ numOpts * sizeof(Tcl_Obj *));
|
| ︙ | ︙ | |||
1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 |
TclCompileSwitchCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *tokenPtr; /* Pointer to tokens in command. */
int numWords; /* Number of words in command. */
Tcl_Token *valueTokenPtr; /* Token for the value to switch on. */
enum {Switch_Exact, Switch_Glob, Switch_Regexp} mode;
/* What kind of switch are we doing? */
Tcl_Token *bodyTokenArray; /* Array of real pattern list items. */
Tcl_Token **bodyToken; /* Array of pointers to pattern list items. */
int *bodyLines; /* Array of line numbers for body list
* items. */
int **bodyContLines; /* Array of continuation line info. */
int noCase; /* Has the -nocase flag been given? */
int foundMode = 0; /* Have we seen a mode flag yet? */
int i, valueIndex;
int result = TCL_ERROR;
| > < | 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 |
TclCompileSwitchCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr; /* Pointer to tokens in command. */
int numWords; /* Number of words in command. */
Tcl_Token *valueTokenPtr; /* Token for the value to switch on. */
enum {Switch_Exact, Switch_Glob, Switch_Regexp} mode;
/* What kind of switch are we doing? */
Tcl_Token *bodyTokenArray; /* Array of real pattern list items. */
Tcl_Token **bodyToken; /* Array of pointers to pattern list items. */
int *bodyLines; /* Array of line numbers for body list
* items. */
int **bodyContLines; /* Array of continuation line info. */
int noCase; /* Has the -nocase flag been given? */
int foundMode = 0; /* Have we seen a mode flag yet? */
int i, valueIndex;
int result = TCL_ERROR;
int *clNext = envPtr->clNext;
/*
* Only handle the following versions:
* switch ?--? word {pattern body ...}
* switch -exact ?--? word {pattern body ...}
* switch -glob ?--? word {pattern body ...}
|
| ︙ | ︙ | |||
3612 3613 3614 3615 3616 3617 3618 3619 3620 |
TclCompileUnsetCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *varTokenPtr;
int isScalar, localIndex, flags = 1, i, varCount = 0, haveFlags = 0;
| > < | 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 |
TclCompileUnsetCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *varTokenPtr;
int isScalar, localIndex, flags = 1, i, varCount = 0, haveFlags = 0;
/* TODO: Consider support for compiling expanded args. */
/*
* Verify that all words - except the first non-option one - are known at
* compile time so that we can handle them without needing to do a nasty
* push/rotate. [Bug 3970f54c4e]
|
| ︙ | ︙ | |||
3749 3750 3751 3752 3753 3754 3755 3756 3757 3758 3759 3760 3761 |
TclCompileWhileCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *testTokenPtr, *bodyTokenPtr;
JumpFixup jumpEvalCondFixup;
int testCodeOffset, bodyCodeOffset, jumpDist, range, code, boolVal;
int loopMayEnd = 1; /* This is set to 0 if it is recognized as an
* infinite loop. */
Tcl_Obj *boolObj;
| > < | 3749 3750 3751 3752 3753 3754 3755 3756 3757 3758 3759 3760 3761 3762 3763 3764 3765 3766 3767 3768 3769 |
TclCompileWhileCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *testTokenPtr, *bodyTokenPtr;
JumpFixup jumpEvalCondFixup;
int testCodeOffset, bodyCodeOffset, jumpDist, range, code, boolVal;
int loopMayEnd = 1; /* This is set to 0 if it is recognized as an
* infinite loop. */
Tcl_Obj *boolObj;
if (parsePtr->numWords != 3) {
return TCL_ERROR;
}
/*
* If the test expression requires substitutions, don't compile the while
|
| ︙ | ︙ | |||
4011 4012 4013 4014 4015 4016 4017 |
static int
CompileUnaryOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
int instruction,
CompileEnv *envPtr)
{
| < > | 4011 4012 4013 4014 4015 4016 4017 4018 4019 4020 4021 4022 4023 4024 4025 4026 |
static int
CompileUnaryOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
int instruction,
CompileEnv *envPtr)
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr;
if (parsePtr->numWords != 2) {
return TCL_ERROR;
}
tokenPtr = TokenAfter(parsePtr->tokenPtr);
CompileWord(envPtr, tokenPtr, interp, 1);
TclEmitOpcode(instruction, envPtr);
|
| ︙ | ︙ | |||
4053 4054 4055 4056 4057 4058 4059 |
CompileAssociativeBinaryOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
const char *identity,
int instruction,
CompileEnv *envPtr)
{
| < > | 4053 4054 4055 4056 4057 4058 4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 |
CompileAssociativeBinaryOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
const char *identity,
int instruction,
CompileEnv *envPtr)
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr = parsePtr->tokenPtr;
int words;
/* TODO: Consider support for compiling expanded args. */
for (words=1 ; words<parsePtr->numWords ; words++) {
tokenPtr = TokenAfter(tokenPtr);
CompileWord(envPtr, tokenPtr, interp, words);
}
|
| ︙ | ︙ | |||
4138 4139 4140 4141 4142 4143 4144 |
static int
CompileComparisonOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
int instruction,
CompileEnv *envPtr)
{
| < > | 4138 4139 4140 4141 4142 4143 4144 4145 4146 4147 4148 4149 4150 4151 4152 4153 |
static int
CompileComparisonOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
int instruction,
CompileEnv *envPtr)
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr;
/* TODO: Consider support for compiling expanded args. */
if (parsePtr->numWords < 3) {
PUSH("1");
} else if (parsePtr->numWords == 3) {
tokenPtr = TokenAfter(parsePtr->tokenPtr);
CompileWord(envPtr, tokenPtr, interp, 1);
|
| ︙ | ︙ | |||
4292 4293 4294 4295 4296 4297 4298 4299 4300 4301 4302 4303 |
int
TclCompilePowOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
/*
* This one has its own implementation because the ** operator is the only
* one with right associativity.
*/
| > > > > < < < < | 4292 4293 4294 4295 4296 4297 4298 4299 4300 4301 4302 4303 4304 4305 4306 4307 4308 4309 4310 4311 4312 4313 4314 |
int
TclCompilePowOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr = parsePtr->tokenPtr;
int words;
/*
* This one has its own implementation because the ** operator is the only
* one with right associativity.
*/
for (words=1 ; words<parsePtr->numWords ; words++) {
tokenPtr = TokenAfter(tokenPtr);
CompileWord(envPtr, tokenPtr, interp, words);
}
if (parsePtr->numWords <= 2) {
PUSH("1");
words++;
|
| ︙ | ︙ | |||
4493 4494 4495 4496 4497 4498 4499 |
int
TclCompileMinusOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
| < > | 4493 4494 4495 4496 4497 4498 4499 4500 4501 4502 4503 4504 4505 4506 4507 4508 |
int
TclCompileMinusOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr = parsePtr->tokenPtr;
int words;
/* TODO: Consider support for compiling expanded args. */
if (parsePtr->numWords == 1) {
/*
* Fallback to direct eval to report syntax error.
*/
|
| ︙ | ︙ | |||
4538 4539 4540 4541 4542 4543 4544 |
int
TclCompileDivOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
| < > | 4538 4539 4540 4541 4542 4543 4544 4545 4546 4547 4548 4549 4550 4551 4552 4553 |
int
TclCompileDivOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr = parsePtr->tokenPtr;
int words;
/* TODO: Consider support for compiling expanded args. */
if (parsePtr->numWords == 1) {
/*
* Fallback to direct eval to report syntax error.
*/
|
| ︙ | ︙ |
Changes to generic/tclCompExpr.c.
| ︙ | ︙ | |||
1837 1838 1839 1840 1841 1842 1843 |
int code;
OpNode *opTree = NULL; /* Will point to the tree of operators. */
Tcl_Obj *litList = Tcl_NewObj(); /* List to hold the literals. */
Tcl_Obj *funcList = Tcl_NewObj(); /* List to hold the functon names. */
Tcl_Parse *exprParsePtr = (Tcl_Parse *)TclStackAlloc(interp, sizeof(Tcl_Parse));
/* Holds the Tcl_Tokens of substitutions. */
| | | 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 |
int code;
OpNode *opTree = NULL; /* Will point to the tree of operators. */
Tcl_Obj *litList = Tcl_NewObj(); /* List to hold the literals. */
Tcl_Obj *funcList = Tcl_NewObj(); /* List to hold the functon names. */
Tcl_Parse *exprParsePtr = (Tcl_Parse *)TclStackAlloc(interp, sizeof(Tcl_Parse));
/* Holds the Tcl_Tokens of substitutions. */
if (numBytes == TCL_INDEX_NONE) {
numBytes = (start ? strlen(start) : 0);
}
code = ParseExpr(interp, start, numBytes, &opTree, litList, funcList,
exprParsePtr, 1 /* parseOnly */);
Tcl_DecrRefCount(funcList);
Tcl_DecrRefCount(litList);
|
| ︙ | ︙ | |||
2721 2722 2723 2724 2725 2726 2727 |
if (objc == 2) {
Tcl_Obj *litObjv[2];
OpNode nodes[2];
int decrMe = 0;
Tcl_Obj *const *litObjPtrPtr = litObjv;
if (lexeme == EXPON) {
| | | | 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 |
if (objc == 2) {
Tcl_Obj *litObjv[2];
OpNode nodes[2];
int decrMe = 0;
Tcl_Obj *const *litObjPtrPtr = litObjv;
if (lexeme == EXPON) {
TclNewIntObj(litObjv[1], occdPtr->i.identity);
Tcl_IncrRefCount(litObjv[1]);
decrMe = 1;
litObjv[0] = objv[1];
nodes[0].lexeme = START;
nodes[0].mark = MARK_RIGHT;
nodes[0].right = 1;
nodes[1].lexeme = lexeme;
nodes[1].mark = MARK_LEFT;
nodes[1].left = OT_LITERAL;
nodes[1].right = OT_LITERAL;
nodes[1].p.parent = 0;
} else {
if (lexeme == DIVIDE) {
litObjv[0] = Tcl_NewDoubleObj(1.0);
} else {
TclNewIntObj(litObjv[0], occdPtr->i.identity);
}
Tcl_IncrRefCount(litObjv[0]);
litObjv[1] = objv[1];
nodes[0].lexeme = START;
nodes[0].mark = MARK_RIGHT;
nodes[0].right = 1;
nodes[1].lexeme = lexeme;
|
| ︙ | ︙ |
Changes to generic/tclCompile.c.
| ︙ | ︙ | |||
1825 1826 1827 1828 1829 1830 1831 1832 1833 |
TclCompileInvocation(
Tcl_Interp *interp,
Tcl_Token *tokenPtr,
Tcl_Obj *cmdObj,
size_t numWords,
CompileEnv *envPtr)
{
size_t wordIdx = 0;
int depth = TclGetStackDepth(envPtr);
| > < | 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 |
TclCompileInvocation(
Tcl_Interp *interp,
Tcl_Token *tokenPtr,
Tcl_Obj *cmdObj,
size_t numWords,
CompileEnv *envPtr)
{
DefineLineInformation;
size_t wordIdx = 0;
int depth = TclGetStackDepth(envPtr);
if (cmdObj) {
CompileCmdLiteral(interp, cmdObj, envPtr);
wordIdx = 1;
tokenPtr = TokenAfter(tokenPtr);
}
|
| ︙ | ︙ | |||
1870 1871 1872 1873 1874 1875 1876 |
CompileExpanded(
Tcl_Interp *interp,
Tcl_Token *tokenPtr,
Tcl_Obj *cmdObj,
int numWords,
CompileEnv *envPtr)
{
| < > | 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 |
CompileExpanded(
Tcl_Interp *interp,
Tcl_Token *tokenPtr,
Tcl_Obj *cmdObj,
int numWords,
CompileEnv *envPtr)
{
DefineLineInformation;
int wordIdx = 0;
int depth = TclGetStackDepth(envPtr);
StartExpanding(envPtr);
if (cmdObj) {
CompileCmdLiteral(interp, cmdObj, envPtr);
wordIdx = 1;
tokenPtr = TokenAfter(tokenPtr);
|
| ︙ | ︙ | |||
1929 1930 1931 1932 1933 1934 1935 |
static int
CompileCmdCompileProc(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
Command *cmdPtr,
CompileEnv *envPtr)
{
| < > | 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 |
static int
CompileCmdCompileProc(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
Command *cmdPtr,
CompileEnv *envPtr)
{
DefineLineInformation;
int unwind = 0, incrOffset = -1;
int depth = TclGetStackDepth(envPtr);
/*
* Emit of the INST_START_CMD instruction is controlled by the value of
* envPtr->atCmdStart:
*
* atCmdStart == 2 : We are not using the INST_START_CMD instruction.
|
| ︙ | ︙ |
Changes to generic/tclCompile.h.
| ︙ | ︙ | |||
901 902 903 904 905 906 907 |
STR_CLASS_WORD, /* Unicode word (alphabetic, digit, connector
* punctuation) characters. */
STR_CLASS_XDIGIT /* Characters that can be used as digits in
* hexadecimal numbers ([0-9A-Fa-f]). */
} InstStringClassType;
typedef struct StringClassDesc {
| | | 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 |
STR_CLASS_WORD, /* Unicode word (alphabetic, digit, connector
* punctuation) characters. */
STR_CLASS_XDIGIT /* Characters that can be used as digits in
* hexadecimal numbers ([0-9A-Fa-f]). */
} InstStringClassType;
typedef struct StringClassDesc {
char name[8]; /* Name of the class. */
int (*comparator)(int); /* Function to test if a single unicode
* character is a member of the class. */
} StringClassDesc;
MODULE_SCOPE StringClassDesc const tclStringClassTable[];
/*
|
| ︙ | ︙ |
Changes to generic/tclDate.c.
| ︙ | ︙ | |||
98 99 100 101 102 103 104 |
* Meridian: am, pm, or 24-hour style.
*/
typedef enum _MERIDIAN {
MERam, MERpm, MER24
} MERIDIAN;
| < < < | 98 99 100 101 102 103 104 105 106 107 108 109 110 111 |
* Meridian: am, pm, or 24-hour style.
*/
typedef enum _MERIDIAN {
MERam, MERpm, MER24
} MERIDIAN;
/*
* yyparse will accept a 'struct DateInfo' as its parameter; that's where the
* parsed fields will be returned.
*/
typedef struct DateInfo {
|
| ︙ | ︙ | |||
205 206 207 208 209 210 211 212 213 214 215 216 217 218 |
/*
* Daylight-savings mode: on, off, or not yet known.
*/
typedef enum _DSTMODE {
DSTon, DSToff, DSTmaybe
} DSTMODE;
# ifndef YY_NULLPTR
# if defined __cplusplus && 201103L <= __cplusplus
# define YY_NULLPTR nullptr
# else
# define YY_NULLPTR 0
# endif
| > > > | 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 |
/*
* Daylight-savings mode: on, off, or not yet known.
*/
typedef enum _DSTMODE {
DSTon, DSToff, DSTmaybe
} DSTMODE;
# ifndef YY_NULLPTR
# if defined __cplusplus && 201103L <= __cplusplus
# define YY_NULLPTR nullptr
# else
# define YY_NULLPTR 0
# endif
|
| ︙ | ︙ | |||
556 557 558 559 560 561 562 | # endif # endif #endif /* !YYCOPY_NEEDED */ /* YYFINAL -- State number of the termination state. */ #define YYFINAL 2 /* YYLAST -- Last index in YYTABLE. */ | | | | | 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 |
# endif
# endif
#endif /* !YYCOPY_NEEDED */
/* YYFINAL -- State number of the termination state. */
#define YYFINAL 2
/* YYLAST -- Last index in YYTABLE. */
#define YYLAST 81
/* YYNTOKENS -- Number of terminals. */
#define YYNTOKENS 26
/* YYNNTS -- Number of nonterminals. */
#define YYNNTS 16
/* YYNRULES -- Number of rules. */
#define YYNRULES 56
/* YYNSTATES -- Number of states. */
#define YYNSTATES 85
/* YYTRANSLATE[YYX] -- Symbol number corresponding to YYX as returned
by yylex, with out-of-bounds checking. */
#define YYUNDEFTOK 2
#define YYMAXUTOK 274
#define YYTRANSLATE(YYX) \
((unsigned) (YYX) <= YYMAXUTOK ? yytranslate[YYX] : YYUNDEFTOK)
/* YYTRANSLATE[TOKEN-NUM] -- Symbol number corresponding to TOKEN-NUM
as returned by yylex, without out-of-bounds checking. */
static const yytype_uint8 yytranslate[] =
{
0, 2, 2, 2, 2, 2, 2, 2, 2, 2,
2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
2, 2, 2, 25, 21, 23, 24, 22, 2, 2,
2, 2, 2, 2, 2, 2, 2, 2, 20, 2,
2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
|
| ︙ | ︙ | |||
614 615 616 617 618 619 620 |
};
#if YYDEBUG
/* YYRLINE[YYN] -- Source line where rule number YYN was defined. */
static const yytype_uint16 yyrline[] =
{
0, 223, 223, 224, 227, 230, 233, 236, 239, 242,
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | | | | | | | | | > | | | | | | | | | | | | | | 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 |
};
#if YYDEBUG
/* YYRLINE[YYN] -- Source line where rule number YYN was defined. */
static const yytype_uint16 yyrline[] =
{
0, 223, 223, 224, 227, 230, 233, 236, 239, 242,
245, 249, 254, 257, 263, 269, 277, 282, 287, 291,
297, 301, 305, 309, 313, 319, 323, 328, 333, 338,
343, 347, 352, 356, 361, 368, 372, 378, 388, 397,
406, 416, 430, 435, 438, 441, 444, 447, 450, 455,
458, 463, 467, 471, 477, 495, 498
};
#endif
#if YYDEBUG || YYERROR_VERBOSE || 0
/* YYTNAME[SYMBOL-NUM] -- String name of the symbol SYMBOL-NUM.
First, the terminals, then, starting at YYNTOKENS, nonterminals. */
static const char *const yytname[] =
{
"$end", "error", "$undefined", "tAGO", "tDAY", "tDAYZONE", "tID",
"tMERIDIAN", "tMONTH", "tMONTH_UNIT", "tSTARDATE", "tSEC_UNIT",
"tSNUMBER", "tUNUMBER", "tZONE", "tEPOCH", "tDST", "tISOBASE",
"tDAY_UNIT", "tNEXT", "':'", "','", "'/'", "'-'", "'.'", "'+'",
"$accept", "spec", "item", "time", "zone", "day", "date", "ordMonth",
"iso", "trek", "relspec", "relunits", "sign", "unit", "number",
"o_merid", YY_NULLPTR
};
#endif
# ifdef YYPRINT
/* YYTOKNUM[NUM] -- (External) token number corresponding to the
(internal) symbol number NUM (which must be that of a token). */
static const yytype_uint16 yytoknum[] =
{
0, 256, 257, 258, 259, 260, 261, 262, 263, 264,
265, 266, 267, 268, 269, 270, 271, 272, 273, 274,
58, 44, 47, 45, 46, 43
};
# endif
#define YYPACT_NINF -18
#define yypact_value_is_default(Yystate) \
(!!((Yystate) == (-18)))
#define YYTABLE_NINF -1
#define yytable_value_is_error(Yytable_value) \
0
/* YYPACT[STATE-NUM] -- Index in YYTABLE of the portion describing
STATE-NUM. */
static const yytype_int8 yypact[] =
{
-18, 2, -18, -17, -18, -4, -18, 10, -18, 22,
8, -18, 18, -18, 39, -18, -18, -18, -18, -18,
-18, -18, -18, -18, -18, -18, 25, 21, -18, -18,
-18, 16, 14, -18, -18, 28, 36, 41, -5, -18,
-18, 5, -18, -18, -18, 47, -18, -18, 42, 46,
48, -18, -6, 40, 43, 44, 49, -18, -18, -18,
-18, -18, -18, -18, -18, 50, -18, 51, 55, 57,
58, 65, -18, -18, 59, 54, -18, 62, 63, 60,
-18, 64, 61, 66, -18
};
/* YYDEFACT[STATE-NUM] -- Default reduction number in state STATE-NUM.
Performed when YYTABLE does not specify something else to do. Zero
means the default is an error. */
static const yytype_uint8 yydefact[] =
{
2, 0, 1, 20, 18, 0, 53, 0, 51, 54,
17, 33, 27, 52, 0, 49, 50, 3, 4, 5,
8, 6, 7, 10, 11, 9, 43, 0, 48, 12,
21, 30, 0, 22, 13, 32, 0, 0, 0, 45,
16, 0, 40, 24, 35, 0, 46, 42, 19, 0,
0, 34, 55, 25, 0, 0, 0, 38, 36, 47,
23, 44, 31, 41, 56, 0, 14, 0, 0, 0,
0, 55, 26, 28, 29, 0, 15, 0, 0, 0,
39, 0, 0, 0, 37
};
/* YYPGOTO[NTERM-NUM]. */
static const yytype_int8 yypgoto[] =
{
-18, -18, -18, -18, -18, -18, -18, -18, -18, -18,
-18, -18, -18, -9, -18, 7
};
/* YYDEFGOTO[NTERM-NUM]. */
static const yytype_int8 yydefgoto[] =
{
-1, 1, 17, 18, 19, 20, 21, 22, 23, 24,
25, 26, 27, 28, 29, 66
};
/* YYTABLE[YYPACT[STATE-NUM]] -- What to do in state STATE-NUM. If
positive, shift that token. If negative, reduce the rule whose
number is the opposite. If YYTABLE_NINF, syntax error. */
static const yytype_uint8 yytable[] =
{
39, 64, 2, 54, 30, 46, 3, 4, 55, 31,
5, 6, 7, 8, 65, 9, 10, 11, 56, 12,
13, 14, 57, 32, 40, 15, 33, 16, 47, 34,
35, 6, 41, 8, 48, 42, 59, 49, 50, 61,
13, 51, 36, 43, 37, 38, 60, 44, 6, 52,
8, 6, 45, 8, 53, 58, 6, 13, 8, 62,
13, 63, 67, 71, 72, 13, 68, 69, 73, 70,
74, 75, 64, 77, 78, 79, 80, 82, 76, 84,
81, 83
};
static const yytype_uint8 yycheck[] =
{
9, 7, 0, 8, 21, 14, 4, 5, 13, 13,
8, 9, 10, 11, 20, 13, 14, 15, 13, 17,
18, 19, 17, 13, 16, 23, 4, 25, 3, 7,
8, 9, 14, 11, 13, 17, 45, 21, 24, 48,
18, 13, 20, 4, 22, 23, 4, 8, 9, 13,
11, 9, 13, 11, 13, 8, 9, 18, 11, 13,
18, 13, 22, 13, 13, 18, 23, 23, 13, 20,
13, 13, 7, 14, 20, 13, 13, 13, 71, 13,
20, 20
};
/* YYSTOS[STATE-NUM] -- The (internal number of the) accessing
symbol of state STATE-NUM. */
static const yytype_uint8 yystos[] =
{
0, 27, 0, 4, 5, 8, 9, 10, 11, 13,
14, 15, 17, 18, 19, 23, 25, 28, 29, 30,
31, 32, 33, 34, 35, 36, 37, 38, 39, 40,
21, 13, 13, 4, 7, 8, 20, 22, 23, 39,
16, 14, 17, 4, 8, 13, 39, 3, 13, 21,
24, 13, 13, 13, 8, 13, 13, 17, 8, 39,
4, 39, 13, 13, 7, 20, 41, 22, 23, 23,
20, 13, 13, 13, 13, 13, 41, 14, 20, 13,
13, 20, 13, 20, 13
};
/* YYR1[YYN] -- Symbol number of symbol that rule YYN derives. */
static const yytype_uint8 yyr1[] =
{
0, 26, 27, 27, 28, 28, 28, 28, 28, 28,
28, 28, 28, 29, 29, 29, 30, 30, 30, 30,
31, 31, 31, 31, 31, 32, 32, 32, 32, 32,
32, 32, 32, 32, 32, 33, 33, 34, 34, 34,
34, 35, 36, 36, 37, 37, 37, 37, 37, 38,
38, 39, 39, 39, 40, 41, 41
};
/* YYR2[YYN] -- Number of symbols on the right hand side of rule YYN. */
static const yytype_uint8 yyr2[] =
{
0, 2, 0, 2, 1, 1, 1, 1, 1, 1,
1, 1, 1, 2, 4, 6, 2, 1, 1, 2,
1, 2, 2, 3, 2, 3, 5, 1, 5, 5,
2, 4, 2, 1, 3, 2, 3, 11, 3, 7,
2, 4, 2, 1, 3, 2, 2, 3, 1, 1,
1, 1, 1, 1, 1, 0, 1
};
#define yyerrok (yyerrstatus = 0)
#define yyclearin (yychar = YYEMPTY)
|
| ︙ | ︙ | |||
1634 1635 1636 1637 1638 1639 1640 |
yyMeridian = (yyvsp[0].Meridian);
}
break;
case 15:
| < < < < < < < < < < < < < > > > > > > > > > > | | < < < < | | > | < | | | | | < < < < < < < < < | | | | | | | | | | | > > > > > > > > > > > > > > | | | 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 |
yyMeridian = (yyvsp[0].Meridian);
}
break;
case 15:
{
yyHour = (yyvsp[-5].Number);
yyMinutes = (yyvsp[-3].Number);
yySeconds = (yyvsp[-1].Number);
yyMeridian = (yyvsp[0].Meridian);
}
break;
case 16:
{
yyTimezone = (yyvsp[-1].Number);
if (yyTimezone > HOUR( 12)) yyTimezone -= HOUR(100);
yyDSTmode = DSTon;
}
break;
case 17:
{
yyTimezone = (yyvsp[0].Number);
if (yyTimezone > HOUR( 12)) yyTimezone -= HOUR(100);
yyDSTmode = DSToff;
}
break;
case 18:
{
yyTimezone = (yyvsp[0].Number);
yyDSTmode = DSTon;
}
break;
case 19:
{
yyTimezone = -(yyvsp[-1].Number)*((yyvsp[0].Number) % 100 + ((yyvsp[0].Number) / 100) * 60);
yyDSTmode = DSToff;
}
break;
case 20:
{
yyDayOrdinal = 1;
yyDayNumber = (yyvsp[0].Number);
}
break;
case 21:
{
yyDayOrdinal = 1;
yyDayNumber = (yyvsp[-1].Number);
}
break;
case 22:
{
yyDayOrdinal = (yyvsp[-1].Number);
yyDayNumber = (yyvsp[0].Number);
}
break;
case 23:
{
yyDayOrdinal = (yyvsp[-2].Number) * (yyvsp[-1].Number);
yyDayNumber = (yyvsp[0].Number);
}
break;
case 24:
{
yyDayOrdinal = 2;
yyDayNumber = (yyvsp[0].Number);
}
break;
case 25:
{
yyMonth = (yyvsp[-2].Number);
yyDay = (yyvsp[0].Number);
}
break;
case 26:
{
yyMonth = (yyvsp[-4].Number);
yyDay = (yyvsp[-2].Number);
yyYear = (yyvsp[0].Number);
}
break;
case 27:
{
yyYear = (yyvsp[0].Number) / 10000;
yyMonth = ((yyvsp[0].Number) % 10000)/100;
yyDay = (yyvsp[0].Number) % 100;
}
break;
case 28:
{
yyDay = (yyvsp[-4].Number);
yyMonth = (yyvsp[-2].Number);
yyYear = (yyvsp[0].Number);
}
break;
case 29:
{
yyMonth = (yyvsp[-2].Number);
yyDay = (yyvsp[0].Number);
yyYear = (yyvsp[-4].Number);
}
break;
case 30:
{
yyMonth = (yyvsp[-1].Number);
yyDay = (yyvsp[0].Number);
}
break;
case 31:
{
yyMonth = (yyvsp[-3].Number);
yyDay = (yyvsp[-2].Number);
yyYear = (yyvsp[0].Number);
}
break;
case 32:
{
yyMonth = (yyvsp[0].Number);
yyDay = (yyvsp[-1].Number);
}
break;
case 33:
{
yyMonth = 1;
yyDay = 1;
yyYear = EPOCH;
}
break;
case 34:
{
yyMonth = (yyvsp[-1].Number);
yyDay = (yyvsp[-2].Number);
yyYear = (yyvsp[0].Number);
}
break;
case 35:
{
yyMonthOrdinal = 1;
yyMonth = (yyvsp[0].Number);
}
break;
case 36:
{
yyMonthOrdinal = (yyvsp[-1].Number);
yyMonth = (yyvsp[0].Number);
}
break;
case 37:
{
if ((yyvsp[-5].Number) != HOUR( 7) + HOUR(100)) YYABORT;
yyYear = (yyvsp[-10].Number);
yyMonth = (yyvsp[-8].Number);
yyDay = (yyvsp[-6].Number);
yyHour = (yyvsp[-4].Number);
yyMinutes = (yyvsp[-2].Number);
yySeconds = (yyvsp[0].Number);
}
break;
case 38:
{
if ((yyvsp[-1].Number) != HOUR( 7) + HOUR(100)) YYABORT;
yyYear = (yyvsp[-2].Number) / 10000;
yyMonth = ((yyvsp[-2].Number) % 10000)/100;
yyDay = (yyvsp[-2].Number) % 100;
yyHour = (yyvsp[0].Number) / 10000;
yyMinutes = ((yyvsp[0].Number) % 10000)/100;
yySeconds = (yyvsp[0].Number) % 100;
}
break;
case 39:
{
if ((yyvsp[-5].Number) != HOUR( 7) + HOUR(100)) YYABORT;
yyYear = (yyvsp[-6].Number) / 10000;
yyMonth = ((yyvsp[-6].Number) % 10000)/100;
yyDay = (yyvsp[-6].Number) % 100;
yyHour = (yyvsp[-4].Number);
yyMinutes = (yyvsp[-2].Number);
yySeconds = (yyvsp[0].Number);
}
|
| ︙ | ︙ | |||
2455 2456 2457 2458 2459 2460 2461 |
};
/*
* Military timezone table.
*/
static const TABLE MilitaryTable[] = {
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 |
};
/*
* Military timezone table.
*/
static const TABLE MilitaryTable[] = {
{ "a", tZONE, -HOUR( 1) + HOUR(100) },
{ "b", tZONE, -HOUR( 2) + HOUR(100) },
{ "c", tZONE, -HOUR( 3) + HOUR(100) },
{ "d", tZONE, -HOUR( 4) + HOUR(100) },
{ "e", tZONE, -HOUR( 5) + HOUR(100) },
{ "f", tZONE, -HOUR( 6) + HOUR(100) },
{ "g", tZONE, -HOUR( 7) + HOUR(100) },
{ "h", tZONE, -HOUR( 8) + HOUR(100) },
{ "i", tZONE, -HOUR( 9) + HOUR(100) },
{ "k", tZONE, -HOUR(10) + HOUR(100) },
{ "l", tZONE, -HOUR(11) + HOUR(100) },
{ "m", tZONE, -HOUR(12) + HOUR(100) },
{ "n", tZONE, HOUR( 1) + HOUR(100) },
{ "o", tZONE, HOUR( 2) + HOUR(100) },
{ "p", tZONE, HOUR( 3) + HOUR(100) },
{ "q", tZONE, HOUR( 4) + HOUR(100) },
{ "r", tZONE, HOUR( 5) + HOUR(100) },
{ "s", tZONE, HOUR( 6) + HOUR(100) },
{ "t", tZONE, HOUR( 7) + HOUR(100) },
{ "u", tZONE, HOUR( 8) + HOUR(100) },
{ "v", tZONE, HOUR( 9) + HOUR(100) },
{ "w", tZONE, HOUR( 10) + HOUR(100) },
{ "x", tZONE, HOUR( 11) + HOUR(100) },
{ "y", tZONE, HOUR( 12) + HOUR(100) },
{ "z", tZONE, HOUR( 0) + HOUR(100) },
{ NULL, 0, 0 }
};
/*
* Dump error messages in the bit bucket.
*/
static void
TclDateerror(
YYLTYPE* location,
DateInfo* infoPtr,
const char *s)
{
Tcl_Obj* t;
Tcl_AppendToObj(infoPtr->messages, infoPtr->separatrix, -1);
Tcl_AppendToObj(infoPtr->messages, s, -1);
Tcl_AppendToObj(infoPtr->messages, " (characters ", -1);
TclNewIntObj(t, location->first_column);
Tcl_IncrRefCount(t);
Tcl_AppendObjToObj(infoPtr->messages, t);
Tcl_DecrRefCount(t);
Tcl_AppendToObj(infoPtr->messages, "-", -1);
TclNewIntObj(t, location->last_column);
Tcl_IncrRefCount(t);
Tcl_AppendObjToObj(infoPtr->messages, t);
Tcl_DecrRefCount(t);
Tcl_AppendToObj(infoPtr->messages, ")", -1);
infoPtr->separatrix = "\n";
}
|
| ︙ | ︙ | |||
2677 2678 2679 2680 2681 2682 2683 |
char c;
char *p;
char buff[20];
int Count;
location->first_column = yyInput - info->dateStart;
for ( ; ; ) {
| | | 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 |
char c;
char *p;
char buff[20];
int Count;
location->first_column = yyInput - info->dateStart;
for ( ; ; ) {
while (TclIsSpaceProcM(*yyInput)) {
yyInput++;
}
if (isdigit(UCHAR(c = *yyInput))) { /* INTL: digit */
/*
* Convert the string into a number; count the number of digits.
*/
|
| ︙ | ︙ | |||
2740 2741 2742 2743 2744 2745 2746 |
}
} while (Count > 0);
}
}
int
TclClockOldscanObjCmd(
| | | 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 |
}
} while (Count > 0);
}
}
int
TclClockOldscanObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Count of paraneters */
Tcl_Obj *const *objv) /* Parameters */
{
Tcl_Obj *result, *resultElement;
int yr, mo, da;
DateInfo dateInfo;
|
| ︙ | ︙ |
Changes to generic/tclDecls.h.
| ︙ | ︙ | |||
477 478 479 480 481 482 483 | EXTERN const char * Tcl_GetCommandName(Tcl_Interp *interp, Tcl_Command command); /* 161 */ EXTERN int Tcl_GetErrno(void); /* 162 */ EXTERN const char * Tcl_GetHostName(void); /* 163 */ | | | 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 | EXTERN const char * Tcl_GetCommandName(Tcl_Interp *interp, Tcl_Command command); /* 161 */ EXTERN int Tcl_GetErrno(void); /* 162 */ EXTERN const char * Tcl_GetHostName(void); /* 163 */ EXTERN int Tcl_GetInterpPath(Tcl_Interp *interp, Tcl_Interp *slaveInterp); /* 164 */ EXTERN Tcl_Interp * Tcl_GetMaster(Tcl_Interp *interp); /* 165 */ EXTERN const char * Tcl_GetNameOfExecutable(void); /* 166 */ EXTERN Tcl_Obj * Tcl_GetObjResult(Tcl_Interp *interp); |
| ︙ | ︙ | |||
1938 1939 1940 1941 1942 1943 1944 |
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 */
| | | 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 |
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 *interp, 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 */
|
| ︙ | ︙ | |||
3905 3906 3907 3908 3909 3910 3911 3912 3913 | # define Tcl_WriteObj(chan, objPtr) (((Tcl_WideInt)((Tcl_WriteObj)(chan, objPtr)+1))-1) # define Tcl_ReadRaw(chan, dst, bytesToRead) (((Tcl_WideInt)((Tcl_ReadRaw)(chan, dst, bytesToRead)+1))-1) # define Tcl_WriteRaw(chan, src, srcLen) (((Tcl_WideInt)((Tcl_WriteRaw()(chan, src, srcLen)+1))-1) # endif #endif #define Tcl_Close(interp, chan) Tcl_CloseEx(interp, chan, 0) #endif /* _TCLDECLS */ | > > > > > > | 3905 3906 3907 3908 3909 3910 3911 3912 3913 3914 3915 3916 3917 3918 3919 | # define Tcl_WriteObj(chan, objPtr) (((Tcl_WideInt)((Tcl_WriteObj)(chan, objPtr)+1))-1) # define Tcl_ReadRaw(chan, dst, bytesToRead) (((Tcl_WideInt)((Tcl_ReadRaw)(chan, dst, bytesToRead)+1))-1) # define Tcl_WriteRaw(chan, src, srcLen) (((Tcl_WideInt)((Tcl_WriteRaw()(chan, src, srcLen)+1))-1) # endif #endif #define Tcl_Close(interp, chan) Tcl_CloseEx(interp, chan, 0) #if defined(USE_TCL_STUBS) && (TCL_UTF_MAX <= 3) # undef Tcl_UtfCharComplete # define Tcl_UtfCharComplete(src, length) (((unsigned)((unsigned char)*(src) - 0xF0) < 5) \ ? ((length) >= TCL_UTF_MAX) : tclStubsPtr->tcl_UtfCharComplete((src), (length))) #endif #endif /* _TCLDECLS */ |
Changes to generic/tclDisassemble.c.
| ︙ | ︙ | |||
828 829 830 831 832 833 834 |
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);
| | | 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 |
size_t inst; /* NOTE: We know this is really an unsigned char */
char *dst;
InstNameGetIntRep(objPtr, inst);
if (inst > LAST_INST_OPCODE) {
dst = Tcl_InitStringRep(objPtr, NULL, TCL_INTEGER_SPACE + 5);
TclOOM(dst, (size_t)TCL_INTEGER_SPACE + 5);
sprintf(dst, "inst_%" TCL_Z_MODIFIER "u", inst);
(void) Tcl_InitStringRep(objPtr, NULL, strlen(dst));
} else {
const char *s = tclInstructionTable[inst].name;
size_t len = strlen(s);
dst = Tcl_InitStringRep(objPtr, s, len);
TclOOM(dst, len);
|
| ︙ | ︙ | |||
857 858 859 860 861 862 863 |
PrintSourceToObj(
Tcl_Obj *appendObj, /* The object to print the source to. */
const char *stringPtr, /* The string to print. */
int maxChars) /* Maximum number of chars to print. */
{
const char *p;
int i = 0, len;
| < > | | | 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 |
PrintSourceToObj(
Tcl_Obj *appendObj, /* The object to print the source to. */
const char *stringPtr, /* The string to print. */
int maxChars) /* Maximum number of chars to print. */
{
const char *p;
int i = 0, len;
if (stringPtr == NULL) {
Tcl_AppendToObj(appendObj, "\"\"", -1);
return;
}
Tcl_AppendToObj(appendObj, "\"", -1);
p = stringPtr;
for (; (*p != '\0') && (i < maxChars); p+=len) {
int ucs4;
len = TclUtfToUCS4(p, &ucs4);
switch (ucs4) {
case '"':
Tcl_AppendToObj(appendObj, "\\\"", -1);
i += 2;
continue;
case '\f':
Tcl_AppendToObj(appendObj, "\\f", -1);
i += 2;
|
| ︙ | ︙ | |||
895 896 897 898 899 900 901 | i += 2; continue; case '\v': Tcl_AppendToObj(appendObj, "\\v", -1); i += 2; continue; default: | < < < < < < < < < < | < < | | < < | | | 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 |
i += 2;
continue;
case '\v':
Tcl_AppendToObj(appendObj, "\\v", -1);
i += 2;
continue;
default:
if (ucs4 > 0xFFFF) {
Tcl_AppendPrintfToObj(appendObj, "\\U%08x", ucs4);
i += 10;
} else if (ucs4 < 0x20 || ucs4 >= 0x7F) {
Tcl_AppendPrintfToObj(appendObj, "\\u%04x", ucs4);
i += 6;
} else {
Tcl_AppendPrintfToObj(appendObj, "%c", ucs4);
i++;
}
continue;
}
}
if (*p != '\0') {
Tcl_AppendToObj(appendObj, "...", -1);
|
| ︙ | ︙ | |||
1204 1205 1206 1207 1208 1209 1210 |
/*
* Convert byte offsets to character offsets; important if multibyte
* characters are present in the source!
*/
Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("scriptfrom", -1),
| | | | 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 |
/*
* Convert byte offsets to character offsets; important if multibyte
* characters are present in the source!
*/
Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("scriptfrom", -1),
Tcl_NewWideIntObj(Tcl_NumUtfChars(codePtr->source,
sourceOffset)));
Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("scriptto", -1),
Tcl_NewWideIntObj(Tcl_NumUtfChars(codePtr->source,
sourceOffset + sourceLength - 1)));
Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("script", -1),
Tcl_NewStringObj(codePtr->source+sourceOffset, sourceLength));
Tcl_ListObjAppendElement(NULL, commands, cmd);
}
#undef Decode
|
| ︙ | ︙ |
Changes to generic/tclEncoding.c.
| ︙ | ︙ | |||
1067 1068 1069 1070 1071 1072 1073 |
if (encoding == NULL) {
encoding = systemEncoding;
}
encodingPtr = (Encoding *) encoding;
if (src == NULL) {
srcLen = 0;
| | | 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 |
if (encoding == NULL) {
encoding = systemEncoding;
}
encodingPtr = (Encoding *) encoding;
if (src == NULL) {
srcLen = 0;
} else if (srcLen == TCL_INDEX_NONE) {
srcLen = encodingPtr->lengthProc(src);
}
flags = TCL_ENCODING_START | TCL_ENCODING_END;
while (1) {
result = encodingPtr->toUtfProc(encodingPtr->clientData, src, srcLen,
|
| ︙ | ︙ | |||
1157 1158 1159 1160 1161 1162 1163 |
if (encoding == NULL) {
encoding = systemEncoding;
}
encodingPtr = (Encoding *) encoding;
if (src == NULL) {
srcLen = 0;
| | | 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 |
if (encoding == NULL) {
encoding = systemEncoding;
}
encodingPtr = (Encoding *) encoding;
if (src == NULL) {
srcLen = 0;
} else if (srcLen == TCL_INDEX_NONE) {
srcLen = encodingPtr->lengthProc(src);
}
if (statePtr == NULL) {
flags |= TCL_ENCODING_START | TCL_ENCODING_END;
statePtr = &state;
}
if (srcReadPtr == NULL) {
|
| ︙ | ︙ | |||
1257 1258 1259 1260 1261 1262 1263 |
if (encoding == NULL) {
encoding = systemEncoding;
}
encodingPtr = (Encoding *) encoding;
if (src == NULL) {
srcLen = 0;
| | | 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 |
if (encoding == NULL) {
encoding = systemEncoding;
}
encodingPtr = (Encoding *) encoding;
if (src == NULL) {
srcLen = 0;
} else if (srcLen == TCL_INDEX_NONE) {
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);
|
| ︙ | ︙ | |||
1346 1347 1348 1349 1350 1351 1352 |
if (encoding == NULL) {
encoding = systemEncoding;
}
encodingPtr = (Encoding *) encoding;
if (src == NULL) {
srcLen = 0;
| | | 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 |
if (encoding == NULL) {
encoding = systemEncoding;
}
encodingPtr = (Encoding *) encoding;
if (src == NULL) {
srcLen = 0;
} else if (srcLen == TCL_INDEX_NONE) {
srcLen = strlen(src);
}
if (statePtr == NULL) {
flags |= TCL_ENCODING_START | TCL_ENCODING_END;
statePtr = &state;
}
if (srcReadPtr == NULL) {
|
| ︙ | ︙ | |||
1710 1711 1712 1713 1714 1715 1716 |
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++) {
| | | 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 |
return NULL;
}
p = TclGetString(objPtr);
hi = (staticHex[UCHAR(p[0])] << 4) + staticHex[UCHAR(p[1])];
dataPtr->toUnicode[hi] = pageMemPtr;
p += 2;
for (lo = 0; lo < 256; lo++) {
if ((lo & 0x0F) == 0) {
p++;
}
ch = (staticHex[UCHAR(p[0])] << 12) + (staticHex[UCHAR(p[1])] << 8)
+ (staticHex[UCHAR(p[2])] << 4) + staticHex[UCHAR(p[3])];
if (ch != 0) {
used[ch >> 8] = 1;
}
|
| ︙ | ︙ | |||
1771 1772 1773 1774 1775 1776 1777 |
if (ch != 0) {
page = dataPtr->fromUnicode[ch >> 8];
if (page == NULL) {
page = pageMemPtr;
pageMemPtr += 256;
dataPtr->fromUnicode[ch >> 8] = page;
}
| | | 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 |
if (ch != 0) {
page = dataPtr->fromUnicode[ch >> 8];
if (page == NULL) {
page = pageMemPtr;
pageMemPtr += 256;
dataPtr->fromUnicode[ch >> 8] = page;
}
page[ch & 0xFF] = (unsigned short) ((hi << 8) + lo);
}
}
}
if (type == ENCODING_MULTIBYTE) {
/*
* If multibyte encodings don't have a backslash character, define
* one. Otherwise, on Windows, native file names don't work because
|
| ︙ | ︙ | |||
1877 1878 1879 1880 1881 1882 1883 |
}
for (p += 5, len -= 5; len >= 0 && *p; p += 5, len -= 5) {
from = (staticHex[p[0]] << 12) + (staticHex[p[1]] << 8)
+ (staticHex[p[2]] << 4) + staticHex[p[3]];
if (from == 0) {
continue;
}
| | | 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 |
}
for (p += 5, len -= 5; len >= 0 && *p; p += 5, len -= 5) {
from = (staticHex[p[0]] << 12) + (staticHex[p[1]] << 8)
+ (staticHex[p[2]] << 4) + staticHex[p[3]];
if (from == 0) {
continue;
}
dataPtr->fromUnicode[from >> 8][from & 0xFF] = to;
}
}
doneParse:
Tcl_DStringFree(&lineString);
/*
* Package everything into an encoding structure.
|
| ︙ | ︙ | |||
2092 2093 2094 2095 2096 2097 2098 | /* *------------------------------------------------------------------------- * * UtfIntToUtfExtProc -- * * Convert from UTF-8 to UTF-8. While converting null-bytes from the | | | 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 | /* *------------------------------------------------------------------------- * * UtfIntToUtfExtProc -- * * Convert from UTF-8 to UTF-8. While converting null-bytes from the * Tcl's internal representation (0xC0, 0x80) to the official * representation (0x00). See UtfToUtfProc for details. * * Results: * Returns TCL_OK if conversion was successful. * * Side effects: * None. |
| ︙ | ︙ | |||
2141 2142 2143 2144 2145 2146 2147 | /* *------------------------------------------------------------------------- * * UtfExtToUtfIntProc -- * * Convert from UTF-8 to UTF-8 while converting null-bytes from the | | | 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 | /* *------------------------------------------------------------------------- * * UtfExtToUtfIntProc -- * * Convert from UTF-8 to UTF-8 while converting null-bytes from the * official representation (0x00) to Tcl's internal representation (0xC0, * 0x80). See UtfToUtfProc for details. * * Results: * Returns TCL_OK if conversion was successful. * * Side effects: * None. |
| ︙ | ︙ | |||
2235 2236 2237 2238 2239 2240 2241 |
int pureNullMode) /* Convert embedded nulls from internal
* representation to real null-bytes or vice
* versa. Also combine or separate surrogate pairs */
{
const char *srcStart, *srcEnd, *srcClose;
const char *dstStart, *dstEnd;
int result, numChars, charLimit = INT_MAX;
| | | | | | | | | | | | | | 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 |
int pureNullMode) /* Convert embedded nulls from internal
* representation to real null-bytes or vice
* versa. Also combine or separate surrogate pairs */
{
const char *srcStart, *srcEnd, *srcClose;
const char *dstStart, *dstEnd;
int result, numChars, charLimit = INT_MAX;
int *chPtr = (int *) statePtr;
if (flags & TCL_ENCODING_START) {
*statePtr = 0;
}
result = TCL_OK;
srcStart = src;
srcEnd = src + srcLen;
srcClose = srcEnd;
if ((flags & TCL_ENCODING_END) == 0) {
srcClose -= 6;
}
if (flags & TCL_ENCODING_CHAR_LIMIT) {
charLimit = *dstCharsPtr;
}
dstStart = dst;
dstEnd = dst + dstLen - TCL_UTF_MAX;
for (numChars = 0; src < srcEnd && numChars <= charLimit; numChars++) {
if ((src > srcClose) && (!TclUCS4Complete(src, srcEnd - src))) {
/*
* If there is more string to follow, this will ensure that the
* last UTF-8 character in the source buffer hasn't been cut off.
*/
result = TCL_CONVERT_MULTIBYTE;
break;
}
if (dst > dstEnd) {
result = TCL_CONVERT_NOSPACE;
break;
}
if (UCHAR(*src) < 0x80 && !(UCHAR(*src) == 0 && pureNullMode == 0)) {
/*
* Copy 7bit characters, but skip null-bytes when we are in input
* mode, so that they get converted to 0xC080.
*/
*dst++ = *src++;
} else if (pureNullMode == 1 && UCHAR(*src) == 0xC0 &&
(src + 1 < srcEnd) && UCHAR(*(src+1)) == 0x80) {
/*
* Convert 0xC080 to real nulls when we are in output mode.
*/
*dst++ = 0;
src += 2;
} else if (!TclUCS4Complete(src, srcEnd - src)) {
/*
* Always check before using TclUtfToUCS4. Not doing can so
* cause it run beyond the end of the buffer! If we happen such an
* incomplete char its bytes are made to represent themselves.
*/
*chPtr = UCHAR(*src);
src += 1;
dst += Tcl_UniCharToUtf(*chPtr, dst);
} else {
src += TclUtfToUCS4(src, chPtr);
if ((*chPtr | 0x7FF) == 0xDFFF) {
/* A surrogate character is detected, handle especially */
int low = *chPtr;
size_t len = (src <= srcEnd-3) ? TclUtfToUCS4(src, &low) : 0;
if (((low & ~0x3FF) != 0xDC00) || (*chPtr & 0x400)) {
*dst++ = (char) (((*chPtr >> 12) | 0xE0) & 0xEF);
*dst++ = (char) (((*chPtr >> 6) | 0x80) & 0xBF);
*dst++ = (char) ((*chPtr | 0x80) & 0xBF);
continue;
}
src += len;
dst += Tcl_UniCharToUtf(*chPtr, dst);
|
| ︙ | ︙ | |||
2492 2493 2494 2495 2496 2497 2498 |
}
if (dst > dstEnd) {
result = TCL_CONVERT_NOSPACE;
break;
}
src += TclUtfToUniChar(src, chPtr);
| < < < < < | 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 |
}
if (dst > dstEnd) {
result = TCL_CONVERT_NOSPACE;
break;
}
src += TclUtfToUniChar(src, chPtr);
if (clientData) {
#if TCL_UTF_MAX > 3
if (*chPtr <= 0xFFFF) {
*dst++ = (*chPtr & 0xFF);
*dst++ = (*chPtr >> 8);
} else {
*dst++ = (((*chPtr - 0x10000) >> 10) & 0xFF);
|
| ︙ | ︙ | |||
2828 2829 2830 2831 2832 2833 2834 | #if TCL_UTF_MAX > 3 /* * This prevents a crash condition. More evaluation is required for * full support of int Tcl_UniChar. [Bug 1004065] */ | | | | 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 |
#if TCL_UTF_MAX > 3
/*
* This prevents a crash condition. More evaluation is required for
* full support of int Tcl_UniChar. [Bug 1004065]
*/
if (ch & 0xFFFF0000) {
word = 0;
} else
#else
if (!len) {
word = 0;
} else
#endif
word = fromUnicode[(ch >> 8)][ch & 0xFF];
if ((word == 0) && (ch != 0)) {
if (flags & TCL_ENCODING_STOPONERROR) {
result = TCL_CONVERT_UNKNOWN;
break;
}
word = dataPtr->fallback;
|
| ︙ | ︙ | |||
3022 3023 3024 3025 3026 3027 3028 | } len = TclUtfToUniChar(src, &ch); /* * Check for illegal characters. */ | | | 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 |
}
len = TclUtfToUniChar(src, &ch);
/*
* Check for illegal characters.
*/
if (ch > 0xFF
#if TCL_UTF_MAX <= 3
|| ((ch >= 0xD800) && (len < 3))
#endif
) {
if (flags & TCL_ENCODING_STOPONERROR) {
result = TCL_CONVERT_UNKNOWN;
break;
|
| ︙ | ︙ | |||
3409 3410 3411 3412 3413 3414 3415 | * last UTF-8 character in the source buffer hasn't been cut off. */ result = TCL_CONVERT_MULTIBYTE; break; } len = TclUtfToUniChar(src, &ch); | | | | 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 |
* last UTF-8 character in the source buffer hasn't been cut off.
*/
result = TCL_CONVERT_MULTIBYTE;
break;
}
len = TclUtfToUniChar(src, &ch);
word = tableFromUnicode[(ch >> 8)][ch & 0xFF];
if ((word == 0) && (ch != 0)) {
int oldState;
const EscapeSubTable *subTablePtr;
oldState = state;
for (state = 0; state < dataPtr->numSubTables; state++) {
encodingPtr = GetTableEncoding(dataPtr, state);
tableDataPtr = (const TableEncodingData *)encodingPtr->clientData;
word = tableDataPtr->fromUnicode[(ch >> 8)][ch & 0xFF];
if (word != 0) {
break;
}
}
if (word == 0) {
state = oldState;
|
| ︙ | ︙ |
Changes to generic/tclEnsemble.c.
| ︙ | ︙ | |||
2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 |
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
Command *cmdPtr, /* Points to defintion of command being
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
Tcl_Obj *mapObj, *subcmdObj, *targetCmdObj, *listObj, **elems;
Tcl_Obj *replaced = Tcl_NewObj(), *replacement;
Tcl_Command ensemble = (Tcl_Command) cmdPtr;
Command *oldCmdPtr = cmdPtr, *newCmdPtr;
int len, result, flags = 0, i, depth = 1, invokeAnyway = 0;
int ourResult = TCL_ERROR;
size_t numBytes;
const char *word;
| > < | 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 |
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
Command *cmdPtr, /* Points to defintion of command being
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation;
Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
Tcl_Obj *mapObj, *subcmdObj, *targetCmdObj, *listObj, **elems;
Tcl_Obj *replaced = Tcl_NewObj(), *replacement;
Tcl_Command ensemble = (Tcl_Command) cmdPtr;
Command *oldCmdPtr = cmdPtr, *newCmdPtr;
int len, result, flags = 0, i, depth = 1, invokeAnyway = 0;
int ourResult = TCL_ERROR;
size_t numBytes;
const char *word;
Tcl_IncrRefCount(replaced);
if (parsePtr->numWords < depth + 1) {
goto failed;
}
if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
/*
|
| ︙ | ︙ | |||
3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 |
TclAttemptCompileProc(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
int depth,
Command *cmdPtr,
CompileEnv *envPtr) /* Holds resulting instructions. */
{
int result, i;
Tcl_Token *saveTokenPtr = parsePtr->tokenPtr;
int savedStackDepth = envPtr->currStackDepth;
unsigned savedCodeNext = envPtr->codeNext - envPtr->codeStart;
int savedAuxDataArrayNext = envPtr->auxDataArrayNext;
int savedExceptArrayNext = envPtr->exceptArrayNext;
#ifdef TCL_COMPILE_DEBUG
int savedExceptDepth = envPtr->exceptDepth;
#endif
| > < | 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 |
TclAttemptCompileProc(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
int depth,
Command *cmdPtr,
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation;
int result, i;
Tcl_Token *saveTokenPtr = parsePtr->tokenPtr;
int savedStackDepth = envPtr->currStackDepth;
unsigned savedCodeNext = envPtr->codeNext - envPtr->codeStart;
int savedAuxDataArrayNext = envPtr->auxDataArrayNext;
int savedExceptArrayNext = envPtr->exceptArrayNext;
#ifdef TCL_COMPILE_DEBUG
int savedExceptDepth = envPtr->exceptDepth;
#endif
if (cmdPtr->compileProc == NULL) {
return TCL_ERROR;
}
/*
* Advance parsePtr->tokenPtr so that it points at the last subcommand.
|
| ︙ | ︙ | |||
3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 |
CompileToInvokedCommand(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
Tcl_Obj *replacements,
Command *cmdPtr,
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *tokPtr;
Tcl_Obj *objPtr, **words;
const char *bytes;
int i, numWords, cmdLit, extraLiteralFlags = LITERAL_CMD_NAME;
size_t length;
| > < | 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 |
CompileToInvokedCommand(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
Tcl_Obj *replacements,
Command *cmdPtr,
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation;
Tcl_Token *tokPtr;
Tcl_Obj *objPtr, **words;
const char *bytes;
int i, numWords, cmdLit, extraLiteralFlags = LITERAL_CMD_NAME;
size_t length;
/*
* Push the words of the command. Take care; the command words may be
* scripts that have backslashes in them, and [info frame 0] can see the
* difference. Hence the call to TclContinuationsEnterDerived...
*/
|
| ︙ | ︙ |
Changes to generic/tclEnv.c.
| ︙ | ︙ | |||
41 42 43 44 45 46 47 |
char **cache; /* Array containing all of the environment
* strings that Tcl has allocated. */
#ifndef USE_PUTENV
techar **ourEnviron; /* Cache of the array that we allocate. We
* need to track this in case another
* subsystem swaps around the environ array
* like we do. */
| | | 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 |
char **cache; /* Array containing all of the environment
* strings that Tcl has allocated. */
#ifndef USE_PUTENV
techar **ourEnviron; /* Cache of the array that we allocate. We
* need to track this in case another
* subsystem swaps around the environ array
* like we do. */
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;
|
| ︙ | ︙ | |||
122 123 124 125 126 127 128 129 130 131 132 133 134 135 |
TclNewLiteralStringObj(varNamePtr, "env");
Tcl_IncrRefCount(varNamePtr);
Tcl_InitObjHashTable(&namesHash);
varPtr = TclObjLookupVarEx(interp, varNamePtr, NULL, TCL_GLOBAL_ONLY,
/*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
TclFindArrayPtrElements(varPtr, &namesHash);
/*
* Go through the environment array and transfer its values into Tcl. At
* the same time, remove those elements we add/update from the hash table
* of existing elements, so that after this part processes, that table
* will hold just the parts to remove.
*/
| > > > > > > > > > > > | 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 |
TclNewLiteralStringObj(varNamePtr, "env");
Tcl_IncrRefCount(varNamePtr);
Tcl_InitObjHashTable(&namesHash);
varPtr = TclObjLookupVarEx(interp, varNamePtr, NULL, TCL_GLOBAL_ONLY,
/*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
TclFindArrayPtrElements(varPtr, &namesHash);
#if defined(_WIN32)
if (tenviron == NULL) {
/*
* When we are started from main(), the _wenviron array could
* be NULL and will be initialized by the first _wgetenv() call.
*/
(void) _wgetenv(L"WINDIR");
}
#endif
/*
* Go through the environment array and transfer its values into Tcl. At
* the same time, remove those elements we add/update from the hash table
* of existing elements, so that after this part processes, that table
* will hold just the parts to remove.
*/
|
| ︙ | ︙ |
Changes to generic/tclExecute.c.
| ︙ | ︙ | |||
2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 |
fflush(stdout);
}
#endif
if (!pc) {
/* bytecode is starting from scratch */
pc = codePtr->codeStart;
goto cleanup0;
} else {
/* resume from invocation */
CACHE_STACK_INFO();
NRE_ASSERT(iPtr->cmdFramePtr == bcFramePtr);
if (bcFramePtr->cmdObj) {
| > > > > > > > > > > > > > > > > | 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 |
fflush(stdout);
}
#endif
if (!pc) {
/* bytecode is starting from scratch */
pc = codePtr->codeStart;
/*
* Reset the interp's result to avoid possible duplications of large
* objects [3c6e47363e], [781585], [804681], This can happen by start
* also in nested compiled blocks (enclosed in parent cycle).
* See else branch below for opposite handling by continuation/resume.
*/
objPtr = iPtr->objResultPtr;
if (objPtr->refCount > 1) {
TclDecrRefCount(objPtr);
TclNewObj(objPtr);
Tcl_IncrRefCount(objPtr);
iPtr->objResultPtr = objPtr;
}
goto cleanup0;
} else {
/* resume from invocation */
CACHE_STACK_INFO();
NRE_ASSERT(iPtr->cmdFramePtr == bcFramePtr);
if (bcFramePtr->cmdObj) {
|
| ︙ | ︙ | |||
2108 2109 2110 2111 2112 2113 2114 |
* instruction.
*/
TRACE_WITH_OBJ(("%u => ... after \"%.20s\": TCL_OK, result=",
objc, cmdNameBuf), Tcl_GetObjResult(interp));
/*
| | | 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 |
* instruction.
*/
TRACE_WITH_OBJ(("%u => ... after \"%.20s\": TCL_OK, result=",
objc, cmdNameBuf), Tcl_GetObjResult(interp));
/*
* Obtain and reset interp's result to avoid possible duplications of
* objects [Bug 781585]. We do not call Tcl_ResetResult to avoid any
* side effects caused by the resetting of errorInfo and errorCode
* [Bug 804681], which are not needed here. We chose instead to
* manipulate the interp's object result directly.
*
* Note that the result object is now in objResultPtr, it keeps the
* refCount it had in its role of iPtr->objResultPtr.
|
| ︙ | ︙ | |||
3473 3474 3475 3476 3477 3478 3479 |
goto doIncrStk;
}
case INST_INCR_ARRAY_STK_IMM:
case INST_INCR_SCALAR_STK_IMM:
case INST_INCR_STK_IMM:
increment = TclGetInt1AtPtr(pc+1);
| | | 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 |
goto doIncrStk;
}
case INST_INCR_ARRAY_STK_IMM:
case INST_INCR_SCALAR_STK_IMM:
case INST_INCR_STK_IMM:
increment = TclGetInt1AtPtr(pc+1);
TclNewIntObj(incrPtr, increment);
Tcl_IncrRefCount(incrPtr);
pcAdjustment = 2;
doIncrStk:
if ((*pc == INST_INCR_ARRAY_STK_IMM)
|| (*pc == INST_INCR_ARRAY_STK)) {
part2Ptr = OBJ_AT_TOS;
|
| ︙ | ︙ | |||
3508 3509 3510 3511 3512 3513 3514 |
}
cleanup = ((part2Ptr == NULL)? 1 : 2);
goto doIncrVar;
case INST_INCR_ARRAY1_IMM:
opnd = TclGetUInt1AtPtr(pc+1);
increment = TclGetInt1AtPtr(pc+2);
| | | 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 |
}
cleanup = ((part2Ptr == NULL)? 1 : 2);
goto doIncrVar;
case INST_INCR_ARRAY1_IMM:
opnd = TclGetUInt1AtPtr(pc+1);
increment = TclGetInt1AtPtr(pc+2);
TclNewIntObj(incrPtr, increment);
Tcl_IncrRefCount(incrPtr);
pcAdjustment = 3;
doIncrArray:
part1Ptr = NULL;
part2Ptr = OBJ_AT_TOS;
arrayPtr = LOCAL(opnd);
|
| ︙ | ︙ | |||
5308 5309 5310 5311 5312 5313 5314 |
}
doneStringMap:
TRACE_WITH_OBJ(("%.20s %.20s %.20s => ",
O2S(value2Ptr), O2S(value3Ptr), O2S(valuePtr)), objResultPtr);
NEXT_INST_V(1, 3, 1);
case INST_STR_FIND:
| | | | < | | | < > | > | | 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 |
}
doneStringMap:
TRACE_WITH_OBJ(("%.20s %.20s %.20s => ",
O2S(value2Ptr), O2S(value3Ptr), O2S(valuePtr)), objResultPtr);
NEXT_INST_V(1, 3, 1);
case INST_STR_FIND:
objResultPtr = TclStringFirst(OBJ_UNDER_TOS, OBJ_AT_TOS, 0);
TRACE(("%.20s %.20s => %d\n",
O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), O2S(objResultPtr)));
NEXT_INST_F(1, 2, 1);
case INST_STR_FIND_LAST:
objResultPtr = TclStringLast(OBJ_UNDER_TOS, OBJ_AT_TOS, INT_MAX - 1);
TRACE(("%.20s %.20s => %d\n",
O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), O2S(objResultPtr)));
NEXT_INST_F(1, 2, 1);
case INST_STR_CLASS:
opnd = TclGetInt1AtPtr(pc+1);
valuePtr = OBJ_AT_TOS;
TRACE(("%s \"%.30s\" => ", tclStringClassTable[opnd].name,
O2S(valuePtr)));
ustring1 = TclGetUnicodeFromObj(valuePtr, &slength);
match = 1;
if (slength > 0) {
int ch;
end = ustring1 + slength;
for (p=ustring1 ; p<end ; ) {
p += TclUniCharToUCS4(p, &ch);
if (!tclStringClassTable[opnd].comparator(ch)) {
match = 0;
break;
}
}
}
TRACE_APPEND(("%d\n", match));
JUMP_PEEPHOLE_F(match, 2, 1);
|
| ︙ | ︙ | |||
6629 6630 6631 6632 6633 6634 6635 |
result = Tcl_DictObjGet(interp, dictPtr, OBJ_AT_TOS, &valuePtr);
if (result != TCL_OK) {
break;
}
if (valuePtr == NULL) {
Tcl_DictObjPut(NULL, dictPtr, OBJ_AT_TOS,Tcl_NewIntObj(opnd));
} else {
| | | 6645 6646 6647 6648 6649 6650 6651 6652 6653 6654 6655 6656 6657 6658 6659 |
result = Tcl_DictObjGet(interp, dictPtr, OBJ_AT_TOS, &valuePtr);
if (result != TCL_OK) {
break;
}
if (valuePtr == NULL) {
Tcl_DictObjPut(NULL, dictPtr, OBJ_AT_TOS,Tcl_NewIntObj(opnd));
} else {
TclNewIntObj(value2Ptr, opnd);
Tcl_IncrRefCount(value2Ptr);
if (Tcl_IsShared(valuePtr)) {
valuePtr = Tcl_DuplicateObj(valuePtr);
Tcl_DictObjPut(NULL, dictPtr, OBJ_AT_TOS, valuePtr);
}
result = TclIncrObj(interp, valuePtr, value2Ptr);
if (result == TCL_OK) {
|
| ︙ | ︙ | |||
8101 8102 8103 8104 8105 8106 8107 | return constants[1]; } WIDE_RESULT(-1); } /* * We refuse to accept exponent arguments that exceed one mp_digit | | | 8117 8118 8119 8120 8121 8122 8123 8124 8125 8126 8127 8128 8129 8130 8131 |
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) {
|
| ︙ | ︙ |
Changes to generic/tclFileName.c.
| ︙ | ︙ | |||
594 595 596 597 598 599 600 |
* 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);
| | | 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 |
* 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.
*/
|
| ︙ | ︙ | |||
2054 2055 2056 2057 2058 2059 2060 | /* *---------------------------------------------------------------------- * * SkipToChar -- * * This function traverses a glob pattern looking for the next unquoted | | | 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 | /* *---------------------------------------------------------------------- * * SkipToChar -- * * This function traverses a glob pattern looking for the next unquoted * occurrence of the specified character at the same braces nesting level. * * Results: * Updates stringPtr to point to the matching character, or to the end of * the string if nothing matched. The return value is 1 if a match was * found at the top level, otherwise it is 0. * * Side effects: |
| ︙ | ︙ | |||
2444 2445 2446 2447 2448 2449 2450 | /* * The current prefix must end in a separator. */ size_t len; const char *joined = TclGetStringFromObj(joinedPtr,&len); | | | 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 |
/*
* The current prefix must end in a separator.
*/
size_t len;
const char *joined = TclGetStringFromObj(joinedPtr,&len);
if ((len > 0) && (strchr(separators, joined[len-1]) == NULL)) {
Tcl_AppendToObj(joinedPtr, "/", 1);
}
}
Tcl_AppendToObj(joinedPtr, Tcl_DStringValue(&append),
Tcl_DStringLength(&append));
}
Tcl_IncrRefCount(joinedPtr);
|
| ︙ | ︙ | |||
2481 2482 2483 2484 2485 2486 2487 | * //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); | | | 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 |
* //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 ((len > 0) && (strchr(separators, joined[len-1]) == NULL)) {
if (Tcl_FSGetPathType(pathPtr) != TCL_PATH_VOLUME_RELATIVE) {
Tcl_AppendToObj(joinedPtr, "/", 1);
}
}
}
Tcl_AppendToObj(joinedPtr, pattern, p-pattern);
}
|
| ︙ | ︙ |
Changes to generic/tclGetDate.y.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 |
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
%parse-param {DateInfo* info}
%lex-param {DateInfo* info}
| | | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 |
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
%parse-param {DateInfo* info}
%lex-param {DateInfo* info}
%define api.pure
/* %error-verbose would be nice, but our token names are meaningless */
%locations
%{
/*
* tclDate.c --
*
|
| ︙ | ︙ | |||
262 263 264 265 266 267 268 |
}
| tUNUMBER ':' tUNUMBER o_merid {
yyHour = $1;
yyMinutes = $3;
yySeconds = 0;
yyMeridian = $4;
}
| < < < < < < < < < < < < < < < < < > > > > > > | 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 |
}
| tUNUMBER ':' tUNUMBER o_merid {
yyHour = $1;
yyMinutes = $3;
yySeconds = 0;
yyMeridian = $4;
}
| tUNUMBER ':' tUNUMBER ':' tUNUMBER o_merid {
yyHour = $1;
yyMinutes = $3;
yySeconds = $5;
yyMeridian = $6;
}
;
zone : tZONE tDST {
yyTimezone = $1;
if (yyTimezone > HOUR( 12)) yyTimezone -= HOUR(100);
yyDSTmode = DSTon;
}
| tZONE {
yyTimezone = $1;
if (yyTimezone > HOUR( 12)) yyTimezone -= HOUR(100);
yyDSTmode = DSToff;
}
| tDAYZONE {
yyTimezone = $1;
yyDSTmode = DSTon;
}
| sign tUNUMBER {
yyTimezone = -$1*($2 % 100 + ($2 / 100) * 60);
yyDSTmode = DSToff;
}
;
day : tDAY {
yyDayOrdinal = 1;
yyDayNumber = $1;
}
| tDAY ',' {
|
| ︙ | ︙ | |||
382 383 384 385 386 387 388 |
}
| tNEXT tUNUMBER tMONTH {
yyMonthOrdinal = $2;
yyMonth = $3;
}
;
| > > > > > > > > > > | | | | 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 |
}
| tNEXT tUNUMBER tMONTH {
yyMonthOrdinal = $2;
yyMonth = $3;
}
;
iso : tUNUMBER '-' tUNUMBER '-' tUNUMBER tZONE
tUNUMBER ':' tUNUMBER ':' tUNUMBER {
if ($6 != HOUR( 7) + HOUR(100)) YYABORT;
yyYear = $1;
yyMonth = $3;
yyDay = $5;
yyHour = $7;
yyMinutes = $9;
yySeconds = $11;
}
| tISOBASE tZONE tISOBASE {
if ($2 != HOUR( 7) + HOUR(100)) YYABORT;
yyYear = $1 / 10000;
yyMonth = ($1 % 10000)/100;
yyDay = $1 % 100;
yyHour = $3 / 10000;
yyMinutes = ($3 % 10000)/100;
yySeconds = $3 % 100;
}
| tISOBASE tZONE tUNUMBER ':' tUNUMBER ':' tUNUMBER {
if ($2 != HOUR( 7) + HOUR(100)) YYABORT;
yyYear = $1 / 10000;
yyMonth = ($1 % 10000)/100;
yyDay = $1 % 100;
yyHour = $3;
yyMinutes = $5;
yySeconds = $7;
}
|
| ︙ | ︙ | |||
671 672 673 674 675 676 677 |
};
/*
* Military timezone table.
*/
static const TABLE MilitaryTable[] = {
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 |
};
/*
* Military timezone table.
*/
static const TABLE MilitaryTable[] = {
{ "a", tZONE, -HOUR( 1) + HOUR(100) },
{ "b", tZONE, -HOUR( 2) + HOUR(100) },
{ "c", tZONE, -HOUR( 3) + HOUR(100) },
{ "d", tZONE, -HOUR( 4) + HOUR(100) },
{ "e", tZONE, -HOUR( 5) + HOUR(100) },
{ "f", tZONE, -HOUR( 6) + HOUR(100) },
{ "g", tZONE, -HOUR( 7) + HOUR(100) },
{ "h", tZONE, -HOUR( 8) + HOUR(100) },
{ "i", tZONE, -HOUR( 9) + HOUR(100) },
{ "k", tZONE, -HOUR(10) + HOUR(100) },
{ "l", tZONE, -HOUR(11) + HOUR(100) },
{ "m", tZONE, -HOUR(12) + HOUR(100) },
{ "n", tZONE, HOUR( 1) + HOUR(100) },
{ "o", tZONE, HOUR( 2) + HOUR(100) },
{ "p", tZONE, HOUR( 3) + HOUR(100) },
{ "q", tZONE, HOUR( 4) + HOUR(100) },
{ "r", tZONE, HOUR( 5) + HOUR(100) },
{ "s", tZONE, HOUR( 6) + HOUR(100) },
{ "t", tZONE, HOUR( 7) + HOUR(100) },
{ "u", tZONE, HOUR( 8) + HOUR(100) },
{ "v", tZONE, HOUR( 9) + HOUR(100) },
{ "w", tZONE, HOUR( 10) + HOUR(100) },
{ "x", tZONE, HOUR( 11) + HOUR(100) },
{ "y", tZONE, HOUR( 12) + HOUR(100) },
{ "z", tZONE, HOUR( 0) + HOUR(100) },
{ NULL, 0, 0 }
};
/*
* Dump error messages in the bit bucket.
*/
static void
TclDateerror(
YYLTYPE* location,
DateInfo* infoPtr,
const char *s)
{
Tcl_Obj* t;
Tcl_AppendToObj(infoPtr->messages, infoPtr->separatrix, -1);
Tcl_AppendToObj(infoPtr->messages, s, -1);
Tcl_AppendToObj(infoPtr->messages, " (characters ", -1);
TclNewIntObj(t, location->first_column);
Tcl_IncrRefCount(t);
Tcl_AppendObjToObj(infoPtr->messages, t);
Tcl_DecrRefCount(t);
Tcl_AppendToObj(infoPtr->messages, "-", -1);
TclNewIntObj(t, location->last_column);
Tcl_IncrRefCount(t);
Tcl_AppendObjToObj(infoPtr->messages, t);
Tcl_DecrRefCount(t);
Tcl_AppendToObj(infoPtr->messages, ")", -1);
infoPtr->separatrix = "\n";
}
|
| ︙ | ︙ | |||
893 894 895 896 897 898 899 |
char c;
char *p;
char buff[20];
int Count;
location->first_column = yyInput - info->dateStart;
for ( ; ; ) {
| | | 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 |
char c;
char *p;
char buff[20];
int Count;
location->first_column = yyInput - info->dateStart;
for ( ; ; ) {
while (TclIsSpaceProcM(*yyInput)) {
yyInput++;
}
if (isdigit(UCHAR(c = *yyInput))) { /* INTL: digit */
/*
* Convert the string into a number; count the number of digits.
*/
|
| ︙ | ︙ | |||
956 957 958 959 960 961 962 |
}
} while (Count > 0);
}
}
int
TclClockOldscanObjCmd(
| | < | | 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 |
}
} while (Count > 0);
}
}
int
TclClockOldscanObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Count of paraneters */
Tcl_Obj *const *objv) /* Parameters */
{
Tcl_Obj *result, *resultElement;
int yr, mo, da;
DateInfo dateInfo;
DateInfo* info = &dateInfo;
int status;
if (objc != 5) {
Tcl_WrongNumArgs(interp, 1, objv,
"stringToParse baseYear baseMonth baseDay" );
return TCL_ERROR;
}
yyInput = 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;
|
| ︙ | ︙ |
Changes to generic/tclIO.c.
| ︙ | ︙ | |||
3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 |
statePtr->nextCSPtr = NULL;
/*
* TIP #218, Channel Thread Actions
*/
ChanThreadAction((Channel *) chan, TCL_CHANNEL_THREAD_REMOVE);
}
void
Tcl_CutChannel(
Tcl_Channel chan) /* The channel being added. Must not be
* referenced in any interpreter. */
{
| > > > | 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 |
statePtr->nextCSPtr = NULL;
/*
* TIP #218, Channel Thread Actions
*/
ChanThreadAction((Channel *) chan, TCL_CHANNEL_THREAD_REMOVE);
/* Channel is not managed by any thread */
statePtr->managingThread = NULL;
}
void
Tcl_CutChannel(
Tcl_Channel chan) /* The channel being added. Must not be
* referenced in any interpreter. */
{
|
| ︙ | ︙ | |||
3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 |
* TIP #218, Channel Thread Actions
* For all transformations and the base channel.
*/
for (; chanPtr != NULL ; chanPtr = chanPtr->upChanPtr) {
ChanThreadAction(chanPtr, TCL_CHANNEL_THREAD_REMOVE);
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_SpliceChannel --
* SpliceChannel --
| > > > | 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 |
* TIP #218, Channel Thread Actions
* For all transformations and the base channel.
*/
for (; chanPtr != NULL ; chanPtr = chanPtr->upChanPtr) {
ChanThreadAction(chanPtr, TCL_CHANNEL_THREAD_REMOVE);
}
/* Channel is not managed by any thread */
statePtr->managingThread = NULL;
}
/*
*----------------------------------------------------------------------
*
* Tcl_SpliceChannel --
* SpliceChannel --
|
| ︙ | ︙ | |||
4002 4003 4004 4005 4006 4007 4008 |
statePtr = ((Channel *) chan)->state;
chanPtr = statePtr->topChanPtr;
if (CheckChannelErrors(statePtr, TCL_WRITABLE) != 0) {
return TCL_IO_FAILURE;
}
| | | 4008 4009 4010 4011 4012 4013 4014 4015 4016 4017 4018 4019 4020 4021 4022 |
statePtr = ((Channel *) chan)->state;
chanPtr = statePtr->topChanPtr;
if (CheckChannelErrors(statePtr, TCL_WRITABLE) != 0) {
return TCL_IO_FAILURE;
}
if (srcLen == TCL_INDEX_NONE) {
srcLen = strlen(src);
}
if (WriteBytes(chanPtr, src, srcLen) == -1) {
return TCL_IO_FAILURE;
}
return srcLen;
}
|
| ︙ | ︙ | |||
4052 4053 4054 4055 4056 4057 4058 |
int errorCode;
size_t written;
if (CheckChannelErrors(statePtr, TCL_WRITABLE | CHANNEL_RAW_MODE) != 0) {
return TCL_IO_FAILURE;
}
| | | 4058 4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 4070 4071 4072 |
int errorCode;
size_t written;
if (CheckChannelErrors(statePtr, TCL_WRITABLE | CHANNEL_RAW_MODE) != 0) {
return TCL_IO_FAILURE;
}
if (srcLen == TCL_INDEX_NONE) {
srcLen = strlen(src);
}
/*
* Go immediately to the driver, do all the error handling by ourselves.
* The code was stolen from 'FlushChannel'.
*/
|
| ︙ | ︙ | |||
4111 4112 4113 4114 4115 4116 4117 |
if (CheckChannelErrors(statePtr, TCL_WRITABLE) != 0) {
return TCL_IO_FAILURE;
}
chanPtr = statePtr->topChanPtr;
| | | 4117 4118 4119 4120 4121 4122 4123 4124 4125 4126 4127 4128 4129 4130 4131 |
if (CheckChannelErrors(statePtr, TCL_WRITABLE) != 0) {
return TCL_IO_FAILURE;
}
chanPtr = statePtr->topChanPtr;
if (len == TCL_INDEX_NONE) {
len = strlen(src);
}
if (statePtr->encoding) {
return WriteChars(chanPtr, src, len);
}
/*
|
| ︙ | ︙ | |||
5813 5814 5815 5816 5817 5818 5819 |
#define UTF_EXPANSION_FACTOR 1024
int factor = UTF_EXPANSION_FACTOR;
binaryMode = (encoding == NULL)
&& (statePtr->inputTranslation == TCL_TRANSLATE_LF)
&& (statePtr->inEofChar == '\0');
| | > > > > | 5819 5820 5821 5822 5823 5824 5825 5826 5827 5828 5829 5830 5831 5832 5833 5834 5835 5836 5837 |
#define UTF_EXPANSION_FACTOR 1024
int factor = UTF_EXPANSION_FACTOR;
binaryMode = (encoding == NULL)
&& (statePtr->inputTranslation == TCL_TRANSLATE_LF)
&& (statePtr->inEofChar == '\0');
if (appendFlag) {
if (binaryMode && (NULL == TclGetBytesFromObj(NULL, objPtr, NULL))) {
binaryMode = 0;
}
} else {
if (binaryMode) {
Tcl_SetByteArrayLength(objPtr, 0);
} else {
Tcl_SetObjLength(objPtr, 0);
/*
* We're going to access objPtr->bytes directly, so we must ensure
|
| ︙ | ︙ | |||
7653 7654 7655 7656 7657 7658 7659 |
}
if (Tcl_SplitList(interp, Tcl_DStringValue(&ds),
&argc, &argv) != TCL_OK) {
Tcl_Panic("malformed option list in channel driver");
}
Tcl_ResetResult(interp);
errObj = Tcl_ObjPrintf("bad option \"%s\": should be one of ",
| | | 7663 7664 7665 7666 7667 7668 7669 7670 7671 7672 7673 7674 7675 7676 7677 |
}
if (Tcl_SplitList(interp, Tcl_DStringValue(&ds),
&argc, &argv) != TCL_OK) {
Tcl_Panic("malformed option list in channel driver");
}
Tcl_ResetResult(interp);
errObj = Tcl_ObjPrintf("bad option \"%s\": should be one of ",
optionName ? optionName : "");
argc--;
for (i = 0; i < argc; i++) {
Tcl_AppendPrintfToObj(errObj, "-%s, ", argv[i]);
}
Tcl_AppendPrintfToObj(errObj, "or -%s", argv[i]);
Tcl_SetObjResult(interp, errObj);
Tcl_DStringFree(&ds);
|
| ︙ | ︙ | |||
8340 8341 8342 8343 8344 8345 8346 8347 8348 8349 8350 8351 8352 8353 |
* Now call the channel handlers as usual.
*
* Preserve the channel struct in case the script closes it.
*/
TclChannelPreserve((Tcl_Channel)channel);
Tcl_Preserve(statePtr);
/*
* If we are flushing in the background, be sure to call FlushChannel for
* writable events. Note that we have to discard the writable event so we
* don't call any write handlers before the flush is complete.
*/
| > > > > > > > | 8350 8351 8352 8353 8354 8355 8356 8357 8358 8359 8360 8361 8362 8363 8364 8365 8366 8367 8368 8369 8370 |
* Now call the channel handlers as usual.
*
* Preserve the channel struct in case the script closes it.
*/
TclChannelPreserve((Tcl_Channel)channel);
Tcl_Preserve(statePtr);
/*
* Avoid processing if the channel owner has been changed.
*/
if (statePtr->managingThread != Tcl_GetCurrentThread()) {
goto done;
}
/*
* If we are flushing in the background, be sure to call FlushChannel for
* writable events. Note that we have to discard the writable event so we
* don't call any write handlers before the flush is complete.
*/
|
| ︙ | ︙ | |||
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 |
if ((chPtr->mask & mask) != 0) {
nh.nextHandlerPtr = chPtr->nextPtr;
chPtr->proc(chPtr->clientData, chPtr->mask & mask);
chPtr = nh.nextHandlerPtr;
} else {
chPtr = chPtr->nextPtr;
}
}
/*
* Update the notifier interest, since it may have changed after invoking
* event handlers. Skip that if the channel was deleted in the call to the
* channel handler.
*/
if (chanPtr->typePtr != NULL) {
/*
* TODO: This call may not be needed. If a handler induced a
* change in interest, that handler should have made its own
* UpdateInterest() call, one would think.
*/
UpdateInterest(chanPtr);
}
Tcl_Release(statePtr);
TclChannelRelease(channel);
tsdPtr->nestedHandlerPtr = nh.nestedHandlerPtr;
}
/*
| > > > > > > > > | 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 |
if ((chPtr->mask & mask) != 0) {
nh.nextHandlerPtr = chPtr->nextPtr;
chPtr->proc(chPtr->clientData, chPtr->mask & mask);
chPtr = nh.nextHandlerPtr;
} else {
chPtr = chPtr->nextPtr;
}
/*
* Stop if the channel owner has been changed in-between.
*/
if (chanPtr->state->managingThread != Tcl_GetCurrentThread()) {
goto done;
}
}
/*
* Update the notifier interest, since it may have changed after invoking
* event handlers. Skip that if the channel was deleted in the call to the
* channel handler.
*/
if (chanPtr->typePtr != NULL) {
/*
* TODO: This call may not be needed. If a handler induced a
* change in interest, that handler should have made its own
* UpdateInterest() call, one would think.
*/
UpdateInterest(chanPtr);
}
done:
Tcl_Release(statePtr);
TclChannelRelease(channel);
tsdPtr->nestedHandlerPtr = nh.nestedHandlerPtr;
}
/*
|
| ︙ | ︙ | |||
8890 8891 8892 8893 8894 8895 8896 8897 8898 8899 8900 8901 8902 8903 |
/* The channel for which this handler is
* registered. */
Tcl_Interp *interp = esPtr->interp;
/* Interpreter in which to eval the script. */
int mask = esPtr->mask;
int result; /* Result of call to eval script. */
/*
* We must preserve the interpreter so we can report errors on it later.
* Note that we do not need to preserve the channel because that is done
* by Tcl_NotifyChannel before calling channel handlers.
*/
Tcl_Preserve(interp);
| > > > > > | 8915 8916 8917 8918 8919 8920 8921 8922 8923 8924 8925 8926 8927 8928 8929 8930 8931 8932 8933 |
/* The channel for which this handler is
* registered. */
Tcl_Interp *interp = esPtr->interp;
/* Interpreter in which to eval the script. */
int mask = esPtr->mask;
int result; /* Result of call to eval script. */
/*
* Be sure event executed in managed channel (covering bugs similar [f583715154]).
*/
assert(chanPtr->state->managingThread == Tcl_GetCurrentThread());
/*
* We must preserve the interpreter so we can report errors on it later.
* Note that we do not need to preserve the channel because that is done
* by Tcl_NotifyChannel before calling channel handlers.
*/
Tcl_Preserve(interp);
|
| ︙ | ︙ | |||
9599 9600 9601 9602 9603 9604 9605 | * 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. */ | | | 9629 9630 9631 9632 9633 9634 9635 9636 9637 9638 9639 9640 9641 9642 9643 |
* 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_INDEX_NONE) {
writeError:
if (interp) {
TclNewObj(errObj);
Tcl_AppendStringsToObj(errObj, "error writing \"",
Tcl_GetChannelName(outChan), "\": ", NULL);
if (msg != NULL) {
Tcl_AppendObjToObj(errObj, msg);
|
| ︙ | ︙ |
Changes to generic/tclIORChan.c.
| ︙ | ︙ | |||
1336 1337 1338 1339 1340 1341 1342 |
*/
*errorCodePtr = -p.base.code;
} else {
PassReceivedError(rcPtr->chan, &p);
*errorCodePtr = EINVAL;
}
| | | | 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 |
*/
*errorCodePtr = -p.base.code;
} else {
PassReceivedError(rcPtr->chan, &p);
*errorCodePtr = EINVAL;
}
p.input.toRead = TCL_INDEX_NONE;
} else {
*errorCodePtr = EOK;
}
return p.input.toRead;
}
#endif
/* ASSERT: rcPtr->method & FLAG(METH_READ) */
/* ASSERT: rcPtr->mode & TCL_READABLE */
Tcl_Preserve(rcPtr);
TclNewIntObj(toReadObj, toRead);
Tcl_IncrRefCount(toReadObj);
if (InvokeTclMethod(rcPtr, METH_READ, toReadObj, NULL, &resObj)!=TCL_OK) {
int code = ErrnoReturn(rcPtr, resObj);
if (code < 0) {
*errorCodePtr = -code;
|
| ︙ | ︙ | |||
3012 3013 3014 3015 3016 3017 3018 |
Tcl_GetChannelName(rcPtr->chan));
Tcl_DeleteHashEntry(hPtr);
MarkDead(rcPtr);
break;
}
case ForwardedInput: {
| | > > | | 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 |
Tcl_GetChannelName(rcPtr->chan));
Tcl_DeleteHashEntry(hPtr);
MarkDead(rcPtr);
break;
}
case ForwardedInput: {
Tcl_Obj *toReadObj;
TclNewIntObj(toReadObj, paramPtr->input.toRead);
Tcl_IncrRefCount(toReadObj);
Tcl_Preserve(rcPtr);
if (InvokeTclMethod(rcPtr, METH_READ, toReadObj, NULL, &resObj)!=TCL_OK){
int code = ErrnoReturn(rcPtr, resObj);
if (code < 0) {
paramPtr->base.code = code;
|
| ︙ | ︙ |
Changes to generic/tclIORTrans.c.
| ︙ | ︙ | |||
2550 2551 2552 2553 2554 2555 2556 |
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);
| | | 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 |
case ForwardedInput: {
Tcl_Obj *bufObj = Tcl_NewByteArrayObj((unsigned char *)
paramPtr->transform.buf, paramPtr->transform.size);
Tcl_IncrRefCount(bufObj);
if (InvokeTclMethod(rtPtr, "read", bufObj, NULL, &resObj) != TCL_OK) {
ForwardSetObjError(paramPtr, resObj);
paramPtr->transform.size = TCL_INDEX_NONE;
} else {
/*
* Process a regular return. Contains the transformation result.
* Sent it back to the request originator.
*/
size_t bytec = 0; /* Number of returned bytes */
|
| ︙ | ︙ | |||
2584 2585 2586 2587 2588 2589 2590 |
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);
| | | 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 |
case ForwardedOutput: {
Tcl_Obj *bufObj = Tcl_NewByteArrayObj((unsigned char *)
paramPtr->transform.buf, paramPtr->transform.size);
Tcl_IncrRefCount(bufObj);
if (InvokeTclMethod(rtPtr, "write", bufObj, NULL, &resObj) != TCL_OK) {
ForwardSetObjError(paramPtr, resObj);
paramPtr->transform.size = TCL_INDEX_NONE;
} else {
/*
* Process a regular return. Contains the transformation result.
* Sent it back to the request originator.
*/
size_t bytec = 0; /* Number of returned bytes */
|
| ︙ | ︙ | |||
2614 2615 2616 2617 2618 2619 2620 |
Tcl_DecrRefCount(bufObj);
break;
}
case ForwardedDrain:
if (InvokeTclMethod(rtPtr, "drain", NULL, NULL, &resObj) != TCL_OK) {
ForwardSetObjError(paramPtr, resObj);
| | | 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 |
Tcl_DecrRefCount(bufObj);
break;
}
case ForwardedDrain:
if (InvokeTclMethod(rtPtr, "drain", NULL, NULL, &resObj) != TCL_OK) {
ForwardSetObjError(paramPtr, resObj);
paramPtr->transform.size = TCL_INDEX_NONE;
} else {
/*
* Process a regular return. Contains the transformation result.
* Sent it back to the request originator.
*/
size_t bytec = 0; /* Number of returned bytes */
|
| ︙ | ︙ | |||
2640 2641 2642 2643 2644 2645 2646 |
}
}
break;
case ForwardedFlush:
if (InvokeTclMethod(rtPtr, "flush", NULL, NULL, &resObj) != TCL_OK) {
ForwardSetObjError(paramPtr, resObj);
| | | 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 |
}
}
break;
case ForwardedFlush:
if (InvokeTclMethod(rtPtr, "flush", NULL, NULL, &resObj) != TCL_OK) {
ForwardSetObjError(paramPtr, resObj);
paramPtr->transform.size = TCL_INDEX_NONE;
} else {
/*
* Process a regular return. Contains the transformation result.
* Sent it back to the request originator.
*/
size_t bytec = 0; /* Number of returned bytes */
|
| ︙ | ︙ |
Changes to generic/tclIndexObj.c.
| ︙ | ︙ | |||
714 715 716 717 718 719 720 |
for (i = 0; i < resultLength; i++) {
if (resultString[i] != elemString[i]) {
/*
* Adjust in case we stopped in the middle of a UTF char.
*/
| | | 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 |
for (i = 0; i < resultLength; i++) {
if (resultString[i] != elemString[i]) {
/*
* Adjust in case we stopped in the middle of a UTF char.
*/
resultLength = TclUtfPrev(&resultString[i+1],
resultString) - resultString;
break;
}
}
}
}
if (resultLength > 0) {
|
| ︙ | ︙ |
Changes to generic/tclInt.decls.
| ︙ | ︙ | |||
917 918 919 920 921 922 923 |
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 {
| | | 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 |
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(Tcl_Interp *interp, Tcl_Obj *procNameObj,
# int skip, ProcErrorProc *errorProc)
# }
declare 229 {
int TclPtrMakeUpvar(Tcl_Interp *interp, Var *otherP1Ptr,
const char *myName, int myFlags, int index)
}
declare 230 {
|
| ︙ | ︙ | |||
1017 1018 1019 1020 1021 1022 1023 |
declare 249 {
char *TclDoubleDigits(double dv, int ndigits, int flags,
int *decpt, int *signum, char **endPtr)
}
# TIP #285: Script cancellation support.
declare 250 {
| | | 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 |
declare 249 {
char *TclDoubleDigits(double dv, int ndigits, int flags,
int *decpt, int *signum, char **endPtr)
}
# TIP #285: Script cancellation support.
declare 250 {
void TclSetChildCancelFlags(Tcl_Interp *interp, int flags, int force)
}
# Allow extensions for optimization
declare 251 {
int TclRegisterLiteral(void *envPtr,
const char *bytes, size_t length, int flags)
}
|
| ︙ | ︙ | |||
1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 |
Tcl_Obj *basenameObj)
}
# TIP 542
declare 259 {
void TclAppendUnicodeToObj(Tcl_Obj *objPtr,
const Tcl_UniChar *unicode, size_t length)
}
##############################################################################
# Define the platform specific internal Tcl interface. These functions are
# only available on the designated platform.
interface tclIntPlat
################################
# Windows specific functions
declare 0 win {
| > > > > > > | | | | 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 |
Tcl_Obj *basenameObj)
}
# TIP 542
declare 259 {
void TclAppendUnicodeToObj(Tcl_Obj *objPtr,
const Tcl_UniChar *unicode, size_t length)
}
declare 260 {
unsigned char *TclGetBytesFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
size_t *lengthPtr)
}
##############################################################################
# Define the platform specific internal Tcl interface. These functions are
# only available on the designated platform.
interface tclIntPlat
################################
# Windows specific functions
declare 0 win {
void TclWinConvertError(int errCode)
}
# Removed in 9.0:
#declare 1 win {
# void TclWinConvertWSAError(int errCode)
#}
# Removed in 9.0:
#declare 2 win {
# struct servent *TclWinGetServByName(const char *nm,
# const char *proto)
#}
# Removed in 9.0:
#declare 3 win {
# int TclWinGetSockOpt(SOCKET s, int level, int optname,
# char *optval, int *optlen)
#}
declare 4 win {
void *TclWinGetTclInstance(void)
}
# new for 8.4.20+/8.5.12+ Cygwin only
declare 5 win {
int TclUnixWaitForFile(int fd, int mask, int timeout)
}
# Removed in 8.1:
# declare 5 win {
|
| ︙ | ︙ | |||
1173 1174 1175 1176 1177 1178 1179 |
declare 18 win {
TclFile TclpMakeFile(Tcl_Channel channel, int direction)
}
declare 19 win {
TclFile TclpOpenFile(const char *fname, int mode)
}
declare 20 win {
| | | 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 |
declare 18 win {
TclFile TclpMakeFile(Tcl_Channel channel, int direction)
}
declare 19 win {
TclFile TclpOpenFile(const char *fname, int mode)
}
declare 20 win {
void TclWinAddProcess(void *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 {
|
| ︙ | ︙ | |||
1240 1241 1242 1243 1244 1245 1246 |
int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe)
}
declare 4 unix {
int TclpCreateProcess(Tcl_Interp *interp, int argc,
const char **argv, TclFile inputFile, TclFile outputFile,
TclFile errorFile, Tcl_Pid *pidPtr)
}
| < | < < > > | 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 |
int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe)
}
declare 4 unix {
int TclpCreateProcess(Tcl_Interp *interp, int argc,
const char **argv, TclFile inputFile, TclFile outputFile,
TclFile errorFile, Tcl_Pid *pidPtr)
}
declare 5 unix {
int TclUnixWaitForFile_(int fd, int mask, int timeout)
}
declare 6 unix {
TclFile TclpMakeFile(Tcl_Channel channel, int direction)
}
declare 7 unix {
TclFile TclpOpenFile(const char *fname, int mode)
}
declare 8 unix {
|
| ︙ | ︙ | |||
1289 1290 1291 1292 1293 1294 1295 |
int TclUnixCopyFile(const char *src, const char *dst,
const Tcl_StatBuf *statBufPtr, int dontCopyAtts)
}
################################
# Mac OS X specific functions
| | | | | | > > > < < | 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 |
int TclUnixCopyFile(const char *src, const char *dst,
const Tcl_StatBuf *statBufPtr, int dontCopyAtts)
}
################################
# Mac OS X specific functions
declare 15 {unix macosx} {
int TclMacOSXGetFileAttribute(Tcl_Interp *interp, int objIndex,
Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr)
}
declare 16 {unix macosx} {
int TclMacOSXSetFileAttribute(Tcl_Interp *interp, int objIndex,
Tcl_Obj *fileName, Tcl_Obj *attributePtr)
}
declare 17 {unix macosx} {
int TclMacOSXCopyFileAttributes(const char *src, const char *dst,
const Tcl_StatBuf *statBufPtr)
}
declare 18 {unix macosx} {
int TclMacOSXMatchType(Tcl_Interp *interp, const char *pathName,
const char *fileName, Tcl_StatBuf *statBufPtr,
Tcl_GlobTypeData *types)
}
declare 19 {unix macosx} {
void TclMacOSXNotifierAddRunLoopMode(const void *runLoopMode)
}
declare 22 {unix macosx} {
TclFile TclpCreateTempFile_(const char *contents)
}
declare 29 {win unix} {
int TclWinCPUID(int index, int *regs)
}
# Added in 8.6; core of TclpOpenTemporaryFile
declare 30 {win unix} {
int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, Tcl_Obj *basenameObj,
Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj)
}
# Local Variables:
# mode: tcl
# End:
|
Changes to generic/tclInt.h.
| ︙ | ︙ | |||
1514 1515 1516 1517 1518 1519 1520 |
* 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
| | | 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 |
* 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_INDEX_NONE. */
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 {
|
| ︙ | ︙ | |||
1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 | #define CMD_IS_DELETED 0x01 #define CMD_TRACE_ACTIVE 0x02 #define CMD_HAS_EXEC_TRACES 0x04 #define CMD_COMPILES_EXPANDED 0x08 #define CMD_REDEF_IN_PROGRESS 0x10 #define CMD_VIA_RESOLVER 0x20 /* *---------------------------------------------------------------- * Data structures related to name resolution procedures. *---------------------------------------------------------------- */ | > | 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 | #define CMD_IS_DELETED 0x01 #define CMD_TRACE_ACTIVE 0x02 #define CMD_HAS_EXEC_TRACES 0x04 #define CMD_COMPILES_EXPANDED 0x08 #define CMD_REDEF_IN_PROGRESS 0x10 #define CMD_VIA_RESOLVER 0x20 #define CMD_DEAD 0x40 /* *---------------------------------------------------------------- * Data structures related to name resolution procedures. *---------------------------------------------------------------- */ |
| ︙ | ︙ | |||
1826 1827 1828 1829 1830 1831 1832 |
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
| | | 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 |
Namespace *globalNsPtr; /* The interpreter's global namespace. */
Tcl_HashTable *hiddenCmdTablePtr;
/* Hash table used by tclBasic.c to keep track
* of hidden commands on a per-interp
* basis. */
void *interpInfo; /* Information used by tclInterp.c to keep
* track of parent/child interps on a
* per-interp basis. */
void (*optimizer)(void *envPtr);
/*
* Information related to procedures and variables. See tclProc.c and
* tclVar.c for usage.
*/
|
| ︙ | ︙ | |||
2080 2081 2082 2083 2084 2085 2086 |
/*
* The thread-specific data ekeko: cache pointers or values that
* (a) do not change during the thread's lifetime
* (b) require access to TSD to determine at runtime
* (c) are accessed very often (e.g., at each command call)
*
* Note that these are the same for all interps in the same thread. They
| | | 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 |
/*
* The thread-specific data ekeko: cache pointers or values that
* (a) do not change during the thread's lifetime
* (b) require access to TSD to determine at runtime
* (c) are accessed very often (e.g., at each command call)
*
* Note that these are the same for all interps in the same thread. They
* just have to be initialised for the thread's parent interp, children
* inherit the value.
*
* They are used by the macros defined below.
*/
AllocCache *allocCache;
void *pendingObjDataPtr; /* Pointer to the Cache and PendingObjData
|
| ︙ | ︙ | |||
2455 2456 2457 2458 2459 2460 2461 |
#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) \
| | | < | | 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 |
#define TclGetIntFromObj(interp, objPtr, intPtr) \
(((objPtr)->typePtr == &tclIntType \
&& (objPtr)->internalRep.wideValue >= (Tcl_WideInt)(INT_MIN) \
&& (objPtr)->internalRep.wideValue <= (Tcl_WideInt)(INT_MAX)) \
? ((*(intPtr) = (int)(objPtr)->internalRep.wideValue), TCL_OK) \
: Tcl_GetIntFromObj((interp), (objPtr), (intPtr)))
#define TclGetIntForIndexM(interp, objPtr, endValue, idxPtr) \
((((objPtr)->typePtr == &tclIntType) && ((objPtr)->internalRep.wideValue >= 0) \
&& ((Tcl_WideUInt)(objPtr)->internalRep.wideValue <= (size_t)(endValue) + 1)) \
? ((*(idxPtr) = (size_t)(objPtr)->internalRep.wideValue), TCL_OK) \
: Tcl_GetIntForIndex((interp), (objPtr), (endValue), (idxPtr)))
/*
* Macro used to save a function call for common uses of
* Tcl_GetWideIntFromObj(). The ANSI C "prototype" is:
*
* MODULE_SCOPE int TclGetWideIntFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
|
| ︙ | ︙ | |||
2603 2604 2605 2606 2607 2608 2609 | typedef void (TclInitProcessGlobalValueProc)(char **valuePtr, size_t *lengthPtr, Tcl_Encoding *encodingPtr); /* * A ProcessGlobalValue struct exists for each internal value in Tcl that is * to be shared among several threads. Each thread sees a (Tcl_Obj) copy of | | | | | | | | | | 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 |
typedef void (TclInitProcessGlobalValueProc)(char **valuePtr, size_t *lengthPtr,
Tcl_Encoding *encodingPtr);
/*
* A ProcessGlobalValue struct exists for each internal value in Tcl that is
* to be shared among several threads. Each thread sees a (Tcl_Obj) copy of
* the value, and the gobal value is kept as a counted string, with epoch and
* mutex control. Each ProcessGlobalValue struct should be a static variable in
* some file.
*/
typedef struct ProcessGlobalValue {
size_t epoch; /* Epoch counter to detect changes in the
* global value. */
size_t numBytes; /* Length of the global string. */
char *value; /* The global string value. */
Tcl_Encoding encoding; /* system encoding when global string was
* initialized. */
TclInitProcessGlobalValueProc *proc;
/* A procedure to initialize the global string
* copy when a "get" request comes in before
* any "set" request has been received. */
Tcl_Mutex mutex; /* Enforce orderly access from multiple
* threads. */
Tcl_ThreadDataKey key; /* Key for per-thread data holding the
* (Tcl_Obj) copy for each thread. */
} ProcessGlobalValue;
|
| ︙ | ︙ | |||
2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 | #define TCL_PARSE_SCAN_PREFIXES 16 /* Use [scan] rules dealing with 0? * prefixes. */ #define TCL_PARSE_NO_WHITESPACE 32 /* Reject leading/trailing whitespace. */ #define TCL_PARSE_BINARY_ONLY 64 /* Parse binary even without prefix. */ /* *---------------------------------------------------------------------- * Type values TclGetNumberFromObj *---------------------------------------------------------------------- */ | > > | 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 | #define TCL_PARSE_SCAN_PREFIXES 16 /* Use [scan] rules dealing with 0? * prefixes. */ #define TCL_PARSE_NO_WHITESPACE 32 /* Reject leading/trailing whitespace. */ #define TCL_PARSE_BINARY_ONLY 64 /* Parse binary even without prefix. */ #define TCL_PARSE_NO_UNDERSCORE 128 /* Reject underscore digit separator */ /* *---------------------------------------------------------------------- * Type values TclGetNumberFromObj *---------------------------------------------------------------------- */ |
| ︙ | ︙ | |||
2953 2954 2955 2956 2957 2958 2959 | 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); | < < | 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 | 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, |
| ︙ | ︙ | |||
3009 3010 3011 3012 3013 3014 3015 | MODULE_SCOPE void TclInitEncodingSubsystem(void); MODULE_SCOPE void TclInitIOSubsystem(void); MODULE_SCOPE void TclInitLimitSupport(Tcl_Interp *interp); MODULE_SCOPE void TclInitNamespaceSubsystem(void); MODULE_SCOPE void TclInitNotifier(void); MODULE_SCOPE void TclInitObjSubsystem(void); MODULE_SCOPE int TclInterpReady(Tcl_Interp *interp); | < | | | 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 | MODULE_SCOPE void TclInitEncodingSubsystem(void); MODULE_SCOPE void TclInitIOSubsystem(void); MODULE_SCOPE void TclInitLimitSupport(Tcl_Interp *interp); MODULE_SCOPE void TclInitNamespaceSubsystem(void); MODULE_SCOPE void TclInitNotifier(void); MODULE_SCOPE void TclInitObjSubsystem(void); MODULE_SCOPE int TclInterpReady(Tcl_Interp *interp); MODULE_SCOPE int TclIsDigitProc(int byte); MODULE_SCOPE int TclIsBareword(int byte); MODULE_SCOPE Tcl_Obj * TclJoinPath(int elements, Tcl_Obj * const objv[], int forceRelative); MODULE_SCOPE int TclJoinThread(Tcl_ThreadId id, int *result); MODULE_SCOPE void TclLimitRemoveAllHandlers(Tcl_Interp *interp); MODULE_SCOPE Tcl_Obj * TclLindexList(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *argPtr); 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, size_t fromIdx, size_t 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[]); |
| ︙ | ︙ | |||
3086 3087 3088 3089 3090 3091 3092 | 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); | | | | 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 | 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 TclpGlobalLock(void); MODULE_SCOPE void TclpGlobalUnlock(void); MODULE_SCOPE int TclpMatchFiles(Tcl_Interp *interp, char *separators, Tcl_DString *dirPtr, char *pattern, char *tail); MODULE_SCOPE int TclpObjNormalizePath(Tcl_Interp *interp, Tcl_Obj *pathPtr, int nextCheckpoint); MODULE_SCOPE void TclpNativeJoinPath(Tcl_Obj *prefix, const char *joining); MODULE_SCOPE Tcl_Obj * TclpNativeSplitPath(Tcl_Obj *pathPtr, int *lenPtr); MODULE_SCOPE Tcl_PathType TclpGetNativePathType(Tcl_Obj *pathPtr, |
| ︙ | ︙ | |||
3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 | MODULE_SCOPE const char*TclGetCommandTypeName(Tcl_Command command); MODULE_SCOPE void TclRegisterCommandTypeName( Tcl_ObjCmdProc *implementationProc, const char *nameStr); MODULE_SCOPE int TclUtfCmp(const char *cs, const char *ct); MODULE_SCOPE int TclUtfCasecmp(const char *cs, const char *ct); MODULE_SCOPE size_t TclUtfCount(int ch); 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 | > > > > > > > > > > > > > | 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 |
MODULE_SCOPE const char*TclGetCommandTypeName(Tcl_Command command);
MODULE_SCOPE void TclRegisterCommandTypeName(
Tcl_ObjCmdProc *implementationProc,
const char *nameStr);
MODULE_SCOPE int TclUtfCmp(const char *cs, const char *ct);
MODULE_SCOPE int TclUtfCasecmp(const char *cs, const char *ct);
MODULE_SCOPE size_t TclUtfCount(int ch);
#if TCL_UTF_MAX > 3
# define TclUtfToUCS4 Tcl_UtfToUniChar
# define TclUniCharToUCS4(src, ptr) (*ptr = *(src),1)
# define TclUCS4Complete Tcl_UtfCharComplete
# define TclChar16Complete(src, length) (((unsigned)((unsigned char)*(src) - 0xF0) < 5) \
? ((length) >= 3) : Tcl_UtfCharComplete((src), (length)))
#else
MODULE_SCOPE int TclUtfToUCS4(const char *src, int *ucs4Ptr);
MODULE_SCOPE int TclUniCharToUCS4(const Tcl_UniChar *src, int *ucs4Ptr);
# define TclUCS4Complete(src, length) (((unsigned)((unsigned char)*(src) - 0xF0) < 5) \
? ((length) >= 4) : Tcl_UtfCharComplete((src), (length)))
# define TclChar16Complete Tcl_UtfCharComplete
#endif
MODULE_SCOPE Tcl_Obj * TclpNativeToNormalized(void *clientData);
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
|
| ︙ | ︙ | |||
3214 3215 3216 3217 3218 3219 3220 | # 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); | | | > > > > > > > > > > | 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 | # endif #endif MODULE_SCOPE Tcl_WideInt TclpGetMicroseconds(void); MODULE_SCOPE int TclZlibInit(Tcl_Interp *interp); MODULE_SCOPE void * TclpThreadCreateKey(void); MODULE_SCOPE void TclpThreadDeleteKey(void *keyPtr); MODULE_SCOPE void TclpThreadSetGlobalTSD(void *tsdKeyPtr, void *ptr); MODULE_SCOPE void * TclpThreadGetGlobalTSD(void *tsdKeyPtr); MODULE_SCOPE void TclErrorStackResetIf(Tcl_Interp *interp, const char *msg, size_t length); /* Tip 430 */ MODULE_SCOPE int TclZipfs_Init(Tcl_Interp *interp); /* * Many parsing tasks need a common definition of whitespace. * Use this routine and macro to achieve that and place * optimization (fragile on changes) in one place. */ MODULE_SCOPE int TclIsSpaceProc(int byte); # define TclIsSpaceProcM(byte) \ (((byte) > 0x20) ? 0 : TclIsSpaceProc(byte)) /* *---------------------------------------------------------------- * Command procedures in the generic core: *---------------------------------------------------------------- */ MODULE_SCOPE int Tcl_AfterObjCmd(void *clientData, |
| ︙ | ︙ | |||
3990 3991 3992 3993 3994 3995 3996 | /* * 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); | | | | 4012 4013 4014 4015 4016 4017 4018 4019 4020 4021 4022 4023 4024 4025 4026 4027 4028 | /* * Routines that provide the [string] ensemble functionality. Possible * candidates for public interface. */ MODULE_SCOPE Tcl_Obj * TclStringCat(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int flags); MODULE_SCOPE Tcl_Obj * TclStringFirst(Tcl_Obj *needle, Tcl_Obj *haystack, size_t start); MODULE_SCOPE Tcl_Obj * TclStringLast(Tcl_Obj *needle, Tcl_Obj *haystack, size_t last); MODULE_SCOPE Tcl_Obj * TclStringRepeat(Tcl_Interp *interp, Tcl_Obj *objPtr, size_t count, int flags); MODULE_SCOPE Tcl_Obj * TclStringReplace(Tcl_Interp *interp, Tcl_Obj *objPtr, size_t first, size_t count, Tcl_Obj *insertPtr, int flags); MODULE_SCOPE Tcl_Obj * TclStringReverse(Tcl_Obj *objPtr, int flags); |
| ︙ | ︙ | |||
4196 4197 4198 4199 4200 4201 4202 |
(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
| | | | 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 |
(objPtr)->length = 0; \
(objPtr)->typePtr = NULL; \
TCL_DTRACE_OBJ_CREATE(objPtr)
/*
* Invalidate the string rep first so we can use the bytes value for our
* pointer chain, and signal an obj deletion (as opposed to shimmering) with
* 'length == TCL_INDEX_NONE'.
* 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_INDEX_NONE; \
TclFreeObjStorage(objPtr); \
TclIncrObjsFreed(); \
} else { \
TclFreeObj(objPtr); \
} \
}
|
| ︙ | ︙ | |||
4408 4409 4410 4411 4412 4413 4414 |
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) {
| | | | | 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 |
Tcl_UniChar *response = Tcl_GetUnicodeFromObj(objPtr, NULL);
*(lenPtr) = *((size_t *) (objPtr)->internalRep.twoPtrValue.ptr1);
return response;
}
static inline unsigned char *TclGetByteArrayFromObj(Tcl_Obj *objPtr, size_t *lenPtr) {
unsigned char *response = Tcl_GetByteArrayFromObj(objPtr, NULL);
if (response) {
*(lenPtr) = *((size_t *) (objPtr)->internalRep.twoPtrValue.ptr1 + 1);
}
return response;
}
#else
#define TclGetStringFromObj(objPtr, lenPtr) \
(((objPtr)->bytes \
? NULL : Tcl_GetString((objPtr)), \
*(lenPtr) = (objPtr)->length, (objPtr)->bytes))
#define TclGetUnicodeFromObj(objPtr, lenPtr) \
(Tcl_GetUnicodeFromObj((objPtr), NULL), \
*(lenPtr) = *((size_t *) (objPtr)->internalRep.twoPtrValue.ptr1), \
Tcl_GetUnicodeFromObj((objPtr), NULL))
#define TclGetByteArrayFromObj(objPtr, lenPtr) \
(Tcl_GetByteArrayFromObj((objPtr), NULL) ? \
(*(lenPtr) = *((size_t *) (objPtr)->internalRep.twoPtrValue.ptr1 + 1), \
(unsigned char *)(((size_t *) (objPtr)->internalRep.twoPtrValue.ptr1) + 3)) : NULL)
#endif
/*
*----------------------------------------------------------------
* 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:
|
| ︙ | ︙ | |||
4509 4510 4511 4512 4513 4514 4515 |
int bignumPayload = \
PTR2INT(bignumObj->internalRep.twoPtrValue.ptr2); \
if (bignumPayload == -1) { \
(bignum) = *((mp_int *) bignumObj->internalRep.twoPtrValue.ptr1); \
} else { \
(bignum).dp = (mp_digit *)bignumObj->internalRep.twoPtrValue.ptr1; \
(bignum).sign = bignumPayload >> 30; \
| | | | 4531 4532 4533 4534 4535 4536 4537 4538 4539 4540 4541 4542 4543 4544 4545 4546 |
int bignumPayload = \
PTR2INT(bignumObj->internalRep.twoPtrValue.ptr2); \
if (bignumPayload == -1) { \
(bignum) = *((mp_int *) bignumObj->internalRep.twoPtrValue.ptr1); \
} else { \
(bignum).dp = (mp_digit *)bignumObj->internalRep.twoPtrValue.ptr1; \
(bignum).sign = bignumPayload >> 30; \
(bignum).alloc = (bignumPayload >> 15) & 0x7FFF; \
(bignum).used = bignumPayload & 0x7FFF; \
} \
} while (0)
/*
*----------------------------------------------------------------
* Macros used by the Tcl core to grow Tcl_Token arrays. They use the same
* growth algorithm as used in tclStringObj.c for growing strings. The ANSI C
|
| ︙ | ︙ | |||
4599 4600 4601 4602 4603 4604 4605 | * * MODULE_SCOPE int TclUtfToUniChar(const char *string, Tcl_UniChar *ch); *---------------------------------------------------------------- */ #if TCL_UTF_MAX > 3 #define TclUtfToUniChar(str, chPtr) \ | | | | 4621 4622 4623 4624 4625 4626 4627 4628 4629 4630 4631 4632 4633 4634 4635 4636 | * * MODULE_SCOPE int TclUtfToUniChar(const char *string, Tcl_UniChar *ch); *---------------------------------------------------------------- */ #if TCL_UTF_MAX > 3 #define TclUtfToUniChar(str, chPtr) \ (((UCHAR(*(str))) < 0x80) ? \ ((*(chPtr) = UCHAR(*(str))), 1) \ : Tcl_UtfToUniChar(str, chPtr)) #else #define TclUtfToUniChar(str, chPtr) \ ((((unsigned char) *(str)) < 0x80) ? \ ((*(chPtr) = (unsigned char) *(str)), 1) \ : Tcl_UtfToChar16(str, chPtr)) #endif |
| ︙ | ︙ | |||
4632 4633 4634 4635 4636 4637 4638 4639 4640 4641 4642 4643 4644 4645 |
while (_i && (*_str < 0xC0)) { _i--; _str++; } \
_count = (numBytes) - _i; \
if (_i) { \
_count += Tcl_NumUtfChars((bytes) + _count, _i); \
} \
(numChars) = _count; \
} while (0);
/*
*----------------------------------------------------------------
* Macro that encapsulates the logic that determines when it is safe to
* interpret a string as a byte array directly. In summary, the object must be
* a byte array and must not have a string representation (as the operations
* that it is used in are defined on strings, not byte arrays). Theoretically
| > > > > > | 4654 4655 4656 4657 4658 4659 4660 4661 4662 4663 4664 4665 4666 4667 4668 4669 4670 4671 4672 |
while (_i && (*_str < 0xC0)) { _i--; _str++; } \
_count = (numBytes) - _i; \
if (_i) { \
_count += Tcl_NumUtfChars((bytes) + _count, _i); \
} \
(numChars) = _count; \
} while (0);
#define TclUtfPrev(src, start) \
(((src) < (start) + 2) ? (start) : \
((unsigned char) *((src) - 1)) < 0x80 ? (src) - 1 : \
Tcl_UtfPrev(src, start))
/*
*----------------------------------------------------------------
* Macro that encapsulates the logic that determines when it is safe to
* interpret a string as a byte array directly. In summary, the object must be
* a byte array and must not have a string representation (as the operations
* that it is used in are defined on strings, not byte arrays). Theoretically
|
| ︙ | ︙ | |||
4771 4772 4773 4774 4775 4776 4777 | * MODULE_SCOPE void TclNewStringObj(Tcl_Obj *objPtr, const char *s, size_t len); * MODULE_SCOPE void TclNewLiteralStringObj(Tcl_Obj*objPtr, const char *sLiteral); * *---------------------------------------------------------------- */ #ifndef TCL_MEM_DEBUG | | | | 4798 4799 4800 4801 4802 4803 4804 4805 4806 4807 4808 4809 4810 4811 4812 4813 4814 4815 4816 4817 4818 |
* MODULE_SCOPE void TclNewStringObj(Tcl_Obj *objPtr, const char *s, size_t len);
* MODULE_SCOPE void TclNewLiteralStringObj(Tcl_Obj*objPtr, const char *sLiteral);
*
*----------------------------------------------------------------
*/
#ifndef TCL_MEM_DEBUG
#define TclNewIntObj(objPtr, w) \
do { \
TclIncrObjsAllocated(); \
TclAllocObjStorage(objPtr); \
(objPtr)->refCount = 0; \
(objPtr)->bytes = NULL; \
(objPtr)->internalRep.wideValue = (Tcl_WideInt)(w); \
(objPtr)->typePtr = &tclIntType; \
TCL_DTRACE_OBJ_CREATE(objPtr); \
} while (0)
#define TclNewDoubleObj(objPtr, d) \
do { \
TclIncrObjsAllocated(); \
|
| ︙ | ︙ | |||
4960 4961 4962 4963 4964 4965 4966 |
#else /* TCL_MEM_DEBUG */
#define TclSmallAllocEx(interp, nbytes, memPtr) \
do { \
Tcl_Obj *_objPtr; \
TCL_CT_ASSERT((nbytes)<=sizeof(Tcl_Obj)); \
TclNewObj(_objPtr); \
| | | 4987 4988 4989 4990 4991 4992 4993 4994 4995 4996 4997 4998 4999 5000 5001 |
#else /* TCL_MEM_DEBUG */
#define TclSmallAllocEx(interp, nbytes, memPtr) \
do { \
Tcl_Obj *_objPtr; \
TCL_CT_ASSERT((nbytes)<=sizeof(Tcl_Obj)); \
TclNewObj(_objPtr); \
*(void **)&memPtr = (void *) _objPtr; \
} while (0)
#define TclSmallFreeEx(interp, memPtr) \
do { \
Tcl_Obj *_objPtr = (Tcl_Obj *) memPtr; \
_objPtr->bytes = NULL; \
_objPtr->typePtr = NULL; \
|
| ︙ | ︙ |
Changes to generic/tclIntDecls.h.
| ︙ | ︙ | |||
542 543 544 545 546 547 548 | EXTERN int TclCopyChannel(Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, Tcl_WideInt toRead, Tcl_Obj *cmdPtr); /* 249 */ EXTERN char * TclDoubleDigits(double dv, int ndigits, int flags, int *decpt, int *signum, char **endPtr); /* 250 */ | | | 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 | EXTERN int TclCopyChannel(Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, Tcl_WideInt toRead, Tcl_Obj *cmdPtr); /* 249 */ EXTERN char * TclDoubleDigits(double dv, int ndigits, int flags, int *decpt, int *signum, char **endPtr); /* 250 */ EXTERN void TclSetChildCancelFlags(Tcl_Interp *interp, int flags, int force); /* 251 */ EXTERN int TclRegisterLiteral(void *envPtr, const char *bytes, size_t length, int flags); /* 252 */ EXTERN Tcl_Obj * TclPtrGetVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, |
| ︙ | ︙ | |||
580 581 582 583 584 585 586 587 588 589 590 591 592 593 |
Tcl_PackageInitProc *safeInitProc);
/* 258 */
EXTERN Tcl_Obj * TclpCreateTemporaryDirectory(Tcl_Obj *dirObj,
Tcl_Obj *basenameObj);
/* 259 */
EXTERN void TclAppendUnicodeToObj(Tcl_Obj *objPtr,
const Tcl_UniChar *unicode, size_t length);
typedef struct TclIntStubs {
int magic;
void *hooks;
void (*reserved0)(void);
void (*reserved1)(void);
| > > > | 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 |
Tcl_PackageInitProc *safeInitProc);
/* 258 */
EXTERN Tcl_Obj * TclpCreateTemporaryDirectory(Tcl_Obj *dirObj,
Tcl_Obj *basenameObj);
/* 259 */
EXTERN void TclAppendUnicodeToObj(Tcl_Obj *objPtr,
const Tcl_UniChar *unicode, size_t length);
/* 260 */
EXTERN unsigned char * TclGetBytesFromObj(Tcl_Interp *interp,
Tcl_Obj *objPtr, size_t *lengthPtr);
typedef struct TclIntStubs {
int magic;
void *hooks;
void (*reserved0)(void);
void (*reserved1)(void);
|
| ︙ | ︙ | |||
835 836 837 838 839 840 841 |
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 */
| | > | 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 |
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 (*tclSetChildCancelFlags) (Tcl_Interp *interp, int flags, int force); /* 250 */
int (*tclRegisterLiteral) (void *envPtr, const char *bytes, size_t length, int flags); /* 251 */
Tcl_Obj * (*tclPtrGetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const int flags); /* 252 */
Tcl_Obj * (*tclPtrSetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr, const int flags); /* 253 */
Tcl_Obj * (*tclPtrIncrObjVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, const int flags); /* 254 */
int (*tclPtrObjMakeUpvar) (Tcl_Interp *interp, Tcl_Var otherPtr, Tcl_Obj *myNamePtr, int myFlags); /* 255 */
int (*tclPtrUnsetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const int flags); /* 256 */
void (*tclStaticPackage) (Tcl_Interp *interp, const char *pkgName, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc); /* 257 */
Tcl_Obj * (*tclpCreateTemporaryDirectory) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj); /* 258 */
void (*tclAppendUnicodeToObj) (Tcl_Obj *objPtr, const Tcl_UniChar *unicode, size_t length); /* 259 */
unsigned char * (*tclGetBytesFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, size_t *lengthPtr); /* 260 */
} TclIntStubs;
extern const TclIntStubs *tclIntStubsPtr;
#ifdef __cplusplus
}
#endif
|
| ︙ | ︙ | |||
1244 1245 1246 1247 1248 1249 1250 | (tclIntStubsPtr->tclInitRewriteEnsemble) /* 246 */ #define TclResetRewriteEnsemble \ (tclIntStubsPtr->tclResetRewriteEnsemble) /* 247 */ #define TclCopyChannel \ (tclIntStubsPtr->tclCopyChannel) /* 248 */ #define TclDoubleDigits \ (tclIntStubsPtr->tclDoubleDigits) /* 249 */ | | | > > | 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 | (tclIntStubsPtr->tclInitRewriteEnsemble) /* 246 */ #define TclResetRewriteEnsemble \ (tclIntStubsPtr->tclResetRewriteEnsemble) /* 247 */ #define TclCopyChannel \ (tclIntStubsPtr->tclCopyChannel) /* 248 */ #define TclDoubleDigits \ (tclIntStubsPtr->tclDoubleDigits) /* 249 */ #define TclSetChildCancelFlags \ (tclIntStubsPtr->tclSetChildCancelFlags) /* 250 */ #define TclRegisterLiteral \ (tclIntStubsPtr->tclRegisterLiteral) /* 251 */ #define TclPtrGetVar \ (tclIntStubsPtr->tclPtrGetVar) /* 252 */ #define TclPtrSetVar \ (tclIntStubsPtr->tclPtrSetVar) /* 253 */ #define TclPtrIncrObjVar \ (tclIntStubsPtr->tclPtrIncrObjVar) /* 254 */ #define TclPtrObjMakeUpvar \ (tclIntStubsPtr->tclPtrObjMakeUpvar) /* 255 */ #define TclPtrUnsetVar \ (tclIntStubsPtr->tclPtrUnsetVar) /* 256 */ #define TclStaticPackage \ (tclIntStubsPtr->tclStaticPackage) /* 257 */ #define TclpCreateTemporaryDirectory \ (tclIntStubsPtr->tclpCreateTemporaryDirectory) /* 258 */ #define TclAppendUnicodeToObj \ (tclIntStubsPtr->tclAppendUnicodeToObj) /* 259 */ #define TclGetBytesFromObj \ (tclIntStubsPtr->tclGetBytesFromObj) /* 260 */ #endif /* defined(USE_TCL_STUBS) */ /* !END!: Do not edit above this line. */ #if defined(USE_TCL_STUBS) #undef Tcl_StaticPackage |
| ︙ | ︙ |
Changes to generic/tclIntPlatDecls.h.
| ︙ | ︙ | |||
53 54 55 56 57 58 59 | /* 3 */ EXTERN int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe); /* 4 */ EXTERN int TclpCreateProcess(Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); | | > | > > > | > > > | > > > | > > > > | > > | > | | | 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 | /* 3 */ EXTERN int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe); /* 4 */ EXTERN int TclpCreateProcess(Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 5 */ EXTERN int TclUnixWaitForFile_(int fd, int mask, int timeout); /* 6 */ EXTERN TclFile TclpMakeFile(Tcl_Channel channel, int direction); /* 7 */ EXTERN TclFile TclpOpenFile(const char *fname, int mode); /* 8 */ EXTERN int TclUnixWaitForFile(int fd, int mask, int timeout); /* 9 */ EXTERN TclFile TclpCreateTempFile(const char *contents); /* Slot 10 is reserved */ /* Slot 11 is reserved */ /* Slot 12 is reserved */ /* Slot 13 is reserved */ /* 14 */ EXTERN int TclUnixCopyFile(const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 15 */ EXTERN int TclMacOSXGetFileAttribute(Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr); /* 16 */ EXTERN int TclMacOSXSetFileAttribute(Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj *attributePtr); /* 17 */ EXTERN int TclMacOSXCopyFileAttributes(const char *src, const char *dst, const Tcl_StatBuf *statBufPtr); /* 18 */ EXTERN int TclMacOSXMatchType(Tcl_Interp *interp, const char *pathName, const char *fileName, Tcl_StatBuf *statBufPtr, Tcl_GlobTypeData *types); /* 19 */ EXTERN void TclMacOSXNotifierAddRunLoopMode( const void *runLoopMode); /* Slot 20 is reserved */ /* Slot 21 is reserved */ /* 22 */ EXTERN TclFile TclpCreateTempFile_(const char *contents); /* Slot 23 is reserved */ /* Slot 24 is reserved */ /* Slot 25 is reserved */ /* Slot 26 is reserved */ /* Slot 27 is reserved */ /* Slot 28 is reserved */ /* 29 */ EXTERN int TclWinCPUID(int index, int *regs); /* 30 */ EXTERN int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); #endif /* UNIX */ #if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ /* 0 */ EXTERN void TclWinConvertError(int errCode); /* Slot 1 is reserved */ /* Slot 2 is reserved */ /* Slot 3 is reserved */ /* 4 */ EXTERN void * TclWinGetTclInstance(void); /* 5 */ EXTERN int TclUnixWaitForFile(int fd, int mask, int timeout); /* Slot 6 is reserved */ /* Slot 7 is reserved */ /* 8 */ EXTERN size_t TclpGetPid(Tcl_Pid pid); /* Slot 9 is reserved */ |
| ︙ | ︙ | |||
134 135 136 137 138 139 140 | const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 18 */ EXTERN TclFile TclpMakeFile(Tcl_Channel channel, int direction); /* 19 */ EXTERN TclFile TclpOpenFile(const char *fname, int mode); /* 20 */ | | | 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 | const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 18 */ EXTERN TclFile TclpMakeFile(Tcl_Channel channel, int direction); /* 19 */ EXTERN TclFile TclpOpenFile(const char *fname, int mode); /* 20 */ EXTERN void TclWinAddProcess(void *hProcess, size_t id); /* Slot 21 is reserved */ /* 22 */ EXTERN TclFile TclpCreateTempFile(const char *contents); /* Slot 23 is reserved */ /* 24 */ EXTERN char * TclWinNoBackslash(char *path); /* Slot 25 is reserved */ |
| ︙ | ︙ | |||
170 171 172 173 174 175 176 | /* 3 */ EXTERN int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe); /* 4 */ EXTERN int TclpCreateProcess(Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); | | > | 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 | /* 3 */ EXTERN int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe); /* 4 */ EXTERN int TclpCreateProcess(Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 5 */ EXTERN int TclUnixWaitForFile_(int fd, int mask, int timeout); /* 6 */ EXTERN TclFile TclpMakeFile(Tcl_Channel channel, int direction); /* 7 */ EXTERN TclFile TclpOpenFile(const char *fname, int mode); /* 8 */ EXTERN int TclUnixWaitForFile(int fd, int mask, int timeout); /* 9 */ |
| ︙ | ︙ | |||
209 210 211 212 213 214 215 | Tcl_StatBuf *statBufPtr, Tcl_GlobTypeData *types); /* 19 */ EXTERN void TclMacOSXNotifierAddRunLoopMode( const void *runLoopMode); /* Slot 20 is reserved */ /* Slot 21 is reserved */ | | > | 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 | Tcl_StatBuf *statBufPtr, Tcl_GlobTypeData *types); /* 19 */ EXTERN void TclMacOSXNotifierAddRunLoopMode( const void *runLoopMode); /* Slot 20 is reserved */ /* Slot 21 is reserved */ /* 22 */ EXTERN TclFile TclpCreateTempFile_(const char *contents); /* Slot 23 is reserved */ /* Slot 24 is reserved */ /* Slot 25 is reserved */ /* Slot 26 is reserved */ /* Slot 27 is reserved */ /* Slot 28 is reserved */ /* 29 */ |
| ︙ | ︙ | |||
234 235 236 237 238 239 240 |
#if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */
void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 0 */
int (*tclpCloseFile) (TclFile file); /* 1 */
Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 2 */
int (*tclpCreatePipe) (TclFile *readPipe, TclFile *writePipe); /* 3 */
int (*tclpCreateProcess) (Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 4 */
| | | | | | | | | | | | | | 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 |
#if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */
void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 0 */
int (*tclpCloseFile) (TclFile file); /* 1 */
Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 2 */
int (*tclpCreatePipe) (TclFile *readPipe, TclFile *writePipe); /* 3 */
int (*tclpCreateProcess) (Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 4 */
int (*tclUnixWaitForFile_) (int fd, int mask, int timeout); /* 5 */
TclFile (*tclpMakeFile) (Tcl_Channel channel, int direction); /* 6 */
TclFile (*tclpOpenFile) (const char *fname, int mode); /* 7 */
int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 8 */
TclFile (*tclpCreateTempFile) (const char *contents); /* 9 */
void (*reserved10)(void);
void (*reserved11)(void);
void (*reserved12)(void);
void (*reserved13)(void);
int (*tclUnixCopyFile) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 14 */
int (*tclMacOSXGetFileAttribute) (Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr); /* 15 */
int (*tclMacOSXSetFileAttribute) (Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj *attributePtr); /* 16 */
int (*tclMacOSXCopyFileAttributes) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr); /* 17 */
int (*tclMacOSXMatchType) (Tcl_Interp *interp, const char *pathName, const char *fileName, Tcl_StatBuf *statBufPtr, Tcl_GlobTypeData *types); /* 18 */
void (*tclMacOSXNotifierAddRunLoopMode) (const void *runLoopMode); /* 19 */
void (*reserved20)(void);
void (*reserved21)(void);
TclFile (*tclpCreateTempFile_) (const char *contents); /* 22 */
void (*reserved23)(void);
void (*reserved24)(void);
void (*reserved25)(void);
void (*reserved26)(void);
void (*reserved27)(void);
void (*reserved28)(void);
int (*tclWinCPUID) (int index, int *regs); /* 29 */
int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */
#endif /* UNIX */
#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */
void (*tclWinConvertError) (int errCode); /* 0 */
void (*reserved1)(void);
void (*reserved2)(void);
void (*reserved3)(void);
void * (*tclWinGetTclInstance) (void); /* 4 */
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) (void *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 */
void (*reserved28)(void);
int (*tclWinCPUID) (int index, int *regs); /* 29 */
int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 0 */
int (*tclpCloseFile) (TclFile file); /* 1 */
Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 2 */
int (*tclpCreatePipe) (TclFile *readPipe, TclFile *writePipe); /* 3 */
int (*tclpCreateProcess) (Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 4 */
int (*tclUnixWaitForFile_) (int fd, int mask, int timeout); /* 5 */
TclFile (*tclpMakeFile) (Tcl_Channel channel, int direction); /* 6 */
TclFile (*tclpOpenFile) (const char *fname, int mode); /* 7 */
int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 8 */
TclFile (*tclpCreateTempFile) (const char *contents); /* 9 */
void (*reserved10)(void);
void (*reserved11)(void);
void (*reserved12)(void);
void (*reserved13)(void);
int (*tclUnixCopyFile) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 14 */
int (*tclMacOSXGetFileAttribute) (Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr); /* 15 */
int (*tclMacOSXSetFileAttribute) (Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj *attributePtr); /* 16 */
int (*tclMacOSXCopyFileAttributes) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr); /* 17 */
int (*tclMacOSXMatchType) (Tcl_Interp *interp, const char *pathName, const char *fileName, Tcl_StatBuf *statBufPtr, Tcl_GlobTypeData *types); /* 18 */
void (*tclMacOSXNotifierAddRunLoopMode) (const void *runLoopMode); /* 19 */
void (*reserved20)(void);
void (*reserved21)(void);
TclFile (*tclpCreateTempFile_) (const char *contents); /* 22 */
void (*reserved23)(void);
void (*reserved24)(void);
void (*reserved25)(void);
void (*reserved26)(void);
void (*reserved27)(void);
void (*reserved28)(void);
int (*tclWinCPUID) (int index, int *regs); /* 29 */
|
| ︙ | ︙ | |||
352 353 354 355 356 357 358 | (tclIntPlatStubsPtr->tclpCloseFile) /* 1 */ #define TclpCreateCommandChannel \ (tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 2 */ #define TclpCreatePipe \ (tclIntPlatStubsPtr->tclpCreatePipe) /* 3 */ #define TclpCreateProcess \ (tclIntPlatStubsPtr->tclpCreateProcess) /* 4 */ | | > | | | | | > > > > > < > > | 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 | (tclIntPlatStubsPtr->tclpCloseFile) /* 1 */ #define TclpCreateCommandChannel \ (tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 2 */ #define TclpCreatePipe \ (tclIntPlatStubsPtr->tclpCreatePipe) /* 3 */ #define TclpCreateProcess \ (tclIntPlatStubsPtr->tclpCreateProcess) /* 4 */ #define TclUnixWaitForFile_ \ (tclIntPlatStubsPtr->tclUnixWaitForFile_) /* 5 */ #define TclpMakeFile \ (tclIntPlatStubsPtr->tclpMakeFile) /* 6 */ #define TclpOpenFile \ (tclIntPlatStubsPtr->tclpOpenFile) /* 7 */ #define TclUnixWaitForFile \ (tclIntPlatStubsPtr->tclUnixWaitForFile) /* 8 */ #define TclpCreateTempFile \ (tclIntPlatStubsPtr->tclpCreateTempFile) /* 9 */ /* Slot 10 is reserved */ /* Slot 11 is reserved */ /* Slot 12 is reserved */ /* Slot 13 is reserved */ #define TclUnixCopyFile \ (tclIntPlatStubsPtr->tclUnixCopyFile) /* 14 */ #define TclMacOSXGetFileAttribute \ (tclIntPlatStubsPtr->tclMacOSXGetFileAttribute) /* 15 */ #define TclMacOSXSetFileAttribute \ (tclIntPlatStubsPtr->tclMacOSXSetFileAttribute) /* 16 */ #define TclMacOSXCopyFileAttributes \ (tclIntPlatStubsPtr->tclMacOSXCopyFileAttributes) /* 17 */ #define TclMacOSXMatchType \ (tclIntPlatStubsPtr->tclMacOSXMatchType) /* 18 */ #define TclMacOSXNotifierAddRunLoopMode \ (tclIntPlatStubsPtr->tclMacOSXNotifierAddRunLoopMode) /* 19 */ /* Slot 20 is reserved */ /* Slot 21 is reserved */ #define TclpCreateTempFile_ \ (tclIntPlatStubsPtr->tclpCreateTempFile_) /* 22 */ /* Slot 23 is reserved */ /* Slot 24 is reserved */ /* Slot 25 is reserved */ /* Slot 26 is reserved */ /* Slot 27 is reserved */ /* Slot 28 is reserved */ #define TclWinCPUID \ |
| ︙ | ︙ | |||
449 450 451 452 453 454 455 | (tclIntPlatStubsPtr->tclpCloseFile) /* 1 */ #define TclpCreateCommandChannel \ (tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 2 */ #define TclpCreatePipe \ (tclIntPlatStubsPtr->tclpCreatePipe) /* 3 */ #define TclpCreateProcess \ (tclIntPlatStubsPtr->tclpCreateProcess) /* 4 */ | | > | 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 | (tclIntPlatStubsPtr->tclpCloseFile) /* 1 */ #define TclpCreateCommandChannel \ (tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 2 */ #define TclpCreatePipe \ (tclIntPlatStubsPtr->tclpCreatePipe) /* 3 */ #define TclpCreateProcess \ (tclIntPlatStubsPtr->tclpCreateProcess) /* 4 */ #define TclUnixWaitForFile_ \ (tclIntPlatStubsPtr->tclUnixWaitForFile_) /* 5 */ #define TclpMakeFile \ (tclIntPlatStubsPtr->tclpMakeFile) /* 6 */ #define TclpOpenFile \ (tclIntPlatStubsPtr->tclpOpenFile) /* 7 */ #define TclUnixWaitForFile \ (tclIntPlatStubsPtr->tclUnixWaitForFile) /* 8 */ #define TclpCreateTempFile \ |
| ︙ | ︙ | |||
476 477 478 479 480 481 482 | (tclIntPlatStubsPtr->tclMacOSXCopyFileAttributes) /* 17 */ #define TclMacOSXMatchType \ (tclIntPlatStubsPtr->tclMacOSXMatchType) /* 18 */ #define TclMacOSXNotifierAddRunLoopMode \ (tclIntPlatStubsPtr->tclMacOSXNotifierAddRunLoopMode) /* 19 */ /* Slot 20 is reserved */ /* Slot 21 is reserved */ | | > > > > > > > > > > > | 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 | (tclIntPlatStubsPtr->tclMacOSXCopyFileAttributes) /* 17 */ #define TclMacOSXMatchType \ (tclIntPlatStubsPtr->tclMacOSXMatchType) /* 18 */ #define TclMacOSXNotifierAddRunLoopMode \ (tclIntPlatStubsPtr->tclMacOSXNotifierAddRunLoopMode) /* 19 */ /* Slot 20 is reserved */ /* Slot 21 is reserved */ #define TclpCreateTempFile_ \ (tclIntPlatStubsPtr->tclpCreateTempFile_) /* 22 */ /* Slot 23 is reserved */ /* Slot 24 is reserved */ /* Slot 25 is reserved */ /* Slot 26 is reserved */ /* Slot 27 is reserved */ /* Slot 28 is reserved */ #define TclWinCPUID \ (tclIntPlatStubsPtr->tclWinCPUID) /* 29 */ #define TclUnixOpenTemporaryFile \ (tclIntPlatStubsPtr->tclUnixOpenTemporaryFile) /* 30 */ #endif /* MACOSX */ #endif /* defined(USE_TCL_STUBS) */ /* !END!: Do not edit above this line. */ #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLIMPORT #define TclWinConvertWSAError TclWinConvertError #undef TclpCreateTempFile_ #undef TclUnixWaitForFile_ #ifndef MAC_OSX_TCL /* not accessable on Win32/UNIX */ #undef TclMacOSXGetFileAttribute /* 15 */ #undef TclMacOSXSetFileAttribute /* 16 */ #undef TclMacOSXCopyFileAttributes /* 17 */ #undef TclMacOSXMatchType /* 18 */ #undef TclMacOSXNotifierAddRunLoopMode /* 19 */ #endif #if !defined(_WIN32) # undef TclpGetPid # define TclpGetPid(pid) ((size_t) (pid)) #endif #endif /* _TCLINTPLATDECLS */ |
Changes to generic/tclInterp.c.
| ︙ | ︙ | |||
2157 2158 2159 2160 2161 2162 2163 |
slavePtr = &((InterpInfo *) ((Interp *) interp)->interpInfo)->slave;
return slavePtr->masterInterp;
}
/*
*----------------------------------------------------------------------
*
| | | | 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 |
slavePtr = &((InterpInfo *) ((Interp *) interp)->interpInfo)->slave;
return slavePtr->masterInterp;
}
/*
*----------------------------------------------------------------------
*
* TclSetChildCancelFlags --
*
* This function marks all slave interpreters belonging to a given
* interpreter as being canceled or not canceled, depending on the
* provided flags.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
void
TclSetChildCancelFlags(
Tcl_Interp *interp, /* Set cancel flags of this interpreter. */
int flags, /* Collection of OR-ed bits that control
* the cancellation of the script. Only
* TCL_CANCEL_UNWIND is currently
* supported. */
int force) /* Non-zero to ignore numLevels for the purpose
* of resetting the cancellation flags. */
|
| ︙ | ︙ | |||
2216 2217 2218 2219 2220 2221 2222 | } /* * Now, recursively handle this for the slaves of this slave * interpreter. */ | | | 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 |
}
/*
* Now, recursively handle this for the slaves of this slave
* interpreter.
*/
TclSetChildCancelFlags((Tcl_Interp *) iPtr, flags, force);
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetInterpPath --
|
| ︙ | ︙ | |||
2246 2247 2248 2249 2250 2251 2252 | * None. * *---------------------------------------------------------------------- */ int Tcl_GetInterpPath( | | | | | | | 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 |
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_GetInterpPath(
Tcl_Interp *interp, /* Interpreter to start search from. */
Tcl_Interp *targetInterp) /* Interpreter to find. */
{
InterpInfo *iiPtr;
if (targetInterp == interp) {
Tcl_SetObjResult(interp, Tcl_NewObj());
return TCL_OK;
}
if (targetInterp == NULL) {
return TCL_ERROR;
}
iiPtr = (InterpInfo *) ((Interp *) targetInterp)->interpInfo;
if (Tcl_GetInterpPath(interp, iiPtr->slave.masterInterp) != TCL_OK){
return TCL_ERROR;
}
Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
Tcl_NewStringObj((const char *)Tcl_GetHashKey(&iiPtr->master.slaveTable,
iiPtr->slave.slaveEntryPtr), -1));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
2870 2871 2872 2873 2874 2875 2876 |
* TIP #285: If necessary, reset the cancellation flags for the slave
* interpreter now; otherwise, canceling a script in a master interpreter
* can result in a situation where a slave interpreter can no longer
* evaluate any scripts unless somebody calls the TclResetCancellation
* function for that particular Tcl_Interp.
*/
| | | 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 |
* TIP #285: If necessary, reset the cancellation flags for the slave
* interpreter now; otherwise, canceling a script in a master interpreter
* can result in a situation where a slave interpreter can no longer
* evaluate any scripts unless somebody calls the TclResetCancellation
* function for that particular Tcl_Interp.
*/
TclSetChildCancelFlags(slaveInterp, 0, 0);
Tcl_Preserve(slaveInterp);
Tcl_AllowExceptions(slaveInterp);
if (objc == 1) {
/*
* TIP #280: Make actual argument location available to eval'd script.
|
| ︙ | ︙ |
Changes to generic/tclLink.c.
| ︙ | ︙ | |||
907 908 909 910 911 912 913 |
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) {
| | | | | | 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 |
case TCL_LINK_CHARS:
value = (char *) TclGetStringFromObj(valueObj, &valueLength);
valueLength++; /* include end of string char */
if (valueLength > linkPtr->bytes) {
return (char *) "wrong size of char* value";
}
if (linkPtr->flags & LINK_ALLOC_LAST) {
memcpy(linkPtr->lastValue.aryPtr, value, valueLength);
memcpy(linkPtr->addr, value, valueLength);
} else {
linkPtr->lastValue.c = '\0';
LinkedVar(char) = linkPtr->lastValue.c;
}
return NULL;
case TCL_LINK_BINARY:
value = (char *) TclGetByteArrayFromObj(valueObj, &valueLength);
if (valueLength != linkPtr->bytes) {
return (char *) "wrong size of binary value";
}
if (linkPtr->flags & LINK_ALLOC_LAST) {
memcpy(linkPtr->lastValue.aryPtr, value, valueLength);
memcpy(linkPtr->addr, value, valueLength);
} else {
linkPtr->lastValue.uc = (unsigned char) *value;
LinkedVar(unsigned char) = linkPtr->lastValue.uc;
}
return NULL;
}
|
| ︙ | ︙ | |||
1184 1185 1186 1187 1188 1189 1190 |
}
break;
case TCL_LINK_ULONG:
if (linkPtr->flags & LINK_ALLOC_LAST) {
for (i=0; i < objc; i++) {
if (GetUWide(objv[i], &valueUWide)
| | | | 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 |
}
break;
case TCL_LINK_ULONG:
if (linkPtr->flags & LINK_ALLOC_LAST) {
for (i=0; i < objc; i++) {
if (GetUWide(objv[i], &valueUWide)
|| (valueUWide > ULONG_MAX)) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
ObjValue(linkPtr), TCL_GLOBAL_ONLY);
return (char *)
"variable array must have unsigned long value";
}
linkPtr->lastValue.ulPtr[i] = (unsigned long) valueUWide;
}
} else {
if (GetUWide(valueObj, &valueUWide)
|| (valueUWide > ULONG_MAX)) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
ObjValue(linkPtr), TCL_GLOBAL_ONLY);
return (char *) "variable must have unsigned long value";
}
LinkedVar(unsigned long) = linkPtr->lastValue.ul =
(unsigned long) valueUWide;
}
|
| ︙ | ︙ | |||
1292 1293 1294 1295 1296 1297 1298 |
switch (linkPtr->type) {
case TCL_LINK_INT:
if (linkPtr->flags & LINK_ALLOC_LAST) {
memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
objv = (Tcl_Obj **)Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *));
for (i=0; i < linkPtr->numElems; i++) {
| | | 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 |
switch (linkPtr->type) {
case TCL_LINK_INT:
if (linkPtr->flags & LINK_ALLOC_LAST) {
memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
objv = (Tcl_Obj **)Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *));
for (i=0; i < linkPtr->numElems; i++) {
TclNewIntObj(objv[i], linkPtr->lastValue.iPtr[i]);
}
resultObj = Tcl_NewListObj(linkPtr->numElems, objv);
Tcl_Free(objv);
return resultObj;
}
linkPtr->lastValue.i = LinkedVar(int);
return Tcl_NewIntObj(linkPtr->lastValue.i);
|
| ︙ | ︙ | |||
1344 1345 1346 1347 1348 1349 1350 |
linkPtr->lastValue.i = LinkedVar(int);
return Tcl_NewBooleanObj(linkPtr->lastValue.i);
case TCL_LINK_CHAR:
if (linkPtr->flags & LINK_ALLOC_LAST) {
memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
objv = (Tcl_Obj **)Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *));
for (i=0; i < linkPtr->numElems; i++) {
| | | | | | 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 |
linkPtr->lastValue.i = LinkedVar(int);
return Tcl_NewBooleanObj(linkPtr->lastValue.i);
case TCL_LINK_CHAR:
if (linkPtr->flags & LINK_ALLOC_LAST) {
memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
objv = (Tcl_Obj **)Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *));
for (i=0; i < linkPtr->numElems; i++) {
TclNewIntObj(objv[i], linkPtr->lastValue.cPtr[i]);
}
resultObj = Tcl_NewListObj(linkPtr->numElems, objv);
Tcl_Free(objv);
return resultObj;
}
linkPtr->lastValue.c = LinkedVar(char);
return Tcl_NewIntObj(linkPtr->lastValue.c);
case TCL_LINK_UCHAR:
if (linkPtr->flags & LINK_ALLOC_LAST) {
memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
objv = (Tcl_Obj **)Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *));
for (i=0; i < linkPtr->numElems; i++) {
TclNewIntObj(objv[i], linkPtr->lastValue.ucPtr[i]);
}
resultObj = Tcl_NewListObj(linkPtr->numElems, objv);
Tcl_Free(objv);
return resultObj;
}
linkPtr->lastValue.uc = LinkedVar(unsigned char);
return Tcl_NewIntObj(linkPtr->lastValue.uc);
case TCL_LINK_SHORT:
if (linkPtr->flags & LINK_ALLOC_LAST) {
memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
objv = (Tcl_Obj **)Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *));
for (i=0; i < linkPtr->numElems; i++) {
TclNewIntObj(objv[i], linkPtr->lastValue.sPtr[i]);
}
resultObj = Tcl_NewListObj(linkPtr->numElems, objv);
Tcl_Free(objv);
return resultObj;
}
linkPtr->lastValue.s = LinkedVar(short);
return Tcl_NewIntObj(linkPtr->lastValue.s);
case TCL_LINK_USHORT:
if (linkPtr->flags & LINK_ALLOC_LAST) {
memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
objv = (Tcl_Obj **)Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *));
for (i=0; i < linkPtr->numElems; i++) {
TclNewIntObj(objv[i], linkPtr->lastValue.usPtr[i]);
}
resultObj = Tcl_NewListObj(linkPtr->numElems, objv);
Tcl_Free(objv);
return resultObj;
}
linkPtr->lastValue.us = LinkedVar(unsigned short);
return Tcl_NewIntObj(linkPtr->lastValue.us);
|
| ︙ | ︙ |
Changes to generic/tclListObj.c.
| ︙ | ︙ | |||
423 424 425 426 427 428 429 |
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclListObjRange(
Tcl_Obj *listPtr, /* List object to take a range from. */
| | | | > | | | | 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 |
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclListObjRange(
Tcl_Obj *listPtr, /* List object to take a range from. */
size_t fromIdx, /* Index of first element to include. */
size_t toIdx) /* Index of last element to include. */
{
Tcl_Obj **elemPtrs;
int listLen;
size_t i, newLen;
List *listRepPtr;
TclListObjGetElements(NULL, listPtr, &listLen, &elemPtrs);
if (fromIdx == TCL_INDEX_NONE) {
fromIdx = 0;
}
if (toIdx + 1 >= (size_t)listLen + 1) {
toIdx = listLen-1;
}
if (fromIdx + 1 > toIdx + 1) {
return Tcl_NewObj();
}
newLen = toIdx - fromIdx + 1;
if (Tcl_IsShared(listPtr) ||
((ListRepPtr(listPtr)->refCount > 1))) {
|
| ︙ | ︙ | |||
467 468 469 470 471 472 473 |
/*
* Delete elements that should not be included.
*/
for (i = 0; i < fromIdx; i++) {
TclDecrRefCount(elemPtrs[i]);
}
| | | 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 |
/*
* Delete elements that should not be included.
*/
for (i = 0; i < fromIdx; i++) {
TclDecrRefCount(elemPtrs[i]);
}
for (i = toIdx + 1; i < (size_t)listLen; i++) {
TclDecrRefCount(elemPtrs[i]);
}
if (fromIdx > 0) {
memmove(elemPtrs, &elemPtrs[fromIdx],
(size_t) newLen * sizeof(Tcl_Obj*));
}
|
| ︙ | ︙ | |||
1239 1240 1241 1242 1243 1244 1245 |
* 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)
| | | 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 |
* 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, WIDE_MAX - 1, &index) == TCL_OK) {
/*
* argPtr designates a single index.
*/
return TclLindexFlat(interp, listPtr, 1, &argPtr);
}
|
| ︙ | ︙ | |||
1345 1346 1347 1348 1349 1350 1351 |
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) {
| | | 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 |
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], WIDE_MAX - 1, &index)
!= TCL_OK) {
Tcl_DecrRefCount(sublistCopy);
return NULL;
}
}
listPtr = Tcl_NewObj();
} else {
|
| ︙ | ︙ | |||
1409 1410 1411 1412 1413 1414 1415 |
* 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
| | | 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 |
* 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, WIDE_MAX - 1, &index) == TCL_OK) {
/*
* indexArgPtr designates a single index.
*/
return TclLsetFlat(interp, listPtr, 1, &indexArgPtr, valuePtr);
}
|
| ︙ | ︙ |
Changes to generic/tclLiteral.c.
| ︙ | ︙ | |||
191 192 193 194 195 196 197 |
size_t globalHash;
Tcl_Obj *objPtr;
/*
* Is it in the interpreter's global literal table?
*/
| | | 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 |
size_t globalHash;
Tcl_Obj *objPtr;
/*
* Is it in the interpreter's global literal table?
*/
if (hash == TCL_INDEX_NONE) {
hash = HashString(bytes, length);
}
globalHash = (hash & globalTablePtr->mask);
for (globalPtr=globalTablePtr->buckets[globalHash] ; globalPtr!=NULL;
globalPtr = globalPtr->nextPtr) {
objPtr = globalPtr->objPtr;
if (globalPtr->nsPtr == nsPtr) {
|
| ︙ | ︙ | |||
225 226 227 228 229 230 231 |
}
if (globalPtrPtr) {
*globalPtrPtr = globalPtr;
}
if (flags & LITERAL_ON_HEAP) {
Tcl_Free((void *)bytes);
}
| | | 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 |
}
if (globalPtrPtr) {
*globalPtrPtr = globalPtr;
}
if (flags & LITERAL_ON_HEAP) {
Tcl_Free((void *)bytes);
}
if (globalPtr->refCount != TCL_INDEX_NONE) {
globalPtr->refCount++;
}
return objPtr;
}
}
}
if (!newPtr) {
|
| ︙ | ︙ | |||
408 409 410 411 412 413 414 |
LiteralTable *localTablePtr = &envPtr->localLitTable;
LiteralEntry *globalPtr, *localPtr;
Tcl_Obj *objPtr;
size_t hash, localHash, objIndex;
int isNew;
Namespace *nsPtr;
| | | 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 |
LiteralTable *localTablePtr = &envPtr->localLitTable;
LiteralEntry *globalPtr, *localPtr;
Tcl_Obj *objPtr;
size_t hash, localHash, objIndex;
int isNew;
Namespace *nsPtr;
if (length == TCL_INDEX_NONE) {
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.
|
| ︙ | ︙ | |||
624 625 626 627 628 629 630 |
}
objIndex = envPtr->literalArrayNext;
envPtr->literalArrayNext++;
lPtr = &envPtr->literalArrayPtr[objIndex];
lPtr->objPtr = objPtr;
Tcl_IncrRefCount(objPtr);
| | | 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 |
}
objIndex = envPtr->literalArrayNext;
envPtr->literalArrayNext++;
lPtr = &envPtr->literalArrayPtr[objIndex];
lPtr->objPtr = objPtr;
Tcl_IncrRefCount(objPtr);
lPtr->refCount = TCL_INDEX_NONE; /* i.e., unused */
lPtr->nextPtr = NULL;
if (litPtrPtr) {
*litPtrPtr = lPtr;
}
return objIndex;
|
| ︙ | ︙ | |||
847 848 849 850 851 852 853 |
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).
*/
| | | 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 |
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_INDEX_NONE) && (entryPtr->refCount-- <= 1)) {
if (prevPtr == NULL) {
globalTablePtr->buckets[index] = entryPtr->nextPtr;
} else {
prevPtr->nextPtr = entryPtr->nextPtr;
}
Tcl_Free(entryPtr);
globalTablePtr->numEntries--;
|
| ︙ | ︙ | |||
986 987 988 989 990 991 992 |
* with what we have.
*/
return;
}
tablePtr->numBuckets *= 4;
| | > | 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 |
* with what we have.
*/
return;
}
tablePtr->numBuckets *= 4;
tablePtr->buckets = (LiteralEntry **)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;
|
| ︙ | ︙ | |||
1170 1171 1172 1173 1174 1175 1176 |
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++;
| | | 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 |
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_INDEX_NONE) {
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",
|
| ︙ | ︙ |
Changes to generic/tclMain.c.
| ︙ | ︙ | |||
468 469 470 471 472 473 474 |
}
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);
| | | 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 |
}
if (Tcl_IsShared(is.commandPtr)) {
Tcl_DecrRefCount(is.commandPtr);
is.commandPtr = Tcl_DuplicateObj(is.commandPtr);
Tcl_IncrRefCount(is.commandPtr);
}
length = Tcl_GetsObj(is.input, is.commandPtr);
if (length == TCL_INDEX_NONE) {
if (Tcl_InputBlocked(is.input)) {
/*
* 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.
|
| ︙ | ︙ | |||
745 746 747 748 749 750 751 |
if (Tcl_IsShared(commandPtr)) {
Tcl_DecrRefCount(commandPtr);
commandPtr = Tcl_DuplicateObj(commandPtr);
Tcl_IncrRefCount(commandPtr);
}
length = Tcl_GetsObj(chan, commandPtr);
| | | 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 |
if (Tcl_IsShared(commandPtr)) {
Tcl_DecrRefCount(commandPtr);
commandPtr = Tcl_DuplicateObj(commandPtr);
Tcl_IncrRefCount(commandPtr);
}
length = Tcl_GetsObj(chan, commandPtr);
if (length == TCL_INDEX_NONE) {
if (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
|
| ︙ | ︙ |
Changes to generic/tclNamesp.c.
| ︙ | ︙ | |||
4924 4925 4926 4927 4928 4929 4930 |
iPtr->errorLine = 1;
for (p = script; p != command; p++) {
if (*p == '\n') {
iPtr->errorLine++;
}
}
| | | 4924 4925 4926 4927 4928 4929 4930 4931 4932 4933 4934 4935 4936 4937 4938 |
iPtr->errorLine = 1;
for (p = script; p != command; p++) {
if (*p == '\n') {
iPtr->errorLine++;
}
}
if (length == TCL_INDEX_NONE) {
length = strlen(command);
}
overflow = (length > (size_t)limit);
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n %s\n\"%.*s%s\"", ((iPtr->errorInfo == NULL)
? "while executing" : "invoked from within"),
(overflow ? limit : (int)length), command,
|
| ︙ | ︙ |
Changes to generic/tclOOBasic.c.
| ︙ | ︙ | |||
1245 1246 1247 1248 1249 1250 1251 |
result[0] = TclOOObjectName(interp, declarerPtr);
result[1] = mPtr->namePtr;
Tcl_SetObjResult(interp, Tcl_NewListObj(2, result));
return TCL_OK;
}
case SELF_CALL:
result[0] = TclOORenderCallChain(interp, contextPtr->callPtr);
| | | 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 |
result[0] = TclOOObjectName(interp, declarerPtr);
result[1] = mPtr->namePtr;
Tcl_SetObjResult(interp, Tcl_NewListObj(2, result));
return TCL_OK;
}
case SELF_CALL:
result[0] = TclOORenderCallChain(interp, contextPtr->callPtr);
TclNewIntObj(result[1], contextPtr->index);
Tcl_SetObjResult(interp, Tcl_NewListObj(2, result));
return TCL_OK;
}
return TCL_ERROR;
}
/*
|
| ︙ | ︙ |
Changes to generic/tclOOCall.c.
| ︙ | ︙ | |||
909 910 911 912 913 914 915 |
doneFilters, flags|TRAVERSED_MIXIN, filterDecl);
}
foundPrivate |= AddSimpleClassChainToCallContext(mixinPtr,
methodNameObj, cbPtr, doneFilters,
flags | TRAVERSED_MIXIN, filterDecl);
}
if (oPtr->methodsPtr && !blockedUnexported) {
| | | 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 |
doneFilters, flags|TRAVERSED_MIXIN, filterDecl);
}
foundPrivate |= AddSimpleClassChainToCallContext(mixinPtr,
methodNameObj, cbPtr, doneFilters,
flags | TRAVERSED_MIXIN, filterDecl);
}
if (oPtr->methodsPtr && !blockedUnexported) {
hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *)methodNameObj);
if (hPtr != NULL) {
mPtr = (Method *)Tcl_GetHashValue(hPtr);
if (!IS_PRIVATE(mPtr)) {
AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl,
flags);
}
}
|
| ︙ | ︙ |
Changes to generic/tclOODefineCmds.c.
| ︙ | ︙ | |||
1841 1842 1843 1844 1845 1846 1847 |
if (isInstanceExport) {
if (!oPtr->methodsPtr) {
oPtr->methodsPtr = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable));
Tcl_InitObjHashTable(oPtr->methodsPtr);
oPtr->flags &= ~USE_CLASS_CACHE;
}
| | | | 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 |
if (isInstanceExport) {
if (!oPtr->methodsPtr) {
oPtr->methodsPtr = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable));
Tcl_InitObjHashTable(oPtr->methodsPtr);
oPtr->flags &= ~USE_CLASS_CACHE;
}
hPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, (char *)objv[i],
&isNew);
} else {
hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, (char *)objv[i],
&isNew);
}
if (isNew) {
mPtr = (Method *)Tcl_Alloc(sizeof(Method));
memset(mPtr, 0, sizeof(Method));
mPtr->refCount = 1;
|
| ︙ | ︙ | |||
2154 2155 2156 2157 2158 2159 2160 |
if (isInstanceUnexport) {
if (!oPtr->methodsPtr) {
oPtr->methodsPtr = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable));
Tcl_InitObjHashTable(oPtr->methodsPtr);
oPtr->flags &= ~USE_CLASS_CACHE;
}
| | | | 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 |
if (isInstanceUnexport) {
if (!oPtr->methodsPtr) {
oPtr->methodsPtr = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable));
Tcl_InitObjHashTable(oPtr->methodsPtr);
oPtr->flags &= ~USE_CLASS_CACHE;
}
hPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, (char *)objv[i],
&isNew);
} else {
hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, (char *)objv[i],
&isNew);
}
if (isNew) {
mPtr = (Method *)Tcl_Alloc(sizeof(Method));
memset(mPtr, 0, sizeof(Method));
mPtr->refCount = 1;
|
| ︙ | ︙ |
Changes to generic/tclObj.c.
| ︙ | ︙ | |||
173 174 175 176 177 178 179 | #endif /* * Macros to pack/unpack a bignum's fields in a Tcl_Obj internal rep */ #define PACK_BIGNUM(bignum, objPtr) \ | | | | 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 |
#endif
/*
* Macros to pack/unpack a bignum's fields in a Tcl_Obj internal rep
*/
#define PACK_BIGNUM(bignum, objPtr) \
if ((bignum).used > 0x7FFF) { \
mp_int *temp = (mp_int *) Tcl_Alloc(sizeof(mp_int)); \
*temp = bignum; \
(objPtr)->internalRep.twoPtrValue.ptr1 = temp; \
(objPtr)->internalRep.twoPtrValue.ptr2 = INT2PTR(-1); \
} else if (((bignum).alloc <= 0x7FFF) || (mp_shrink(&(bignum))) == MP_OKAY) { \
(objPtr)->internalRep.twoPtrValue.ptr1 = (bignum).dp; \
(objPtr)->internalRep.twoPtrValue.ptr2 = INT2PTR( ((bignum).sign << 30) \
| ((bignum).alloc << 15) | ((bignum).used)); \
}
/*
* Prototypes for functions defined later in this file:
|
| ︙ | ︙ | |||
410 411 412 413 414 415 416 |
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)) {
| | | 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 |
Tcl_HashSearch hSearch;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
Tcl_HashTable *tablePtr = tsdPtr->objThreadMap;
if (tablePtr != NULL) {
for (hPtr = Tcl_FirstHashEntry(tablePtr, &hSearch);
hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) {
ObjData *objData = (ObjData *)Tcl_GetHashValue(hPtr);
if (objData != NULL) {
Tcl_Free(objData);
}
}
Tcl_DeleteHashTable(tablePtr);
|
| ︙ | ︙ | |||
971 972 973 974 975 976 977 |
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)) {
| | | 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 |
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 = (ObjData *)Tcl_GetHashValue(hPtr);
if (objData != NULL) {
fprintf(outFile,
"key = 0x%p, objPtr = 0x%p, file = %s, line = %d\n",
Tcl_GetHashKey(tablePtr, hPtr), objData->objPtr,
objData->file, objData->line);
} else {
|
| ︙ | ︙ | |||
1280 1281 1282 1283 1284 1285 1286 |
}
hPtr = Tcl_FindHashEntry(tablePtr, (char *) objPtr);
if (hPtr) {
/*
* As the Tcl_Obj is going to be deleted we remove the entry.
*/
| | | 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 |
}
hPtr = Tcl_FindHashEntry(tablePtr, (char *) objPtr);
if (hPtr) {
/*
* As the Tcl_Obj is going to be deleted we remove the entry.
*/
ObjData *objData = (ObjData *)Tcl_GetHashValue(hPtr);
if (objData != NULL) {
Tcl_Free(objData);
}
Tcl_DeleteHashEntry(hPtr);
}
|
| ︙ | ︙ | |||
1305 1306 1307 1308 1309 1310 1311 |
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.
*/
| | | | | 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 |
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_INDEX_NONE;
/*
* Invalidate the string rep first so we can use the bytes value for our
* pointer chain, and signal an obj deletion (as opposed to shimmering)
* with 'length == TCL_INDEX_NONE'.
*/
TclInvalidateStringRep(objPtr);
objPtr->length = TCL_INDEX_NONE;
if (ObjDeletePending(context)) {
PushObjToDelete(context, objPtr);
} else {
TCL_DTRACE_OBJ_FREE(objPtr);
if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) {
ObjDeletionLock(context);
|
| ︙ | ︙ | |||
1382 1383 1384 1385 1386 1387 1388 |
/*
* 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);
| | | 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 |
/*
* Invalidate the string rep first so we can use the bytes value for our
* pointer chain, and signal an obj deletion (as opposed to shimmering)
* with 'length == -1'.
*/
TclInvalidateStringRep(objPtr);
objPtr->length = TCL_INDEX_NONE;
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.
*/
|
| ︙ | ︙ | |||
1484 1485 1486 1487 1488 1489 1490 |
*----------------------------------------------------------------------
*/
int
TclObjBeingDeleted(
Tcl_Obj *objPtr)
{
| | | 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 |
*----------------------------------------------------------------------
*/
int
TclObjBeingDeleted(
Tcl_Obj *objPtr)
{
return (objPtr->length == TCL_INDEX_NONE);
}
/*
*----------------------------------------------------------------------
*
* Tcl_DuplicateObj --
*
|
| ︙ | ︙ | |||
1603 1604 1605 1606 1607 1608 1609 |
* 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);
| | | 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 |
* updateStringProc must be written in such a way that
* (objPtr->bytes) never becomes NULL.
*/
Tcl_Panic("UpdateStringProc should not be invoked for type %s",
objPtr->typePtr->name);
}
objPtr->typePtr->updateStringProc(objPtr);
if (objPtr->bytes == NULL || objPtr->length == TCL_INDEX_NONE
|| objPtr->bytes[objPtr->length] != '\0') {
Tcl_Panic("UpdateStringProc for type '%s' "
"failed to create a valid string rep",
objPtr->typePtr->name);
}
}
return objPtr->bytes;
|
| ︙ | ︙ | |||
1662 1663 1664 1665 1666 1667 1668 |
* 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);
| | | 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 |
* updateStringProc must be written in such a way that
* (objPtr->bytes) never becomes NULL.
*/
Tcl_Panic("UpdateStringProc should not be invoked for type %s",
objPtr->typePtr->name);
}
objPtr->typePtr->updateStringProc(objPtr);
if (objPtr->bytes == NULL || objPtr->length == TCL_INDEX_NONE
|| objPtr->bytes[objPtr->length] != '\0') {
Tcl_Panic("UpdateStringProc for type '%s' "
"failed to create a valid string rep",
objPtr->typePtr->name);
}
}
if (lengthPtr != NULL) {
|
| ︙ | ︙ | |||
2377 2378 2379 2380 2381 2382 2383 |
static void
UpdateStringOfDouble(
Tcl_Obj *objPtr) /* Double obj with string rep to update. */
{
char *dst = Tcl_InitStringRep(objPtr, NULL, TCL_DOUBLE_SPACE);
| | | 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 |
static void
UpdateStringOfDouble(
Tcl_Obj *objPtr) /* Double obj with string rep to update. */
{
char *dst = Tcl_InitStringRep(objPtr, NULL, TCL_DOUBLE_SPACE);
TclOOM(dst, (size_t)TCL_DOUBLE_SPACE + 1);
Tcl_PrintDouble(NULL, objPtr->internalRep.doubleValue, dst);
(void) Tcl_InitStringRep(objPtr, NULL, strlen(dst));
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
2490 2491 2492 2493 2494 2495 2496 |
static void
UpdateStringOfInt(
Tcl_Obj *objPtr) /* Int object whose string rep to update. */
{
char *dst = Tcl_InitStringRep( objPtr, NULL, TCL_INTEGER_SPACE);
| | | 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 |
static void
UpdateStringOfInt(
Tcl_Obj *objPtr) /* Int object whose string rep to update. */
{
char *dst = Tcl_InitStringRep( objPtr, NULL, TCL_INTEGER_SPACE);
TclOOM(dst, (size_t)TCL_INTEGER_SPACE + 1);
(void) Tcl_InitStringRep(objPtr, NULL,
TclFormatInt(dst, objPtr->internalRep.wideValue));
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ |
Changes to generic/tclOptimize.c.
| ︙ | ︙ | |||
30 31 32 33 34 35 36 |
#define DefineTargetAddress(tablePtr, address) \
((void) Tcl_CreateHashEntry((tablePtr), (void *) (address), &isNew))
#define IsTargetAddress(tablePtr, address) \
(Tcl_FindHashEntry((tablePtr), (void *) (address)) != NULL)
#define AddrLength(address) \
(tclInstructionTable[*(unsigned char *)(address)].numBytes)
#define InstLength(instruction) \
| | | 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 |
#define DefineTargetAddress(tablePtr, address) \
((void) Tcl_CreateHashEntry((tablePtr), (void *) (address), &isNew))
#define IsTargetAddress(tablePtr, address) \
(Tcl_FindHashEntry((tablePtr), (void *) (address)) != NULL)
#define AddrLength(address) \
(tclInstructionTable[*(unsigned char *)(address)].numBytes)
#define InstLength(instruction) \
(tclInstructionTable[UCHAR(instruction)].numBytes)
/*
* ----------------------------------------------------------------------
*
* LocateTargetAddresses --
*
* Populate a hash table with places that we need to be careful around
|
| ︙ | ︙ |
Changes to generic/tclParse.c.
| ︙ | ︙ | |||
124 125 126 127 128 129 130 131 132 133 134 135 136 137 | 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 -- * * Initialize the fields of a Tcl_Parse struct. | > > | 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 | 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); static int ParseHex(const char *src, size_t numBytes, int *resultPtr); /* *---------------------------------------------------------------------- * * TclParseInit -- * * Initialize the fields of a Tcl_Parse struct. |
| ︙ | ︙ | |||
214 215 216 217 218 219 220 221 222 223 224 225 226 227 |
int wordIndex; /* Index of word token for current word. */
int terminators; /* CHAR_TYPE bits that indicate the end of a
* command. */
const char *termPtr; /* Set by Tcl_ParseBraces/QuotedString to
* point to char after terminating one. */
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;
}
| > > > > < < < < | 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 |
int wordIndex; /* Index of word token for current word. */
int terminators; /* CHAR_TYPE bits that indicate the end of a
* command. */
const char *termPtr; /* Set by Tcl_ParseBraces/QuotedString to
* point to char after terminating one. */
size_t scanned;
if (numBytes == TCL_INDEX_NONE && start) {
numBytes = strlen(start);
}
TclParseInit(interp, start, numBytes, parsePtr);
if ((start == NULL) && (numBytes != 0)) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"can't parse a NULL pointer", -1));
}
return TCL_ERROR;
}
parsePtr->commentStart = NULL;
parsePtr->commentSize = 0;
parsePtr->commandStart = NULL;
parsePtr->commandSize = 0;
if (nested != 0) {
terminators = TYPE_COMMAND_END | TYPE_CLOSE_BRACK;
} else {
|
| ︙ | ︙ | |||
698 699 700 701 702 703 704 |
int dummy;
return ParseAllWhiteSpace(src, numBytes, &dummy);
}
/*
*----------------------------------------------------------------------
*
| | | | | 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 |
int dummy;
return ParseAllWhiteSpace(src, numBytes, &dummy);
}
/*
*----------------------------------------------------------------------
*
* ParseHex --
*
* Scans a hexadecimal number as a Tcl_UniChar value (e.g., for parsing
* \x and \u escape sequences). At most numBytes bytes are scanned.
*
* Results:
* The numeric value is stored in *resultPtr. Returns the number of bytes
* consumed.
*
* Notes:
* Relies on the following properties of the ASCII character set, with
* which UTF-8 is compatible:
*
* The digits '0' .. '9' and the letters 'A' .. 'Z' and 'a' .. 'z' occupy
* consecutive code points, and '0' < 'A' < 'a'.
*
*----------------------------------------------------------------------
*/
int
ParseHex(
const char *src, /* First character to parse. */
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;
const char *p = src;
while (numBytes--) {
unsigned char digit = UCHAR(*p);
if (!isxdigit(digit) || (result > 0x10FFF)) {
break;
}
p++;
result <<= 4;
if (digit >= 'a') {
|
| ︙ | ︙ | |||
842 843 844 845 846 847 848 |
case 't':
result = 0x9;
break;
case 'v':
result = 0xB;
break;
case 'x':
| | | | | | | | | 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 |
case 't':
result = 0x9;
break;
case 'v':
result = 0xB;
break;
case 'x':
count += ParseHex(p+1, (numBytes > 3) ? 2 : numBytes-2, &result);
if (count == 2) {
/*
* No hexdigits -> This is just "x".
*/
result = 'x';
} else {
/*
* Keep only the last byte (2 hex digits).
*/
result = UCHAR(result);
}
break;
case 'u':
count += ParseHex(p+1, (numBytes > 5) ? 4 : numBytes-2, &result);
if (count == 2) {
/*
* No hexdigits -> This is just "u".
*/
result = 'u';
} else if (((result & 0xFC00) == 0xD800) && (count == 6)
&& (p[5] == '\\') && (p[6] == 'u') && (numBytes >= 10)) {
/* If high surrogate is immediately followed by a low surrogate
* escape, combine them into one character. */
int low;
int count2 = ParseHex(p+7, 4, &low);
if ((count2 == 4) && ((low & 0xFC00) == 0xDC00)) {
result = ((result & 0x3FF)<<10 | (low & 0x3FF)) + 0x10000;
count += count2 + 2;
}
}
break;
case 'U':
count += ParseHex(p+1, (numBytes > 9) ? 8 : numBytes-2, &result);
if (count == 2) {
/*
* No hexdigits -> This is just "U".
*/
result = 'U';
} else if ((result | 0x7FF) == 0xDFFF) {
/* Upper or lower surrogate, not allowed in this syntax. */
|
| ︙ | ︙ | |||
1342 1343 1344 1345 1346 1347 1348 |
* reinitialize it. */
{
Tcl_Token *tokenPtr;
const char *src;
int varIndex;
unsigned array;
| < < < | < > > > | 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 |
* reinitialize it. */
{
Tcl_Token *tokenPtr;
const char *src;
int varIndex;
unsigned array;
if (numBytes == TCL_INDEX_NONE && start) {
numBytes = strlen(start);
}
if (!append) {
TclParseInit(interp, start, numBytes, parsePtr);
}
if ((numBytes == 0) || (start == NULL)) {
return TCL_ERROR;
}
/*
* Generate one token for the variable, an additional token for the name,
* plus any number of additional tokens for the index, if there is one.
*/
|
| ︙ | ︙ | |||
1625 1626 1627 1628 1629 1630 1631 |
* successful. */
{
Tcl_Token *tokenPtr;
const char *src;
int startIndex, level;
size_t length;
| < < < | < > > > | 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 |
* successful. */
{
Tcl_Token *tokenPtr;
const char *src;
int startIndex, level;
size_t length;
if (numBytes == TCL_INDEX_NONE && start) {
numBytes = strlen(start);
}
if (!append) {
TclParseInit(interp, start, numBytes, parsePtr);
}
if ((numBytes == 0) || (start == NULL)) {
return TCL_ERROR;
}
src = start;
startIndex = parsePtr->numTokens;
TclGrowParseTokenArray(parsePtr, 1);
tokenPtr = &parsePtr->tokenPtr[startIndex];
|
| ︙ | ︙ | |||
1759 1760 1761 1762 1763 1764 1765 |
case '{':
openBrace = 1;
break;
case '\n':
openBrace = 0;
break;
case '#' :
| | | 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 |
case '{':
openBrace = 1;
break;
case '\n':
openBrace = 0;
break;
case '#' :
if (openBrace && TclIsSpaceProcM(src[-1])) {
Tcl_AppendToObj(Tcl_GetObjResult(parsePtr->interp),
": possible unbalanced brace in comment", -1);
goto error;
}
break;
}
}
|
| ︙ | ︙ | |||
1823 1824 1825 1826 1827 1828 1829 |
* 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. */
{
| < < < | < > > > | 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 |
* 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 == TCL_INDEX_NONE && start) {
numBytes = strlen(start);
}
if (!append) {
TclParseInit(interp, start, numBytes, parsePtr);
}
if ((numBytes == 0) || (start == NULL)) {
return TCL_ERROR;
}
if (TCL_OK != ParseTokens(start+1, numBytes-1, TYPE_QUOTE, TCL_SUBST_ALL,
parsePtr)) {
goto error;
}
if (*parsePtr->term != '"') {
|
| ︙ | ︙ |
Changes to generic/tclPkg.c.
| ︙ | ︙ | |||
901 902 903 904 905 906 907 |
name, Tcl_GetString(reqPtr->pkgPtr->version)));
Tcl_SetErrorCode(interp, "TCL", "PACKAGE",
"WRONGPROVIDE", NULL);
}
}
}
} else if (result != TCL_ERROR) {
| | > | 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 |
name, Tcl_GetString(reqPtr->pkgPtr->version)));
Tcl_SetErrorCode(interp, "TCL", "PACKAGE",
"WRONGPROVIDE", NULL);
}
}
}
} else if (result != TCL_ERROR) {
Tcl_Obj *codePtr;
TclNewIntObj(codePtr, result);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"attempt to provide package %s %s failed:"
" bad return code: %s",
name, versionToProvide, TclGetString(codePtr)));
Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL);
TclDecrRefCount(codePtr);
result = TCL_ERROR;
|
| ︙ | ︙ |
Changes to generic/tclPlatDecls.h.
| ︙ | ︙ | |||
47 48 49 50 51 52 53 | #endif /* * Exported function declarations: */ #ifdef MAC_OSX_TCL /* MACOSX */ | | < < < | | < > > > > > | 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 |
#endif
/*
* Exported function declarations:
*/
#ifdef MAC_OSX_TCL /* MACOSX */
/* Slot 0 is reserved */
/* 1 */
EXTERN 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;
#ifdef MAC_OSX_TCL /* MACOSX */
void (*reserved0)(void);
int (*tcl_MacOSXOpenVersionedBundleResources) (Tcl_Interp *interp, const char *bundleName, const char *bundleVersion, int hasResourceFile, size_t maxPathLen, char *libraryPath); /* 1 */
#endif /* MACOSX */
} TclPlatStubs;
extern const TclPlatStubs *tclPlatStubsPtr;
#ifdef __cplusplus
}
#endif
#if defined(USE_TCL_STUBS)
/*
* Inline function declarations:
*/
#ifdef MAC_OSX_TCL /* MACOSX */
/* Slot 0 is reserved */
#define Tcl_MacOSXOpenVersionedBundleResources \
(tclPlatStubsPtr->tcl_MacOSXOpenVersionedBundleResources) /* 1 */
#endif /* MACOSX */
#endif /* defined(USE_TCL_STUBS) */
/* !END!: Do not edit above this line. */
#ifdef MAC_OSX_TCL /* MACOSX */
#undef Tcl_MacOSXOpenBundleResources
#define Tcl_MacOSXOpenBundleResources(a,b,c,d,e) Tcl_MacOSXOpenVersionedBundleResources(a,b,NULL,c,d,e)
#endif
#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS DLLIMPORT
#if defined(USE_TCL_STUBS) && defined(_WIN32) && !defined(TCL_NO_DEPRECATED)
#define Tcl_WinUtfToTChar(string, len, dsPtr) (Tcl_DStringInit(dsPtr), \
(TCHAR *)Tcl_UtfToChar16DString((string), (len), (dsPtr)))
#define Tcl_WinTCharToUtf(string, len, dsPtr) (Tcl_DStringInit(dsPtr), \
(char *)Tcl_Char16ToUtfDString((const unsigned short *)(string), ((((len) + 2) >> 1) - 1), (dsPtr)))
#endif
#endif /* _TCLPLATDECLS */
|
Changes to generic/tclProc.c.
| ︙ | ︙ | |||
541 542 543 544 545 546 547 | argname = TclGetStringFromObj(fieldValues[0], &nameLength); /* * Check that the formal parameter name is a scalar. */ argnamei = argname; | | | | 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 |
argname = TclGetStringFromObj(fieldValues[0], &nameLength);
/*
* Check that the formal parameter name is a scalar.
*/
argnamei = argname;
argnamelast = (nameLength > 0) ? (argname + nameLength - 1) : argname;
while (argnamei < argnamelast) {
if (*argnamei == '(') {
if (*argnamelast == ')') { /* We have an array element. */
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"formal parameter \"%s\" is an array element",
TclGetString(fieldValues[0])));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
"FORMALARGUMENTFORMAT", NULL);
goto procError;
}
} else if (*argnamei == ':' && *(argnamei+1) == ':') {
Tcl_Obj *errorObj = Tcl_NewStringObj(
"formal parameter \"", -1);
Tcl_AppendObjToObj(errorObj, fieldValues[0]);
Tcl_AppendToObj(errorObj, "\" is not a simple name", -1);
Tcl_SetObjResult(interp, errorObj);
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
"FORMALARGUMENTFORMAT", NULL);
goto procError;
}
argnamei++;
}
if (precompiled) {
/*
* Compare the parsed argument with the stored one. Note that the
* only flag value that makes sense at this point is VAR_ARGUMENT
* (its value was kept the same as pre VarReform to simplify
|
| ︙ | ︙ |
Changes to generic/tclProcess.c.
| ︙ | ︙ | |||
263 264 265 266 267 268 269 |
* Child exited with a non-zero exit status.
*/
if (msgObjPtr) *msgObjPtr = Tcl_NewStringObj(
"child process exited abnormally", -1);
if (errorObjPtr) {
errorStrings[0] = Tcl_NewStringObj("CHILDSTATUS", -1);
| | | | | | | 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 |
* Child exited with a non-zero exit status.
*/
if (msgObjPtr) *msgObjPtr = Tcl_NewStringObj(
"child process exited abnormally", -1);
if (errorObjPtr) {
errorStrings[0] = Tcl_NewStringObj("CHILDSTATUS", -1);
TclNewIntObj(errorStrings[1], resolvedPid);
TclNewIntObj(errorStrings[2], WEXITSTATUS(waitStatus));
*errorObjPtr = Tcl_NewListObj(3, errorStrings);
}
}
return TCL_PROCESS_EXITED;
} else if (WIFSIGNALED(waitStatus)) {
/*
* CHILDKILLED pid sigName msg
*
* Child killed because of a signal.
*/
msg = Tcl_SignalMsg(WTERMSIG(waitStatus));
if (codePtr) *codePtr = WTERMSIG(waitStatus);
if (msgObjPtr) *msgObjPtr = Tcl_ObjPrintf(
"child killed: %s", msg);
if (errorObjPtr) {
errorStrings[0] = Tcl_NewStringObj("CHILDKILLED", -1);
TclNewIntObj(errorStrings[1], resolvedPid);
errorStrings[2] = Tcl_NewStringObj(Tcl_SignalId(WTERMSIG(waitStatus)), -1);
errorStrings[3] = Tcl_NewStringObj(msg, -1);
*errorObjPtr = Tcl_NewListObj(4, errorStrings);
}
return TCL_PROCESS_SIGNALED;
} else if (WIFSTOPPED(waitStatus)) {
/*
* CHILDSUSP pid sigName msg
*
* Child suspended because of a signal.
*/
msg = Tcl_SignalMsg(WSTOPSIG(waitStatus));
if (codePtr) *codePtr = WSTOPSIG(waitStatus);
if (msgObjPtr) *msgObjPtr = Tcl_ObjPrintf(
"child suspended: %s", msg);
if (errorObjPtr) {
errorStrings[0] = Tcl_NewStringObj("CHILDSUSP", -1);
TclNewIntObj(errorStrings[1], resolvedPid);
errorStrings[2] = Tcl_NewStringObj(Tcl_SignalId(WSTOPSIG(waitStatus)), -1);
errorStrings[3] = Tcl_NewStringObj(msg, -1);
*errorObjPtr = Tcl_NewListObj(4, errorStrings);
}
return TCL_PROCESS_STOPPED;
} else {
/*
* TCL OPERATION EXEC ODDWAITRESULT
*
* Child wait status didn't make sense.
*/
if (codePtr) *codePtr = waitStatus;
if (msgObjPtr) *msgObjPtr = Tcl_NewStringObj(
"child wait status didn't make sense\n", -1);
if (errorObjPtr) {
errorStrings[0] = Tcl_NewStringObj("TCL", -1);
errorStrings[1] = Tcl_NewStringObj("OPERATION", -1);
errorStrings[2] = Tcl_NewStringObj("EXEC", -1);
errorStrings[3] = Tcl_NewStringObj("ODDWAITRESULT", -1);
TclNewIntObj(errorStrings[4], resolvedPid);
*errorObjPtr = Tcl_NewListObj(5, errorStrings);
}
return TCL_PROCESS_UNKNOWN_STATUS;
}
}
|
| ︙ | ︙ | |||
374 375 376 377 378 379 380 |
return Tcl_NewIntObj(TCL_OK);
}
/*
* Abnormal exit, return {TCL_ERROR msg error}
*/
| | | 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 |
return Tcl_NewIntObj(TCL_OK);
}
/*
* Abnormal exit, return {TCL_ERROR msg error}
*/
TclNewIntObj(resultObjs[0], TCL_ERROR);
resultObjs[1] = info->msg;
resultObjs[2] = info->error;
return Tcl_NewListObj(3, resultObjs);
}
/*----------------------------------------------------------------------
*
|
| ︙ | ︙ |
Changes to generic/tclScan.c.
| ︙ | ︙ | |||
872 873 874 875 876 877 878 | break; } case 'c': /* * Scan a single Unicode character. */ | | < < < < < < < | | 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 |
break;
}
case 'c':
/*
* Scan a single Unicode character.
*/
offset = TclUtfToUCS4(string, &i);
string += offset;
if (!(flags & SCAN_SUPPRESS)) {
objPtr = Tcl_NewWideIntObj(i);
Tcl_IncrRefCount(objPtr);
CLANG_ASSERT(objs);
objs[objIndex++] = objPtr;
}
break;
case 'i':
/*
* Scan an unsigned or signed integer.
*/
objPtr = Tcl_NewWideIntObj(0);
Tcl_IncrRefCount(objPtr);
if (width == 0) {
width = ~0;
}
if (TCL_OK != TclParseNumber(NULL, objPtr, NULL, string, width,
&end, TCL_PARSE_INTEGER_ONLY | TCL_PARSE_NO_UNDERSCORE | parseFlag)) {
Tcl_DecrRefCount(objPtr);
if (width < 0) {
if (*end == '\0') {
underflow = 1;
}
} else {
if (end == string + width) {
|
| ︙ | ︙ | |||
1001 1002 1003 1004 1005 1006 1007 |
objPtr = Tcl_NewDoubleObj(0.0);
Tcl_IncrRefCount(objPtr);
if (width == 0) {
width = ~0;
}
if (TCL_OK != TclParseNumber(NULL, objPtr, NULL, string, width,
| | | 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 |
objPtr = Tcl_NewDoubleObj(0.0);
Tcl_IncrRefCount(objPtr);
if (width == 0) {
width = ~0;
}
if (TCL_OK != TclParseNumber(NULL, objPtr, NULL, string, width,
&end, TCL_PARSE_DECIMAL_ONLY | TCL_PARSE_NO_WHITESPACE | TCL_PARSE_NO_UNDERSCORE)) {
Tcl_DecrRefCount(objPtr);
if (width < 0) {
if (*end == '\0') {
underflow = 1;
}
} else {
if (end == string + width) {
|
| ︙ | ︙ |
Changes to generic/tclStrToD.c.
| ︙ | ︙ | |||
46 47 48 49 50 51 52 |
*/
#if defined(__GNUC__)
typedef unsigned int fpu_control_t __attribute__ ((__mode__ (__HI__)));
#define _FPU_GETCW(cw) __asm__ __volatile__ ("fnstcw %0" : "=m" (*&cw))
#define _FPU_SETCW(cw) __asm__ __volatile__ ("fldcw %0" : : "m" (*&cw))
| | | 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 |
*/
#if defined(__GNUC__)
typedef unsigned int fpu_control_t __attribute__ ((__mode__ (__HI__)));
#define _FPU_GETCW(cw) __asm__ __volatile__ ("fnstcw %0" : "=m" (*&cw))
#define _FPU_SETCW(cw) __asm__ __volatile__ ("fldcw %0" : : "m" (*&cw))
# define FPU_IEEE_ROUNDING 0x027F
# define ADJUST_FPU_CONTROL_WORD
#define TCL_IEEE_DOUBLE_ROUNDING \
fpu_control_t roundTo53Bits = FPU_IEEE_ROUNDING; \
fpu_control_t oldRoundingMode; \
_FPU_GETCW(oldRoundingMode); \
_FPU_SETCW(roundTo53Bits)
#define TCL_DEFAULT_DOUBLE_ROUNDING \
|
| ︙ | ︙ | |||
95 96 97 98 99 100 101 | /* * HP's PA_RISC architecture uses 7ff4000000000000 to represent a quiet NaN. * Everyone else uses 7ff8000000000000. (Why, HP, why?) */ #ifdef __hppa | | | | 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 | /* * HP's PA_RISC architecture uses 7ff4000000000000 to represent a quiet NaN. * Everyone else uses 7ff8000000000000. (Why, HP, why?) */ #ifdef __hppa # define NAN_START 0x7FF4 # define NAN_MASK (((Tcl_WideUInt) 1) << 50) #else # define NAN_START 0x7FF8 # define NAN_MASK (((Tcl_WideUInt) 1) << 51) #endif /* * Constants used by this file (most of which are only ever calculated at * runtime). */ |
| ︙ | ︙ | |||
120 121 122 123 124 125 126 | /* * Definitions of the parts of an IEEE754-format floating point number. */ #define SIGN_BIT 0x80000000 /* Mask for the sign bit in the first word of * a double. */ | | | | | | 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 | /* * Definitions of the parts of an IEEE754-format floating point number. */ #define SIGN_BIT 0x80000000 /* Mask for the sign bit in the first word of * a double. */ #define EXP_MASK 0x7FF00000 /* Mask for the exponent field in the first * word of a double. */ #define EXP_SHIFT 20 /* Shift count to make the exponent an * integer. */ #define HIDDEN_BIT (((Tcl_WideUInt) 0x00100000) << 32) /* Hidden 1 bit for the significand. */ #define HI_ORDER_SIG_MASK 0x000FFFFF /* Mask for the high-order part of the * significand in the first word of a * double. */ #define SIG_MASK (((Tcl_WideUInt) HI_ORDER_SIG_MASK << 32) \ | 0xFFFFFFFF) /* Mask for the 52-bit significand. */ #define FP_PRECISION 53 /* Number of bits of significand plus the * hidden bit. */ #define EXPONENT_BIAS 0x3FF /* Bias of the exponent 0. */ /* * Derived quantities. */ #define TEN_PMAX 22 /* floor(FP_PRECISION*log(2)/log(5)) */ #define QUICK_MAX 14 /* floor((FP_PRECISION-1)*log(2)/log(10))-1 */ |
| ︙ | ︙ | |||
530 531 532 533 534 535 536 537 538 539 540 541 542 543 |
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 */
mp_err err = MP_OKAY;
#define ALL_BITS ((Tcl_WideUInt)-1)
#define MOST_BITS (ALL_BITS >> 1)
/*
* Initialize bytes to start of the object's string rep if the caller
* didn't pass anything else.
| > > | 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 |
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 */
mp_err err = MP_OKAY;
int under = 0; /* Flag trailing '_' as error if true once
* number is accepted. */
#define ALL_BITS ((Tcl_WideUInt)-1)
#define MOST_BITS (ALL_BITS >> 1)
/*
* Initialize bytes to start of the object's string rep if the caller
* didn't pass anything else.
|
| ︙ | ︙ | |||
571 572 573 574 575 576 577 | case INITIAL: /* * Initial state. Acceptable characters are +, -, digits, period, * I, N, and whitespace. */ | | | 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 |
case INITIAL:
/*
* Initial state. Acceptable characters are +, -, digits, period,
* I, N, and whitespace.
*/
if (TclIsSpaceProcM(c)) {
if (flags & TCL_PARSE_NO_WHITESPACE) {
goto endgame;
}
break;
} else if (c == '+') {
state = SIGNUM;
break;
|
| ︙ | ︙ | |||
638 639 640 641 642 643 644 |
* OCTAL state differ only in whether they recognize 'X' and 'b'.
*/
acceptState = state;
acceptPoint = p;
acceptLen = len;
if (c == 'x' || c == 'X') {
| | | > > > > > > > > | 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 |
* OCTAL state differ only in whether they recognize 'X' and 'b'.
*/
acceptState = state;
acceptPoint = p;
acceptLen = len;
if (c == 'x' || c == 'X') {
if (flags & (TCL_PARSE_OCTAL_ONLY|TCL_PARSE_BINARY_ONLY) || under) {
goto endgame;
}
state = ZERO_X;
break;
}
if (flags & TCL_PARSE_HEXADECIMAL_ONLY) {
goto zerox;
}
if (flags & TCL_PARSE_SCAN_PREFIXES) {
goto zeroo;
}
if (c == 'b' || c == 'B') {
if ((flags & TCL_PARSE_OCTAL_ONLY) || under) {
goto endgame;
}
state = ZERO_B;
break;
}
if (flags & TCL_PARSE_BINARY_ONLY) {
goto zerob;
}
if (c == 'o' || c == 'O') {
if (under) {
goto endgame;
}
state = ZERO_O;
break;
}
if (c == 'd' || c == 'D') {
if (under) {
goto endgame;
}
state = ZERO_D;
break;
}
goto decimal;
case OCTAL:
/*
* Scanned an optional + or -, followed by a string of octal
* digits. Acceptable inputs are more digits, period, or E. If 8
* or 9 is encountered, commit to floating point.
*/
acceptState = state;
acceptPoint = p;
acceptLen = len;
/* FALLTHROUGH */
case ZERO_O:
zeroo:
if (c == '0') {
numTrailZeros++;
under = 0;
state = OCTAL;
break;
} else if (c >= '1' && c <= '7') {
under = 0;
if (objPtr != NULL) {
shift = 3 * (numTrailZeros + 1);
significandOverflow = AccumulateDecimalDigit(
(unsigned)(c-'0'), numTrailZeros,
&significandWide, &significandBig,
significandOverflow);
|
| ︙ | ︙ | |||
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 |
numSigDigs += numTrailZeros+1;
} else {
numSigDigs = 1;
}
numTrailZeros = 0;
state = OCTAL;
break;
}
goto endgame;
/*
* Scanned 0x. If state is HEXADECIMAL, scanned at least one
* character following the 0x. The only acceptable inputs are
* hexadecimal digits.
*/
case HEXADECIMAL:
acceptState = state;
acceptPoint = p;
acceptLen = len;
/* FALLTHROUGH */
case ZERO_X:
zerox:
if (c == '0') {
numTrailZeros++;
state = HEXADECIMAL;
break;
} else if (isdigit(UCHAR(c))) {
d = (c-'0');
} else if (c >= 'A' && c <= 'F') {
d = (c-'A'+10);
} else if (c >= 'a' && c <= 'f') {
d = (c-'a'+10);
} else {
goto endgame;
}
if (objPtr != NULL) {
shift = 4 * (numTrailZeros + 1);
if (!significandOverflow) {
/*
| > > > > > > > > > > > > | 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 |
numSigDigs += numTrailZeros+1;
} else {
numSigDigs = 1;
}
numTrailZeros = 0;
state = OCTAL;
break;
} else if (c == '_' && !(flags & TCL_PARSE_NO_UNDERSCORE)) {
/* Ignore numeric "white space" */
under = 1;
break;
}
goto endgame;
/*
* Scanned 0x. If state is HEXADECIMAL, scanned at least one
* character following the 0x. The only acceptable inputs are
* hexadecimal digits.
*/
case HEXADECIMAL:
acceptState = state;
acceptPoint = p;
acceptLen = len;
/* FALLTHROUGH */
case ZERO_X:
zerox:
if (c == '0') {
numTrailZeros++;
under = 0;
state = HEXADECIMAL;
break;
} else if (isdigit(UCHAR(c))) {
under = 0;
d = (c-'0');
} else if (c >= 'A' && c <= 'F') {
under = 0;
d = (c-'A'+10);
} else if (c >= 'a' && c <= 'f') {
under = 0;
d = (c-'a'+10);
} else if (c == '_' && !(flags & TCL_PARSE_NO_UNDERSCORE)) {
/* Ignore numeric "white space" */
under = 1;
break;
} else {
goto endgame;
}
if (objPtr != NULL) {
shift = 4 * (numTrailZeros + 1);
if (!significandOverflow) {
/*
|
| ︙ | ︙ | |||
809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 |
acceptPoint = p;
acceptLen = len;
/* FALLTHRU */
case ZERO_B:
zerob:
if (c == '0') {
numTrailZeros++;
state = BINARY;
break;
} else if (c != '1') {
goto endgame;
}
if (objPtr != NULL) {
shift = numTrailZeros + 1;
if (!significandOverflow) {
/*
| > > > > > | 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 |
acceptPoint = p;
acceptLen = len;
/* FALLTHRU */
case ZERO_B:
zerob:
if (c == '0') {
numTrailZeros++;
under = 0;
state = BINARY;
break;
} else if (c == '_' && !(flags & TCL_PARSE_NO_UNDERSCORE)) {
/* Ignore numeric "white space" */
under = 1;
break;
} else if (c != '1') {
goto endgame;
}
if (objPtr != NULL) {
shift = numTrailZeros + 1;
if (!significandOverflow) {
/*
|
| ︙ | ︙ | |||
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 |
}
numTrailZeros = 0;
state = BINARY;
break;
case ZERO_D:
if (c == '0') {
numTrailZeros++;
} else if ( ! isdigit(UCHAR(c))) {
goto endgame;
}
state = DECIMAL;
flags |= TCL_PARSE_INTEGER_ONLY;
/* FALLTHROUGH */
case DECIMAL:
/*
* Scanned an optional + or - followed by a string of decimal
* digits.
*/
decimal:
acceptState = state;
acceptPoint = p;
acceptLen = len;
if (c == '0') {
numTrailZeros++;
state = DECIMAL;
break;
} else if (isdigit(UCHAR(c))) {
if (objPtr != NULL) {
significandOverflow = AccumulateDecimalDigit(
(unsigned)(c - '0'), numTrailZeros,
&significandWide, &significandBig,
significandOverflow);
}
numSigDigs += numTrailZeros+1;
numTrailZeros = 0;
state = DECIMAL;
break;
} else if (flags & TCL_PARSE_INTEGER_ONLY) {
goto endgame;
} else if (c == '.') {
state = FRACTION;
break;
} else if (c == 'E' || c == 'e') {
state = EXPONENT_START;
break;
}
goto endgame;
/*
* Found a decimal point. If no digits have yet been scanned, E is
| > > > > > > > > > > > > > > > | 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 |
}
numTrailZeros = 0;
state = BINARY;
break;
case ZERO_D:
if (c == '0') {
under = 0;
numTrailZeros++;
} else if ( ! isdigit(UCHAR(c))) {
if (c == '_' && !(flags & TCL_PARSE_NO_UNDERSCORE)) {
/* Ignore numeric "white space" */
under = 1;
break;
}
goto endgame;
}
under = 0;
state = DECIMAL;
flags |= TCL_PARSE_INTEGER_ONLY;
/* FALLTHROUGH */
case DECIMAL:
/*
* Scanned an optional + or - followed by a string of decimal
* digits.
*/
decimal:
acceptState = state;
acceptPoint = p;
acceptLen = len;
if (c == '0') {
numTrailZeros++;
under = 0;
state = DECIMAL;
break;
} else if (isdigit(UCHAR(c))) {
if (objPtr != NULL) {
significandOverflow = AccumulateDecimalDigit(
(unsigned)(c - '0'), numTrailZeros,
&significandWide, &significandBig,
significandOverflow);
}
numSigDigs += numTrailZeros+1;
numTrailZeros = 0;
under = 0;
state = DECIMAL;
break;
} else if (c == '_' && !(flags & TCL_PARSE_NO_UNDERSCORE)) {
/* Ignore numeric "white space" */
under = 1;
break;
} else if (flags & TCL_PARSE_INTEGER_ONLY) {
goto endgame;
} else if (c == '.') {
under = 0;
state = FRACTION;
break;
} else if (c == 'E' || c == 'e') {
under = 0;
state = EXPONENT_START;
break;
}
goto endgame;
/*
* Found a decimal point. If no digits have yet been scanned, E is
|
| ︙ | ︙ | |||
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 |
}
/* FALLTHROUGH */
case LEADING_RADIX_POINT:
if (c == '0') {
numDigitsAfterDp++;
numTrailZeros++;
state = FRACTION;
break;
} else if (isdigit(UCHAR(c))) {
numDigitsAfterDp++;
if (objPtr != NULL) {
significandOverflow = AccumulateDecimalDigit(
(unsigned)(c-'0'), numTrailZeros,
&significandWide, &significandBig,
significandOverflow);
}
if (numSigDigs != 0) {
numSigDigs += numTrailZeros+1;
} else {
numSigDigs = 1;
}
numTrailZeros = 0;
state = FRACTION;
break;
}
goto endgame;
case EXPONENT_START:
/*
* Scanned the E at the start of an exponent. Make sure a legal
* character follows before using the C library strtol routine,
* which allows whitespace.
*/
if (c == '+') {
state = EXPONENT_SIGNUM;
break;
} else if (c == '-') {
exponentSignum = 1;
state = EXPONENT_SIGNUM;
break;
}
/* FALLTHROUGH */
case EXPONENT_SIGNUM:
/*
* Found the E at the start of the exponent, followed by a sign
* character.
*/
if (isdigit(UCHAR(c))) {
exponent = c - '0';
state = EXPONENT;
break;
}
goto endgame;
case EXPONENT:
/*
* Found an exponent with at least one digit. Accumulate it,
* making sure to hard-pin it to LONG_MAX on overflow.
*/
acceptState = state;
acceptPoint = p;
acceptLen = len;
if (isdigit(UCHAR(c))) {
if (exponent < (LONG_MAX - 9) / 10) {
exponent = 10 * exponent + (c - '0');
} else {
exponent = LONG_MAX;
}
state = EXPONENT;
break;
}
goto endgame;
/*
* Parse out INFINITY by simply spelling it out. INF is accepted
* as an abbreviation; other prefices are not.
*/
case sI:
if (c == 'n' || c == 'N') {
state = sIN;
break;
}
goto endgame;
case sIN:
if (c == 'f' || c == 'F') {
state = sINF;
break;
}
goto endgame;
case sINF:
acceptState = state;
acceptPoint = p;
acceptLen = len;
if (c == 'i' || c == 'I') {
state = sINFI;
break;
}
goto endgame;
case sINFI:
if (c == 'n' || c == 'N') {
state = sINFIN;
break;
}
goto endgame;
case sINFIN:
if (c == 'i' || c == 'I') {
state = sINFINI;
break;
}
goto endgame;
case sINFINI:
if (c == 't' || c == 'T') {
state = sINFINIT;
break;
}
goto endgame;
case sINFINIT:
if (c == 'y' || c == 'Y') {
state = sINFINITY;
break;
}
goto endgame;
/*
* Parse NaN's.
*/
#ifdef IEEE_FLOATING_POINT
case sN:
if (c == 'a' || c == 'A') {
state = sNA;
break;
}
goto endgame;
case sNA:
if (c == 'n' || c == 'N') {
state = sNAN;
break;
}
goto endgame;
case sNAN:
acceptState = state;
acceptPoint = p;
acceptLen = len;
if (c == '(') {
state = sNANPAREN;
break;
}
goto endgame;
/*
* Parse NaN(hexdigits)
*/
case sNANHEX:
if (c == ')') {
state = sNANFINISH;
break;
}
/* FALLTHROUGH */
case sNANPAREN:
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > | | > | | 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 |
}
/* FALLTHROUGH */
case LEADING_RADIX_POINT:
if (c == '0') {
numDigitsAfterDp++;
numTrailZeros++;
under = 0;
state = FRACTION;
break;
} else if (isdigit(UCHAR(c))) {
numDigitsAfterDp++;
if (objPtr != NULL) {
significandOverflow = AccumulateDecimalDigit(
(unsigned)(c-'0'), numTrailZeros,
&significandWide, &significandBig,
significandOverflow);
}
if (numSigDigs != 0) {
numSigDigs += numTrailZeros+1;
} else {
numSigDigs = 1;
}
numTrailZeros = 0;
under = 0;
state = FRACTION;
break;
} else if (c == '_' && !(flags & TCL_PARSE_NO_UNDERSCORE)) {
/* Ignore numeric "white space" */
under = 1;
break;
}
goto endgame;
case EXPONENT_START:
/*
* Scanned the E at the start of an exponent. Make sure a legal
* character follows before using the C library strtol routine,
* which allows whitespace.
*/
if (c == '+') {
under = 0;
state = EXPONENT_SIGNUM;
break;
} else if (c == '-') {
exponentSignum = 1;
under = 0;
state = EXPONENT_SIGNUM;
break;
}
/* FALLTHROUGH */
case EXPONENT_SIGNUM:
/*
* Found the E at the start of the exponent, followed by a sign
* character.
*/
if (isdigit(UCHAR(c))) {
exponent = c - '0';
under = 0;
state = EXPONENT;
break;
} else if (c == '_' && !(flags & TCL_PARSE_NO_UNDERSCORE)) {
/* Ignore numeric "white space" */
under = 1;
break;
}
goto endgame;
case EXPONENT:
/*
* Found an exponent with at least one digit. Accumulate it,
* making sure to hard-pin it to LONG_MAX on overflow.
*/
acceptState = state;
acceptPoint = p;
acceptLen = len;
if (isdigit(UCHAR(c))) {
if (exponent < (LONG_MAX - 9) / 10) {
exponent = 10 * exponent + (c - '0');
} else {
exponent = LONG_MAX;
}
under = 0;
state = EXPONENT;
break;
} else if (c == '_' && !(flags & TCL_PARSE_NO_UNDERSCORE)) {
/* Ignore numeric "white space" */
under = 1;
break;
}
goto endgame;
/*
* Parse out INFINITY by simply spelling it out. INF is accepted
* as an abbreviation; other prefices are not.
*/
case sI:
if (c == 'n' || c == 'N') {
under = 0;
state = sIN;
break;
}
goto endgame;
case sIN:
if (c == 'f' || c == 'F') {
under = 0;
state = sINF;
break;
}
goto endgame;
case sINF:
acceptState = state;
acceptPoint = p;
acceptLen = len;
under = 0;
if (c == 'i' || c == 'I') {
state = sINFI;
break;
}
goto endgame;
case sINFI:
if (c == 'n' || c == 'N') {
under = 0;
state = sINFIN;
break;
}
goto endgame;
case sINFIN:
if (c == 'i' || c == 'I') {
under = 0;
state = sINFINI;
break;
}
goto endgame;
case sINFINI:
if (c == 't' || c == 'T') {
under = 0;
state = sINFINIT;
break;
}
goto endgame;
case sINFINIT:
if (c == 'y' || c == 'Y') {
under = 0;
state = sINFINITY;
break;
}
goto endgame;
/*
* Parse NaN's.
*/
#ifdef IEEE_FLOATING_POINT
case sN:
if (c == 'a' || c == 'A') {
under = 0;
state = sNA;
break;
}
goto endgame;
case sNA:
if (c == 'n' || c == 'N') {
under = 0;
state = sNAN;
break;
}
goto endgame;
case sNAN:
acceptState = state;
acceptPoint = p;
acceptLen = len;
if (c == '(') {
under = 0;
state = sNANPAREN;
break;
}
goto endgame;
/*
* Parse NaN(hexdigits)
*/
case sNANHEX:
if (c == ')') {
under = 0;
state = sNANFINISH;
break;
}
/* FALLTHROUGH */
case sNANPAREN:
if (TclIsSpaceProcM(c)) {
under = 0;
break;
}
if (numSigDigs < 13) {
if (c >= '0' && c <= '9') {
d = c - '0';
} else if (c >= 'a' && c <= 'f') {
d = 10 + c - 'a';
} else if (c >= 'A' && c <= 'F') {
d = 10 + c - 'A';
} else {
goto endgame;
}
numSigDigs++;
significandWide = (significandWide << 4) + d;
under = 0;
state = sNANHEX;
break;
}
goto endgame;
case sNANFINISH:
#endif
case sINFINITY:
acceptState = state;
acceptPoint = p;
acceptLen = len;
goto endgame;
}
p++;
len--;
}
endgame:
if (acceptState == INITIAL) {
/*
* No numeric string at all found.
*/
status = TCL_ERROR;
if (endPtrPtr != NULL) {
*endPtrPtr = p;
}
} else {
/*
* Back up to the last accepting state in the lexer.
* If the last char seen is the numeric whitespace character '_',
* backup to that.
*/
p = under ? acceptPoint-1 : acceptPoint;
len = under ? acceptLen-1 : acceptLen;
if (!(flags & TCL_PARSE_NO_WHITESPACE)) {
/*
* Accept trailing whitespace.
*/
while (len != 0 && TclIsSpaceProcM(*p)) {
p++;
len--;
}
}
if (endPtrPtr == NULL) {
if ((len != 0) && ((numBytes + 1 > 1) || (*p != '\0'))) {
status = TCL_ERROR;
|
| ︙ | ︙ | |||
2096 2097 2098 2099 2100 2101 2102 |
static inline int
NormalizeRightward(
Tcl_WideUInt *wPtr) /* INOUT: Number to shift. */
{
int rv = 0;
Tcl_WideUInt w = *wPtr;
| | | | | | 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 |
static inline int
NormalizeRightward(
Tcl_WideUInt *wPtr) /* INOUT: Number to shift. */
{
int rv = 0;
Tcl_WideUInt w = *wPtr;
if (!(w & (Tcl_WideUInt) 0xFFFFFFFF)) {
w >>= 32; rv += 32;
}
if (!(w & (Tcl_WideUInt) 0xFFFF)) {
w >>= 16; rv += 16;
}
if (!(w & (Tcl_WideUInt) 0xFF)) {
w >>= 8; rv += 8;
}
if (!(w & (Tcl_WideUInt) 0xF)) {
w >>= 4; rv += 4;
}
if (!(w & 0x3)) {
w >>= 2; rv += 2;
}
if (!(w & 0x1)) {
w >>= 1; ++rv;
|
| ︙ | ︙ | |||
2139 2140 2141 2142 2143 2144 2145 |
static int
RequiredPrecision(
Tcl_WideUInt w) /* Number to interrogate. */
{
int rv;
unsigned long wi;
| | | | | | | 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 |
static int
RequiredPrecision(
Tcl_WideUInt w) /* Number to interrogate. */
{
int rv;
unsigned long wi;
if (w & ((Tcl_WideUInt) 0xFFFFFFFF << 32)) {
wi = (unsigned long) (w >> 32); rv = 32;
} else {
wi = (unsigned long) w; rv = 0;
}
if (wi & 0xFFFF0000) {
wi >>= 16; rv += 16;
}
if (wi & 0xFF00) {
wi >>= 8; rv += 8;
}
if (wi & 0xF0) {
wi >>= 4; rv += 4;
}
if (wi & 0xC) {
wi >>= 2; rv += 2;
}
if (wi & 0x2) {
wi >>= 1; ++rv;
}
if (wi & 0x1) {
++rv;
|
| ︙ | ︙ | |||
2591 2592 2593 2594 2595 2596 2597 |
ieps = 2;
if (k > 0) {
/*
* The number must be reduced to bring it into range.
*/
| | | | 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 |
ieps = 2;
if (k > 0) {
/*
* The number must be reduced to bring it into range.
*/
ds = tens[k & 0xF];
j = k >> 4;
if (j & BLETCH) {
j &= (BLETCH-1);
d /= bigtens[N_BIGTENS - 1];
ieps++;
}
i = 0;
for (; j != 0; j>>=1) {
if (j & 1) {
ds *= bigtens[i];
++ieps;
}
++i;
}
d /= ds;
} else if ((j1 = -k) != 0) {
/*
* The number must be increased to bring it into range.
*/
d *= tens[j1 & 0xF];
i = 0;
for (j = j1>>4; j; j>>=1) {
if (j & 1) {
ieps++;
d *= bigtens[i];
}
++i;
|
| ︙ | ︙ | |||
4555 4556 4557 4558 4559 4560 4561 |
* integers), but the two words of a 'double' are presented most
* significant word first.
*/
#ifdef IEEE_FLOATING_POINT
bitwhack.dv = 1.000000238418579;
/* 3ff0 0000 4000 0000 */
| | | | 4632 4633 4634 4635 4636 4637 4638 4639 4640 4641 4642 4643 4644 4645 4646 4647 4648 |
* integers), but the two words of a 'double' are presented most
* significant word first.
*/
#ifdef IEEE_FLOATING_POINT
bitwhack.dv = 1.000000238418579;
/* 3ff0 0000 4000 0000 */
if ((bitwhack.iv >> 32) == 0x3FF00000) {
n770_fp = 0;
} else if ((bitwhack.iv & 0xFFFFFFFF) == 0x3FF00000) {
n770_fp = 1;
} else {
Tcl_Panic("unknown floating point word order on this machine");
}
#endif
}
|
| ︙ | ︙ | |||
5011 5012 5013 5014 5015 5016 5017 |
double retval = fraction;
if (exponent > 0) {
/*
* Multiply by 10**exponent.
*/
| | | | 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 |
double retval = fraction;
if (exponent > 0) {
/*
* Multiply by 10**exponent.
*/
retval = frexp(retval * pow10vals[exponent & 0xF], &j);
expt += j;
for (i=4; i<9; ++i) {
if (exponent & (1<<i)) {
retval = frexp(retval * pow_10_2_n[i], &j);
expt += j;
}
}
} else if (exponent < 0) {
/*
* Divide by 10**-exponent.
*/
retval = frexp(retval / pow10vals[(-exponent) & 0xF], &j);
expt += j;
for (i=4; i<9; ++i) {
if ((-exponent) & (1<<i)) {
retval = frexp(retval / pow_10_2_n[i], &j);
expt += j;
}
}
|
| ︙ | ︙ | |||
5140 5141 5142 5143 5144 5145 5146 |
*----------------------------------------------------------------------
*/
#ifdef IEEE_FLOATING_POINT
static Tcl_WideUInt
Nokia770Twiddle(
Tcl_WideUInt w) /* Number to transpose. */
{
| | | 5217 5218 5219 5220 5221 5222 5223 5224 5225 5226 5227 5228 5229 5230 5231 |
*----------------------------------------------------------------------
*/
#ifdef IEEE_FLOATING_POINT
static Tcl_WideUInt
Nokia770Twiddle(
Tcl_WideUInt w) /* Number to transpose. */
{
return (((w >> 32) & 0xFFFFFFFF) | (w << 32));
}
#endif
/*
*----------------------------------------------------------------------
*
* TclNokia770Doubles --
|
| ︙ | ︙ |
Changes to generic/tclStringObj.c.
| ︙ | ︙ | |||
261 262 263 264 265 266 267 |
* 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;
| | | 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 |
* 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_INDEX_NONE) {
length = (bytes? strlen(bytes) : 0);
}
TclNewStringObj(objPtr, bytes, length);
return objPtr;
}
#endif /* TCL_MEM_DEBUG */
|
| ︙ | ︙ | |||
313 314 315 316 317 318 319 |
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;
| | | 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 |
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_INDEX_NONE) {
length = (bytes? strlen(bytes) : 0);
}
TclDbNewObj(objPtr, file, line);
TclInitStringRep(objPtr, bytes, length);
return objPtr;
}
#else /* if not TCL_MEM_DEBUG */
|
| ︙ | ︙ | |||
430 431 432 433 434 435 436 |
stringPtr = GET_STRING(objPtr);
numChars = stringPtr->numChars;
/*
* If numChars is unknown, compute it.
*/
| | | 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 |
stringPtr = GET_STRING(objPtr);
numChars = stringPtr->numChars;
/*
* If numChars is unknown, compute it.
*/
if (numChars == TCL_INDEX_NONE) {
TclNumUtfChars(numChars, objPtr->bytes, objPtr->length);
stringPtr->numChars = numChars;
}
return numChars;
}
/*
|
| ︙ | ︙ | |||
533 534 535 536 537 538 539 |
stringPtr = GET_STRING(objPtr);
if (stringPtr->hasUnicode == 0) {
/*
* If numChars is unknown, compute it.
*/
| | | 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 |
stringPtr = GET_STRING(objPtr);
if (stringPtr->hasUnicode == 0) {
/*
* If numChars is unknown, compute it.
*/
if (stringPtr->numChars == TCL_INDEX_NONE) {
TclNumUtfChars(stringPtr->numChars, objPtr->bytes, objPtr->length);
}
if (stringPtr->numChars == objPtr->length) {
return (Tcl_UniChar) objPtr->bytes[index];
}
FillUnicodeRep(objPtr);
stringPtr = GET_STRING(objPtr);
|
| ︙ | ︙ | |||
674 675 676 677 678 679 680 |
stringPtr = GET_STRING(objPtr);
if (stringPtr->hasUnicode == 0) {
/*
* If numChars is unknown, compute it.
*/
| | | 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 |
stringPtr = GET_STRING(objPtr);
if (stringPtr->hasUnicode == 0) {
/*
* If numChars is unknown, compute it.
*/
if (stringPtr->numChars == TCL_INDEX_NONE) {
TclNumUtfChars(stringPtr->numChars, objPtr->bytes, objPtr->length);
}
if (stringPtr->numChars == objPtr->length) {
if (last >= stringPtr->numChars) {
last = stringPtr->numChars - 1;
}
if (last < first) {
|
| ︙ | ︙ | |||
765 766 767 768 769 770 771 |
/*
* Free any old string rep, then set the string rep to a copy of the
* length bytes starting at "bytes".
*/
TclInvalidateStringRep(objPtr);
| | | 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 |
/*
* Free any old string rep, then set the string rep to a copy of the
* length bytes starting at "bytes".
*/
TclInvalidateStringRep(objPtr);
if (length == TCL_INDEX_NONE) {
length = (bytes? strlen(bytes) : 0);
}
TclInitStringRep(objPtr, bytes, length);
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
838 839 840 841 842 843 844 | objPtr->length = length; objPtr->bytes[length] = 0; /* * Invalidate the unicode data. */ | | | 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 |
objPtr->length = length;
objPtr->bytes[length] = 0;
/*
* Invalidate the unicode data.
*/
stringPtr->numChars = TCL_INDEX_NONE;
stringPtr->hasUnicode = 0;
} else {
if (length > stringPtr->maxChars) {
stringPtr = stringRealloc(stringPtr, length);
SET_STRING(objPtr, stringPtr);
stringPtr->maxChars = length;
}
|
| ︙ | ︙ | |||
935 936 937 938 939 940 941 | objPtr->length = length; objPtr->bytes[length] = 0; /* * Invalidate the unicode data. */ | | | 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 |
objPtr->length = length;
objPtr->bytes[length] = 0;
/*
* Invalidate the unicode data.
*/
stringPtr->numChars = TCL_INDEX_NONE;
stringPtr->hasUnicode = 0;
} else {
/*
* Changing length of pure unicode string.
*/
if (length > stringPtr->maxChars) {
|
| ︙ | ︙ | |||
1005 1006 1007 1008 1009 1010 1011 |
static size_t
UnicodeLength(
const Tcl_UniChar *unicode)
{
size_t numChars = 0;
if (unicode) {
| | | | 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 |
static size_t
UnicodeLength(
const Tcl_UniChar *unicode)
{
size_t numChars = 0;
if (unicode) {
while ((numChars != TCL_INDEX_NONE) && (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_INDEX_NONE) {
numChars = UnicodeLength(unicode);
}
/*
* Allocate enough space for the String structure + Unicode string.
*/
|
| ︙ | ︙ | |||
1078 1079 1080 1081 1082 1083 1084 |
* 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;
| | < < | < | > > > > > > > | | > > > > | | | 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 |
* the object. */
const char *ellipsis) /* Ellipsis marker string, appended to the
* object to indicate not all available bytes
* at "bytes" were appended. */
{
String *stringPtr;
size_t toCopy = 0;
size_t eLen = 0;
if (length == TCL_INDEX_NONE) {
length = (bytes ? strlen(bytes) : 0);
}
if (length == 0) {
return;
}
if (limit <= 0) {
return;
}
if (length <= limit) {
toCopy = length;
} else {
if (ellipsis == NULL) {
ellipsis = "...";
}
eLen = strlen(ellipsis);
while (eLen > limit) {
eLen = TclUtfPrev(ellipsis+eLen, ellipsis) - ellipsis;
}
toCopy = TclUtfPrev(bytes+limit+1-eLen, bytes) - bytes;
}
/*
* If objPtr has a valid Unicode rep, then append the Unicode conversion
* of "bytes" to the objPtr's Unicode rep, otherwise append "bytes" to
* objPtr's string rep.
*/
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_AppendLimitedToObj");
}
SetStringFromAny(NULL, objPtr);
stringPtr = GET_STRING(objPtr);
if (stringPtr->hasUnicode && (stringPtr->numChars+1) > 1) {
AppendUtfToUnicodeRep(objPtr, bytes, toCopy);
} else {
AppendUtfToUtfRep(objPtr, bytes, toCopy);
}
if (length <= limit) {
return;
}
stringPtr = GET_STRING(objPtr);
if (stringPtr->hasUnicode && (stringPtr->numChars+1) > 1) {
AppendUtfToUnicodeRep(objPtr, ellipsis, eLen);
} else {
AppendUtfToUtfRep(objPtr, ellipsis, eLen);
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_AppendToObj --
|
| ︙ | ︙ | |||
1153 1154 1155 1156 1157 1158 1159 |
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. */
{
| | | 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 |
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_INDEX_NONE, NULL);
}
/*
*----------------------------------------------------------------------
*
* TclAppendUnicodeToObj --
*
|
| ︙ | ︙ | |||
1233 1234 1235 1236 1237 1238 1239 |
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;
| | | 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 |
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_INDEX_NONE;
const char *bytes;
/*
* Special case: second object is standard-empty is fast case. We know
* that appending nothing to anything leaves that starting anything...
*/
|
| ︙ | ︙ | |||
1338 1339 1340 1341 1342 1343 1344 |
* 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;
| | | | 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 |
* 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_INDEX_NONE) && TclHasIntRep(appendObjPtr, &tclStringType)) {
String *appendStringPtr = GET_STRING(appendObjPtr);
appendNumChars = appendStringPtr->numChars;
}
AppendUtfToUtfRep(objPtr, bytes, length);
if ((numChars != TCL_INDEX_NONE) && (appendNumChars != TCL_INDEX_NONE)) {
stringPtr->numChars = numChars + appendNumChars;
}
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1377 1378 1379 1380 1381 1382 1383 |
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;
| | | 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 |
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_INDEX_NONE) {
appendNumChars = UnicodeLength(unicode);
}
if (appendNumChars == 0) {
return;
}
SetStringFromAny(NULL, objPtr);
|
| ︙ | ︙ | |||
1466 1467 1468 1469 1470 1471 1472 |
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);
| | | 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 |
const Tcl_UniChar *unicode, /* String to convert to UTF. */
size_t numChars) /* Number of chars of "unicode" to convert. */
{
String *stringPtr = GET_STRING(objPtr);
numChars = ExtendStringRepWithUnicode(objPtr, unicode, numChars);
if (stringPtr->numChars != TCL_INDEX_NONE) {
stringPtr->numChars += numChars;
}
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1551 1552 1553 1554 1555 1556 1557 |
objPtr->length = 0;
}
oldLength = objPtr->length;
newLength = numBytes + oldLength;
stringPtr = GET_STRING(objPtr);
if (newLength > stringPtr->allocated) {
| | | 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 |
objPtr->length = 0;
}
oldLength = objPtr->length;
newLength = numBytes + oldLength;
stringPtr = GET_STRING(objPtr);
if (newLength > stringPtr->allocated) {
size_t offset = 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.
*/
|
| ︙ | ︙ | |||
1575 1576 1577 1578 1579 1580 1581 | GrowStringBuffer(objPtr, newLength, 0); /* * Relocate bytes if needed; see above. */ | | | | 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 |
GrowStringBuffer(objPtr, newLength, 0);
/*
* Relocate bytes if needed; see above.
*/
if (offset != TCL_INDEX_NONE) {
bytes = objPtr->bytes + offset;
}
}
/*
* Invalidate the unicode data.
*/
stringPtr->numChars = TCL_INDEX_NONE;
stringPtr->hasUnicode = 0;
if (bytes) {
memmove(objPtr->bytes + oldLength, bytes, numBytes);
}
objPtr->bytes[newLength] = 0;
objPtr->length = newLength;
|
| ︙ | ︙ | |||
2498 2499 2500 2501 2502 2503 2504 | /* * Within that buffer, we trim both ends if needed so that we * copy only whole characters, and avoid copying any partial * multi-byte characters. */ | | | 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 |
/*
* Within that buffer, we trim both ends if needed so that we
* copy only whole characters, and avoid copying any partial
* multi-byte characters.
*/
q = TclUtfPrev(end, bytes);
if (!Tcl_UtfCharComplete(q, (end - q))) {
end = q;
}
q = bytes + 4;
while ((bytes < end) && (bytes < q)
&& ((*bytes & 0xC0) == 0x80)) {
|
| ︙ | ︙ | |||
3375 3376 3377 3378 3379 3380 3381 | * As a catch-all we will work with UTF-8. We cannot use * memcmp() as that is unsafe with any string containing NUL * (\xC0\x80 in Tcl's utf rep). We can use the more efficient * TclpUtfNcmp2 if we are case-sensitive and no specific * length was requested. */ | | | | 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 |
* As a catch-all we will work with UTF-8. We cannot use
* memcmp() as that is unsafe with any string containing NUL
* (\xC0\x80 in Tcl's utf rep). We can use the more efficient
* TclpUtfNcmp2 if we are case-sensitive and no specific
* length was requested.
*/
if ((reqlength == TCL_INDEX_NONE) && !nocase) {
memCmpFn = (memCmpFn_t) TclpUtfNcmp2;
} else {
s1len = Tcl_NumUtfChars(s1, s1len);
s2len = Tcl_NumUtfChars(s2, s2len);
memCmpFn = (memCmpFn_t)
(nocase ? Tcl_UtfNcasecmp : Tcl_UtfNcmp);
}
}
}
length = (s1len < s2len) ? s1len : s2len;
if (reqlength == TCL_INDEX_NONE) {
/*
* The requested length is negative, so we ignore it by setting it
* to length + 1 so we correct the match var.
*/
reqlength = length + 1;
} else if (reqlength > 0 && reqlength < length) {
|
| ︙ | ︙ | |||
3427 3428 3429 3430 3431 3432 3433 | * 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 | | | > > > | | | | | > | < < | < | | | < > | | | | | | > | | > > | < | | > > > | | | > < > < | | | | | | | | | | | | | | > | | | > > | < | 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 |
* TclStringFirst --
*
* Implements the [string first] operation.
*
* Results:
* If needle is found as a substring of haystack, the index of the
* first instance of such a find is returned. If needle is not present
* as a substring of haystack, -1 is returned.
*
* Side effects:
* needle and haystack may have their Tcl_ObjType changed.
*
*---------------------------------------------------------------------------
*/
Tcl_Obj *
TclStringFirst(
Tcl_Obj *needle,
Tcl_Obj *haystack,
size_t start)
{
size_t lh = 0, ln = Tcl_GetCharLength(needle);
Tcl_Obj *result;
size_t value = TCL_IO_FAILURE;
Tcl_UniChar *check, *end, *uh, *un;
if (start == TCL_INDEX_NONE) {
start = 0;
}
if (ln == 0) {
/* We don't find empty substrings. Bizarre!
* Whenever this routine is turned into a proper substring
* finder, change to `return start` after limits imposed. */
goto firstEnd;
}
if (TclIsPureByteArray(needle) && TclIsPureByteArray(haystack)) {
unsigned char *end, *check, *bh;
unsigned char *bn = TclGetByteArrayFromObj(needle, &ln);
/* Find bytes in bytes */
bh = TclGetByteArrayFromObj(haystack, &lh);
if ((lh < ln) || (start > lh - ln)) {
/* Don't start the loop if there cannot be a valid answer */
goto firstEnd;
}
end = bh + lh;
check = bh + start;
while (check + ln <= end) {
/*
* Look for the leading byte of the needle in the haystack
* starting at check and stopping when there's not enough room
* for the needle left.
*/
check = (unsigned char *)memchr(check, bn[0], (end + 1 - ln) - check);
if (check == NULL) {
/* Leading byte not found -> needle cannot be found. */
goto firstEnd;
}
/* Leading byte found, check rest of needle. */
if (0 == memcmp(check+1, bn+1, ln-1)) {
/* Checks! Return the successful index. */
value = (check - bh);
goto firstEnd;
}
/* Rest of needle match failed; Iterate to continue search. */
check++;
}
goto firstEnd;
}
/*
* TODO: It might be nice to support some cases where it is not
* necessary to shimmer to &tclStringType to compute the result,
* and instead operate just on the objPtr->bytes values directly.
* However, we also do not want the answer to change based on the
* code pathway, or if it does we want that to be for some values
* we explicitly decline to support. Getting there will involve
* locking down in practice more firmly just what encodings produce
* what supported results for the objPtr->bytes values. For now,
* do only the well-defined Tcl_UniChar array search.
*/
un = TclGetUnicodeFromObj(needle, &ln);
uh = TclGetUnicodeFromObj(haystack, &lh);
if ((lh < ln) || (start > lh - ln)) {
/* Don't start the loop if there cannot be a valid answer */
goto firstEnd;
}
end = uh + lh;
for (check = uh + start; check + ln <= end; check++) {
if ((*check == *un) && (0 ==
memcmp(check + 1, un + 1, (ln-1) * sizeof(Tcl_UniChar)))) {
value = (check - uh);
goto firstEnd;
}
}
firstEnd:
TclNewIntObj(result, TclWideIntFromSize(value));
return result;
}
/*
*---------------------------------------------------------------------------
*
* TclStringLast --
*
* Implements the [string last] operation.
*
* Results:
* If needle is found as a substring of haystack, the index of the
* last instance of such a find is returned. If needle is not present
* as a substring of haystack, -1 is returned.
*
* Side effects:
* needle and haystack may have their Tcl_ObjType changed.
*
*---------------------------------------------------------------------------
*/
Tcl_Obj *
TclStringLast(
Tcl_Obj *needle,
Tcl_Obj *haystack,
size_t last)
{
size_t lh = 0, ln = Tcl_GetCharLength(needle);
Tcl_Obj *result;
size_t value = TCL_IO_FAILURE;
Tcl_UniChar *check, *uh, *un;
if (ln == 0) {
/*
* We don't find empty substrings. Bizarre!
*
* TODO: When we one day make this a true substring
* finder, change this to "return last", after limitation.
*/
goto lastEnd;
}
if (TclIsPureByteArray(needle) && TclIsPureByteArray(haystack)) {
unsigned char *check, *bh = TclGetByteArrayFromObj(haystack, &lh);
unsigned char *bn = TclGetByteArrayFromObj(needle, &ln);
if (last + 1 >= lh + 1) {
last = lh - 1;
}
if (last + 1 < ln) {
/* Don't start the loop if there cannot be a valid answer */
goto lastEnd;
}
check = bh + last + 1 - ln;
while (check >= bh) {
if ((*check == bn[0])
&& (0 == memcmp(check+1, bn+1, ln-1))) {
value = (check - bh);
goto lastEnd;
}
check--;
}
goto lastEnd;
}
uh = TclGetUnicodeFromObj(haystack, &lh);
un = TclGetUnicodeFromObj(needle, &ln);
if (last + 1 >= lh + 1) {
last = lh - 1;
}
if (last + 1 < ln) {
/* Don't start the loop if there cannot be a valid answer */
goto lastEnd;
}
check = uh + last + 1 - ln;
while (check >= uh) {
if ((*check == un[0])
&& (0 == memcmp(check+1, un+1, (ln-1)*sizeof(Tcl_UniChar)))) {
value = (check - uh);
goto lastEnd;
}
check--;
}
lastEnd:
TclNewIntObj(result, TclWideIntFromSize(value));
return result;
}
/*
*---------------------------------------------------------------------------
*
* TclStringReverse --
*
|
| ︙ | ︙ | |||
3710 3711 3712 3713 3714 3715 3716 |
if (!inPlace || Tcl_IsShared(objPtr)) {
objPtr = Tcl_NewObj();
Tcl_SetObjLength(objPtr, numBytes);
}
to = objPtr->bytes;
| | | 3726 3727 3728 3729 3730 3731 3732 3733 3734 3735 3736 3737 3738 3739 3740 |
if (!inPlace || Tcl_IsShared(objPtr)) {
objPtr = Tcl_NewObj();
Tcl_SetObjLength(objPtr, numBytes);
}
to = objPtr->bytes;
if ((numChars == TCL_INDEX_NONE) || (numChars < numBytes)) {
/*
* Either numChars == -1 and we don't know how many chars are
* represented by objPtr->bytes and we need Pass 1 just in case,
* or numChars >= 0 and we know we have fewer chars than bytes, so
* we know there's a multibyte character needing Pass 1.
*
* Pass 1. Reverse the bytes of each multi-byte character.
|
| ︙ | ︙ | |||
3933 3934 3935 3936 3937 3938 3939 |
String *stringPtr = GET_STRING(objPtr);
size_t needed, numOrigChars = 0;
Tcl_UniChar *dst, unichar = 0;
if (stringPtr->hasUnicode) {
numOrigChars = stringPtr->numChars;
}
| | | 3949 3950 3951 3952 3953 3954 3955 3956 3957 3958 3959 3960 3961 3962 3963 |
String *stringPtr = GET_STRING(objPtr);
size_t needed, numOrigChars = 0;
Tcl_UniChar *dst, unichar = 0;
if (stringPtr->hasUnicode) {
numOrigChars = stringPtr->numChars;
}
if (numAppendChars == TCL_INDEX_NONE) {
TclNumUtfChars(numAppendChars, bytes, numBytes);
}
needed = numOrigChars + numAppendChars;
if (needed > stringPtr->maxChars) {
GrowUnicodeBuffer(objPtr, needed);
stringPtr = GET_STRING(objPtr);
|
| ︙ | ︙ | |||
3984 3985 3986 3987 3988 3989 3990 |
* an internal rep of type "String". */
Tcl_Obj *copyPtr) /* Object with internal rep to set. Must not
* currently have an internal rep.*/
{
String *srcStringPtr = GET_STRING(srcPtr);
String *copyStringPtr = NULL;
| | | 4000 4001 4002 4003 4004 4005 4006 4007 4008 4009 4010 4011 4012 4013 4014 |
* 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_INDEX_NONE) {
/*
* The String struct in the source value holds zero useful data. Don't
* bother copying it. Don't even bother allocating space in which to
* copy it. Just let the copy be untyped.
*/
return;
|
| ︙ | ︙ | |||
4134 4135 4136 4137 4138 4139 4140 |
* Pre-condition: this is the "string" Tcl_ObjType.
*/
size_t i, origLength, size = 0;
char *dst;
String *stringPtr = GET_STRING(objPtr);
| | | 4150 4151 4152 4153 4154 4155 4156 4157 4158 4159 4160 4161 4162 4163 4164 |
* Pre-condition: this is the "string" Tcl_ObjType.
*/
size_t i, origLength, size = 0;
char *dst;
String *stringPtr = GET_STRING(objPtr);
if (numChars == TCL_INDEX_NONE) {
numChars = UnicodeLength(unicode);
}
if (numChars == 0) {
return 0;
}
|
| ︙ | ︙ |
Changes to generic/tclStringTrim.h.
| ︙ | ︙ | |||
24 25 26 27 28 29 30 31 32 33 34 35 36 37 | */ MODULE_SCOPE const char tclDefaultTrimSet[]; /* * The whitespace trimming set used when [concat]enating. This is a subset of * the above, and deliberately so. */ #define CONCAT_TRIM_SET " \f\v\r\t\n" #endif /* TCL_STRING_TRIM_H */ /* | > > | 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 | */ MODULE_SCOPE const char tclDefaultTrimSet[]; /* * The whitespace trimming set used when [concat]enating. This is a subset of * the above, and deliberately so. * * TODO: Find a reasonable way to guarantee in sync with TclIsSpaceProc() */ #define CONCAT_TRIM_SET " \f\v\r\t\n" #endif /* TCL_STRING_TRIM_H */ /* |
| ︙ | ︙ |
Changes to generic/tclStubInit.c.
| ︙ | ︙ | |||
67 68 69 70 71 72 73 |
#undef Tcl_UtfToUniCharDString
#undef Tcl_UtfToUniChar
#if TCL_UTF_MAX <= 3
static void uniCodePanic() {
Tcl_Panic("This extension uses a deprecated function, not available now: Tcl is compiled with -DTCL_UTF_MAX==%d", TCL_UTF_MAX);
}
| | | | | | 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 |
#undef Tcl_UtfToUniCharDString
#undef Tcl_UtfToUniChar
#if TCL_UTF_MAX <= 3
static void uniCodePanic() {
Tcl_Panic("This extension uses a deprecated function, not available now: Tcl is compiled with -DTCL_UTF_MAX==%d", TCL_UTF_MAX);
}
# define Tcl_GetUnicode (int *(*)(Tcl_Obj *))(void *)uniCodePanic
# define Tcl_GetUnicodeFromObj (Tcl_UniChar *(*)(Tcl_Obj *, int *))(void *)uniCodePanic
# define Tcl_NewUnicodeObj (Tcl_Obj *(*)(const Tcl_UniChar *, size_t))(void *)uniCodePanic
# define Tcl_SetUnicodeObj (void(*)(Tcl_Obj *, const Tcl_UniChar *, size_t))(void *)uniCodePanic
#endif
#define TclBN_mp_add mp_add
#define TclBN_mp_add_d mp_add_d
#define TclBN_mp_and mp_and
#define TclBN_mp_clamp mp_clamp
#define TclBN_mp_clear mp_clear
|
| ︙ | ︙ | |||
138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 | #define TclBN_s_mp_mul_digs_fast s_mp_mul_digs_fast #define TclBN_s_mp_reverse s_mp_reverse #define TclBN_s_mp_sqr s_mp_sqr #define TclBN_s_mp_sqr_fast s_mp_sqr_fast #define TclBN_s_mp_sub s_mp_sub #define TclBN_mp_toom_mul s_mp_toom_mul #define TclBN_mp_toom_sqr s_mp_toom_sqr #ifdef _WIN32 # define TclUnixWaitForFile 0 # define TclUnixCopyFile 0 # define TclUnixOpenTemporaryFile 0 # define TclpReaddir 0 # define TclpIsAtty 0 #elif defined(__CYGWIN__) | > > > > > > > > > > | < < < < < < < < < < < < < < > > > > > > > > | 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 |
#define TclBN_s_mp_mul_digs_fast s_mp_mul_digs_fast
#define TclBN_s_mp_reverse s_mp_reverse
#define TclBN_s_mp_sqr s_mp_sqr
#define TclBN_s_mp_sqr_fast s_mp_sqr_fast
#define TclBN_s_mp_sub s_mp_sub
#define TclBN_mp_toom_mul s_mp_toom_mul
#define TclBN_mp_toom_sqr s_mp_toom_sqr
#define TclpCreateTempFile_ TclpCreateTempFile
#define TclUnixWaitForFile_ TclUnixWaitForFile
#ifndef MAC_OSX_TCL /* On UNIX, fill with other stub entries */
#define TclMacOSXGetFileAttribute (int (*)(Tcl_Interp *, int, Tcl_Obj *, Tcl_Obj **))(void *)TclpCreateProcess
#define TclMacOSXSetFileAttribute (int (*)(Tcl_Interp *, int, Tcl_Obj *, Tcl_Obj *))(void *)isatty
#define TclMacOSXCopyFileAttributes (int (*)(const char *, const char *, const Tcl_StatBuf *))(void *)TclUnixCopyFile
#define TclMacOSXMatchType (int (*)(Tcl_Interp *, const char *, const char *, Tcl_StatBuf *, Tcl_GlobTypeData *))(void *)TclpMakeFile
#define TclMacOSXNotifierAddRunLoopMode (void (*)(const void *))(void *)TclpOpenFile
#endif
#ifdef _WIN32
# define TclUnixWaitForFile 0
# define TclUnixCopyFile 0
# define TclUnixOpenTemporaryFile 0
# define TclpReaddir 0
# define TclpIsAtty 0
#elif defined(__CYGWIN__)
# define TclpIsAtty isatty
static void
doNothing(void)
{
/* dummy implementation, no need to do anything */
}
# define TclWinAddProcess (void (*) (void *, size_t)) doNothing
# define TclWinFlushDirtyChannels doNothing
#define TclWinNoBackslash winNoBackslash
static char *
TclWinNoBackslash(char *path)
{
char *p;
for (p = path; *p != '\0'; p++) {
if (*p == '\\') {
*p = '/';
}
}
return path;
}
void *TclWinGetTclInstance()
{
void *hInstance = NULL;
GetModuleHandleExW(GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS,
(const wchar_t *)&TclWinNoBackslash, &hInstance);
return hInstance;
}
size_t
TclpGetPid(Tcl_Pid pid)
{
return (size_t) pid;
}
|
| ︙ | ︙ | |||
513 514 515 516 517 518 519 |
TclDbDumpActiveObjects, /* 243 */
TclGetNamespaceChildTable, /* 244 */
TclGetNamespaceCommandTable, /* 245 */
TclInitRewriteEnsemble, /* 246 */
TclResetRewriteEnsemble, /* 247 */
TclCopyChannel, /* 248 */
TclDoubleDigits, /* 249 */
| | > | | | | | | | | 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 |
TclDbDumpActiveObjects, /* 243 */
TclGetNamespaceChildTable, /* 244 */
TclGetNamespaceCommandTable, /* 245 */
TclInitRewriteEnsemble, /* 246 */
TclResetRewriteEnsemble, /* 247 */
TclCopyChannel, /* 248 */
TclDoubleDigits, /* 249 */
TclSetChildCancelFlags, /* 250 */
TclRegisterLiteral, /* 251 */
TclPtrGetVar, /* 252 */
TclPtrSetVar, /* 253 */
TclPtrIncrObjVar, /* 254 */
TclPtrObjMakeUpvar, /* 255 */
TclPtrUnsetVar, /* 256 */
TclStaticPackage, /* 257 */
TclpCreateTemporaryDirectory, /* 258 */
TclAppendUnicodeToObj, /* 259 */
TclGetBytesFromObj, /* 260 */
};
static const TclIntPlatStubs tclIntPlatStubs = {
TCL_STUB_MAGIC,
0,
#if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */
TclGetAndDetachPids, /* 0 */
TclpCloseFile, /* 1 */
TclpCreateCommandChannel, /* 2 */
TclpCreatePipe, /* 3 */
TclpCreateProcess, /* 4 */
TclUnixWaitForFile_, /* 5 */
TclpMakeFile, /* 6 */
TclpOpenFile, /* 7 */
TclUnixWaitForFile, /* 8 */
TclpCreateTempFile, /* 9 */
0, /* 10 */
0, /* 11 */
0, /* 12 */
0, /* 13 */
TclUnixCopyFile, /* 14 */
TclMacOSXGetFileAttribute, /* 15 */
TclMacOSXSetFileAttribute, /* 16 */
TclMacOSXCopyFileAttributes, /* 17 */
TclMacOSXMatchType, /* 18 */
TclMacOSXNotifierAddRunLoopMode, /* 19 */
0, /* 20 */
0, /* 21 */
TclpCreateTempFile_, /* 22 */
0, /* 23 */
0, /* 24 */
0, /* 25 */
0, /* 26 */
0, /* 27 */
0, /* 28 */
TclWinCPUID, /* 29 */
|
| ︙ | ︙ | |||
600 601 602 603 604 605 606 |
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
TclGetAndDetachPids, /* 0 */
TclpCloseFile, /* 1 */
TclpCreateCommandChannel, /* 2 */
TclpCreatePipe, /* 3 */
TclpCreateProcess, /* 4 */
| | | | | 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 |
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
TclGetAndDetachPids, /* 0 */
TclpCloseFile, /* 1 */
TclpCreateCommandChannel, /* 2 */
TclpCreatePipe, /* 3 */
TclpCreateProcess, /* 4 */
TclUnixWaitForFile_, /* 5 */
TclpMakeFile, /* 6 */
TclpOpenFile, /* 7 */
TclUnixWaitForFile, /* 8 */
TclpCreateTempFile, /* 9 */
0, /* 10 */
0, /* 11 */
0, /* 12 */
0, /* 13 */
TclUnixCopyFile, /* 14 */
TclMacOSXGetFileAttribute, /* 15 */
TclMacOSXSetFileAttribute, /* 16 */
TclMacOSXCopyFileAttributes, /* 17 */
TclMacOSXMatchType, /* 18 */
TclMacOSXNotifierAddRunLoopMode, /* 19 */
0, /* 20 */
0, /* 21 */
TclpCreateTempFile_, /* 22 */
0, /* 23 */
0, /* 24 */
0, /* 25 */
0, /* 26 */
0, /* 27 */
0, /* 28 */
TclWinCPUID, /* 29 */
TclUnixOpenTemporaryFile, /* 30 */
#endif /* MACOSX */
};
static const TclPlatStubs tclPlatStubs = {
TCL_STUB_MAGIC,
0,
#ifdef MAC_OSX_TCL /* MACOSX */
0, /* 0 */
Tcl_MacOSXOpenVersionedBundleResources, /* 1 */
#endif /* MACOSX */
};
const TclTomMathStubs tclTomMathStubs = {
TCL_STUB_MAGIC,
0,
|
| ︙ | ︙ |
Changes to generic/tclStubLib.c.
| ︙ | ︙ | |||
63 64 65 66 67 68 69 |
/*
* 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]
*/
| | | 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 |
/*
* We can't optimize this check by caching tclStubsPtr because that
* prevents apps from being able to load/unload Tcl dynamically multiple
* times. [Bug 615304]
*/
if (!stubsPtr || (stubsPtr->magic != (((exact&0xFF00) >= 0x900) ? magic : TCL_STUB_MAGIC))) {
iPtr->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) {
|
| ︙ | ︙ | |||
99 100 101 102 103 104 105 |
} else {
actualVersion = stubsPtr->tcl_PkgRequireEx(interp, "Tcl", version, 1, NULL);
if (actualVersion == NULL) {
return NULL;
}
}
}
| | | 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 |
} else {
actualVersion = stubsPtr->tcl_PkgRequireEx(interp, "Tcl", version, 1, NULL);
if (actualVersion == NULL) {
return NULL;
}
}
}
if (((exact&0xFF00) < 0x900)) {
/* We are running Tcl 8.x */
stubsPtr = (TclStubs *)pkgData;
}
if (tclStubsHandle == NULL) {
tclStubsHandle = (void *) -1;
}
tclStubsPtr = stubsPtr;
|
| ︙ | ︙ |
Changes to generic/tclTest.c.
| ︙ | ︙ | |||
16 17 18 19 20 21 22 | */ #undef STATIC_BUILD #ifndef USE_TCL_STUBS # define USE_TCL_STUBS #endif #include "tclInt.h" | > > > | > | 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 | */ #undef STATIC_BUILD #ifndef USE_TCL_STUBS # define USE_TCL_STUBS #endif #include "tclInt.h" #ifdef TCL_WITH_EXTERNAL_TOMMATH # include "tommath.h" #else # include "tclTomMath.h" #endif #include "tclOO.h" #include <math.h> /* * Required for Testregexp*Cmd */ #include "tclRegexp.h" |
| ︙ | ︙ | |||
43 44 45 46 47 48 49 | /* * 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; | < | 47 48 49 50 51 52 53 54 55 56 57 58 59 60 |
/*
* 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 {
|
| ︙ | ︙ | |||
305 306 307 308 309 310 311 | static Tcl_FSFileAttrsGetProc TestReportFileAttrsGet; static Tcl_FSFileAttrsSetProc TestReportFileAttrsSet; static Tcl_FSUtimeProc TestReportUtime; static Tcl_FSNormalizePathProc TestReportNormalizePath; static Tcl_FSPathInFilesystemProc TestReportInFilesystem; static Tcl_FSFreeInternalRepProc TestReportFreeInternalRep; static Tcl_FSDupInternalRepProc TestReportDupInternalRep; | | > > | 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 | static Tcl_FSFileAttrsGetProc TestReportFileAttrsGet; static Tcl_FSFileAttrsSetProc TestReportFileAttrsSet; static Tcl_FSUtimeProc TestReportUtime; static Tcl_FSNormalizePathProc TestReportNormalizePath; static Tcl_FSPathInFilesystemProc TestReportInFilesystem; static Tcl_FSFreeInternalRepProc TestReportFreeInternalRep; static Tcl_FSDupInternalRepProc TestReportDupInternalRep; static Tcl_CmdProc TestServiceModeCmd; static Tcl_FSStatProc SimpleStat; static Tcl_FSAccessProc SimpleAccess; static Tcl_FSOpenFileChannelProc SimpleOpenFileChannel; static Tcl_FSListVolumesProc SimpleListVolumes; static Tcl_FSPathInFilesystemProc SimplePathInFilesystem; static Tcl_Obj * SimpleRedirect(Tcl_Obj *pathPtr); static Tcl_FSMatchInDirectoryProc SimpleMatchInDirectory; static Tcl_ObjCmdProc TestUtfNextCmd; static Tcl_ObjCmdProc TestUtfPrevCmd; static Tcl_ObjCmdProc TestNumUtfCharsCmd; static Tcl_ObjCmdProc TestFindFirstCmd; static Tcl_ObjCmdProc TestFindLastCmd; static Tcl_ObjCmdProc TestHashSystemHashCmd; static Tcl_NRPostProc NREUnwind_callback; static Tcl_ObjCmdProc TestNREUnwind; |
| ︙ | ︙ | |||
441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 |
"-appinitprocerror", "-appinitprocdeleteinterp",
"-appinitprocclosestderr", "-appinitprocsetrcfile", NULL
};
if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) {
return TCL_ERROR;
}
if (Tcl_TomMath_InitStubs(interp, "8.5-") == NULL) {
return TCL_ERROR;
}
if (Tcl_OOInitStubs(interp) == NULL) {
return TCL_ERROR;
}
/* TIP #268: Full patchlevel instead of just major.minor */
if (Tcl_PkgProvideEx(interp, "Tcltest", TCL_PATCH_LEVEL, NULL) == TCL_ERROR) {
return TCL_ERROR;
}
| > > < < < < < | 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 |
"-appinitprocerror", "-appinitprocdeleteinterp",
"-appinitprocclosestderr", "-appinitprocsetrcfile", NULL
};
if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) {
return TCL_ERROR;
}
#ifndef TCL_WITH_EXTERNAL_TOMMATH
if (Tcl_TomMath_InitStubs(interp, "8.5-") == NULL) {
return TCL_ERROR;
}
#endif
if (Tcl_OOInitStubs(interp) == NULL) {
return TCL_ERROR;
}
/* TIP #268: Full patchlevel instead of just major.minor */
if (Tcl_PkgProvideEx(interp, "Tcltest", TCL_PATCH_LEVEL, NULL) == TCL_ERROR) {
return TCL_ERROR;
}
/*
* Create additional commands and math functions for testing Tcl.
*/
Tcl_CreateObjCommand(interp, "gettimes", GetTimesObjCmd, NULL, NULL);
Tcl_CreateCommand(interp, "noop", NoopCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "noop", NoopObjCmd, NULL, NULL);
|
| ︙ | ︙ | |||
566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 |
Tcl_CreateObjCommand(interp, "testprint", TestprintObjCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testregexp", TestregexpObjCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testreturn", TestreturnObjCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testsaveresult", TestsaveresultCmd,
NULL, NULL);
Tcl_CreateCommand(interp, "testsetassocdata", TestsetassocdataCmd,
NULL, NULL);
Tcl_CreateCommand(interp, "testsetnoerr", TestsetCmd,
NULL, NULL);
Tcl_CreateCommand(interp, "testseterr", TestsetCmd,
INT2PTR(TCL_LEAVE_ERR_MSG), NULL);
Tcl_CreateCommand(interp, "testset2", Testset2Cmd,
INT2PTR(TCL_LEAVE_ERR_MSG), NULL);
Tcl_CreateCommand(interp, "testseterrorcode", TestseterrorcodeCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testsetobjerrorcode",
TestsetobjerrorcodeCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testnumutfchars",
TestNumUtfCharsCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testfindfirst",
TestFindFirstCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testfindlast",
TestFindLastCmd, NULL, NULL);
Tcl_CreateCommand(interp, "testsetplatform", TestsetplatformCmd,
| > > > > > > | 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 |
Tcl_CreateObjCommand(interp, "testprint", TestprintObjCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testregexp", TestregexpObjCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testreturn", TestreturnObjCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testsaveresult", TestsaveresultCmd,
NULL, NULL);
Tcl_CreateCommand(interp, "testservicemode", TestServiceModeCmd,
NULL, NULL);
Tcl_CreateCommand(interp, "testsetassocdata", TestsetassocdataCmd,
NULL, NULL);
Tcl_CreateCommand(interp, "testsetnoerr", TestsetCmd,
NULL, NULL);
Tcl_CreateCommand(interp, "testseterr", TestsetCmd,
INT2PTR(TCL_LEAVE_ERR_MSG), NULL);
Tcl_CreateCommand(interp, "testset2", Testset2Cmd,
INT2PTR(TCL_LEAVE_ERR_MSG), NULL);
Tcl_CreateCommand(interp, "testseterrorcode", TestseterrorcodeCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testsetobjerrorcode",
TestsetobjerrorcodeCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testutfnext",
TestUtfNextCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testutfprev",
TestUtfPrevCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testnumutfchars",
TestNumUtfCharsCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testfindfirst",
TestFindFirstCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testfindlast",
TestFindLastCmd, NULL, NULL);
Tcl_CreateCommand(interp, "testsetplatform", TestsetplatformCmd,
|
| ︙ | ︙ | |||
1515 1516 1517 1518 1519 1520 1521 |
}
slave = Tcl_GetSlave(interp, argv[1]);
if (slave == NULL) {
return TCL_ERROR;
}
| | | 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 |
}
slave = Tcl_GetSlave(interp, argv[1]);
if (slave == NULL) {
return TCL_ERROR;
}
dPtr = (DelCmd *)Tcl_Alloc(sizeof(DelCmd));
dPtr->interp = interp;
dPtr->deleteCmd = (char *)Tcl_Alloc(strlen(argv[3]) + 1);
strcpy(dPtr->deleteCmd, argv[3]);
Tcl_CreateCommand(slave, argv[2], DelCmdProc, dPtr,
DelDeleteProc);
return TCL_OK;
|
| ︙ | ︙ | |||
1544 1545 1546 1547 1548 1549 1550 |
return TCL_OK;
}
static void
DelDeleteProc(
void *clientData) /* String command to evaluate. */
{
| | | 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 |
return TCL_OK;
}
static void
DelDeleteProc(
void *clientData) /* String command to evaluate. */
{
DelCmd *dPtr = (DelCmd *)clientData;
Tcl_EvalEx(dPtr->interp, dPtr->deleteCmd, -1, 0);
Tcl_ResetResult(dPtr->interp);
Tcl_Free(dPtr->deleteCmd);
Tcl_Free(dPtr);
}
|
| ︙ | ︙ | |||
1749 1750 1751 1752 1753 1754 1755 |
} else if (strcmp(argv[2], "staticlarge") == 0) {
Tcl_AppendResult(interp, "first0 first1 first2 first3 first4 first5 first6 first7 first8 first9\nsecond0 second1 second2 second3 second4 second5 second6 second7 second8 second9\nthird0 third1 third2 third3 third4 third5 third6 third7 third8 third9\nfourth0 fourth1 fourth2 fourth3 fourth4 fourth5 fourth6 fourth7 fourth8 fourth9\nfifth0 fifth1 fifth2 fifth3 fifth4 fifth5 fifth6 fifth7 fifth8 fifth9\nsixth0 sixth1 sixth2 sixth3 sixth4 sixth5 sixth6 sixth7 sixth8 sixth9\nseventh0 seventh1 seventh2 seventh3 seventh4 seventh5 seventh6 seventh7 seventh8 seventh9\n", NULL);
} else if (strcmp(argv[2], "free") == 0) {
char *s = (char *)Tcl_Alloc(100);
strcpy(s, "This is a malloc-ed string");
Tcl_SetResult(interp, s, TCL_DYNAMIC);
} else if (strcmp(argv[2], "special") == 0) {
| | | 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 |
} else if (strcmp(argv[2], "staticlarge") == 0) {
Tcl_AppendResult(interp, "first0 first1 first2 first3 first4 first5 first6 first7 first8 first9\nsecond0 second1 second2 second3 second4 second5 second6 second7 second8 second9\nthird0 third1 third2 third3 third4 third5 third6 third7 third8 third9\nfourth0 fourth1 fourth2 fourth3 fourth4 fourth5 fourth6 fourth7 fourth8 fourth9\nfifth0 fifth1 fifth2 fifth3 fifth4 fifth5 fifth6 fifth7 fifth8 fifth9\nsixth0 sixth1 sixth2 sixth3 sixth4 sixth5 sixth6 sixth7 sixth8 sixth9\nseventh0 seventh1 seventh2 seventh3 seventh4 seventh5 seventh6 seventh7 seventh8 seventh9\n", NULL);
} else if (strcmp(argv[2], "free") == 0) {
char *s = (char *)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;
|
| ︙ | ︙ | |||
2733 2734 2735 2736 2737 2738 2739 |
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;
| | | 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 |
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;
|
| ︙ | ︙ | |||
5060 5061 5062 5063 5064 5065 5066 |
static int
TestbytestringObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
| | > | | < | 5068 5069 5070 5071 5072 5073 5074 5075 5076 5077 5078 5079 5080 5081 5082 5083 5084 5085 5086 5087 5088 5089 5090 5091 |
static int
TestbytestringObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
size_t n = 0;
const char *p;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "bytearray");
return TCL_ERROR;
}
p = (const char *)TclGetBytesFromObj(interp, objv[1], &n);
if (p == NULL) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewStringObj(p, n));
return TCL_OK;
}
/*
|
| ︙ | ︙ | |||
6153 6154 6155 6156 6157 6158 6159 6160 6161 6162 6163 6164 6165 6166 |
"testflags", NULL);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* TestWrongNumArgsObjCmd --
*
* Test the Tcl_WrongNumArgs function.
*
* Results:
* Standard Tcl result.
*
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 6161 6162 6163 6164 6165 6166 6167 6168 6169 6170 6171 6172 6173 6174 6175 6176 6177 6178 6179 6180 6181 6182 6183 6184 6185 6186 6187 6188 6189 6190 6191 6192 6193 6194 6195 6196 6197 6198 6199 6200 6201 6202 6203 6204 6205 6206 6207 6208 6209 6210 6211 6212 6213 6214 6215 6216 6217 6218 6219 6220 6221 6222 |
"testflags", NULL);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* TestServiceModeCmd --
*
* This procedure implements the "testservicemode" command which gets or
* sets the current Tcl ServiceMode. There are several tests which open
* a file and assign various handlers to it. For these tests to be
* deterministic it is important that file events not be processed until
* all of the handlers are in place.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* May change the ServiceMode setting.
*
*----------------------------------------------------------------------
*/
static int
TestServiceModeCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
int newmode, oldmode;
if (argc > 2) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" ?newmode?\"", NULL);
return TCL_ERROR;
}
oldmode = (Tcl_GetServiceMode() != TCL_SERVICE_NONE);
if (argc == 2) {
if (Tcl_GetInt(interp, argv[1], &newmode) == TCL_ERROR) {
return TCL_ERROR;
}
if (newmode == 0) {
Tcl_SetServiceMode(TCL_SERVICE_NONE);
} else {
Tcl_SetServiceMode(TCL_SERVICE_ALL);
}
}
Tcl_SetObjResult(interp, Tcl_NewIntObj(oldmode));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestWrongNumArgsObjCmd --
*
* Test the Tcl_WrongNumArgs function.
*
* Results:
* Standard Tcl result.
*
|
| ︙ | ︙ | |||
6378 6379 6380 6381 6382 6383 6384 |
Tcl_Obj *arg2)
{
Tcl_Interp *interp = (Tcl_Interp *) Tcl_FSData(&testReportingFilesystem);
if (interp == NULL) {
/* This is bad, but not much we can do about it */
} else {
| < < < < < | 6434 6435 6436 6437 6438 6439 6440 6441 6442 6443 6444 6445 6446 6447 |
Tcl_Obj *arg2)
{
Tcl_Interp *interp = (Tcl_Interp *) Tcl_FSData(&testReportingFilesystem);
if (interp == NULL) {
/* This is bad, but not much we can do about it */
} else {
Tcl_Obj *savedResult;
Tcl_DString ds;
Tcl_DStringInit(&ds);
Tcl_DStringAppend(&ds, "lappend filesystemReport ", -1);
Tcl_DStringStartSublist(&ds);
Tcl_DStringAppendElement(&ds, cmd);
|
| ︙ | ︙ | |||
6807 6808 6809 6810 6811 6812 6813 6814 6815 6816 6817 6818 6819 6820 6821 6822 6823 6824 6825 6826 |
/* Add one new volume */
Tcl_Obj *retVal;
retVal = Tcl_NewStringObj("simplefs:/", -1);
Tcl_IncrRefCount(retVal);
return retVal;
}
/*
* Used to check correct string-length determining in Tcl_NumUtfChars
*/
static int
TestNumUtfCharsCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
if (objc > 1) {
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > | > | > > > > | | | 6858 6859 6860 6861 6862 6863 6864 6865 6866 6867 6868 6869 6870 6871 6872 6873 6874 6875 6876 6877 6878 6879 6880 6881 6882 6883 6884 6885 6886 6887 6888 6889 6890 6891 6892 6893 6894 6895 6896 6897 6898 6899 6900 6901 6902 6903 6904 6905 6906 6907 6908 6909 6910 6911 6912 6913 6914 6915 6916 6917 6918 6919 6920 6921 6922 6923 6924 6925 6926 6927 6928 6929 6930 6931 6932 6933 6934 6935 6936 6937 6938 6939 6940 6941 6942 6943 6944 6945 6946 6947 6948 6949 6950 6951 6952 6953 6954 6955 6956 6957 6958 6959 6960 6961 6962 6963 6964 6965 6966 6967 6968 6969 6970 6971 6972 6973 6974 6975 6976 6977 6978 6979 6980 6981 6982 6983 6984 6985 6986 6987 6988 6989 6990 6991 6992 6993 6994 6995 6996 6997 6998 6999 7000 7001 |
/* Add one new volume */
Tcl_Obj *retVal;
retVal = Tcl_NewStringObj("simplefs:/", -1);
Tcl_IncrRefCount(retVal);
return retVal;
}
/*
* Used to check operations of Tcl_UtfNext.
*
* Usage: testutfnext -bytestring $bytes
*/
static int
TestUtfNextCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
size_t numBytes;
char *bytes;
const char *result, *first;
char buffer[32];
static const char tobetested[] = "A\xA0\xC0\xC1\xC2\xD0\xE0\xE8\xF2\xF7\xF8\xFE\xFF";
const char *p = tobetested;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?-bytestring? bytes");
return TCL_ERROR;
}
bytes = Tcl_GetString(objv[1]);
numBytes = objv[1]->length;
if (numBytes > (int)sizeof(buffer) - 4) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"testutfnext\" can only handle %d bytes",
(int)sizeof(buffer) - 4));
return TCL_ERROR;
}
memcpy(buffer + 1, bytes, numBytes);
buffer[0] = buffer[numBytes + 1] = buffer[numBytes + 2] = buffer[numBytes + 3] = '\xA0';
first = result = Tcl_UtfNext(buffer + 1);
while ((buffer[0] = *p++) != '\0') {
/* Run Tcl_UtfNext with many more possible bytes at src[-1], all should give the same result */
result = Tcl_UtfNext(buffer + 1);
if (first != result) {
Tcl_AppendResult(interp, "Tcl_UtfNext is not supposed to read src[-1]", NULL);
return TCL_ERROR;
}
}
p = tobetested;
while ((buffer[numBytes + 1] = *p++) != '\0') {
/* Run Tcl_UtfNext with many more possible bytes at src[end], all should give the same result */
result = Tcl_UtfNext(buffer + 1);
if (first != result) {
first = buffer;
break;
}
}
Tcl_SetObjResult(interp, Tcl_NewIntObj(first - buffer - 1));
return TCL_OK;
}
/*
* Used to check operations of Tcl_UtfPrev.
*
* Usage: testutfprev $bytes $offset
*/
static int
TestUtfPrevCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
size_t numBytes, offset;
char *bytes;
const char *result;
if (objc < 2 || objc > 3) {
Tcl_WrongNumArgs(interp, 1, objv, "bytes ?offset?");
return TCL_ERROR;
}
bytes = Tcl_GetString(objv[1]);
numBytes = objv[1]->length;
if (objc == 3) {
if (TCL_OK != Tcl_GetIntForIndex(interp, objv[2], numBytes, &offset)) {
return TCL_ERROR;
}
if (offset == TCL_INDEX_NONE) {
offset = 0;
}
if (offset > numBytes) {
offset = numBytes;
}
} else {
offset = numBytes;
}
result = TclUtfPrev(bytes + offset, bytes);
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(result - bytes));
return TCL_OK;
}
/*
* Used to check correct string-length determining in Tcl_NumUtfChars
*/
static int
TestNumUtfCharsCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
if (objc > 1) {
size_t len, limit = TCL_INDEX_NONE;
const char *bytes = Tcl_GetString(objv[1]);
size_t numBytes = objv[1]->length;
if (objc > 2) {
if (Tcl_GetIntForIndex(interp, objv[2], numBytes, &limit) != TCL_OK) {
return TCL_ERROR;
}
if (limit > numBytes + 1) {
limit = numBytes + 1;
}
}
len = Tcl_NumUtfChars(bytes, limit);
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(len));
}
return TCL_OK;
}
/*
* Used to check correct operation of Tcl_UtfFindFirst
*/
|
| ︙ | ︙ |
Changes to generic/tclThread.c.
| ︙ | ︙ | |||
122 123 124 125 126 127 128 | *---------------------------------------------------------------------- * * RememberSyncObject * * Keep a list of (mutexes/condition variable/data key) used during * finalization. * | | | 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 | *---------------------------------------------------------------------- * * RememberSyncObject * * Keep a list of (mutexes/condition variable/data key) used during * finalization. * * Assume global lock is held. * * Results: * None. * * Side effects: * Add to the appropriate list. * |
| ︙ | ︙ | |||
183 184 185 186 187 188 189 | /* *---------------------------------------------------------------------- * * ForgetSyncObject * * Remove a single object from the list. | | | 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 | /* *---------------------------------------------------------------------- * * ForgetSyncObject * * Remove a single object from the list. * Assume global lock is held. * * Results: * None. * * Side effects: * Remove from the appropriate list. * |
| ︙ | ︙ | |||
215 216 217 218 219 220 221 | /* *---------------------------------------------------------------------- * * TclRememberMutex * * Keep a list of mutexes used during finalization. | | | 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 | /* *---------------------------------------------------------------------- * * TclRememberMutex * * Keep a list of mutexes used during finalization. * Assume global lock is held. * * Results: * None. * * Side effects: * Add to the mutex list. * |
| ︙ | ︙ | |||
258 259 260 261 262 263 264 |
void
Tcl_MutexFinalize(
Tcl_Mutex *mutexPtr)
{
#if TCL_THREADS
TclpFinalizeMutex(mutexPtr);
#endif
| | | | | 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 |
void
Tcl_MutexFinalize(
Tcl_Mutex *mutexPtr)
{
#if TCL_THREADS
TclpFinalizeMutex(mutexPtr);
#endif
TclpGlobalLock();
ForgetSyncObject(mutexPtr, &mutexRecord);
TclpGlobalUnlock();
}
/*
*----------------------------------------------------------------------
*
* TclRememberCondition
*
* Keep a list of condition variables used during finalization.
* Assume global lock is held.
*
* Results:
* None.
*
* Side effects:
* Add to the condition variable list.
*
|
| ︙ | ︙ | |||
312 313 314 315 316 317 318 |
void
Tcl_ConditionFinalize(
Tcl_Condition *condPtr)
{
#if TCL_THREADS
TclpFinalizeCondition(condPtr);
#endif
| | | | 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 |
void
Tcl_ConditionFinalize(
Tcl_Condition *condPtr)
{
#if TCL_THREADS
TclpFinalizeCondition(condPtr);
#endif
TclpGlobalLock();
ForgetSyncObject(condPtr, &condRecord);
TclpGlobalUnlock();
}
/*
*----------------------------------------------------------------------
*
* TclFinalizeThreadData --
*
|
| ︙ | ︙ | |||
346 347 348 349 350 351 352 353 354 355 356 357 358 359 |
#if TCL_THREADS && defined(USE_THREAD_ALLOC)
if (!quick) {
/*
* Quick exit principle makes it useless to terminate allocators
*/
TclFinalizeThreadAllocThread();
}
#endif
}
/*
*----------------------------------------------------------------------
*
* TclFinalizeSynchronization --
| > > | 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 |
#if TCL_THREADS && defined(USE_THREAD_ALLOC)
if (!quick) {
/*
* Quick exit principle makes it useless to terminate allocators
*/
TclFinalizeThreadAllocThread();
}
#else
(void)quick;
#endif
}
/*
*----------------------------------------------------------------------
*
* TclFinalizeSynchronization --
|
| ︙ | ︙ | |||
376 377 378 379 380 381 382 |
int i;
void *blockPtr;
Tcl_ThreadDataKey *keyPtr;
#if TCL_THREADS
Tcl_Mutex *mutexPtr;
Tcl_Condition *condPtr;
| | | 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 |
int i;
void *blockPtr;
Tcl_ThreadDataKey *keyPtr;
#if TCL_THREADS
Tcl_Mutex *mutexPtr;
Tcl_Condition *condPtr;
TclpGlobalLock();
#endif
/*
* If we're running unthreaded, the TSD blocks are simply stored inside
* their thread data keys. Free them here.
*/
|
| ︙ | ︙ | |||
398 399 400 401 402 403 404 |
keyRecord.list = NULL;
}
keyRecord.max = 0;
keyRecord.num = 0;
#if TCL_THREADS
/*
| | | 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 |
keyRecord.list = NULL;
}
keyRecord.max = 0;
keyRecord.num = 0;
#if TCL_THREADS
/*
* Call thread storage global cleanup.
*/
TclFinalizeThreadStorage();
for (i=0 ; i<mutexRecord.num ; i++) {
mutexPtr = (Tcl_Mutex *)mutexRecord.list[i];
if (mutexPtr != NULL) {
|
| ︙ | ︙ | |||
429 430 431 432 433 434 435 |
if (condRecord.list != NULL) {
Tcl_Free(condRecord.list);
condRecord.list = NULL;
}
condRecord.max = 0;
condRecord.num = 0;
| | | 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 |
if (condRecord.list != NULL) {
Tcl_Free(condRecord.list);
condRecord.list = NULL;
}
condRecord.max = 0;
condRecord.num = 0;
TclpGlobalUnlock();
#endif /* TCL_THREADS */
}
/*
*----------------------------------------------------------------------
*
* Tcl_ExitThread --
|
| ︙ | ︙ |
Changes to generic/tclThreadAlloc.c.
| ︙ | ︙ | |||
1142 1143 1144 1145 1146 1147 1148 | * List appended to given dstring. * *---------------------------------------------------------------------- */ void Tcl_GetMemoryInfo( | | | 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 |
* List appended to given dstring.
*
*----------------------------------------------------------------------
*/
void
Tcl_GetMemoryInfo(
TCL_UNUSED(Tcl_DString *))
{
Tcl_Panic("Tcl_GetMemoryInfo called when threaded memory allocator not in use");
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ |
Changes to generic/tclThreadStorage.c.
| ︙ | ︙ | |||
23 24 25 26 27 28 29 | * it for storing a table pointer. Each Tcl_ThreadDataKey has an offset into * the table of TSD values. We don't use more than 1 platform-specific TSD * slot, because there is a hard limit on the number of TSD slots. Valid key * offsets are greater than 0; 0 is for the initialized Tcl_ThreadDataKey. */ /* | | | | | | 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 |
* it for storing a table pointer. Each Tcl_ThreadDataKey has an offset into
* the table of TSD values. We don't use more than 1 platform-specific TSD
* slot, because there is a hard limit on the number of TSD slots. Valid key
* offsets are greater than 0; 0 is for the initialized Tcl_ThreadDataKey.
*/
/*
* The global collection of information about TSDs. This is shared across the
* whole process, and includes the mutex used to protect it.
*/
static struct {
void *key; /* Key into the system TSD structure. The
* collection of Tcl TSD values for a
* particular thread will hang off the
* back-end of this. */
sig_atomic_t counter; /* The number of different Tcl TSDs used
* across *all* threads. This is a strictly
* increasing value. */
Tcl_Mutex mutex; /* Protection for the rest of this structure,
* which holds per-process data. */
} tsdGlobal = { NULL, 0, NULL };
/*
* The type of the data held per thread in a system TSD.
*/
typedef struct {
ClientData *tablePtr; /* The table of Tcl TSDs. */
sig_atomic_t allocated; /* The size of the table in the current
* thread. */
} TSDTable;
/*
* The actual type of Tcl_ThreadDataKey.
*/
typedef union {
volatile sig_atomic_t offset;
/* The type is really an offset into the
* thread-local table of TSDs, which is this
* field. */
void *ptr; /* For alignment purposes only. Not actually
* accessed through this. */
} TSDUnion;
|
| ︙ | ︙ | |||
185 186 187 188 189 190 191 |
*----------------------------------------------------------------------
*/
void *
TclThreadStorageKeyGet(
Tcl_ThreadDataKey *dataKeyPtr)
{
| | | 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 |
*----------------------------------------------------------------------
*/
void *
TclThreadStorageKeyGet(
Tcl_ThreadDataKey *dataKeyPtr)
{
TSDTable *tsdTablePtr = (TSDTable *)TclpThreadGetGlobalTSD(tsdGlobal.key);
ClientData resultPtr = NULL;
TSDUnion *keyPtr = (TSDUnion *) dataKeyPtr;
sig_atomic_t offset = keyPtr->offset;
if ((tsdTablePtr != NULL) && (offset > 0)
&& (offset < tsdTablePtr->allocated)) {
resultPtr = tsdTablePtr->tablePtr[offset];
|
| ︙ | ︙ | |||
219 220 221 222 223 224 225 |
*/
void
TclThreadStorageKeySet(
Tcl_ThreadDataKey *dataKeyPtr,
void *value)
{
| | | | | | | 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 |
*/
void
TclThreadStorageKeySet(
Tcl_ThreadDataKey *dataKeyPtr,
void *value)
{
TSDTable *tsdTablePtr = (TSDTable *)TclpThreadGetGlobalTSD(tsdGlobal.key);
TSDUnion *keyPtr = (TSDUnion *) dataKeyPtr;
if (tsdTablePtr == NULL) {
tsdTablePtr = TSDTableCreate();
TclpThreadSetGlobalTSD(tsdGlobal.key, tsdTablePtr);
}
/*
* Get the lock while we check if this TSD is new or not. Note that this
* is the only place where Tcl_ThreadDataKey values are set. We use a
* double-checked lock to try to avoid having to grab this lock a lot,
* since it is on quite a few critical paths and will only get set once in
* each location.
*/
if (keyPtr->offset == 0) {
Tcl_MutexLock(&tsdGlobal.mutex);
if (keyPtr->offset == 0) {
/*
* The Tcl_ThreadDataKey hasn't been used yet. Make a new one.
*/
keyPtr->offset = ++tsdGlobal.counter;
}
Tcl_MutexUnlock(&tsdGlobal.mutex);
}
/*
* Check if this is the first time this Tcl_ThreadDataKey has been used
* with the current thread. Note that we don't need to hold a lock when
* doing this, as we are *definitely* the only point accessing this
* tsdTablePtr right now; it's thread-local.
|
| ︙ | ︙ | |||
284 285 286 287 288 289 290 |
*
*----------------------------------------------------------------------
*/
void
TclFinalizeThreadDataThread(void)
{
| | | | 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 |
*
*----------------------------------------------------------------------
*/
void
TclFinalizeThreadDataThread(void)
{
TSDTable *tsdTablePtr = (TSDTable *)TclpThreadGetGlobalTSD(tsdGlobal.key);
if (tsdTablePtr != NULL) {
TSDTableDelete(tsdTablePtr);
TclpThreadSetGlobalTSD(tsdGlobal.key, NULL);
}
}
/*
*----------------------------------------------------------------------
*
* TclInitializeThreadStorage --
|
| ︙ | ︙ | |||
312 313 314 315 316 317 318 |
*
*----------------------------------------------------------------------
*/
void
TclInitThreadStorage(void)
{
| | | 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 |
*
*----------------------------------------------------------------------
*/
void
TclInitThreadStorage(void)
{
tsdGlobal.key = TclpThreadCreateKey();
}
/*
*----------------------------------------------------------------------
*
* TclFinalizeThreadStorage --
*
|
| ︙ | ︙ | |||
335 336 337 338 339 340 341 |
*
*----------------------------------------------------------------------
*/
void
TclFinalizeThreadStorage(void)
{
| | | | 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 |
*
*----------------------------------------------------------------------
*/
void
TclFinalizeThreadStorage(void)
{
TclpThreadDeleteKey(tsdGlobal.key);
tsdGlobal.key = NULL;
}
#else /* !TCL_THREADS */
/*
* Stub functions for non-threaded builds
*/
|
| ︙ | ︙ |
Changes to generic/tclTomMath.h.
1 2 3 4 | #ifndef BN_TCL_H_ #define BN_TCL_H_ #ifdef MP_NO_STDINT | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 |
#ifndef BN_TCL_H_
#define BN_TCL_H_
#ifdef MP_NO_STDINT
# ifdef HAVE_STDINT_H
# include <stdint.h>
#else
# include "../compat/stdint.h"
# endif
#endif
#if defined(TCL_NO_TOMMATH_H)
typedef size_t mp_digit;
typedef int mp_sign;
# define MP_ZPOS 0 /* positive integer */
# define MP_NEG 1 /* negative */
typedef int mp_ord;
# define MP_LT -1 /* less than */
# define MP_EQ 0 /* equal to */
# define MP_GT 1 /* greater than */
typedef int mp_err;
# define MP_OKAY 0 /* no error */
# define MP_ERR -1 /* unknown error */
# define MP_MEM -2 /* out of mem */
# define MP_VAL -3 /* invalid input */
# define MP_ITER -4 /* maximum iterations reached */
# define MP_BUF -5 /* buffer overflow, supplied buffer too small */
# define MP_WUR /* nothing */
# define mp_iszero(a) ((a)->used == 0)
# define mp_isneg(a) ((a)->sign != 0)
/* the infamous mp_int structure */
# ifndef MP_INT_DECLARED
# define MP_INT_DECLARED
typedef struct mp_int mp_int;
# endif
struct mp_int {
int used, alloc;
mp_sign sign;
mp_digit *dp;
};
#elif !defined(BN_H_) /* If BN_H_ already defined, don't try to include tommath.h again. */
# include "tommath.h"
#endif
#include "tclTomMathDecls.h"
#endif
|
Changes to generic/tclTomMathDecls.h.
| ︙ | ︙ | |||
589 590 591 592 593 594 595 | #define mp_init_i32(a,b) mp_init_i64((a),(int32_t)(b)) #define mp_init_l(a,b) mp_init_i64((a),(long)(b)) #define mp_init_u32(a,b) mp_init_u64((a),(uint32_t)(b)) #define mp_init_ul(a,b) mp_init_u64((a),(unsigned long)(b)) #undef mp_iseven #undef mp_isodd #define mp_iseven(a) (!mp_isodd(a)) | | | 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 | #define mp_init_i32(a,b) mp_init_i64((a),(int32_t)(b)) #define mp_init_l(a,b) mp_init_i64((a),(long)(b)) #define mp_init_u32(a,b) mp_init_u64((a),(uint32_t)(b)) #define mp_init_ul(a,b) mp_init_u64((a),(unsigned long)(b)) #undef mp_iseven #undef mp_isodd #define mp_iseven(a) (!mp_isodd(a)) #define mp_isodd(a) (((a)->used != 0) && (((a)->dp[0] & 1) != 0)) #undef mp_sqr #define mp_sqr(a,b) mp_mul(a,a,b) #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLIMPORT #endif /* _TCLINTDECLS */ |
Changes to generic/tclTrace.c.
| ︙ | ︙ | |||
1845 1846 1847 1848 1849 1850 1851 | Tcl_Obj *resultCode; const char *resultCodeStr; /* * Append result code. */ | | | 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 | Tcl_Obj *resultCode; const char *resultCodeStr; /* * Append result code. */ TclNewIntObj(resultCode, code); resultCodeStr = TclGetString(resultCode); Tcl_DStringAppendElement(&cmd, resultCodeStr); Tcl_DecrRefCount(resultCode); /* * Append result string. */ |
| ︙ | ︙ | |||
1973 1974 1975 1976 1977 1978 1979 |
TraceVarInfo *tvarPtr = (TraceVarInfo *)clientData;
char *result;
int code, destroy = 0;
Tcl_DString cmd;
int rewind = ((Interp *)interp)->execEnvPtr->rewind;
/*
| | | 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 |
TraceVarInfo *tvarPtr = (TraceVarInfo *)clientData;
char *result;
int code, destroy = 0;
Tcl_DString cmd;
int rewind = ((Interp *)interp)->execEnvPtr->rewind;
/*
* We might call Tcl_EvalEx() below, and that might evaluate [trace vdelete]
* which might try to free tvarPtr. We want to use tvarPtr until the end
* of this function, so we use Tcl_Preserve() and Tcl_Release() to be sure
* it is not freed while we still need it.
*/
result = NULL;
if ((tvarPtr->flags & flags) && !Tcl_InterpDeleted(interp)
|
| ︙ | ︙ |
Changes to generic/tclUtf.c.
| ︙ | ︙ | |||
51 52 53 54 55 56 57 | * Unicode characters less than this value are represented by themselves in * UTF-8 strings. */ #define UNICODE_SELF 0x80 /* | | > > > > > > > > > > > > > > > > > > > > > | | > > > > > > > > > > > > | 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 |
* Unicode characters less than this value are represented by themselves in
* UTF-8 strings.
*/
#define UNICODE_SELF 0x80
/*
* The following structures are used when mapping between Unicode and
* UTF-8.
*/
static const unsigned char totalBytes[256] = {
1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
/* Tcl_UtfCharComplete() might point to 2nd byte of valid 4-byte sequence */
3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,
3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,
/* End of "continuation byte section" */
2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,
3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,
#if TCL_UTF_MAX > 3
4,4,4,4,4,
#else
1,1,1,1,1,
#endif
1,1,1,1,1,1,1,1,1,1,1
};
static const unsigned char complete[256] = {
1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
/* Tcl_UtfCharComplete() might point to 2nd byte of valid 4-byte sequence */
3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,
3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,
/* End of "continuation byte section" */
2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,
3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,
#if TCL_UTF_MAX > 3
4,4,4,4,4,
#else
3,3,3,3,3,
#endif
1,1,1,1,1,1,1,1,1,1,1
};
/*
* Functions used only in this module.
*/
static int Invalid(const char *src);
/*
*---------------------------------------------------------------------------
*
* TclUtfCount --
*
* Find the number of bytes in the Utf character "ch".
|
| ︙ | ︙ | |||
97 98 99 100 101 102 103 |
return 2;
}
if (((unsigned)(ch - 0x10000) <= 0xFFFFF)) {
return 4;
}
return 3;
}
| | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 |
return 2;
}
if (((unsigned)(ch - 0x10000) <= 0xFFFFF)) {
return 4;
}
return 3;
}
/*
*---------------------------------------------------------------------------
*
* Invalid --
*
* Given a pointer to a two-byte prefix of a well-formed UTF-8 byte
* sequence (a lead byte followed by a trail byte) this routine
* examines those two bytes to determine whether the sequence is
* invalid in UTF-8. This might be because it is an overlong
* encoding, or because it encodes something out of the proper range.
*
* Given a pointer to the bytes \xF8 or \xFC , this routine will
* try to read beyond the end of the "bounds" table. Callers must
* prevent this.
*
* Given a pointer to something else (an ASCII byte, a trail byte,
* or another byte that can never begin a valid byte sequence such
* as \xF5) this routine returns false. That makes the routine poorly
* named, as it does not detect and report all invalid sequences.
*
* Callers have to take care that this routine does something useful
* for their needs.
*
* Results:
* A boolean.
*---------------------------------------------------------------------------
*/
static const unsigned char bounds[28] = {
0x80, 0x80, /* \xC0 accepts \x80 only */
0x80, 0xBF, 0x80, 0xBF, 0x80, 0xBF, 0x80, 0xBF, 0x80, 0xBF, 0x80, 0xBF,
0x80, 0xBF, /* (\xC4 - \xDC) -- all sequences valid */
0xA0, 0xBF, /* \xE0\x80 through \xE0\x9F are invalid prefixes */
0x80, 0xBF, 0x80, 0xBF, 0x80, 0xBF, /* (\xE4 - \xEC) -- all valid */
0x90, 0xBF, /* \xF0\x80 through \xF0\x8F are invalid prefixes */
0x80, 0x8F /* \xF4\x90 and higher are invalid prefixes */
};
static int
Invalid(
const char *src) /* Points to lead byte of a UTF-8 byte sequence */
{
unsigned char byte = UCHAR(*src);
int index;
if ((byte & 0xC3) == 0xC0) {
/* Only lead bytes 0xC0, 0xE0, 0xF0, 0xF4 need examination */
index = (byte - 0xC0) >> 1;
if (UCHAR(src[1]) < bounds[index] || UCHAR(src[1]) > bounds[index+1]) {
/* Out of bounds - report invalid. */
return 1;
}
}
return 0;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_UniCharToUtf --
*
* Store the given Tcl_UniChar as a sequence of UTF-8 bytes in the
* provided buffer. Equivalent to Plan 9 runetochar().
|
| ︙ | ︙ | |||
236 237 238 239 240 241 242 |
/*
* UTF-8 string length in bytes will be <= Unicode string length * 4.
*/
if (uniStr == NULL) {
return NULL;
}
| | | 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 |
/*
* UTF-8 string length in bytes will be <= Unicode string length * 4.
*/
if (uniStr == NULL) {
return NULL;
}
if (uniLength == TCL_INDEX_NONE) {
uniLength = 0;
w = uniStr;
while (*w != '\0') {
uniLength++;
w++;
}
}
|
| ︙ | ︙ | |||
278 279 280 281 282 283 284 |
/*
* UTF-8 string length in bytes will be <= Utf16 string length * 3.
*/
if (uniStr == NULL) {
return NULL;
}
| | | 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 |
/*
* UTF-8 string length in bytes will be <= Utf16 string length * 3.
*/
if (uniStr == NULL) {
return NULL;
}
if (uniLength == TCL_INDEX_NONE) {
uniLength = 0;
w = uniStr;
while (*w != '\0') {
uniLength++;
w++;
}
|
| ︙ | ︙ | |||
329 330 331 332 333 334 335 | * 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. * | | | | | 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 |
* The caller must ensure that the source buffer is long enough that this
* routine does not run off the end and dereference non-existent memory
* looking for trail bytes. If the source buffer is known to be '\0'
* terminated, this cannot happen. Otherwise, the caller should call
* Tcl_UtfCharComplete() before calling this routine to ensure that
* enough bytes remain in the string.
*
* If TCL_UTF_MAX <= 3, special handling of Surrogate pairs is done:
* For any UTF-8 string containing a character outside of the BMP, the
* first call to this function will fill *chPtr with the high surrogate
* and generate a return value of 1. Calling Tcl_UtfToUniChar again
* will produce the low surrogate and a return value of 3. Because *chPtr
* is used to remember whether the high surrogate is already produced, it
* is recommended to initialize the variable it points to as 0 before
* the first call to Tcl_UtfToUniChar is done.
*
* Results:
* *chPtr is filled with the Tcl_UniChar, and the return value is the
* number of bytes from the UTF-8 string that were consumed.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
static const unsigned short cp1252[32] = {
0x20AC, 0x81, 0x201A, 0x0192, 0x201E, 0x2026, 0x2020, 0x2021,
0x02C6, 0x2030, 0x0160, 0x2039, 0x0152, 0x8D, 0x017D, 0x8F,
0x90, 0x2018, 0x2019, 0x201C, 0x201D, 0x2022, 0x2013, 0x2014,
0x2DC, 0x2122, 0x0161, 0x203A, 0x0153, 0x9D, 0x017E, 0x0178
};
#undef Tcl_UtfToUniChar
int
Tcl_UtfToUniChar(
const char *src, /* The UTF-8 string. */
int *chPtr)/* Filled with the Unicode character represented by
* the UTF-8 string. */
{
int byte;
/*
* Unroll 1 to 4 byte UTF-8 sequences.
*/
|
| ︙ | ︙ | |||
418 419 420 421 422 423 424 |
}
/*
* A three-byte-character lead-byte not followed by two trail-bytes
* represents itself.
*/
}
| | | 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 |
}
/*
* A three-byte-character lead-byte not followed by two trail-bytes
* represents itself.
*/
}
else if (byte < 0xF5) {
if (((src[1] & 0xC0) == 0x80) && ((src[2] & 0xC0) == 0x80) && ((src[3] & 0xC0) == 0x80)) {
/*
* Four-byte-character lead byte followed by three trail bytes.
*/
*chPtr = (((byte & 0x07) << 18) | ((src[1] & 0x3F) << 12)
| ((src[2] & 0x3F) << 6) | (src[3] & 0x3F));
if ((unsigned)(*chPtr - 0x10000) <= 0xFFFFF) {
|
| ︙ | ︙ | |||
443 444 445 446 447 448 449 |
*chPtr = byte;
return 1;
}
int
Tcl_UtfToChar16(
const char *src, /* The UTF-8 string. */
| | | | | > | < | 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 |
*chPtr = byte;
return 1;
}
int
Tcl_UtfToChar16(
const char *src, /* The UTF-8 string. */
unsigned short *chPtr)/* Filled with the Tcl_UniChar represented by
* the UTF-8 string. This could be a surrogate too. */
{
unsigned short byte;
/*
* Unroll 1 to 4 byte UTF-8 sequences.
*/
byte = UCHAR(*src);
if (byte < 0xC0) {
/*
* Handles properly formed UTF-8 characters between 0x01 and 0x7F.
* Treats naked trail bytes 0x80 to 0x9F as valid characters from
* the cp1252 table. See: <https://en.wikipedia.org/wiki/UTF-8>
* Also treats \0 and other naked trail bytes 0xA0 to 0xBF as valid
* characters representing themselves.
*/
/* If *chPtr contains a high surrogate (produced by a previous
* Tcl_UtfToUniChar() call) and the next 3 bytes are UTF-8 continuation
* bytes, then we must produce a follow-up low surrogate. We only
* do that if the high surrogate matches the bits we encounter.
*/
if (((byte & 0xC0) == 0x80)
&& ((src[1] & 0xC0) == 0x80) && ((src[2] & 0xC0) == 0x80)
&& (((((byte - 0x10) << 2) & 0xFC) | 0xD800) == (*chPtr & 0xFCFC))
&& ((src[1] & 0xF0) == (((*chPtr << 4) & 0x30) | 0x80))) {
*chPtr = ((src[1] & 0x0F) << 6) + (src[2] & 0x3F) + 0xDC00;
return 3;
}
if ((unsigned)(byte-0x80) < (unsigned)0x20) {
*chPtr = cp1252[byte-0x80];
} else {
*chPtr = byte;
|
| ︙ | ︙ | |||
514 515 516 517 518 519 520 |
}
/*
* A three-byte-character lead-byte not followed by two trail-bytes
* represents itself.
*/
}
| | | | > | | < < > | | 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 |
}
/*
* A three-byte-character lead-byte not followed by two trail-bytes
* represents itself.
*/
}
else if (byte < 0xF5) {
if (((src[1] & 0xC0) == 0x80) && ((src[2] & 0xC0) == 0x80)) {
/*
* Four-byte-character lead byte followed by at least two trail bytes.
* We don't test the validity of 3th trail byte, see [ed29806ba]
*/
Tcl_UniChar high = (((byte & 0x07) << 8) | ((src[1] & 0x3F) << 2)
| ((src[2] & 0x3F) >> 4)) - 0x40;
if (high < 0x400) {
/* produce high surrogate, advance source pointer */
*chPtr = 0xD800 + high;
return 1;
}
/* out of range, < 0x10000 or > 0x10FFFF */
}
/*
* A four-byte-character lead-byte not followed by three trail-bytes
* represents itself.
*/
}
*chPtr = byte;
return 1;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_UtfToUniCharDString --
*
* Convert the UTF-8 string to Unicode.
*
|
| ︙ | ︙ | |||
569 570 571 572 573 574 575 |
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. */
{
int ch = 0, *w, *wString;
| | > > > > | | > | | < < | | < | | > | | < | > > > > | | > | < | | > | < > | 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 |
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. */
{
int ch = 0, *w, *wString;
const char *p;
size_t oldLength;
/* Pointer to the end of string. Never read endPtr[0] */
const char *endPtr = src + length;
/* Pointer to last byte where optimization still can be used */
const char *optPtr = endPtr - TCL_UTF_MAX;
if (src == NULL) {
return NULL;
}
if (length == TCL_INDEX_NONE) {
length = strlen(src);
}
/*
* Unicode string length in Tcl_UniChars will be <= UTF-8 string length in
* bytes.
*/
oldLength = Tcl_DStringLength(dsPtr);
Tcl_DStringSetLength(dsPtr,
oldLength + ((length + 1) * sizeof(int)));
wString = (int *) (Tcl_DStringValue(dsPtr) + oldLength);
w = wString;
p = src;
endPtr = src + length;
optPtr = endPtr - 4;
while (p <= optPtr) {
p += TclUtfToUCS4(p, &ch);
*w++ = ch;
}
while ((p < endPtr) && TclUCS4Complete(p, endPtr-p)) {
p += TclUtfToUCS4(p, &ch);
*w++ = ch;
}
while (p < endPtr) {
*w++ = UCHAR(*p++);
}
*w = '\0';
Tcl_DStringSetLength(dsPtr,
oldLength + ((char *) w - (char *) wString));
return wString;
}
unsigned short *
Tcl_UtfToChar16DString(
const char *src, /* UTF-8 string to convert to Unicode. */
size_t length, /* Length of UTF-8 string in bytes, or -1 for
* strlen(). */
Tcl_DString *dsPtr) /* Unicode representation of string is
* appended to this previously initialized
* DString. */
{
unsigned short ch = 0, *w, *wString;
const char *p;
size_t oldLength;
/* Pointer to the end of string. Never read endPtr[0] */
const char *endPtr = src + length;
/* Pointer to last byte where optimization still can be used */
const char *optPtr = endPtr - TCL_UTF_MAX;
if (src == NULL) {
return NULL;
}
if (length == TCL_INDEX_NONE) {
length = strlen(src);
}
/*
* Unicode string length in WCHARs will be <= UTF-8 string length in
* bytes.
*/
oldLength = Tcl_DStringLength(dsPtr);
Tcl_DStringSetLength(dsPtr,
oldLength + ((length + 1) * sizeof(unsigned short)));
wString = (unsigned short *) (Tcl_DStringValue(dsPtr) + oldLength);
w = wString;
p = src;
endPtr = src + length;
optPtr = endPtr - 3;
while (p <= optPtr) {
p += Tcl_UtfToChar16(p, &ch);
*w++ = ch;
}
while (p < endPtr) {
if (TclChar16Complete(p, endPtr-p)) {
p += Tcl_UtfToChar16(p, &ch);
*w++ = ch;
} else {
*w++ = UCHAR(*p++);
}
}
*w = '\0';
Tcl_DStringSetLength(dsPtr,
oldLength + ((char *) w - (char *) wString));
return wString;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_UtfCharComplete --
*
* Determine if the UTF-8 string of the given length is long enough to be
* decoded by Tcl_UtfToUniChar(). This does not ensure that the UTF-8
|
| ︙ | ︙ | |||
692 693 694 695 696 697 698 |
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. */
{
| | | 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 |
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 >= complete[UCHAR(*src)];
}
/*
*---------------------------------------------------------------------------
*
* Tcl_NumUtfChars --
*
|
| ︙ | ︙ | |||
716 717 718 719 720 721 722 |
*
*---------------------------------------------------------------------------
*/
size_t
Tcl_NumUtfChars(
const char *src, /* The UTF-8 string to measure. */
| | | < < < < < < < | > > > > | > > > > > > > > > | > > | | | > > > > > | | < < > | < < < < | < < < < < | < | | < < < | < | < < < < < | < | | | | > > > | | > > > | > > | > > > | > > > > > | | | > > > > > > > > > | > > | 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 |
*
*---------------------------------------------------------------------------
*/
size_t
Tcl_NumUtfChars(
const char *src, /* The UTF-8 string to measure. */
size_t length) /* The length of the string in bytes, or
* TCL_INDEX_NONE for strlen(src). */
{
Tcl_UniChar ch = 0;
size_t i = 0;
if (length == TCL_INDEX_NONE) {
/* string is NUL-terminated, so TclUtfToUniChar calls are safe. */
while (*src != '\0') {
src += TclUtfToUniChar(src, &ch);
i++;
}
} else {
/* Will return value between 0 and length. No overflow checks. */
/* Pointer to the end of string. Never read endPtr[0] */
const char *endPtr = src + length;
/* Pointer to last byte where optimization still can be used */
const char *optPtr = endPtr - TCL_UTF_MAX;
/*
* Optimize away the call in this loop. Justified because...
* when (src <= optPtr), (endPtr - src) >= (endPtr - optPtr)
* By initialization above (endPtr - optPtr) = TCL_UTF_MAX
* So (endPtr - src) >= TCL_UTF_MAX, and passing that to
* Tcl_UtfCharComplete we know will cause return of 1.
*/
while (src <= optPtr
/* && Tcl_UtfCharComplete(src, endPtr - src) */ ) {
src += TclUtfToUniChar(src, &ch);
i++;
}
/* Loop over the remaining string where call must happen */
while (src < endPtr) {
if (Tcl_UtfCharComplete(src, endPtr - src)) {
src += TclUtfToUniChar(src, &ch);
} else {
/*
* src points to incomplete UTF-8 sequence
* Treat first byte as character and count it
*/
src++;
}
i++;
}
}
return i;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_UtfFindFirst --
*
* Returns a pointer to the first occurrence of the given Unicode character
* in the NULL-terminated UTF-8 string. The NULL terminator is considered
* part of the UTF-8 string. Equivalent to Plan 9 utfrune().
*
* Results:
* As above. If the Unicode character does not exist in the given string,
* the return value is NULL.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
const char *
Tcl_UtfFindFirst(
const char *src, /* The UTF-8 string to be searched. */
int ch) /* The Unicode character to search for. */
{
while (1) {
int find, len = TclUtfToUCS4(src, &find);
if (find == ch) {
return src;
}
if (*src == '\0') {
return NULL;
}
src += len;
}
}
/*
*---------------------------------------------------------------------------
*
* Tcl_UtfFindLast --
*
* Returns a pointer to the last occurrence of the given Unicode character
* in the NULL-terminated UTF-8 string. The NULL terminator is considered
* part of the UTF-8 string. Equivalent to Plan 9 utfrrune().
*
* Results:
* As above. If the Unicode character does not exist in the given string, the
* return value is NULL.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
const char *
Tcl_UtfFindLast(
const char *src, /* The UTF-8 string to be searched. */
int ch) /* The Unicode character to search for. */
{
const char *last = NULL;
while (1) {
int find, len = TclUtfToUCS4(src, &find);
if (find == ch) {
last = src;
}
if (*src == '\0') {
break;
}
src += len;
}
return last;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_UtfNext --
*
* Given a pointer to some location in a UTF-8 string, Tcl_UtfNext
* returns a pointer to the next UTF-8 character in the string.
* The caller must not ask for the next character after the last
* character in the string if the string is not terminated by a null
* character.
*
* Results:
* The return value is the pointer to the next character in the UTF-8
* string.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
const char *
Tcl_UtfNext(
const char *src) /* The current location in the string. */
{
size_t left;
const char *next;
if (((*src) & 0xC0) == 0x80) {
if ((((*++src) & 0xC0) == 0x80) && (((*++src) & 0xC0) == 0x80)) {
++src;
}
return src;
}
left = totalBytes[UCHAR(*src)];
next = src + 1;
while (--left) {
if ((*next & 0xC0) != 0x80) {
/*
* src points to non-trail byte; We ran out of trail bytes
* before the needs of the lead byte were satisfied.
* Let the (malformed) lead byte alone be a character
*/
return src + 1;
}
next++;
}
/*
* Call Invalid() here only if required conditions are met:
* src[0] is known a lead byte.
* src[1] is known a trail byte.
* Especially important to prevent calls when src[0] == '\xF8' or '\xFC'
* See tests utf-6.37 through utf-6.43 through valgrind or similar tool.
*/
if ((next == src + 1) || Invalid(src)) {
return src + 1;
}
return next;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_UtfPrev --
*
|
| ︙ | ︙ | |||
907 908 909 910 911 912 913 | * None. * *--------------------------------------------------------------------------- */ const char * Tcl_UtfPrev( | | | < > | | > > > > < < > | < | | < | > | > > > > > > > | > > > > > > > > > > > > > > > > > > > | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > | > | | | | | | < < | < | < < | | < < > > | | 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 |
* None.
*
*---------------------------------------------------------------------------
*/
const char *
Tcl_UtfPrev(
const char *src, /* A location in a UTF-8 string. */
const char *start) /* Pointer to the beginning of the string */
{
int trailBytesSeen = 0; /* How many trail bytes have been verified? */
const char *fallback = src - 1;
/* If we cannot find a lead byte that might
* start a prefix of a valid UTF byte sequence,
* we will fallback to a one-byte back step */
const char *look = fallback;
/* Start search at the fallback position */
/* Quick boundary case exit. */
if (fallback <= start) {
return start;
}
do {
unsigned char byte = UCHAR(look[0]);
if (byte < 0x80) {
/*
* Single byte character. Either this is a correct previous
* character, or it is followed by at least one trail byte
* which indicates a malformed sequence. In either case the
* correct result is to return the fallback.
*/
return fallback;
}
if (byte >= 0xC0) {
/* Non-trail byte; May be multibyte lead. */
if ((trailBytesSeen == 0)
/*
* We've seen no trailing context to use to check
* anything. From what we know, this non-trail byte
* is a prefix of a previous character, and accepting
* it (the fallback) is correct.
*/
|| (trailBytesSeen >= complete[byte])) {
/*
* That is, (1 + trailBytesSeen > needed).
* We've examined more bytes than needed to complete
* this lead byte. No matter about well-formedness or
* validity, the sequence starting with this lead byte
* will never include the fallback location, so we must
* return the fallback location. See test utf-7.17
*/
return fallback;
}
/*
* trailBytesSeen > 0, so we can examine look[1] safely.
* Use that capability to screen out invalid sequences.
*/
if (Invalid(look)) {
/* Reject */
return fallback;
}
return (const char *)look;
}
/* We saw a trail byte. */
trailBytesSeen++;
if ((const char *)look == start) {
/*
* Do not read before the start of the string
*
* If we get here, we've examined bytes at every location
* >= start and < src and all of them are trail bytes,
* including (*start). We need to return our fallback
* and exit this loop before we run past the start of the string.
*/
return fallback;
}
/* Continue the search backwards... */
look--;
} while (trailBytesSeen < TCL_UTF_MAX);
/*
* We've seen TCL_UTF_MAX trail bytes, so we know there will not be a
* properly formed byte sequence to find, and we can stop looking,
* accepting the fallback (for TCL_UTF_MAX > 3) or just go back as
* far as we can.
*/
#if TCL_UTF_MAX > 3
return fallback;
#else
return src - TCL_UTF_MAX;
#endif
}
/*
*---------------------------------------------------------------------------
*
* Tcl_UniCharAtIndex --
*
* Returns the Unicode character represented at the specified character
* (not byte) position in the UTF-8 string.
*
* Results:
* As above.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
int
Tcl_UniCharAtIndex(
const char *src, /* The UTF-8 string to dereference. */
size_t index) /* The position of the desired character. */
{
Tcl_UniChar ch = 0;
int i = 0;
if (index == TCL_INDEX_NONE) {
return -1;
}
while (index--) {
i = TclUtfToUniChar(src, &ch);
src += i;
}
#if TCL_UTF_MAX <= 3
if ((ch >= 0xD800) && (i < 3)) {
/* Index points at character following high Surrogate */
return -1;
}
#endif
TclUtfToUCS4(src, &i);
return i;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_UtfAtIndex --
*
|
| ︙ | ︙ | |||
1006 1007 1008 1009 1010 1011 1012 |
const char *
Tcl_UtfAtIndex(
const char *src, /* The UTF-8 string. */
size_t index) /* The position of the desired character. */
{
Tcl_UniChar ch = 0;
| | | | 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 |
const char *
Tcl_UtfAtIndex(
const char *src, /* The UTF-8 string. */
size_t index) /* The position of the desired character. */
{
Tcl_UniChar ch = 0;
#if TCL_UTF_MAX <= 3
size_t len = 0;
#endif
if (index != TCL_INDEX_NONE) {
while (index--) {
#if TCL_UTF_MAX <= 3
src += (len = TclUtfToUniChar(src, &ch));
#else
src += TclUtfToUniChar(src, &ch);
#endif
}
#if TCL_UTF_MAX <= 3
if ((ch >= 0xD800) && (len < 3)) {
|
| ︙ | ︙ | |||
1102 1103 1104 1105 1106 1107 1108 |
*----------------------------------------------------------------------
*/
int
Tcl_UtfToUpper(
char *str) /* String to convert in place. */
{
| < | | < < < < < < < < | | | 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 |
*----------------------------------------------------------------------
*/
int
Tcl_UtfToUpper(
char *str) /* String to convert in place. */
{
int ch, upChar;
char *src, *dst;
size_t len;
/*
* Iterate over the string until we hit the terminating null.
*/
src = dst = str;
while (*src) {
len = TclUtfToUCS4(src, &ch);
upChar = Tcl_UniCharToUpper(ch);
/*
* To keep badly formed Utf strings from getting inflated by the
* conversion (thereby causing a segfault), only copy the upper case
* char to dst if its size is <= the original char.
*/
if ((len < TclUtfCount(upChar)) || ((upChar & ~0x7FF) == 0xD800)) {
memmove(dst, src, len);
dst += len;
} else {
dst += Tcl_UniCharToUtf(upChar, dst);
}
src += len;
}
|
| ︙ | ︙ | |||
1164 1165 1166 1167 1168 1169 1170 |
*----------------------------------------------------------------------
*/
int
Tcl_UtfToLower(
char *str) /* String to convert in place. */
{
| < | | < < < < < < < < | | | 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 |
*----------------------------------------------------------------------
*/
int
Tcl_UtfToLower(
char *str) /* String to convert in place. */
{
int ch, lowChar;
char *src, *dst;
size_t len;
/*
* Iterate over the string until we hit the terminating null.
*/
src = dst = str;
while (*src) {
len = TclUtfToUCS4(src, &ch);
lowChar = Tcl_UniCharToLower(ch);
/*
* To keep badly formed Utf strings from getting inflated by the
* conversion (thereby causing a segfault), only copy the lower case
* char to dst if its size is <= the original char.
*/
if ((len < TclUtfCount(lowChar)) || ((lowChar & ~0x7FF) == 0xD800)) {
memmove(dst, src, len);
dst += len;
} else {
dst += Tcl_UniCharToUtf(lowChar, dst);
}
src += len;
}
|
| ︙ | ︙ | |||
1227 1228 1229 1230 1231 1232 1233 |
*----------------------------------------------------------------------
*/
int
Tcl_UtfToTitle(
char *str) /* String to convert in place. */
{
| < | | < < < < < < < < | | | < < < < < < < | | 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 |
*----------------------------------------------------------------------
*/
int
Tcl_UtfToTitle(
char *str) /* String to convert in place. */
{
int ch, 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 = TclUtfToUCS4(src, &ch);
titleChar = Tcl_UniCharToTitle(ch);
if ((len < TclUtfCount(titleChar)) || ((titleChar & ~0x7FF) == 0xD800)) {
memmove(dst, src, len);
dst += len;
} else {
dst += Tcl_UniCharToUtf(titleChar, dst);
}
src += len;
}
while (*src) {
len = TclUtfToUCS4(src, &ch);
lowChar = ch;
/* Special exception for Georgian Asomtavruli chars, no titlecase. */
if ((unsigned)(lowChar - 0x1C90) >= 0x30) {
lowChar = Tcl_UniCharToLower(lowChar);
}
if ((len < TclUtfCount(lowChar)) || ((lowChar & ~0x7FF) == 0xD800)) {
memmove(dst, src, len);
dst += len;
} else {
dst += Tcl_UniCharToUtf(lowChar, dst);
}
src += len;
}
|
| ︙ | ︙ | |||
1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 |
if (!UNICODE_OUT_OF_RANGE(ch)) {
int info = GetUniCharInfo(ch);
if (GetCaseType(info) & 0x04) {
ch -= GetDelta(info);
}
}
return ch & 0x1FFFFF;
}
/*
*----------------------------------------------------------------------
*
* Tcl_UniCharToLower --
| > | 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 |
if (!UNICODE_OUT_OF_RANGE(ch)) {
int info = GetUniCharInfo(ch);
if (GetCaseType(info) & 0x04) {
ch -= GetDelta(info);
}
}
/* Clear away extension bits, if any */
return ch & 0x1FFFFF;
}
/*
*----------------------------------------------------------------------
*
* Tcl_UniCharToLower --
|
| ︙ | ︙ | |||
1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 |
int info = GetUniCharInfo(ch);
int mode = GetCaseType(info);
if ((mode & 0x02) && (mode != 0x7)) {
ch += GetDelta(info);
}
}
return ch & 0x1FFFFF;
}
/*
*----------------------------------------------------------------------
*
* Tcl_UniCharToTitle --
| > | 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 |
int info = GetUniCharInfo(ch);
int mode = GetCaseType(info);
if ((mode & 0x02) && (mode != 0x7)) {
ch += GetDelta(info);
}
}
/* Clear away extension bits, if any */
return ch & 0x1FFFFF;
}
/*
*----------------------------------------------------------------------
*
* Tcl_UniCharToTitle --
|
| ︙ | ︙ | |||
1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 |
if (mode != 0x7) {
ch += ((mode & 0x4) ? -1 : 1);
}
} else if (mode == 0x4) {
ch -= GetDelta(info);
}
}
return ch & 0x1FFFFF;
}
/*
*----------------------------------------------------------------------
*
* TclUniCharLen --
| > | 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 |
if (mode != 0x7) {
ch += ((mode & 0x4) ? -1 : 1);
}
} else if (mode == 0x4) {
ch -= GetDelta(info);
}
}
/* Clear away extension bits, if any */
return ch & 0x1FFFFF;
}
/*
*----------------------------------------------------------------------
*
* TclUniCharLen --
|
| ︙ | ︙ | |||
1825 1826 1827 1828 1829 1830 1831 1832 |
*/
int
Tcl_UniCharIsControl(
int ch) /* Unicode character to test. */
{
if (UNICODE_OUT_OF_RANGE(ch)) {
ch &= 0x1FFFFF;
| > | | 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 |
*/
int
Tcl_UniCharIsControl(
int ch) /* Unicode character to test. */
{
if (UNICODE_OUT_OF_RANGE(ch)) {
/* Clear away extension bits, if any */
ch &= 0x1FFFFF;
if ((ch == 0xE0001) || ((ch >= 0xE0020) && (ch <= 0xE007F))) {
return 1;
}
if ((ch >= 0xF0000) && ((ch & 0xFFFF) <= 0xFFFD)) {
return 1;
}
return 0;
}
|
| ︙ | ︙ | |||
1884 1885 1886 1887 1888 1889 1890 |
*/
int
Tcl_UniCharIsGraph(
int ch) /* Unicode character to test. */
{
if (UNICODE_OUT_OF_RANGE(ch)) {
| | < | 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 |
*/
int
Tcl_UniCharIsGraph(
int ch) /* Unicode character to test. */
{
if (UNICODE_OUT_OF_RANGE(ch)) {
return ((unsigned)((ch & 0x1FFFFF) - 0xE0100) <= 0xEF);
}
return ((GRAPH_BITS >> GetCategory(ch)) & 1);
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1937 1938 1939 1940 1941 1942 1943 |
*/
int
Tcl_UniCharIsPrint(
int ch) /* Unicode character to test. */
{
if (UNICODE_OUT_OF_RANGE(ch)) {
| | < | 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 |
*/
int
Tcl_UniCharIsPrint(
int ch) /* Unicode character to test. */
{
if (UNICODE_OUT_OF_RANGE(ch)) {
return ((unsigned)((ch & 0x1FFFFF) - 0xE0100) <= 0xEF);
}
return (((GRAPH_BITS|SPACE_BITS) >> GetCategory(ch)) & 1);
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1998 1999 2000 2001 2002 2003 2004 |
/*
* If the character is within the first 127 characters, just use the
* standard C function, otherwise consult the Unicode table.
*/
if (ch < 0x80) {
| | | 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 |
/*
* If the character is within the first 127 characters, just use the
* standard C function, otherwise consult the Unicode table.
*/
if (ch < 0x80) {
return TclIsSpaceProcM((char) ch);
} else if (UNICODE_OUT_OF_RANGE(ch)) {
return 0;
} else if (ch == 0x0085 || ch == 0x180E || ch == 0x200B
|| ch == 0x202F || ch == 0x2060 || ch == 0xFEFF) {
return 1;
} else {
return ((SPACE_BITS >> GetCategory(ch)) & 1);
|
| ︙ | ︙ | |||
2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 |
return 0;
}
string++;
pattern++;
}
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
return 0;
}
string++;
pattern++;
}
}
/*
*---------------------------------------------------------------------------
*
* TclUtfToUCS4 --
*
* Extract the 4-byte codepoint from the leading bytes of the
* Modified UTF-8 string "src". This is a utility routine to
* contain the surrogate gymnastics in one place.
*
* The caller must ensure that the source buffer is long enough that this
* routine does not run off the end and dereference non-existent memory
* looking for trail bytes. If the source buffer is known to be '\0'
* terminated, this cannot happen. Otherwise, the caller should call
* Tcl_UtfCharComplete() before calling this routine to ensure that
* enough bytes remain in the string.
*
* Results:
* *usc4Ptr is filled with the UCS4 code point, and the return value is
* the number of bytes from the UTF-8 string that were consumed.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
#if TCL_UTF_MAX <= 3
int
TclUtfToUCS4(
const char *src, /* The UTF-8 string. */
int *ucs4Ptr) /* Filled with the UCS4 codepoint represented
* by the UTF-8 string. */
{
/* Make use of the #undef Tcl_UtfToUniChar above, which already handles UCS4. */
return Tcl_UtfToUniChar(src, ucs4Ptr);
}
int
TclUniCharToUCS4(
const Tcl_UniChar *src, /* The Tcl_UniChar string. */
int *ucs4Ptr) /* Filled with the UCS4 codepoint represented
* by the Tcl_UniChar string. */
{
if (((src[0] & 0xFC00) == 0xD800) && ((src[1] & 0xFC00) == 0xDC00)) {
*ucs4Ptr = (((src[0] & 0x3FF) << 10) | (src[01] & 0x3FF)) + 0x10000;
return 2;
}
*ucs4Ptr = src[0];
return 1;
}
#endif
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclUtil.c.
| ︙ | ︙ | |||
97 98 99 100 101 102 103 | /* * 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 | /* * Prototypes for functions defined later in this file. */ static void ClearHash(Tcl_HashTable *tablePtr); static void FreeProcessGlobalValue(ClientData clientData); static void FreeThreadHash(ClientData clientData); static int GetEndOffsetFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, size_t endValue, Tcl_WideInt *indexPtr); static Tcl_HashTable * GetThreadHash(Tcl_ThreadDataKey *keyPtr); static int GetWideForIndex(Tcl_Interp *interp, Tcl_Obj *objPtr, size_t endValue, Tcl_WideInt *widePtr); static int FindElement(Tcl_Interp *interp, const char *string, int stringLength, const char *typeStr, const char *typeCode, const char **elementPtr, |
| ︙ | ︙ | |||
388 389 390 391 392 393 394 |
TclMaxListLength(
const char *bytes,
size_t numBytes,
const char **endPtr)
{
size_t count = 0;
| | | | | | | | | | | 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 |
TclMaxListLength(
const char *bytes,
size_t numBytes,
const char **endPtr)
{
size_t count = 0;
if ((numBytes == 0) || ((numBytes == TCL_INDEX_NONE) && (*bytes == '\0'))) {
/* Empty string case - quick exit */
goto done;
}
/*
* No list element before leading white space.
*/
count += 1 - TclIsSpaceProcM(*bytes);
/*
* Count white space runs as potential element separators.
*/
while (numBytes) {
if ((numBytes == TCL_INDEX_NONE) && (*bytes == '\0')) {
break;
}
if (TclIsSpaceProcM(*bytes)) {
/*
* Space run started; bump count.
*/
count++;
do {
bytes++;
numBytes -= (numBytes != TCL_INDEX_NONE);
} while (numBytes && TclIsSpaceProcM(*bytes));
if ((numBytes == 0) || ((numBytes == TCL_INDEX_NONE) && (*bytes == '\0'))) {
break;
}
/*
* (*bytes) is non-space; return to counting state.
*/
}
bytes++;
numBytes -= (numBytes != TCL_INDEX_NONE);
}
/*
* No list element following trailing white space.
*/
count -= TclIsSpaceProcM(bytes[-1]);
done:
if (endPtr) {
*endPtr = bytes;
}
return count;
}
|
| ︙ | ︙ | |||
582 583 584 585 586 587 588 |
/*
* Skim off leading white space and check for an opening brace or quote.
* We treat embedded NULLs in the list/dict as bytes belonging to a list
* element (or dictionary key or value).
*/
limit = (string + stringLength);
| | | 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 |
/*
* Skim off leading white space and check for an opening brace or quote.
* We treat embedded NULLs in the list/dict as bytes belonging to a list
* element (or dictionary key or value).
*/
limit = (string + stringLength);
while ((p < limit) && (TclIsSpaceProcM(*p))) {
p++;
}
if (p == limit) { /* no element found */
elemStart = limit;
goto done;
}
|
| ︙ | ︙ | |||
627 628 629 630 631 632 633 |
case '}':
if (openBraces > 1) {
openBraces--;
} else if (openBraces == 1) {
size = (p - elemStart);
p++;
| | | | 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 |
case '}':
if (openBraces > 1) {
openBraces--;
} else if (openBraces == 1) {
size = (p - elemStart);
p++;
if ((p >= limit) || TclIsSpaceProcM(*p)) {
goto done;
}
/*
* Garbage after the closing brace; return an error.
*/
if (interp != NULL) {
p2 = p;
while ((p2 < limit) && (!TclIsSpaceProcM(*p2))
&& (p2 < p+20)) {
p2++;
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%s element in braces followed by \"%.*s\" "
"instead of space", typeStr, (int) (p2-p), p));
Tcl_SetErrorCode(interp, "TCL", "VALUE", typeCode, "JUNK",
|
| ︙ | ︙ | |||
671 672 673 674 675 676 677 | literal = 0; } TclParseBackslash(p, limit - p, &numChars, NULL); p += (numChars - 1); break; | < < < < < < < < < < < < < < < < < | | > > > > > > > > > > > > > > | 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 |
literal = 0;
}
TclParseBackslash(p, limit - p, &numChars, NULL);
p += (numChars - 1);
break;
/*
* Double-quote: if element is in quotes then terminate it.
*/
case '"':
if (inQuotes) {
size = (p - elemStart);
p++;
if ((p >= limit) || TclIsSpaceProcM(*p)) {
goto done;
}
/*
* Garbage after the closing quote; return an error.
*/
if (interp != NULL) {
p2 = p;
while ((p2 < limit) && (!TclIsSpaceProcM(*p2))
&& (p2 < p+20)) {
p2++;
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%s element in quotes followed by \"%.*s\" "
"instead of space", typeStr, (int) (p2-p), p));
Tcl_SetErrorCode(interp, "TCL", "VALUE", typeCode, "JUNK",
NULL);
}
return TCL_ERROR;
}
break;
default:
if (TclIsSpaceProcM(*p)) {
/*
* Space: ignore if element is in braces or quotes;
* otherwise terminate element.
*/
if ((openBraces == 0) && !inQuotes) {
size = (p - elemStart);
goto done;
}
}
break;
}
p++;
}
/*
* End of list/dict: terminate element.
*/
|
| ︙ | ︙ | |||
749 750 751 752 753 754 755 |
}
return TCL_ERROR;
}
size = (p - elemStart);
}
done:
| | | 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 |
}
return TCL_ERROR;
}
size = (p - elemStart);
}
done:
while ((p < limit) && (TclIsSpaceProcM(*p))) {
p++;
}
*elementPtr = elemStart;
*nextPtr = p;
if (sizePtr != 0) {
*sizePtr = size;
}
|
| ︙ | ︙ | |||
1031 1032 1033 1034 1035 1036 1037 |
* 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 */
| | | 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 |
* 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_INDEX_NONE))) {
/*
* Empty string element must be brace quoted.
*/
*flagPtr = CONVERT_BRACE;
return 2;
}
|
| ︙ | ︙ | |||
1106 1107 1108 1109 1110 1111 1112 | break; #else /* FLOW THROUGH */ #endif /* COMPAT */ case '[': /* TYPE_SUBS */ case '$': /* TYPE_SUBS */ case ';': /* TYPE_COMMAND_END */ | < < < < < < | | 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 |
break;
#else
/* FLOW THROUGH */
#endif /* COMPAT */
case '[': /* TYPE_SUBS */
case '$': /* TYPE_SUBS */
case ';': /* TYPE_COMMAND_END */
forbidNone = 1;
extra++; /* Escape sequences all one byte longer. */
#if COMPAT
preferBrace = 1;
#endif /* COMPAT */
break;
case '\\': /* TYPE_SUBS */
extra++; /* Escape '\' => '\\' */
if ((length == 1) || ((length == TCL_INDEX_NONE) && (p[1] == '\0'))) {
/*
* Final backslash. Cannot format with brace quoting.
*/
requireEscape = 1;
break;
}
|
| ︙ | ︙ | |||
1151 1152 1153 1154 1155 1156 1157 | } forbidNone = 1; #if COMPAT preferBrace = 1; #endif /* COMPAT */ break; case '\0': /* TYPE_SUBS */ | | > > > > > > > > > | 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 |
}
forbidNone = 1;
#if COMPAT
preferBrace = 1;
#endif /* COMPAT */
break;
case '\0': /* TYPE_SUBS */
if (length == TCL_INDEX_NONE) {
goto endOfString;
}
/* TODO: Panic on improper encoding? */
break;
default:
if (TclIsSpaceProcM(*p)) {
forbidNone = 1;
extra++; /* Escape sequences all one byte longer. */
#if COMPAT
preferBrace = 1;
#endif
}
break;
}
}
length -= (length+1 > 1);
p++;
}
|
| ︙ | ︙ | |||
1391 1392 1393 1394 1395 1396 1397 |
conversion = CONVERT_ESCAPE;
}
/*
* No matter what the caller demands, empty string must be braced!
*/
| | | 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 |
conversion = CONVERT_ESCAPE;
}
/*
* No matter what the caller demands, empty string must be braced!
*/
if ((src == NULL) || (length == 0) || (*src == '\0' && length == TCL_INDEX_NONE)) {
p[0] = '{';
p[1] = '}';
return 2;
}
/*
* Escape leading hash as needed and requested.
|
| ︙ | ︙ | |||
1418 1419 1420 1421 1422 1423 1424 |
}
/*
* No escape or quoting needed. Copy the literal string value.
*/
if (conversion == CONVERT_NONE) {
| | | | 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 |
}
/*
* No escape or quoting needed. Copy the literal string value.
*/
if (conversion == CONVERT_NONE) {
if (length == TCL_INDEX_NONE) {
/* 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_INDEX_NONE) {
/* TODO: INT_MAX overflow? */
while (*src) {
*p++ = *src++;
}
} else {
memcpy(p, src, length);
p += length;
|
| ︙ | ︙ | |||
1510 1511 1512 1513 1514 1515 1516 | 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 |
case '\v':
*p = '\\';
p++;
*p = 'v';
p++;
continue;
case '\0':
if (length == TCL_INDEX_NONE) {
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
|
| ︙ | ︙ | |||
1610 1611 1612 1613 1614 1615 1616 |
}
return result;
}
/*
*----------------------------------------------------------------------
*
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | | > > | | > > | | | > > > > | | > > | > | < > < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | | > > | | > > > | > > > > | | | 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 |
}
return result;
}
/*
*----------------------------------------------------------------------
*
* TclTrimRight --
* Takes two counted strings in the Tcl encoding. Conceptually
* finds the sub string (offset) to trim from the right side of the
* first string all characters found in the second string.
*
* Results:
* The number of bytes to be removed from the end of the string.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
size_t
TclTrimRight(
const char *bytes, /* String to be trimmed... */
size_t numBytes, /* ...and its length in bytes */
/* Calls to TclUtfToUniChar() in this routine
* rely on (bytes[numBytes] == '\0'). */
const char *trim, /* String of trim characters... */
size_t numTrim) /* ...and its length in bytes */
/* Calls to TclUtfToUniChar() in this routine
* rely on (trim[numTrim] == '\0'). */
{
const char *pp, *p = bytes + numBytes;
int ch1, ch2;
/* Empty strings -> nothing to do */
if ((numBytes == 0) || (numTrim == 0)) {
return 0;
}
/*
* Outer loop: iterate over string to be trimmed.
*/
do {
const char *q = trim;
size_t pInc = 0, bytesLeft = numTrim;
pp = TclUtfPrev(p, bytes);
do {
pp += pInc;
pInc = TclUtfToUCS4(pp, &ch1);
} while (pp + pInc < p);
/*
* Inner loop: scan trim string for match to current character.
*/
do {
size_t qInc = TclUtfToUCS4(q, &ch2);
if (ch1 == ch2) {
break;
}
q += qInc;
bytesLeft -= qInc;
} while (bytesLeft);
if (bytesLeft == 0) {
/*
* No match; trim task done; *p is last non-trimmed char.
*/
break;
}
p = pp;
} while (p > bytes);
return numBytes - (p - bytes);
}
/*
*----------------------------------------------------------------------
*
* TclTrimLeft --
*
* Takes two counted strings in the Tcl encoding. Conceptually
* finds the sub string (offset) to trim from the left side of the
* first string all characters found in the second string.
*
* Results:
* The number of bytes to be removed from the start of the string.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
size_t
TclTrimLeft(
const char *bytes, /* String to be trimmed... */
size_t numBytes, /* ...and its length in bytes */
/* Calls to TclUtfToUniChar() in this routine
* rely on (bytes[numBytes] == '\0'). */
const char *trim, /* String of trim characters... */
size_t numTrim) /* ...and its length in bytes */
/* Calls to TclUtfToUniChar() in this routine
* rely on (trim[numTrim] == '\0'). */
{
const char *p = bytes;
int ch1, ch2;
/* Empty strings -> nothing to do */
if ((numBytes == 0) || (numTrim == 0)) {
return 0;
}
/*
* Outer loop: iterate over string to be trimmed.
*/
do {
size_t pInc = TclUtfToUCS4(p, &ch1);
const char *q = trim;
size_t bytesLeft = numTrim;
/*
* Inner loop: scan trim string for match to current character.
*/
do {
size_t qInc = TclUtfToUCS4(q, &ch2);
if (ch1 == ch2) {
break;
}
q += qInc;
bytesLeft -= qInc;
|
| ︙ | ︙ | |||
1807 1808 1809 1810 1811 1812 1813 |
p += pInc;
numBytes -= pInc;
} while (numBytes > 0);
return p - bytes;
}
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 |
p += pInc;
numBytes -= pInc;
} while (numBytes > 0);
return p - bytes;
}
/*
*----------------------------------------------------------------------
*
* TclTrim --
* Finds the sub string (offset) to trim from both sides of the
* first string all characters found in the second string.
|
| ︙ | ︙ | |||
1859 1860 1861 1862 1863 1864 1865 1866 1867 |
*----------------------------------------------------------------------
*/
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 */
| > > > > | | < < | < | | < < | | > > | > | > | | < < | | < | | | | | < < | | 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 |
*----------------------------------------------------------------------
*/
size_t
TclTrim(
const char *bytes, /* String to be trimmed... */
size_t numBytes, /* ...and its length in bytes */
/* Calls in this routine
* rely on (bytes[numBytes] == '\0'). */
const char *trim, /* String of trim characters... */
size_t numTrim, /* ...and its length in bytes */
/* Calls in this routine
* rely on (trim[numTrim] == '\0'). */
size_t *trimRightPtr) /* Offset from the end of the string. */
{
size_t trimLeft = 0, trimRight = 0;
/* Empty strings -> nothing to do */
if ((numBytes > 0) && (numTrim > 0)) {
/* When bytes is NUL-terminated, returns 0 <= trimLeft <= numBytes */
trimLeft = TclTrimLeft(bytes, numBytes, trim, numTrim);
numBytes -= trimLeft;
/* If we did not trim the whole string, it starts with a character
* that we will not trim. Skip over it. */
if (numBytes > 0) {
int ch;
const char *first = bytes + trimLeft;
bytes += TclUtfToUCS4(first, &ch);
numBytes -= (bytes - first);
if (numBytes > 0) {
/* When bytes is NUL-terminated, returns
* 0 <= trimRight <= numBytes */
trimRight = TclTrimRight(bytes, numBytes, trim, numTrim);
}
}
}
*trimRightPtr = trimRight;
return trimLeft;
}
/*
*----------------------------------------------------------------------
*
* Tcl_Concat --
|
| ︙ | ︙ | |||
2145 2146 2147 2148 2149 2150 2151 |
Tcl_StringCaseMatch(
const char *str, /* String. */
const char *pattern, /* Pattern, which may contain special
* characters. */
int nocase) /* 0 for case sensitive, 1 for insensitive */
{
int p, charLen;
| < | | 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 |
Tcl_StringCaseMatch(
const char *str, /* String. */
const char *pattern, /* Pattern, which may contain special
* characters. */
int nocase) /* 0 for case sensitive, 1 for insensitive */
{
int p, charLen;
int ch1 = 0, ch2 = 0;
while (1) {
p = *pattern;
/*
* See if we're at the end of both the pattern and the string. If so,
* we succeeded. If we're at the end of the pattern but not at the end
|
| ︙ | ︙ | |||
2187 2188 2189 2190 2191 2192 2193 |
}
/*
* This is a special case optimization for single-byte utf.
*/
if (UCHAR(*pattern) < 0x80) {
| | | | | | | | | | | | | | > | > > | | 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 |
}
/*
* This is a special case optimization for single-byte utf.
*/
if (UCHAR(*pattern) < 0x80) {
ch2 = (int)
(nocase ? tolower(UCHAR(*pattern)) : UCHAR(*pattern));
} else {
TclUtfToUCS4(pattern, &ch2);
if (nocase) {
ch2 = Tcl_UniCharToLower(ch2);
}
}
while (1) {
/*
* Optimization for matching - cruise through the string
* quickly if the next char in the pattern isn't a special
* character
*/
if ((p != '[') && (p != '?') && (p != '\\')) {
if (nocase) {
while (*str) {
charLen = TclUtfToUCS4(str, &ch1);
if (ch2==ch1 || ch2==Tcl_UniCharToLower(ch1)) {
break;
}
str += charLen;
}
} else {
/*
* There's no point in trying to make this code
* shorter, as the number of bytes you want to compare
* each time is non-constant.
*/
while (*str) {
charLen = TclUtfToUCS4(str, &ch1);
if (ch2 == ch1) {
break;
}
str += charLen;
}
}
}
if (Tcl_StringCaseMatch(str, pattern, nocase)) {
return 1;
}
if (*str == '\0') {
return 0;
}
str += TclUtfToUCS4(str, &ch1);
}
}
/*
* Check for a "?" as the next pattern character. It matches any
* single character.
*/
if (p == '?') {
pattern++;
str += TclUtfToUCS4(str, &ch1);
continue;
}
/*
* Check for a "[" as the next pattern character. It is followed by a
* list of characters that are acceptable, or by a range (two
* characters separated by "-").
*/
if (p == '[') {
int startChar = 0, endChar = 0;
pattern++;
if (UCHAR(*str) < 0x80) {
ch1 = (int)
(nocase ? tolower(UCHAR(*str)) : UCHAR(*str));
str++;
} else {
str += TclUtfToUCS4(str, &ch1);
if (nocase) {
ch1 = Tcl_UniCharToLower(ch1);
}
}
while (1) {
if ((*pattern == ']') || (*pattern == '\0')) {
return 0;
}
if (UCHAR(*pattern) < 0x80) {
startChar = (int) (nocase
? tolower(UCHAR(*pattern)) : UCHAR(*pattern));
pattern++;
} else {
pattern += TclUtfToUCS4(pattern, &startChar);
if (nocase) {
startChar = Tcl_UniCharToLower(startChar);
}
}
if (*pattern == '-') {
pattern++;
if (*pattern == '\0') {
return 0;
}
if (UCHAR(*pattern) < 0x80) {
endChar = (int) (nocase
? tolower(UCHAR(*pattern)) : UCHAR(*pattern));
pattern++;
} else {
pattern += TclUtfToUCS4(pattern, &endChar);
if (nocase) {
endChar = Tcl_UniCharToLower(endChar);
}
}
if (((startChar <= ch1) && (ch1 <= endChar))
|| ((endChar <= ch1) && (ch1 <= startChar))) {
/*
* Matches ranges of form [a-z] or [z-a].
*/
break;
}
} else if (startChar == ch1) {
break;
}
}
/* If we reach here, we matched. Need to move past closing ] */
while (*pattern != ']') {
if (*pattern == '\0') {
/* We ran out of pattern after matching something in
* (unclosed!) brackets. So long as we ran out of string
* at the same time, we have a match. Otherwise, not. */
return (*str == '\0');
}
pattern++;
}
pattern++;
continue;
}
|
| ︙ | ︙ | |||
2338 2339 2340 2341 2342 2343 2344 | } /* * There's no special character. Just make sure that the next bytes of * each string match. */ | | | | 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 |
}
/*
* There's no special character. Just make sure that the next bytes of
* each string match.
*/
str += TclUtfToUCS4(str, &ch1);
pattern += TclUtfToUCS4(pattern, &ch2);
if (nocase) {
if (Tcl_UniCharToLower(ch1) != Tcl_UniCharToLower(ch2)) {
return 0;
}
} else if (ch1 != ch2) {
return 0;
}
|
| ︙ | ︙ | |||
2634 2635 2636 2637 2638 2639 2640 |
*----------------------------------------------------------------------
*/
char *
Tcl_DStringAppend(
Tcl_DString *dsPtr, /* Structure describing dynamic string. */
const char *bytes, /* String to append. If length is
| | | | | 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 |
*----------------------------------------------------------------------
*/
char *
Tcl_DStringAppend(
Tcl_DString *dsPtr, /* Structure describing dynamic string. */
const char *bytes, /* String to append. If length is
* TCL_INDEX_NONE then this must be null-terminated. */
size_t length) /* Number of bytes from "bytes" to append. If
* TCL_INDEX_NONE, then append all of bytes, up to null
* at end. */
{
size_t newSize;
if (length == TCL_INDEX_NONE) {
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
|
| ︙ | ︙ | |||
2743 2744 2745 2746 2747 2748 2749 |
Tcl_DStringAppendElement(
Tcl_DString *dsPtr, /* Structure describing dynamic string. */
const char *element) /* String to append. Must be
* null-terminated. */
{
char *dst = dsPtr->string + dsPtr->length;
int needSpace = TclNeedSpace(dsPtr->string, dst);
| | > | > > > > > > > > > > > > > > > > > > > > > > > > > | > > > | 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 |
Tcl_DStringAppendElement(
Tcl_DString *dsPtr, /* Structure describing dynamic string. */
const char *element) /* String to append. Must be
* null-terminated. */
{
char *dst = dsPtr->string + dsPtr->length;
int needSpace = TclNeedSpace(dsPtr->string, dst);
char flags = 0;
int quoteHash = 1;
size_t newSize;
if (needSpace) {
/*
* If we need a space to separate the new element from something
* already ending the string, we're not appending the first element
* of any list, so we need not quote any leading hash character.
*/
quoteHash = 0;
} else {
/*
* We don't need a space, maybe because there's some already there.
* Checking whether we might be appending a first element is a bit
* more involved.
*
* Backtrack over all whitespace.
*/
while ((--dst >= dsPtr->string) && TclIsSpaceProcM(*dst)) {
}
/* Call again without whitespace to confound things. */
quoteHash = !TclNeedSpace(dsPtr->string, dst+1);
}
if (!quoteHash) {
flags |= TCL_DONT_QUOTE_HASH;
}
newSize = dsPtr->length + needSpace + TclScanElement(element, -1, &flags);
if (!quoteHash) {
flags |= TCL_DONT_QUOTE_HASH;
}
/*
* Allocate a larger buffer for the string if the current one isn't large
* enough. Allocate extra space in the new buffer so that there will be
* room to grow before we have to allocate again. SPECIAL NOTE: must use
* memcpy, not strcpy, to copy the string to a larger buffer, since there
* may be embedded NULLs in the string in some cases.
|
| ︙ | ︙ | |||
2777 2778 2779 2780 2781 2782 2783 |
dsPtr->string = (char *)Tcl_Realloc(dsPtr->string, dsPtr->spaceAvl);
if (offset >= 0) {
element = dsPtr->string + offset;
}
}
| < > | < < < < < < < | 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 |
dsPtr->string = (char *)Tcl_Realloc(dsPtr->string, dsPtr->spaceAvl);
if (offset >= 0) {
element = dsPtr->string + offset;
}
}
}
dst = dsPtr->string + dsPtr->length;
/*
* Convert the new string to a list element and copy it into the buffer at
* the end, with a space, if needed.
*/
if (needSpace) {
*dst = ' ';
dst++;
dsPtr->length++;
}
dsPtr->length += TclConvertElement(element, -1, dst, flags);
dsPtr->string[dsPtr->length] = '\0';
return dsPtr->string;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
3211 3212 3213 3214 3215 3216 3217 |
const char *start, /* First character in string. */
const char *end) /* End of string (place where space will be
* added, if appropriate). */
{
/*
* A space is needed unless either:
* (a) we're at the start of the string, or
| < > > > > > > < | > > > > > > > > > > > | | | | > > > > > > > > > | | < < < < < < < < > > | < < < < < > | > | | < < < < < < < < | < | 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 |
const char *start, /* First character in string. */
const char *end) /* End of string (place where space will be
* added, if appropriate). */
{
/*
* A space is needed unless either:
* (a) we're at the start of the string, or
*
* (NOTE: This check is now absorbed into the loop below.)
*
if (end == start) {
return 0;
}
*
*/
/*
* (b) we're at the start of a nested list-element, quoted with an open
* curly brace; we can be nested arbitrarily deep, so long as the
* first curly brace starts an element, so backtrack over open curly
* braces that are trailing characters of the string; and
*
* (NOTE: Every character our parser is looking for is a proper
* single-byte encoding of an ASCII value. It does not accept
* overlong encodings. Given that, there's no benefit using
* Tcl_UtfPrev. If it would find what we seek, so would byte-by-byte
* backward scan. Save routine call overhead and risk of wrong
* results should the behavior of Tcl_UtfPrev change in unexpected ways.
* Reconsider this if we ever start treating non-ASCII Unicode
* characters as meaningful list syntax, expanded Unicode spaces as
* element separators, for example.)
*
end = Tcl_UtfPrev(end, start);
while (*end == '{') {
if (end == start) {
return 0;
}
end = Tcl_UtfPrev(end, start);
}
*
*/
while ((--end >= start) && (*end == '{')) {
}
if (end < start) {
return 0;
}
/*
* (c) the trailing character of the string is already a list-element
* separator, Use the same testing routine as TclFindElement to
* enforce consistency.
*/
if (TclIsSpaceProcM(*end)) {
int result = 0;
/*
* Trailing whitespace might be part of a backslash escape
* sequence. Handle that possibility.
*/
while ((--end >= start) && (*end == '\\')) {
result = !result;
}
return result;
}
return 1;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
3373 3374 3375 3376 3377 3378 3379 3380 |
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;
| > < < | < < < < | | | | | | < < < | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 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 |
Tcl_Obj *objPtr, /* Points to the value to be parsed */
size_t endValue, /* The value to be stored at *widePtr if
* objPtr holds "end".
* NOTE: this value may be TCL_INDEX_NONE. */
Tcl_WideInt *widePtr) /* Location filled in with a wide integer
* representing an index. */
{
int numType;
ClientData cd;
int code = TclGetNumberFromObj(NULL, objPtr, &cd, &numType);
if (code == TCL_OK) {
if (numType == TCL_NUMBER_INT) {
/* objPtr holds an integer in the signed wide range */
*widePtr = *(Tcl_WideInt *)cd;
return TCL_OK;
}
if (numType == TCL_NUMBER_BIG) {
/* objPtr holds an integer outside the signed wide range */
/* Truncate to the signed wide range. */
*widePtr = ((mp_isneg((mp_int *)cd)) ? WIDE_MIN : WIDE_MAX);
return TCL_OK;
}
}
/* objPtr does not hold a number, check the end+/- format... */
return GetEndOffsetFromObj(interp, objPtr, endValue, widePtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetIntForIndex --
*
|
| ︙ | ︙ | |||
3579 3580 3581 3582 3583 3584 3585 |
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;
}
| > | | | | | | > | | > > > > > > > > > > > > | > > > > > | > | > | > > > > > > | > > > > > | > > > > > | > > > > | > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > < | | | > > > > > > > > > > > > | | | | | | | > > > > > > > > > > > > > > > | 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 |
Tcl_WideInt wide;
/* Use platform-related size_t to wide-int to consider negative value
* TCL_INDEX_NONE if wide-int and size_t have different dimensions. */
if (GetWideForIndex(interp, objPtr, endValue, &wide) == TCL_ERROR) {
return TCL_ERROR;
}
if (indexPtr != NULL) {
if ((wide < 0) && (endValue != TCL_INDEX_END)) {
*indexPtr = TCL_INDEX_NONE;
} else if ((Tcl_WideUInt)wide > TCL_INDEX_END) {
*indexPtr = TCL_INDEX_END;
} else {
*indexPtr = (size_t) wide;
}
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* GetEndOffsetFromObj --
*
* Look for a string of the form "end[+-]offset" or "offset[+-]offset" and
* convert it to an internal representation.
*
* The internal representation (wideValue) uses the following encoding:
*
* WIDE_MIN: Index value TCL_INDEX_NONE (or -1)
* WIDE_MIN+1: Index value n, for any n < -1 (usually same effect as -1)
* -$n: Index "end-[expr {$n-1}]"
* -2: Index "end-1"
* -1: Index "end"
* 0: Index "0"
* WIDE_MAX-1: Index "end+n", for any n > 1
* WIDE_MAX: Index "end+1"
*
* Results:
* Tcl return code.
*
* Side effects:
* May store a Tcl_ObjType.
*
*----------------------------------------------------------------------
*/
static int
GetEndOffsetFromObj(
Tcl_Interp *interp,
Tcl_Obj *objPtr, /* Pointer to the object to parse */
size_t endValue, /* The value to be stored at "indexPtr" if
* "objPtr" holds "end". */
Tcl_WideInt *widePtr) /* Location filled in with an integer
* representing an index. */
{
Tcl_ObjIntRep *irPtr;
Tcl_WideInt offset = -1; /* Offset in the "end-offset" expression - 1 */
ClientData cd;
while ((irPtr = TclFetchIntRep(objPtr, &endOffsetType)) == NULL) {
Tcl_ObjIntRep ir;
size_t length;
const char *bytes = TclGetStringFromObj(objPtr, &length);
if (*bytes != 'e') {
int numType;
const char *opPtr;
int length, t1 = 0, t2 = 0;
/* Value doesn't start with "e" */
/* If we reach here, the string rep of objPtr exists. */
/*
* The valid index syntax does not include any value that is
* a list of more than one element. This is necessary so that
* lists of index values can be reliably distinguished from any
* single index value.
*/
/*
* Quick scan to see if multi-value list is even possible.
* This relies on TclGetString() returning a NUL-terminated string.
*/
if ((TclMaxListLength(TclGetString(objPtr), -1, NULL) > 1)
/* If it's possible, do the full list parse. */
&& (TCL_OK == Tcl_ListObjLength(NULL, objPtr, &length))
&& (length > 1)) {
goto parseError;
}
/* Passed the list screen, so parse for index arithmetic expression */
if (TCL_OK == TclParseNumber(NULL, objPtr, NULL, NULL, -1, &opPtr,
TCL_PARSE_INTEGER_ONLY)) {
Tcl_WideInt w1=0, w2=0;
/* value starts with valid integer... */
if ((*opPtr == '-') || (*opPtr == '+')) {
/* ... value continues with [-+] ... */
/* Save first integer as wide if possible */
TclGetNumberFromObj(NULL, objPtr, &cd, &t1);
if (t1 == TCL_NUMBER_INT) {
w1 = (*(Tcl_WideInt *)cd);
}
if (TCL_OK == TclParseNumber(NULL, objPtr, NULL, opPtr + 1,
-1, NULL, TCL_PARSE_INTEGER_ONLY)) {
/* ... value concludes with second valid integer */
/* Save second integer as wide if possible */
TclGetNumberFromObj(NULL, objPtr, &cd, &t2);
if (t2 == TCL_NUMBER_INT) {
w2 = (*(Tcl_WideInt *)cd);
}
}
}
/* Clear invalid intreps left by TclParseNumber */
TclFreeIntRep(objPtr);
if (t1 && t2) {
/* We have both integer values */
if ((t1 == TCL_NUMBER_INT) && (t2 == TCL_NUMBER_INT)) {
/* Both are wide, do wide-integer math */
if (*opPtr == '-') {
if ((w2 == WIDE_MIN) && (interp != NULL)) {
goto extreme;
}
w2 = -w2;
}
if ((w1 ^ w2) < 0) {
/* Different signs, sum cannot overflow */
offset = w1 + w2;
} else if (w1 >= 0) {
if (w1 < WIDE_MAX - w2) {
offset = w1 + w2;
} else {
offset = WIDE_MAX;
}
} else {
if (w1 > WIDE_MIN - w2) {
offset = w1 + w2;
} else {
offset = WIDE_MIN;
}
}
} else if (interp == NULL) {
/*
* We use an interp to do bignum index calculations.
* If we don't get one, call all indices with bignums errors,
* and rely on callers to handle it.
*/
goto parseError;
} else {
/*
* At least one is big, do bignum math. Little reason to
* value performance here. Re-use code. Parse has verified
* objPtr is an expression. Compute it.
*/
Tcl_Obj *sum;
extreme:
Tcl_ExprObj(interp, objPtr, &sum);
TclGetNumberFromObj(NULL, sum, &cd, &numType);
if (numType == TCL_NUMBER_INT) {
/* sum holds an integer in the signed wide range */
offset = *(Tcl_WideInt *)cd;
} else {
/* sum holds an integer outside the signed wide range */
/* Truncate to the signed wide range. */
if (mp_isneg((mp_int *)cd)) {
offset = WIDE_MIN;
} else {
offset = WIDE_MAX;
}
}
Tcl_DecrRefCount(sum);
}
if (offset < 0) {
offset = (offset == -1) ? WIDE_MIN : WIDE_MIN+1;
}
goto parseOK;
}
}
goto parseError;
}
if ((length < 3) || (length == 4) || (strncmp(bytes, "end", 3) != 0)) {
/* Doesn't start with "end" */
goto parseError;
}
if (length > 4) {
int t;
/* Parse for the "end-..." or "end+..." formats */
if ((bytes[3] != '-') && (bytes[3] != '+')) {
/* No operator where we need one */
goto parseError;
}
if (TclIsSpaceProc(bytes[4])) {
/* Space after + or - not permitted. */
goto parseError;
}
/* Parse the integer offset */
if (TCL_OK != TclParseNumber(NULL, objPtr, NULL,
bytes+4, length-4, NULL, TCL_PARSE_INTEGER_ONLY)) {
/* Not a recognized integer format */
goto parseError;
}
/* Got an integer offset; pull it from where parser left it. */
TclGetNumberFromObj(NULL, objPtr, &cd, &t);
if (t == TCL_NUMBER_BIG) {
/* Truncate to the signed wide range. */
if (mp_isneg((mp_int *)cd)) {
offset = (bytes[3] == '-') ? WIDE_MAX : WIDE_MIN;
} else {
offset = (bytes[3] == '-') ? WIDE_MIN : WIDE_MAX;
}
} else {
/* assert (t == TCL_NUMBER_INT); */
offset = (*(Tcl_WideInt *)cd);
if (bytes[3] == '-') {
offset = (offset == WIDE_MIN) ? WIDE_MAX : -offset;
}
if (offset == 1) {
offset = WIDE_MAX; /* "end+1" */
} else if (offset > 1) {
offset = WIDE_MAX - 1; /* "end+n", out of range */
} else if (offset != WIDE_MIN) {
offset--;
}
}
}
parseOK:
/* Success. Store the new internal rep. */
ir.wideValue = offset;
Tcl_StoreIntRep(objPtr, &endOffsetType, &ir);
}
offset = irPtr->wideValue;
if (offset == WIDE_MAX) {
*widePtr = endValue + 1;
} else if (offset == WIDE_MIN) {
*widePtr = -1;
} else if (endValue == (size_t)-1) {
*widePtr = offset;
} else if (offset < 0) {
/* Different signs, sum cannot overflow */
*widePtr = endValue + offset + 1;
} else if (offset < WIDE_MAX) {
*widePtr = offset;
} else {
*widePtr = WIDE_MAX;
}
return TCL_OK;
/* Report a parse error. */
parseError:
if (interp != NULL) {
char * bytes = TclGetString(objPtr);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad index \"%s\": must be integer?[+-]integer? or"
" end?[+-]integer?", bytes));
if (!strncmp(bytes, "end-", 4)) {
bytes += 4;
}
Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", NULL);
}
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* TclIndexEncode --
*
|
| ︙ | ︙ | |||
3725 3726 3727 3728 3729 3730 3731 | * * A token can also be parsed as an end-relative index expression. * All end-relative expressions that indicate an index larger * than end (end+2, end--5) point beyond the end of the indexed * collection, and can be encoded as after. The end-relative * expressions that indicate an index less than or equal to end * are encoded relative to the value TCL_INDEX_END (-2). The | | | | | | 3703 3704 3705 3706 3707 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 | * * A token can also be parsed as an end-relative index expression. * All end-relative expressions that indicate an index larger * than end (end+2, end--5) point beyond the end of the indexed * collection, and can be encoded as after. The end-relative * expressions that indicate an index less than or equal to end * are encoded relative to the value TCL_INDEX_END (-2). The * index "end" is encoded as -2, down to the index "end-0x7FFFFFFE" * which is encoded as INT_MIN. Since the largest index into a * string possible in Tcl 8 is 0x7FFFFFFE, the interpretation of * "end-0x7FFFFFFE" for that largest string would be 0. Thus, * if the tokens "end-0x7FFFFFFF" or "end+-0x80000000" are parsed, * they can be encoded with the before value. * * These details will require re-examination whenever string and * list length limits are increased, but that will likely also * mean a revised routine capable of returning Tcl_WideInt values. * * Returns: |
| ︙ | ︙ | |||
3754 3755 3756 3757 3758 3759 3760 |
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 */
{
| < | > | | | < < < < < < | < < < < | | | | | | | | | | | | | | | | | < < < < < < < < < < | 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 |
TclIndexEncode(
Tcl_Interp *interp, /* For error reporting, may be NULL */
Tcl_Obj *objPtr, /* Index value to parse */
size_t before, /* Value to return for index before beginning */
size_t after, /* Value to return for index after end */
int *indexPtr) /* Where to write the encoded answer, not NULL */
{
Tcl_WideInt wide;
int idx;
if (TCL_OK == GetWideForIndex(interp, objPtr, (unsigned)TCL_INDEX_END , &wide)) {
const Tcl_ObjIntRep *irPtr = TclFetchIntRep(objPtr, &endOffsetType);
if (irPtr && irPtr->wideValue >= 0) {
/* "int[+-]int" syntax, works the same here as "int" */
irPtr = NULL;
}
/*
* We parsed an end+offset index value.
* wide holds the offset value in the range WIDE_MIN...WIDE_MAX.
*/
if (wide > (unsigned)(irPtr ? TCL_INDEX_END : INT_MAX)) {
/*
* All end+postive or end-negative expressions
* always indicate "after the end".
*/
idx = after;
} else if (wide <= (irPtr ? INT_MAX : -1)) {
/* These indices always indicate "before the beginning */
idx = before;
} else {
/* Encoded end-positive (or end+negative) are offset */
idx = (int)wide;
}
} else {
return TCL_ERROR;
}
*indexPtr = idx;
return TCL_OK;
}
|
| ︙ | ︙ | |||
4033 4034 4035 4036 4037 4038 4039 |
size_t epoch = pgvPtr->epoch;
if (pgvPtr->encoding) {
Tcl_Encoding current = Tcl_GetEncoding(NULL, NULL);
if (pgvPtr->encoding != current) {
/*
| | | | 3991 3992 3993 3994 3995 3996 3997 3998 3999 4000 4001 4002 4003 4004 4005 4006 |
size_t epoch = pgvPtr->epoch;
if (pgvPtr->encoding) {
Tcl_Encoding current = Tcl_GetEncoding(NULL, NULL);
if (pgvPtr->encoding != current) {
/*
* The system encoding has changed since the global string value
* was saved. Convert the global value to be based on the new
* system encoding.
*/
Tcl_DString native, newValue;
Tcl_MutexLock(&pgvPtr->mutex);
epoch = ++pgvPtr->epoch;
|
| ︙ | ︙ |
Changes to generic/tclVar.c.
| ︙ | ︙ | |||
2223 2224 2225 2226 2227 2228 2229 |
}
varValuePtr = TclPtrGetVarIdx(interp, varPtr, arrayPtr, part1Ptr,
part2Ptr, flags, index);
if (TclIsVarInHash(varPtr)) {
VarHashRefCount(varPtr)--;
}
if (varValuePtr == NULL) {
| | | 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 |
}
varValuePtr = TclPtrGetVarIdx(interp, varPtr, arrayPtr, part1Ptr,
part2Ptr, flags, index);
if (TclIsVarInHash(varPtr)) {
VarHashRefCount(varPtr)--;
}
if (varValuePtr == NULL) {
TclNewIntObj(varValuePtr, 0);
}
if (Tcl_IsShared(varValuePtr)) {
/* Copy on write */
varValuePtr = Tcl_DuplicateObj(varValuePtr);
if (TCL_OK == TclIncrObj(interp, varValuePtr, incrPtr)) {
return TclPtrSetVarIdx(interp, varPtr, arrayPtr, part1Ptr,
|
| ︙ | ︙ |
Changes to generic/tclZipfs.c.
| ︙ | ︙ | |||
22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 | #ifndef _WIN32 #include <sys/mman.h> #endif /* _WIN32*/ #ifndef MAP_FILE #define MAP_FILE 0 #endif /* !MAP_FILE */ #ifdef HAVE_ZLIB #include "zlib.h" #include "crypt.h" #ifdef CFG_RUNTIME_DLLFILE /* ** We are compiling as part of the core. ** TIP430 style zipfs prefix */ | > > > > > > > | 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 | #ifndef _WIN32 #include <sys/mman.h> #endif /* _WIN32*/ #ifndef MAP_FILE #define MAP_FILE 0 #endif /* !MAP_FILE */ #define NOBYFOUR #define crc32tab crc_table[0] #ifndef TBLS #define TBLS 1 #endif #ifdef HAVE_ZLIB #include "zlib.h" #include "crypt.h" #include "zutil.h" #include "crc32.h" #ifdef CFG_RUNTIME_DLLFILE /* ** We are compiling as part of the core. ** TIP430 style zipfs prefix */ |
| ︙ | ︙ | |||
285 286 287 288 289 290 291 |
* For password rotation.
*/
static const char pwrot[17] =
"\x00\x80\x40\xC0\x20\xA0\x60\xE0"
"\x10\x90\x50\xD0\x30\xB0\x70\xF0";
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 292 293 294 295 296 297 298 299 300 301 302 303 304 305 |
* For password rotation.
*/
static const char pwrot[17] =
"\x00\x80\x40\xC0\x20\xA0\x60\xE0"
"\x10\x90\x50\xD0\x30\xB0\x70\xF0";
static const char *zipfs_literal_tcl_library = NULL;
/* Function prototypes */
static inline int DescribeMounted(Tcl_Interp *interp,
const char *mountPoint);
static inline int ListMountPoints(Tcl_Interp *interp);
|
| ︙ | ︙ | |||
1935 1936 1937 1938 1939 1940 1941 |
if (objc < 3) {
ReadLock();
DescribeMounted(interp, mountPoint);
Unlock();
return TCL_OK;
}
| | > > > | 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 |
if (objc < 3) {
ReadLock();
DescribeMounted(interp, mountPoint);
Unlock();
return TCL_OK;
}
data = TclGetBytesFromObj(interp, objv[2], &length);
if (data == NULL) {
return TCL_ERROR;
}
return TclZipfs_MountBuffer(interp, mountPoint, data, length, 1);
}
/*
*-------------------------------------------------------------------------
*
* ZipFSRootObjCmd --
|
| ︙ | ︙ | |||
2223 2224 2225 2226 2227 2228 2229 | i); Tcl_AppendObjToErrorInfo(interp, eiPtr); Tcl_CloseEx(interp, in, 0); return TCL_ERROR; } ch = (int) (r * 256); | | < | | | | 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 |
i);
Tcl_AppendObjToErrorInfo(interp, eiPtr);
Tcl_CloseEx(interp, in, 0);
return TCL_ERROR;
}
ch = (int) (r * 256);
kvbuf[i + 12] = UCHAR(zencode(keys, crc32tab, ch, tmp));
}
Tcl_ResetResult(interp);
init_keys(passwd, keys, crc32tab);
for (i = 0; i < 12 - 2; i++) {
kvbuf[i] = UCHAR(zencode(keys, crc32tab, kvbuf[i + 12], tmp));
}
kvbuf[i++] = UCHAR(zencode(keys, crc32tab, crc >> 16, tmp));
kvbuf[i++] = UCHAR(zencode(keys, crc32tab, crc >> 24, tmp));
len = Tcl_Write(out, (char *) kvbuf, 12);
memset(kvbuf, 0, 24);
if (len != 12) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"write error on %s: %s", path, Tcl_PosixError(interp)));
Tcl_CloseEx(interp, in, 0);
return TCL_ERROR;
|
| ︙ | ︙ | |||
3201 3202 3203 3204 3205 3206 3207 |
/*
* 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)
| | | 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 |
/*
* Look for the library file system within the DLL/shared library. Note
* that we must mount the zip file and dll before releasing to search.
*/
#if defined(_WIN32)
hModule = (HMODULE)TclWinGetTclInstance();
GetModuleFileNameW(hModule, wName, MAX_PATH);
WideCharToMultiByte(CP_UTF8, 0, wName, -1, dllName, sizeof(dllName), NULL, NULL);
if (ZipfsAppHookFindTclInit(dllName) == TCL_OK) {
return Tcl_NewStringObj(zipfs_literal_tcl_library, -1);
}
#elif /* !_WIN32 && */ defined(CFG_RUNTIME_DLLFILE)
|
| ︙ | ︙ |
Changes to generic/tclZlib.c.
| ︙ | ︙ | |||
106 107 108 109 110 111 112 |
int mode; /* Either the value TCL_ZLIB_STREAM_DEFLATE
* for compression on output, or
* TCL_ZLIB_STREAM_INFLATE for decompression
* on input. */
int format; /* What format of data is going on the wire.
* Needed so that the correct [fconfigure]
* options can be enabled. */
| | < > > | | | > > | 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 |
int mode; /* Either the value TCL_ZLIB_STREAM_DEFLATE
* for compression on output, or
* TCL_ZLIB_STREAM_INFLATE for decompression
* on input. */
int format; /* What format of data is going on the wire.
* Needed so that the correct [fconfigure]
* options can be enabled. */
unsigned int readAheadLimit;/* The maximum number of bytes to read from
* the underlying stream in one go. */
z_stream inStream; /* Structure used by zlib for decompression of
* input. */
z_stream outStream; /* Structure used by zlib for compression of
* output. */
char *inBuffer, *outBuffer; /* Working buffers. */
size_t inAllocated, outAllocated;
/* Sizes of working buffers. */
GzipHeader inHeader; /* Header read from input stream, when
* decompressing a gzip stream. */
GzipHeader outHeader; /* Header to write to an output stream, when
* compressing a gzip stream. */
Tcl_TimerToken timer; /* Timer used for keeping events fresh. */
Tcl_Obj *compDictObj; /* Byte-array object containing compression
* dictionary (not dictObj!) to use if
* necessary. */
} ZlibChannelData;
/*
* Value bits for the flags field. Definitions are:
* ASYNC - Whether this is an asynchronous channel.
* IN_HEADER - Whether the inHeader field has been registered with
* the input compressor.
* OUT_HEADER - Whether the outputHeader field has been registered
* with the output decompressor.
* STREAM_DECOMPRESS - Signal decompress pending data.
* STREAM_DONE - Flag to signal stream end up to transform input.
*/
#define ASYNC 0x01
#define IN_HEADER 0x02
#define OUT_HEADER 0x04
#define STREAM_DECOMPRESS 0x08
#define STREAM_DONE 0x10
/*
* Size of buffers allocated by default, and the range it can be set to. The
* same sorts of values apply to streams, except with different limits (they
* permit byte-level activity). Channels always use bytes unless told to use
* larger buffers.
*/
|
| ︙ | ︙ | |||
180 181 182 183 184 185 186 | 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[]); | | < < | | 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 | static inline int Deflate(z_streamp strm, void *bufferPtr, size_t bufferSize, int flush, size_t *writtenPtr); static void ExtractHeader(gz_header *headerPtr, Tcl_Obj *dictObj); static int GenerateHeader(Tcl_Interp *interp, Tcl_Obj *dictObj, GzipHeader *headerPtr, int *extraSizePtr); static int ZlibPushSubcmd(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int ResultDecompress(ZlibChannelData *cd, char *buf, int toRead, int flush, int *errorCodePtr); static Tcl_Channel ZlibStackChannelTransform(Tcl_Interp *interp, int mode, int format, int level, int limit, Tcl_Channel channel, Tcl_Obj *gzipHeaderDictPtr, Tcl_Obj *compDictObj); static void ZlibStreamCleanup(ZlibStreamHandle *zshPtr); static int ZlibStreamSubcmd(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); |
| ︙ | ︙ | |||
1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 |
void
Tcl_ZlibStreamSetCompressionDictionary(
Tcl_ZlibStream zshandle,
Tcl_Obj *compressionDictionaryObj)
{
ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zshandle;
if (compressionDictionaryObj != NULL) {
if (Tcl_IsShared(compressionDictionaryObj)) {
compressionDictionaryObj =
Tcl_DuplicateObj(compressionDictionaryObj);
}
Tcl_IncrRefCount(compressionDictionaryObj);
zshPtr->flags |= DICT_TO_SET;
| > > > > > | 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 |
void
Tcl_ZlibStreamSetCompressionDictionary(
Tcl_ZlibStream zshandle,
Tcl_Obj *compressionDictionaryObj)
{
ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zshandle;
if (compressionDictionaryObj && (NULL == TclGetBytesFromObj(NULL,
compressionDictionaryObj, NULL))) {
/* Missing or invalid compression dictionary */
compressionDictionaryObj = NULL;
}
if (compressionDictionaryObj != NULL) {
if (Tcl_IsShared(compressionDictionaryObj)) {
compressionDictionaryObj =
Tcl_DuplicateObj(compressionDictionaryObj);
}
Tcl_IncrRefCount(compressionDictionaryObj);
zshPtr->flags |= DICT_TO_SET;
|
| ︙ | ︙ | |||
1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 |
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) {
| > > > > > > | | 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 |
int flush) /* TCL_ZLIB_NO_FLUSH, TCL_ZLIB_FLUSH,
* TCL_ZLIB_FULLFLUSH, or TCL_ZLIB_FINALIZE */
{
ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zshandle;
char *dataTmp = NULL;
int e;
size_t size = 0, outSize, toStore;
unsigned char *bytes;
if (zshPtr->streamEnd) {
if (zshPtr->interp) {
Tcl_SetObjResult(zshPtr->interp, Tcl_NewStringObj(
"already past compressed stream end", -1));
Tcl_SetErrorCode(zshPtr->interp, "TCL", "ZIP", "CLOSED", NULL);
}
return TCL_ERROR;
}
bytes = TclGetBytesFromObj(zshPtr->interp, data, &size);
if (bytes == NULL) {
return TCL_ERROR;
}
if (zshPtr->mode == TCL_ZLIB_STREAM_DEFLATE) {
zshPtr->stream.next_in = bytes;
zshPtr->stream.avail_in = size;
/*
* Must not do a zero-length compress unless finalizing. [Bug 25842c161]
*/
if (size == 0 && flush != Z_FINISH) {
|
| ︙ | ︙ | |||
1325 1326 1327 1328 1329 1330 1331 |
* Getting beyond the of stream, just return empty string.
*/
if (zshPtr->streamEnd) {
return TCL_OK;
}
| | > | > | | 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 |
* Getting beyond the of stream, just return empty string.
*/
if (zshPtr->streamEnd) {
return TCL_OK;
}
if (NULL == TclGetBytesFromObj(zshPtr->interp, data, &existing)) {
return TCL_ERROR;
}
if (zshPtr->mode == TCL_ZLIB_STREAM_INFLATE) {
if (count == TCL_INDEX_NONE) {
/*
* The only safe thing to do is restict to 65k. We might cause a
* panic for out of memory if we just kept growing the buffer.
*/
count = MAX_BUFFER_SIZE;
}
|
| ︙ | ︙ | |||
1485 1486 1487 1488 1489 1490 1491 |
Tcl_DecrRefCount(zshPtr->currentInput);
zshPtr->currentInput = 0;
}
inflateEnd(&zshPtr->stream);
}
} else {
Tcl_ListObjLength(NULL, zshPtr->outData, &listLen);
| | | 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 |
Tcl_DecrRefCount(zshPtr->currentInput);
zshPtr->currentInput = 0;
}
inflateEnd(&zshPtr->stream);
}
} else {
Tcl_ListObjLength(NULL, zshPtr->outData, &listLen);
if (count == TCL_INDEX_NONE) {
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 {
|
| ︙ | ︙ | |||
1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 |
GzipHeader header;
gz_header *headerPtr = NULL;
Tcl_Obj *obj;
if (!interp) {
return TCL_ERROR;
}
/*
* Compressed format is specified by the wbits parameter. See zlib.h for
* details.
*/
if (format == TCL_ZLIB_FORMAT_RAW) {
| > > > > > > > > > > | 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 |
GzipHeader header;
gz_header *headerPtr = NULL;
Tcl_Obj *obj;
if (!interp) {
return TCL_ERROR;
}
/*
* Obtain the pointer to the byte array, we'll pass this pointer straight
* to the deflate command.
*/
inData = TclGetBytesFromObj(interp, data, &inLen);
if (inData == NULL) {
return TCL_ERROR;
}
/*
* Compressed format is specified by the wbits parameter. See zlib.h for
* details.
*/
if (format == TCL_ZLIB_FORMAT_RAW) {
|
| ︙ | ︙ | |||
1617 1618 1619 1620 1621 1622 1623 |
/*
* Allocate some space to store the output.
*/
TclNewObj(obj);
| < < < < < < | 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 |
/*
* Allocate some space to store the output.
*/
TclNewObj(obj);
memset(&stream, 0, sizeof(z_stream));
stream.avail_in = inLen;
stream.next_in = inData;
/*
* No output buffer available yet, will alloc after deflateInit2.
*/
|
| ︙ | ︙ | |||
1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 |
gz_header header, *headerPtr = NULL;
Tcl_Obj *obj;
char *nameBuf = NULL, *commentBuf = NULL;
if (!interp) {
return TCL_ERROR;
}
/*
* Compressed format is specified by the wbits parameter. See zlib.h for
* details.
*/
switch (format) {
| > > > > > | 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 |
gz_header header, *headerPtr = NULL;
Tcl_Obj *obj;
char *nameBuf = NULL, *commentBuf = NULL;
if (!interp) {
return TCL_ERROR;
}
inData = TclGetBytesFromObj(interp, data, &inLen);
if (inData == NULL) {
return TCL_ERROR;
}
/*
* Compressed format is specified by the wbits parameter. See zlib.h for
* details.
*/
switch (format) {
|
| ︙ | ︙ | |||
1761 1762 1763 1764 1765 1766 1767 |
header.name = (Bytef *) nameBuf;
header.name_max = MAXPATHLEN - 1;
commentBuf = (char *)Tcl_Alloc(MAX_COMMENT_LEN);
header.comment = (Bytef *) commentBuf;
header.comm_max = MAX_COMMENT_LEN - 1;
}
| < | 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 |
header.name = (Bytef *) nameBuf;
header.name_max = MAXPATHLEN - 1;
commentBuf = (char *)Tcl_Alloc(MAX_COMMENT_LEN);
header.comment = (Bytef *) commentBuf;
header.comm_max = MAX_COMMENT_LEN - 1;
}
if (bufferSize < 1) {
/*
* Start with a buffer (up to) 3 times the size of the input data.
*/
if (inLen < 32*1024*1024) {
bufferSize = 3*inLen;
|
| ︙ | ︙ | |||
1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 |
switch ((enum zlibCommands) command) {
case CMD_ADLER: /* adler32 str ?startvalue?
* -> checksum */
if (objc < 3 || objc > 4) {
Tcl_WrongNumArgs(interp, 2, objv, "data ?startValue?");
return TCL_ERROR;
}
if (objc>3 && Tcl_GetIntFromObj(interp, objv[3],
(int *) &start) != TCL_OK) {
return TCL_ERROR;
}
if (objc < 4) {
start = Tcl_ZlibAdler32(0, NULL, 0);
}
| > > > > < > > > > < | 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 |
switch ((enum zlibCommands) command) {
case CMD_ADLER: /* adler32 str ?startvalue?
* -> checksum */
if (objc < 3 || objc > 4) {
Tcl_WrongNumArgs(interp, 2, objv, "data ?startValue?");
return TCL_ERROR;
}
data = TclGetBytesFromObj(interp, objv[2], &dlen);
if (data == NULL) {
return TCL_ERROR;
}
if (objc>3 && Tcl_GetIntFromObj(interp, objv[3],
(int *) &start) != TCL_OK) {
return TCL_ERROR;
}
if (objc < 4) {
start = Tcl_ZlibAdler32(0, NULL, 0);
}
Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt)
(uLong) Tcl_ZlibAdler32(start, data, dlen)));
return TCL_OK;
case CMD_CRC: /* crc32 str ?startvalue?
* -> checksum */
if (objc < 3 || objc > 4) {
Tcl_WrongNumArgs(interp, 2, objv, "data ?startValue?");
return TCL_ERROR;
}
data = TclGetBytesFromObj(interp, objv[2], &dlen);
if (data == NULL) {
return TCL_ERROR;
}
if (objc>3 && Tcl_GetIntFromObj(interp, objv[3],
(int *) &start) != TCL_OK) {
return TCL_ERROR;
}
if (objc < 4) {
start = Tcl_ZlibCRC32(0, NULL, 0);
}
Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt)
(uLong) Tcl_ZlibCRC32(start, data, dlen)));
return TCL_OK;
case CMD_DEFLATE: /* deflate data ?level?
* -> rawCompressedData */
if (objc < 3 || objc > 4) {
Tcl_WrongNumArgs(interp, 2, objv, "data ?level?");
|
| ︙ | ︙ | |||
2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 |
return TCL_ERROR;
} else if (level < 0 || level > 9) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("level must be 0 to 9",-1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMPRESSIONLEVEL", NULL);
Tcl_AddErrorInfo(interp, "\n (in -level option)");
return TCL_ERROR;
}
/*
* Construct the stream now we know its configuration.
*/
if (Tcl_ZlibStreamInit(interp, mode, format, level, gzipHeaderObj,
&zh) != TCL_OK) {
| > > > > > > | 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 |
return TCL_ERROR;
} else if (level < 0 || level > 9) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("level must be 0 to 9",-1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMPRESSIONLEVEL", NULL);
Tcl_AddErrorInfo(interp, "\n (in -level option)");
return TCL_ERROR;
}
if (compDictObj) {
if (NULL == TclGetBytesFromObj(interp, compDictObj, NULL)) {
return TCL_ERROR;
}
}
/*
* Construct the stream now we know its configuration.
*/
if (Tcl_ZlibStreamInit(interp, mode, format, level, gzipHeaderObj,
&zh) != TCL_OK) {
|
| ︙ | ︙ | |||
2371 2372 2373 2374 2375 2376 2377 |
};
static const char *const pushDecompressOptions[] = {
"-dictionary", "-header", "-level", "-limit", NULL
};
const char *const *pushOptions = pushDecompressOptions;
enum pushOptions {poDictionary, poHeader, poLevel, poLimit};
Tcl_Obj *headerObj = NULL, *compDictObj = NULL;
| | | 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 |
};
static const char *const pushDecompressOptions[] = {
"-dictionary", "-header", "-level", "-limit", NULL
};
const char *const *pushOptions = pushDecompressOptions;
enum pushOptions {poDictionary, poHeader, poLevel, poLimit};
Tcl_Obj *headerObj = NULL, *compDictObj = NULL;
int limit = DEFAULT_BUFFER_SIZE, dummy;
if (objc < 4) {
Tcl_WrongNumArgs(interp, 2, objv, "mode channel ?options...?");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[2], stream_formats, "mode", 0,
|
| ︙ | ︙ | |||
2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 |
Tcl_SetErrorCode(interp, "TCL", "ZIP", "BADOPT", NULL);
goto genericOptionError;
}
compDictObj = objv[i];
break;
}
}
if (ZlibStackChannelTransform(interp, mode, format, level, limit, chan,
headerObj, compDictObj) == NULL) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, objv[3]);
return TCL_OK;
| > > > > | 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 |
Tcl_SetErrorCode(interp, "TCL", "ZIP", "BADOPT", NULL);
goto genericOptionError;
}
compDictObj = objv[i];
break;
}
}
if (compDictObj && (NULL == TclGetBytesFromObj(interp, compDictObj, NULL))) {
return TCL_ERROR;
}
if (ZlibStackChannelTransform(interp, mode, format, level, limit, chan,
headerObj, compDictObj) == NULL) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, objv[3]);
return TCL_OK;
|
| ︙ | ︙ | |||
2740 2741 2742 2743 2744 2745 2746 |
/*
* Set the compression dictionary if requested.
*/
if (compDictObj != NULL) {
size_t len = 0;
| > > > | | 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 |
/*
* Set the compression dictionary if requested.
*/
if (compDictObj != NULL) {
size_t len = 0;
if (NULL == TclGetBytesFromObj(interp, compDictObj, &len)) {
return TCL_ERROR;
}
if (len == 0) {
compDictObj = NULL;
}
Tcl_ZlibStreamSetCompressionDictionary(zstream, compDictObj);
}
/*
|
| ︙ | ︙ | |||
2844 2845 2846 2847 2848 2849 2850 |
/*
* Set the compression dictionary if requested.
*/
if (compDictObj != NULL) {
size_t len = 0;
| | > > | 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 |
/*
* Set the compression dictionary if requested.
*/
if (compDictObj != NULL) {
size_t len = 0;
if (NULL == TclGetBytesFromObj(interp, compDictObj, &len)) {
return TCL_ERROR;
}
if (len == 0) {
compDictObj = NULL;
}
Tcl_ZlibStreamSetCompressionDictionary(zstream, compDictObj);
}
/*
|
| ︙ | ︙ | |||
2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 |
}
result = TCL_ERROR;
break;
}
} while (e != Z_STREAM_END);
(void) deflateEnd(&cd->outStream);
} else {
(void) inflateEnd(&cd->inStream);
}
/*
* Release all memory.
*/
if (cd->compDictObj) {
Tcl_DecrRefCount(cd->compDictObj);
cd->compDictObj = NULL;
}
| > > > > > > > > > < | 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 |
}
result = TCL_ERROR;
break;
}
} while (e != Z_STREAM_END);
(void) deflateEnd(&cd->outStream);
} else {
/*
* If we have unused bytes from the read input (overshot by
* Z_STREAM_END or on possible error), unget them back to the parent
* channel, so that they appear as not being read yet.
*/
if (cd->inStream.avail_in) {
Tcl_Ungets (cd->parent, (char *)cd->inStream.next_in, cd->inStream.avail_in, 0);
}
(void) inflateEnd(&cd->inStream);
}
/*
* Release all memory.
*/
if (cd->compDictObj) {
Tcl_DecrRefCount(cd->compDictObj);
cd->compDictObj = NULL;
}
if (cd->inBuffer) {
Tcl_Free(cd->inBuffer);
cd->inBuffer = NULL;
}
if (cd->outBuffer) {
Tcl_Free(cd->outBuffer);
|
| ︙ | ︙ | |||
3004 3005 3006 3007 3008 3009 3010 |
char *buf,
int toRead,
int *errorCodePtr)
{
ZlibChannelData *cd = (ZlibChannelData *)instanceData;
Tcl_DriverInputProc *inProc =
Tcl_ChannelInputProc(Tcl_GetChannelType(cd->parent));
| | > | < | < < < < < < | | > | > > > > > > | | < | > | | | > | > > | > > > | | > | > | | | < > > > > > | | > > | > | | | < < < < < > > < < | < < < > > > > > > > | < | > | > > > > > > | 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 |
char *buf,
int toRead,
int *errorCodePtr)
{
ZlibChannelData *cd = (ZlibChannelData *)instanceData;
Tcl_DriverInputProc *inProc =
Tcl_ChannelInputProc(Tcl_GetChannelType(cd->parent));
int readBytes, gotBytes;
if (cd->mode == TCL_ZLIB_STREAM_DEFLATE) {
return inProc(Tcl_GetChannelInstanceData(cd->parent), buf, toRead,
errorCodePtr);
}
gotBytes = 0;
readBytes = cd->inStream.avail_in; /* how many bytes in buffer now */
while (!(cd->flags & STREAM_DONE) && toRead > 0) {
unsigned int n; int decBytes;
/* if starting from scratch or continuation after full decompression */
if (!cd->inStream.avail_in) {
/* buffer to start, we can read to whole available buffer */
cd->inStream.next_in = (Bytef *) cd->inBuffer;
}
/*
* If done - no read needed anymore, check we have to copy rest of
* decompressed data, otherwise return with size (or 0 for Eof)
*/
if (cd->flags & STREAM_DECOMPRESS) {
goto copyDecompressed;
}
/*
* The buffer is exhausted, but the caller wants even more. We now
* have to go to the underlying channel, get more bytes and then
* transform them for delivery. We may not get what we want (full EOF
* or temporarily out of data).
*/
/* Check free buffer size and adjust size of next chunk to read. */
n = cd->inAllocated - ((char *)cd->inStream.next_in - cd->inBuffer);
if (n <= 0) {
/* Normally unreachable: not enough input buffer to uncompress.
* Todo: firstly try to realloc inBuffer upto MAX_BUFFER_SIZE.
*/
*errorCodePtr = ENOBUFS;
return -1;
}
if (n > cd->readAheadLimit) {
n = cd->readAheadLimit;
}
readBytes = Tcl_ReadRaw(cd->parent, (char *)cd->inStream.next_in, n);
/*
* Three cases here:
* 1. Got some data from the underlying channel (readBytes > 0) so
* it should be fed through the decompression engine.
* 2. Got an error (readBytes == -1) which we should report up except
* for the case where we can convert it to a short read.
* 3. Got an end-of-data from EOF or blocking (readBytes == 0). If
* it is EOF, try flushing the data out of the decompressor.
*/
if (readBytes == -1) {
/* See ReflectInput() in tclIORTrans.c */
if (Tcl_InputBlocked(cd->parent) && (gotBytes > 0)) {
break;
}
*errorCodePtr = Tcl_GetErrno();
return -1;
}
/* more bytes (or Eof if readBytes == 0) */
cd->inStream.avail_in += readBytes;
copyDecompressed:
/*
* Transform the read chunk, if not empty. Anything we get
* back is a transformation result to be put into our buffers, and
* the next iteration will put it into the result.
* For the case readBytes is 0 which signaling Eof in parent, the
* partial data waiting is converted and returned.
*/
decBytes = ResultDecompress(cd, buf, toRead,
(readBytes != 0) ? Z_NO_FLUSH : Z_SYNC_FLUSH,
errorCodePtr);
if (decBytes == -1) {
return -1;
}
gotBytes += decBytes;
buf += decBytes;
toRead -= decBytes;
if (((decBytes == 0) || (cd->flags & STREAM_DECOMPRESS))) {
/*
* The drain delivered nothing (or buffer too small to decompress).
* Time to deliver what we've got.
*/
if (!gotBytes && !(cd->flags & STREAM_DONE)) {
/* if no-data, but not ready - avoid signaling Eof,
* continue in blocking mode, otherwise EAGAIN */
if (Tcl_InputBlocked(cd->parent)) {
continue;
}
*errorCodePtr = EAGAIN;
return -1;
}
break;
}
/*
* Loop until the request is satisfied (or no data available from
* above, possibly EOF).
*/
}
return gotBytes;
}
/*
*----------------------------------------------------------------------
*
* ZlibTransformOutput --
|
| ︙ | ︙ | |||
3254 3255 3256 3257 3258 3259 3260 |
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);
| > | > > | 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 |
if (optionName && (strcmp(optionName, "-dictionary") == 0)
&& (cd->format != TCL_ZLIB_FORMAT_GZIP)) {
Tcl_Obj *compDictObj;
int code;
TclNewStringObj(compDictObj, value, strlen(value));
Tcl_IncrRefCount(compDictObj);
if (NULL == TclGetBytesFromObj(interp, compDictObj, NULL)) {
Tcl_DecrRefCount(compDictObj);
return TCL_ERROR;
}
if (cd->compDictObj) {
TclDecrRefCount(cd->compDictObj);
}
cd->compDictObj = compDictObj;
code = Z_OK;
if (cd->mode == TCL_ZLIB_STREAM_DEFLATE) {
code = SetDeflateDictionary(&cd->outStream, compDictObj);
|
| ︙ | ︙ | |||
3479 3480 3481 3482 3483 3484 3485 |
/*
* This code is based on the code in tclIORTrans.c
*/
watchProc = Tcl_ChannelWatchProc(Tcl_GetChannelType(cd->parent));
watchProc(Tcl_GetChannelInstanceData(cd->parent), mask);
| | | 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 |
/*
* This code is based on the code in tclIORTrans.c
*/
watchProc = Tcl_ChannelWatchProc(Tcl_GetChannelType(cd->parent));
watchProc(Tcl_GetChannelInstanceData(cd->parent), mask);
if (!(mask & TCL_READABLE) || !(cd->flags & STREAM_DECOMPRESS)) {
ZlibTransformEventTimerKill(cd);
} else if (cd->timer == NULL) {
cd->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME,
ZlibTransformTimerRun, cd);
}
}
|
| ︙ | ︙ | |||
3665 3666 3667 3668 3669 3670 3671 3672 3673 3674 3675 3676 3677 3678 |
*/
if (mode == TCL_ZLIB_STREAM_INFLATE) {
if (inflateInit2(&cd->inStream, wbits) != Z_OK) {
goto error;
}
cd->inAllocated = DEFAULT_BUFFER_SIZE;
cd->inBuffer = (char *)Tcl_Alloc(cd->inAllocated);
if (cd->flags & IN_HEADER) {
if (inflateGetHeader(&cd->inStream, &cd->inHeader.header) != Z_OK) {
goto error;
}
}
if (cd->format == TCL_ZLIB_FORMAT_RAW && cd->compDictObj) {
| > > > | 3740 3741 3742 3743 3744 3745 3746 3747 3748 3749 3750 3751 3752 3753 3754 3755 3756 |
*/
if (mode == TCL_ZLIB_STREAM_INFLATE) {
if (inflateInit2(&cd->inStream, wbits) != Z_OK) {
goto error;
}
cd->inAllocated = DEFAULT_BUFFER_SIZE;
if (cd->inAllocated < cd->readAheadLimit) {
cd->inAllocated = cd->readAheadLimit;
}
cd->inBuffer = (char *)Tcl_Alloc(cd->inAllocated);
if (cd->flags & IN_HEADER) {
if (inflateGetHeader(&cd->inStream, &cd->inHeader.header) != Z_OK) {
goto error;
}
}
if (cd->format == TCL_ZLIB_FORMAT_RAW && cd->compDictObj) {
|
| ︙ | ︙ | |||
3695 3696 3697 3698 3699 3700 3701 |
if (cd->compDictObj) {
if (SetDeflateDictionary(&cd->outStream, cd->compDictObj) != Z_OK) {
goto error;
}
}
}
| < < | 3773 3774 3775 3776 3777 3778 3779 3780 3781 3782 3783 3784 3785 3786 |
if (cd->compDictObj) {
if (SetDeflateDictionary(&cd->outStream, cd->compDictObj) != Z_OK) {
goto error;
}
}
}
chan = Tcl_StackChannel(interp, &zlibChannelType, cd,
Tcl_GetChannelMode(channel), channel);
if (chan == NULL) {
goto error;
}
cd->chan = chan;
cd->parent = Tcl_GetStackedChannel(chan);
|
| ︙ | ︙ | |||
3726 3727 3728 3729 3730 3731 3732 |
Tcl_Free(cd);
return NULL;
}
/*
*----------------------------------------------------------------------
*
| < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | < > > | > | < < | < < < > | | > < < < | | < < < < | > > > > | > > > > > | > > > > > | > > > > > > > | | 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 |
Tcl_Free(cd);
return NULL;
}
/*
*----------------------------------------------------------------------
*
* ResultDecompress --
*
* Extract uncompressed bytes from the compression engine and store them
* in our buffer (buf) up to toRead bytes.
*
* Result:
* Number of bytes decompressed or -1 if error (with *errorCodePtr updated with reason).
*
* Side effects:
* After execution it updates cd->inStream (next_in, avail_in) to reflect
* the data that has been decompressed.
*
*----------------------------------------------------------------------
*/
static int
ResultDecompress(
ZlibChannelData *cd,
char *buf,
int toRead,
int flush,
int *errorCodePtr)
{
int e, written, resBytes = 0;
Tcl_Obj *errObj;
cd->flags &= ~STREAM_DECOMPRESS;
cd->inStream.next_out = (Bytef *) buf;
cd->inStream.avail_out = toRead;
while (cd->inStream.avail_out > 0) {
e = inflate(&cd->inStream, flush);
if (e == Z_NEED_DICT && cd->compDictObj) {
e = SetInflateDictionary(&cd->inStream, cd->compDictObj);
if (e == Z_OK) {
/*
* A repetition of Z_NEED_DICT is just an error.
*/
e = inflate(&cd->inStream, flush);
}
}
/*
* avail_out is now the left over space in the output. Therefore
* "toRead - avail_out" is the amount of bytes generated.
*/
written = toRead - cd->inStream.avail_out;
/*
* The cases where we're definitely done.
*/
if (e == Z_STREAM_END) {
cd->flags |= STREAM_DONE;
resBytes += written;
break;
}
if (e == Z_OK) {
if (written == 0) {
break;
}
resBytes += written;
}
if ((flush == Z_SYNC_FLUSH) && (e == Z_BUF_ERROR)) {
break;
}
/*
* Z_BUF_ERROR can be ignored as per http://www.zlib.net/zlib_how.html
*
* Just indicates that the zlib couldn't consume input/produce output,
* and is fixed by supplying more input.
*
* Otherwise, we've got errors and need to report to higher-up.
*/
if ((e != Z_OK) && (e != Z_BUF_ERROR)) {
goto handleError;
}
/*
* Check if the inflate stopped early.
*/
if (cd->inStream.avail_in <= 0 && flush != Z_SYNC_FLUSH) {
break;
}
}
if (!(cd->flags & STREAM_DONE)) {
/* if we have pending input data, but no available output buffer */
if (cd->inStream.avail_in && !cd->inStream.avail_out) {
/* next time try to decompress it got readable (new output buffer) */
cd->flags |= STREAM_DECOMPRESS;
}
}
return resBytes;
handleError:
errObj = Tcl_NewListObj(0, NULL);
Tcl_ListObjAppendElement(NULL, errObj, Tcl_NewStringObj("-errorcode",-1));
Tcl_ListObjAppendElement(NULL, errObj,
ConvertErrorToList(e, cd->inStream.adler));
Tcl_ListObjAppendElement(NULL, errObj,
Tcl_NewStringObj(cd->inStream.msg, -1));
Tcl_SetChannelError(cd->parent, errObj);
*errorCodePtr = EINVAL;
return -1;
}
/*
*----------------------------------------------------------------------
* Finally, the TclZlibInit function. Used to install the zlib API.
*----------------------------------------------------------------------
*/
|
| ︙ | ︙ |
Changes to library/auto.tcl.
| ︙ | ︙ | |||
423 424 425 426 427 428 429 |
catch {$parser eval [list _%@namespace forget $name]}
}
return $index
}
# auto_mkindex_parser::hook command
#
| | | | | | | | | | 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 |
catch {$parser eval [list _%@namespace forget $name]}
}
return $index
}
# auto_mkindex_parser::hook command
#
# Registers a Tcl command to evaluate when initializing the child interpreter
# used by the mkindex parser. The command is evaluated in the parent
# interpreter, and can use the variable auto_mkindex_parser::parser to get to
# the child
proc auto_mkindex_parser::hook {cmd} {
variable initCommands
lappend initCommands $cmd
}
# auto_mkindex_parser::childhook command
#
# Registers a Tcl command to evaluate when initializing the child interpreter
# used by the mkindex parser. The command is evaluated in the child
# interpreter.
proc auto_mkindex_parser::childhook {cmd} {
variable initCommands
# The $parser variable is defined to be the name of the child interpreter
# when this command is used later.
lappend initCommands "\$parser eval [list $cmd]"
}
# auto_mkindex_parser::command --
#
|
| ︙ | ︙ | |||
597 598 599 600 601 602 603 |
auto_mkindex_parser::command proc {name args} {
indexEntry $name
}
# Conditionally add support for Tcl byte code files. There are some tricky
# details here. First, we need to get the tbcload library initialized in the
| | | 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 |
auto_mkindex_parser::command proc {name args} {
indexEntry $name
}
# Conditionally add support for Tcl byte code files. There are some tricky
# details here. First, we need to get the tbcload library initialized in the
# current interpreter. We cannot load tbcload into the child until we have
# done so because it needs access to the tcl_patchLevel variable. Second,
# because the package index file may defer loading the library until we invoke
# a command, we need to explicitly invoke auto_load to force it to be loaded.
# This should be a noop if the package has already been loaded
auto_mkindex_parser::hook {
try {
|
| ︙ | ︙ |
Changes to library/cookiejar/cookiejar.tcl.
| ︙ | ︙ | |||
94 95 96 97 98 99 100 |
for {set i [llength $pieces]} {[incr i -1] >= 0} {} {
lappend result [join [lrange $pieces $i end] "."]
}
return $result
}
proc splitPath path {
set pieces [split [string trimleft $path "/"] "/"]
| > | | 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 |
for {set i [llength $pieces]} {[incr i -1] >= 0} {} {
lappend result [join [lrange $pieces $i end] "."]
}
return $result
}
proc splitPath path {
set pieces [split [string trimleft $path "/"] "/"]
set result /
for {set j 0} {$j < [llength $pieces]} {incr j} {
lappend result /[join [lrange $pieces 0 $j] "/"]
}
return $result
}
proc isoNow {} {
set ms [clock milliseconds]
set ts [expr {$ms / 1000}]
|
| ︙ | ︙ |
Changes to library/cookiejar/idna.tcl.
| ︙ | ︙ | |||
148 149 150 151 152 153 154 | set m $ch } } # Increase delta enough to advance the decoder's <n,i> state to # <m,0>, but guard against overflow: | | | | 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 |
set m $ch
}
}
# Increase delta enough to advance the decoder's <n,i> state to
# <m,0>, but guard against overflow:
if {$m-$n > (0xFFFFFFFF-$delta)/($h+1)} {
throw {PUNYCODE OVERFLOW} "overflow in delta computation"
}
incr delta [expr {($m-$n) * ($h+1)}]
set n $m
foreach ch $in {
if {$ch < $n && ([incr delta] & 0xFFFFFFFF) == 0} {
throw {PUNYCODE OVERFLOW} "overflow in delta computation"
}
if {$ch != $n} {
continue
}
|
| ︙ | ︙ | |||
247 248 249 250 251 252 253 |
incr i [expr {$digit * $w}]
set t [expr {min(max($tmin, $k-$bias), $tmax)}]
if {$digit < $t} {
set bias [adapt [expr {$i-$oldi}] $first [incr out]]
set first 0
break
}
| | | | | 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 |
incr i [expr {$digit * $w}]
set t [expr {min(max($tmin, $k-$bias), $tmax)}]
if {$digit < $t} {
set bias [adapt [expr {$i-$oldi}] $first [incr out]]
set first 0
break
}
if {[set w [expr {$w * ($base - $t)}]] > 0x7FFFFFFF} {
throw {PUNYCODE OVERFLOW} \
"excessively large integer computed in digit decode"
}
incr k $base
}
# i was supposed to wrap around from out+1 to 0, incrementing n
# each time, so we'll fix that now:
if {[incr n [expr {$i / $out}]] > 0x7FFFFFFF} {
throw {PUNYCODE OVERFLOW} \
"excessively large integer computed in character choice"
} elseif {$n > $max_codepoint} {
if {$n >= 0x00D800 && $n < 0x00E000} {
# Bare surrogate?!
throw {PUNYCODE NON_BMP} \
[format "unsupported character U+%06x" $n]
}
throw {PUNYCODE NON_UNICODE} "bad codepoint $n"
}
set i [expr {$i % $out}]
|
| ︙ | ︙ |
Changes to library/dde/pkgIndex.tcl.
1 2 |
if {![package vsatisfies [package provide Tcl] 8.5-]} return
if {[info sharedlibextension] != ".dll"} return
| < < < | < | 1 2 3 |
if {![package vsatisfies [package provide Tcl] 8.5-]} return
if {[info sharedlibextension] != ".dll"} return
package ifneeded dde 1.4.3 [list load [file join $dir tcldde14.dll] dde]
|
Changes to library/http/http.tcl.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # http.tcl -- # # Client-side HTTP for GET, POST, and HEAD commands. These routines can # be used in untrusted code that uses the Safesock security policy. # These procedures use a callback interface to avoid using vwait, which # is not defined in the safe base. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. package require Tcl 8.6- # Keep this in sync with pkgIndex.tcl and with the install directories in # Makefiles | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
# http.tcl --
#
# Client-side HTTP for GET, POST, and HEAD commands. These routines can
# be used in untrusted code that uses the Safesock security policy.
# These procedures use a callback interface to avoid using vwait, which
# is not defined in the safe base.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
package require Tcl 8.6-
# Keep this in sync with pkgIndex.tcl and with the install directories in
# Makefiles
package provide http 2.9.3
namespace eval http {
# Allow resourcing to not clobber existing data
variable http
if {![info exists http]} {
array set http {
|
| ︙ | ︙ | |||
730 731 732 733 734 735 736 |
totalsize 0
querylength 0
queryoffset 0
type text/html
body {}
status ""
http ""
| | | 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 |
totalsize 0
querylength 0
queryoffset 0
type text/html
body {}
status ""
http ""
connection keep-alive
}
set state(-keepalive) $defaultKeepalive
set state(-strict) $strict
# These flags have their types verified [Bug 811170]
array set type {
-binary boolean
-blocksize integer
|
| ︙ | ︙ | |||
1050 1051 1052 1053 1054 1055 1056 | # is handled by socketWrQueue later in this command. set reusing 1 set sock $socketMapping($state(socketinfo)) Log "reusing socket $sock for $state(socketinfo) - token $token" } # Do not automatically close the connection socket. | | | 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 |
# is handled by socketWrQueue later in this command.
set reusing 1
set sock $socketMapping($state(socketinfo))
Log "reusing socket $sock for $state(socketinfo) - token $token"
}
# Do not automatically close the connection socket.
set state(connection) keep-alive
}
}
if {$reusing} {
# Define state(tmpState) and state(tmpOpenCmd) for use
# by http::ReplayIfDead if the persistent connection has died.
set state(tmpState) [array get state]
|
| ︙ | ︙ | |||
1345 1346 1347 1348 1349 1350 1351 |
}
} elseif {$state(-validate)} {
set how HEAD
} elseif {$isQueryChannel} {
set how POST
# The query channel must be blocking for the async Write to
# work properly.
| < | < | 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 |
}
} elseif {$state(-validate)} {
set how HEAD
} elseif {$isQueryChannel} {
set how POST
# The query channel must be blocking for the async Write to
# work properly.
fconfigure $state(-querychannel) -blocking 1 -translation binary
set contDone 0
}
if {[info exists state(-method)] && ($state(-method) ne "")} {
set how $state(-method)
}
# We cannot handle chunked encodings with -handler, so force HTTP/1.0
# until we can manage this.
|
| ︙ | ︙ | |||
2723 2724 2725 2726 2727 2728 2729 |
}
transfer-encoding {
set state(transfer) \
[string trim [string tolower $value]]
}
proxy-connection -
connection {
| > > > > > > > > > > > > > > > > > > > > > > > > | < | 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 |
}
transfer-encoding {
set state(transfer) \
[string trim [string tolower $value]]
}
proxy-connection -
connection {
set tmpHeader [string trim [string tolower $value]]
# RFC 7230 Section 6.1 states that a comma-separated
# list is an acceptable value. According to
# https://developer.mozilla.org/en-US/docs/Web/HTTP/Headers/Connection
# any comma-separated list implies keep-alive, but I
# don't see this in the RFC so we'll play safe and
# scan any list for "close".
if {$tmpHeader in {close keep-alive}} {
# The common cases, continue.
} elseif {[string first , $tmpHeader] == -1} {
# Not a comma-separated list, not "close",
# therefore "keep-alive".
set tmpHeader keep-alive
} else {
set tmpHeader keep-alive
set tmpCsl [split $tmpHeader ,]
# Optional whitespace either side of separator.
foreach el $tmpCsl {
if {[string trim $el] eq {close}} {
set tmpHeader close
break
}
}
}
set state(connection) $tmpHeader
}
set-cookie {
if {$http(-cookiejar) ne ""} {
ParseCookie $token [string trim $value]
}
}
}
|
| ︙ | ︙ |
Changes to library/http/pkgIndex.tcl.
1 |
if {![package vsatisfies [package provide Tcl] 8.6-]} {return}
| | | 1 2 |
if {![package vsatisfies [package provide Tcl] 8.6-]} {return}
package ifneeded http 2.9.3 [list tclPkgSetup $dir http 2.9.3 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}]
|
Changes to library/init.tcl.
| ︙ | ︙ | |||
36 37 38 39 40 41 42 | # Also add the directory ../lib relative to the directory where the # executable is located. This is meant to find binary packages for the # same architecture as the current executable. # # tcl_pkgPath, which is set by the platform-specific initialization routines # On UNIX it is compiled in # On Windows, it is not used | | > > > > | > | | < < < < < < < < < < < > > > > > > > > > > > | < | | | | > | 36 37 38 39 40 41 42 43 44 45 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 |
# Also add the directory ../lib relative to the directory where the
# executable is located. This is meant to find binary packages for the
# same architecture as the current executable.
#
# tcl_pkgPath, which is set by the platform-specific initialization routines
# On UNIX it is compiled in
# On Windows, it is not used
#
# (Ticket 41c9857bdd) In a safe interpreter, this file does not set
# ::auto_path (other than to {} if it is undefined). The caller, typically
# a Safe Base command, is responsible for setting ::auto_path.
if {![info exists auto_path]} {
if {[info exists env(TCLLIBPATH)] && (![interp issafe])} {
set auto_path $env(TCLLIBPATH)
} else {
set auto_path ""
}
}
namespace eval tcl {
if {![interp issafe]} {
variable Dir
foreach Dir [list $::tcl_library [file dirname $::tcl_library]] {
if {$Dir ni $::auto_path} {
lappend ::auto_path $Dir
}
}
set Dir [file join [file dirname [file dirname \
[info nameofexecutable]]] lib]
if {$Dir ni $::auto_path} {
lappend ::auto_path $Dir
}
if {[info exists ::tcl_pkgPath]} { catch {
foreach Dir $::tcl_pkgPath {
if {$Dir ni $::auto_path} {
lappend ::auto_path $Dir
}
}
}}
variable Path [encoding dirs]
set Dir [file join $::tcl_library encoding]
if {$Dir ni $Path} {
lappend Path $Dir
encoding dirs $Path
}
unset Dir Path
}
}
namespace eval tcl::Pkg {}
# Setup the unknown package handler
|
| ︙ | ︙ |
Changes to library/manifest.txt.
1 2 3 4 5 6 7 |
###
# Package manifest for all Tcl packages included in the /library file system
###
apply {{dir} {
set ::test [info script]
set isafe [interp issafe]
foreach {safe package version file} {
| | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 |
###
# Package manifest for all Tcl packages included in the /library file system
###
apply {{dir} {
set ::test [info script]
set isafe [interp issafe]
foreach {safe package version file} {
0 http 2.9.3 {http http.tcl}
1 msgcat 1.7.1 {msgcat msgcat.tcl}
1 opt 0.4.7 {opt optparse.tcl}
0 cookiejar 0.2.0 {cookiejar cookiejar.tcl}
0 tcl::idna 1.0.1 {cookiejar idna.tcl}
0 platform 1.0.14 {platform platform.tcl}
0 platform::shell 1.1.4 {platform shell.tcl}
1 tcltest 2.5.3 {tcltest tcltest.tcl}
} {
if {$isafe && !$safe} continue
package ifneeded $package $version [list source [file join $dir {*}$file]]
}
}} $dir
|
Changes to library/msgcat/msgcat.tcl.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 | # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # We use oo::define::self, which is new in Tcl 8.7 package require Tcl 8.7- # When the version number changes, be sure to update the pkgIndex.tcl file, # and the installation directory in the Makefiles. | | | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# We use oo::define::self, which is new in Tcl 8.7
package require Tcl 8.7-
# When the version number changes, be sure to update the pkgIndex.tcl file,
# and the installation directory in the Makefiles.
package provide msgcat 1.7.1
namespace eval msgcat {
namespace export mc mcn mcexists mcload mclocale mcmax\
mcmset mcpreferences mcset\
mcunknown mcflset mcflmset mcloadedlocales mcforgetpackage\
mcpackagenamespaceget mcpackageconfig mcpackagelocale mcutil
|
| ︙ | ︙ | |||
356 357 358 359 360 361 362 |
# Locale.
#
# Results:
# Locale list
proc msgcat::mcutil::getpreferences {locale} {
set locale [string tolower $locale]
| | | | | | > > > > | < < | | 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 |
# Locale.
#
# Results:
# Locale list
proc msgcat::mcutil::getpreferences {locale} {
set locale [string tolower $locale]
set result [list {}]
set el {}
foreach e [split $locale _] {
if {$el eq {}} {
set el ${e}
} else {
set el ${el}_${e}
}
if {[string index $el end] != {_}} {
set result [linsert $result 0 $el]
}
}
return $result
}
# msgcat::mcpreferences --
#
# Fetch the list of locales used to look up strings, ordered from
# most preferred to least preferred.
#
|
| ︙ | ︙ |
Changes to library/msgcat/pkgIndex.tcl.
1 |
if {![package vsatisfies [package provide Tcl] 8.7-]} {return}
| | | 1 2 |
if {![package vsatisfies [package provide Tcl] 8.7-]} {return}
package ifneeded msgcat 1.7.1 [list source [file join $dir msgcat.tcl]]
|
Changes to library/reg/pkgIndex.tcl.
1 2 |
if {![package vsatisfies [package provide Tcl] 8.5-]} return
if {[info sharedlibextension] != ".dll"} return
| < | < < < | < | 1 2 3 4 |
if {![package vsatisfies [package provide Tcl] 8.5-]} return
if {[info sharedlibextension] != ".dll"} return
package ifneeded registry 1.3.5 \
[list load [file join $dir tclreg13.dll] registry]
|
Changes to library/tclIndex.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 | set auto_index(tcl_findLibrary) [list ::tcl::Pkg::source [file join $dir auto.tcl]] set auto_index(auto_mkindex) [list ::tcl::Pkg::source [file join $dir auto.tcl]] set auto_index(auto_mkindex_old) [list ::tcl::Pkg::source [file join $dir auto.tcl]] set auto_index(::auto_mkindex_parser::init) [list ::tcl::Pkg::source [file join $dir auto.tcl]] set auto_index(::auto_mkindex_parser::cleanup) [list ::tcl::Pkg::source [file join $dir auto.tcl]] set auto_index(::auto_mkindex_parser::mkindex) [list ::tcl::Pkg::source [file join $dir auto.tcl]] set auto_index(::auto_mkindex_parser::hook) [list ::tcl::Pkg::source [file join $dir auto.tcl]] | | | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 | set auto_index(tcl_findLibrary) [list ::tcl::Pkg::source [file join $dir auto.tcl]] set auto_index(auto_mkindex) [list ::tcl::Pkg::source [file join $dir auto.tcl]] set auto_index(auto_mkindex_old) [list ::tcl::Pkg::source [file join $dir auto.tcl]] set auto_index(::auto_mkindex_parser::init) [list ::tcl::Pkg::source [file join $dir auto.tcl]] set auto_index(::auto_mkindex_parser::cleanup) [list ::tcl::Pkg::source [file join $dir auto.tcl]] set auto_index(::auto_mkindex_parser::mkindex) [list ::tcl::Pkg::source [file join $dir auto.tcl]] set auto_index(::auto_mkindex_parser::hook) [list ::tcl::Pkg::source [file join $dir auto.tcl]] set auto_index(::auto_mkindex_parser::childhook) [list ::tcl::Pkg::source [file join $dir auto.tcl]] set auto_index(::auto_mkindex_parser::command) [list ::tcl::Pkg::source [file join $dir auto.tcl]] set auto_index(::auto_mkindex_parser::commandInit) [list ::tcl::Pkg::source [file join $dir auto.tcl]] set auto_index(::auto_mkindex_parser::fullname) [list ::tcl::Pkg::source [file join $dir auto.tcl]] set auto_index(history) [list ::tcl::Pkg::source [file join $dir history.tcl]] set auto_index(::tcl::HistAdd) [list ::tcl::Pkg::source [file join $dir history.tcl]] set auto_index(::tcl::HistKeep) [list ::tcl::Pkg::source [file join $dir history.tcl]] set auto_index(::tcl::HistClear) [list ::tcl::Pkg::source [file join $dir history.tcl]] |
| ︙ | ︙ |
Changes to library/tcltest/pkgIndex.tcl.
1 2 3 4 5 6 7 8 9 10 11 |
# Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex -direct" command
# and sourced either when an application starts up or
# by a "package unknown" script. It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands. When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.
if {![package vsatisfies [package provide Tcl] 8.5-]} {return}
| | | 1 2 3 4 5 6 7 8 9 10 11 12 |
# Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex -direct" command
# and sourced either when an application starts up or
# by a "package unknown" script. It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands. When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.
if {![package vsatisfies [package provide Tcl] 8.5-]} {return}
package ifneeded tcltest 2.5.3 [list source [file join $dir tcltest.tcl]]
|
Changes to library/tcltest/tcltest.tcl.
| ︙ | ︙ | |||
18 19 20 21 22 23 24 |
package require Tcl 8.5- ;# -verbose line uses [info frame]
namespace eval tcltest {
# When the version number changes, be sure to update the pkgIndex.tcl file,
# and the install directory in the Makefiles. When the minor version
# changes (new feature) be sure to update the man page as well.
| | | 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 |
package require Tcl 8.5- ;# -verbose line uses [info frame]
namespace eval tcltest {
# When the version number changes, be sure to update the pkgIndex.tcl file,
# and the install directory in the Makefiles. When the minor version
# changes (new feature) be sure to update the man page as well.
variable Version 2.5.3
# Compatibility support for dumb variables defined in tcltest 1
# Do not use these. Call [package provide Tcl] and [info patchlevel]
# yourself. You don't need tcltest to wrap it for you.
variable version [package provide Tcl]
variable patchLevel [info patchlevel]
|
| ︙ | ︙ | |||
807 808 809 810 811 812 813 |
# errors go to stderr by default
Option -errfile stderr {
Send errors from test runs to the specified file.
} AcceptOutFile errorFile
trace add variable Option(-errfile) write \
[namespace code {errorChannel $Option(-errfile) ;#}]
| | | | | | | | 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 |
# errors go to stderr by default
Option -errfile stderr {
Send errors from test runs to the specified file.
} AcceptOutFile errorFile
trace add variable Option(-errfile) write \
[namespace code {errorChannel $Option(-errfile) ;#}]
proc loadIntoChildInterpreter {child args} {
variable Version
interp eval $child [package ifneeded tcltest $Version]
interp eval $child "tcltest::configure {*}{$args}"
interp alias $child ::tcltest::ReportToParent \
{} ::tcltest::ReportedFromChild
}
proc ReportedFromChild {total passed skipped failed because newfiles} {
variable numTests
variable skippedBecause
variable createdNewFiles
incr numTests(Total) $total
incr numTests(Passed) $passed
incr numTests(Skipped) $skipped
incr numTests(Failed) $failed
|
| ︙ | ︙ | |||
2458 2459 2460 2461 2462 2463 2464 |
variable originalTclPlatform
variable coreModTime
FillFilesExisted
set testFileName [file tail [info script]]
# Hook to handle reporting to a parent interpreter
| | | | 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 |
variable originalTclPlatform
variable coreModTime
FillFilesExisted
set testFileName [file tail [info script]]
# Hook to handle reporting to a parent interpreter
if {[llength [info commands [namespace current]::ReportToParent]]} {
ReportToParent $numTests(Total) $numTests(Passed) $numTests(Skipped) \
$numTests(Failed) [array get skippedBecause] \
[array get createdNewFiles]
set testSingleFile false
}
# Call the cleanup hook
cleanupTestsHook
|
| ︙ | ︙ | |||
3103 3104 3105 3106 3107 3108 3109 |
FillFilesExisted
if {[llength [info level 0]] == 2} {
set directory [temporaryDirectory]
}
set fullName [file join $directory $name]
DebugPuts 3 "[lindex [info level 0] 0]: removing $fullName"
set idx [lsearch -exact $filesMade $fullName]
| < > > | 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 |
FillFilesExisted
if {[llength [info level 0]] == 2} {
set directory [temporaryDirectory]
}
set fullName [file join $directory $name]
DebugPuts 3 "[lindex [info level 0] 0]: removing $fullName"
set idx [lsearch -exact $filesMade $fullName]
if {$idx == -1} {
DebugDo 1 {
Warn "removeFile removing \"$fullName\":\n not created by makeFile"
}
} else {
set filesMade [lreplace $filesMade $idx $idx]
}
if {![file isfile $fullName]} {
DebugDo 1 {
Warn "removeFile removing \"$fullName\":\n not a file"
}
}
if {[catch {file delete -- $fullName} msg ]} {
|
| ︙ | ︙ |
Changes to library/tm.tcl.
| ︙ | ︙ | |||
234 235 236 237 238 239 240 |
package vcompare $pkgversion 0
} on error {} {
# Ignore everything where the version part is not
# acceptable to "package vcompare".
continue
}
| | > > > > | 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 |
package vcompare $pkgversion 0
} on error {} {
# Ignore everything where the version part is not
# acceptable to "package vcompare".
continue
}
if {([package ifneeded $pkgname $pkgversion] ne {})
&& (![interp issafe])
} {
# There's already a provide script registered for
# this version of this package. Since all units of
# code claiming to be the same version of the same
# package ought to be identical, just stick with
# the one we already have.
# This does not apply to Safe Base interpreters because
# the token-to-directory mapping may have changed.
continue
}
# We have found a candidate, generate a "provide script"
# for it, and remember it. Note that we are using ::list
# to do this; locally [list] means something else without
# the namespace specifier.
|
| ︙ | ︙ |
Changes to library/tzdata/Africa/Casablanca.
| ︙ | ︙ | |||
56 57 58 59 60 61 62 |
{1521943200 3600 1 +00}
{1526176800 0 0 +00}
{1529200800 3600 1 +00}
{1540695600 3600 0 +01}
{1557021600 0 1 +01}
{1560045600 3600 0 +01}
{1587261600 0 1 +01}
| | | | | | | | | | | | | | 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 |
{1521943200 3600 1 +00}
{1526176800 0 0 +00}
{1529200800 3600 1 +00}
{1540695600 3600 0 +01}
{1557021600 0 1 +01}
{1560045600 3600 0 +01}
{1587261600 0 1 +01}
{1590890400 3600 0 +01}
{1618106400 0 1 +01}
{1621130400 3600 0 +01}
{1648346400 0 1 +01}
{1651975200 3600 0 +01}
{1679191200 0 1 +01}
{1682215200 3600 0 +01}
{1710036000 0 1 +01}
{1713060000 3600 0 +01}
{1740276000 0 1 +01}
{1743904800 3600 0 +01}
{1771120800 0 1 +01}
{1774144800 3600 0 +01}
{1801965600 0 1 +01}
{1804989600 3600 0 +01}
{1832205600 0 1 +01}
{1835834400 3600 0 +01}
{1863050400 0 1 +01}
{1866074400 3600 0 +01}
{1893290400 0 1 +01}
{1896919200 3600 0 +01}
{1924135200 0 1 +01}
{1927159200 3600 0 +01}
{1954980000 0 1 +01}
{1958004000 3600 0 +01}
{1985220000 0 1 +01}
{1988848800 3600 0 +01}
{2016064800 0 1 +01}
{2019088800 3600 0 +01}
{2046304800 0 1 +01}
{2049933600 3600 0 +01}
{2077149600 0 1 +01}
{2080778400 3600 0 +01}
{2107994400 0 1 +01}
{2111018400 3600 0 +01}
{2138234400 0 1 +01}
{2141863200 3600 0 +01}
{2169079200 0 1 +01}
{2172103200 3600 0 +01}
{2199924000 0 1 +01}
{2202948000 3600 0 +01}
{2230164000 0 1 +01}
{2233792800 3600 0 +01}
{2261008800 0 1 +01}
{2264032800 3600 0 +01}
{2291248800 0 1 +01}
{2294877600 3600 0 +01}
{2322093600 0 1 +01}
{2325722400 3600 0 +01}
{2352938400 0 1 +01}
{2355962400 3600 0 +01}
{2383178400 0 1 +01}
{2386807200 3600 0 +01}
{2414023200 0 1 +01}
{2417047200 3600 0 +01}
{2444868000 0 1 +01}
{2447892000 3600 0 +01}
{2475108000 0 1 +01}
{2478736800 3600 0 +01}
{2505952800 0 1 +01}
{2508976800 3600 0 +01}
{2536192800 0 1 +01}
{2539821600 3600 0 +01}
{2567037600 0 1 +01}
{2570666400 3600 0 +01}
{2597882400 0 1 +01}
{2600906400 3600 0 +01}
{2628122400 0 1 +01}
{2631751200 3600 0 +01}
{2658967200 0 1 +01}
{2661991200 3600 0 +01}
{2689812000 0 1 +01}
{2692836000 3600 0 +01}
{2720052000 0 1 +01}
{2723680800 3600 0 +01}
{2750896800 0 1 +01}
{2753920800 3600 0 +01}
{2781136800 0 1 +01}
{2784765600 3600 0 +01}
{2811981600 0 1 +01}
{2815610400 3600 0 +01}
{2842826400 0 1 +01}
{2845850400 3600 0 +01}
{2873066400 0 1 +01}
{2876695200 3600 0 +01}
{2903911200 0 1 +01}
{2906935200 3600 0 +01}
{2934756000 0 1 +01}
{2937780000 3600 0 +01}
{2964996000 0 1 +01}
{2968624800 3600 0 +01}
{2995840800 0 1 +01}
{2998864800 3600 0 +01}
{3026080800 0 1 +01}
{3029709600 3600 0 +01}
{3056925600 0 1 +01}
{3060554400 3600 0 +01}
{3087770400 0 1 +01}
{3090794400 3600 0 +01}
{3118010400 0 1 +01}
{3121639200 3600 0 +01}
{3148855200 0 1 +01}
{3151879200 3600 0 +01}
{3179700000 0 1 +01}
{3182724000 3600 0 +01}
{3209940000 0 1 +01}
{3213568800 3600 0 +01}
{3240784800 0 1 +01}
{3243808800 3600 0 +01}
{3271024800 0 1 +01}
{3274653600 3600 0 +01}
{3301869600 0 1 +01}
{3305498400 3600 0 +01}
{3332714400 0 1 +01}
{3335738400 3600 0 +01}
{3362954400 0 1 +01}
{3366583200 3600 0 +01}
{3393799200 0 1 +01}
{3396823200 3600 0 +01}
{3424644000 0 1 +01}
{3427668000 3600 0 +01}
{3454884000 0 1 +01}
{3458512800 3600 0 +01}
{3485728800 0 1 +01}
{3488752800 3600 0 +01}
{3515968800 0 1 +01}
{3519597600 3600 0 +01}
{3546813600 0 1 +01}
{3549837600 3600 0 +01}
{3577658400 0 1 +01}
{3580682400 3600 0 +01}
{3607898400 0 1 +01}
{3611527200 3600 0 +01}
{3638743200 0 1 +01}
{3641767200 3600 0 +01}
{3669588000 0 1 +01}
{3672612000 3600 0 +01}
{3699828000 0 1 +01}
{3703456800 3600 0 +01}
}
|
Changes to library/tzdata/Africa/El_Aaiun.
| ︙ | ︙ | |||
45 46 47 48 49 50 51 |
{1521943200 3600 1 +00}
{1526176800 0 0 +00}
{1529200800 3600 1 +00}
{1540695600 3600 0 +01}
{1557021600 0 1 +01}
{1560045600 3600 0 +01}
{1587261600 0 1 +01}
| | | | | | | | | | | | | | 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 |
{1521943200 3600 1 +00}
{1526176800 0 0 +00}
{1529200800 3600 1 +00}
{1540695600 3600 0 +01}
{1557021600 0 1 +01}
{1560045600 3600 0 +01}
{1587261600 0 1 +01}
{1590890400 3600 0 +01}
{1618106400 0 1 +01}
{1621130400 3600 0 +01}
{1648346400 0 1 +01}
{1651975200 3600 0 +01}
{1679191200 0 1 +01}
{1682215200 3600 0 +01}
{1710036000 0 1 +01}
{1713060000 3600 0 +01}
{1740276000 0 1 +01}
{1743904800 3600 0 +01}
{1771120800 0 1 +01}
{1774144800 3600 0 +01}
{1801965600 0 1 +01}
{1804989600 3600 0 +01}
{1832205600 0 1 +01}
{1835834400 3600 0 +01}
{1863050400 0 1 +01}
{1866074400 3600 0 +01}
{1893290400 0 1 +01}
{1896919200 3600 0 +01}
{1924135200 0 1 +01}
{1927159200 3600 0 +01}
{1954980000 0 1 +01}
{1958004000 3600 0 +01}
{1985220000 0 1 +01}
{1988848800 3600 0 +01}
{2016064800 0 1 +01}
{2019088800 3600 0 +01}
{2046304800 0 1 +01}
{2049933600 3600 0 +01}
{2077149600 0 1 +01}
{2080778400 3600 0 +01}
{2107994400 0 1 +01}
{2111018400 3600 0 +01}
{2138234400 0 1 +01}
{2141863200 3600 0 +01}
{2169079200 0 1 +01}
{2172103200 3600 0 +01}
{2199924000 0 1 +01}
{2202948000 3600 0 +01}
{2230164000 0 1 +01}
{2233792800 3600 0 +01}
{2261008800 0 1 +01}
{2264032800 3600 0 +01}
{2291248800 0 1 +01}
{2294877600 3600 0 +01}
{2322093600 0 1 +01}
{2325722400 3600 0 +01}
{2352938400 0 1 +01}
{2355962400 3600 0 +01}
{2383178400 0 1 +01}
{2386807200 3600 0 +01}
{2414023200 0 1 +01}
{2417047200 3600 0 +01}
{2444868000 0 1 +01}
{2447892000 3600 0 +01}
{2475108000 0 1 +01}
{2478736800 3600 0 +01}
{2505952800 0 1 +01}
{2508976800 3600 0 +01}
{2536192800 0 1 +01}
{2539821600 3600 0 +01}
{2567037600 0 1 +01}
{2570666400 3600 0 +01}
{2597882400 0 1 +01}
{2600906400 3600 0 +01}
{2628122400 0 1 +01}
{2631751200 3600 0 +01}
{2658967200 0 1 +01}
{2661991200 3600 0 +01}
{2689812000 0 1 +01}
{2692836000 3600 0 +01}
{2720052000 0 1 +01}
{2723680800 3600 0 +01}
{2750896800 0 1 +01}
{2753920800 3600 0 +01}
{2781136800 0 1 +01}
{2784765600 3600 0 +01}
{2811981600 0 1 +01}
{2815610400 3600 0 +01}
{2842826400 0 1 +01}
{2845850400 3600 0 +01}
{2873066400 0 1 +01}
{2876695200 3600 0 +01}
{2903911200 0 1 +01}
{2906935200 3600 0 +01}
{2934756000 0 1 +01}
{2937780000 3600 0 +01}
{2964996000 0 1 +01}
{2968624800 3600 0 +01}
{2995840800 0 1 +01}
{2998864800 3600 0 +01}
{3026080800 0 1 +01}
{3029709600 3600 0 +01}
{3056925600 0 1 +01}
{3060554400 3600 0 +01}
{3087770400 0 1 +01}
{3090794400 3600 0 +01}
{3118010400 0 1 +01}
{3121639200 3600 0 +01}
{3148855200 0 1 +01}
{3151879200 3600 0 +01}
{3179700000 0 1 +01}
{3182724000 3600 0 +01}
{3209940000 0 1 +01}
{3213568800 3600 0 +01}
{3240784800 0 1 +01}
{3243808800 3600 0 +01}
{3271024800 0 1 +01}
{3274653600 3600 0 +01}
{3301869600 0 1 +01}
{3305498400 3600 0 +01}
{3332714400 0 1 +01}
{3335738400 3600 0 +01}
{3362954400 0 1 +01}
{3366583200 3600 0 +01}
{3393799200 0 1 +01}
{3396823200 3600 0 +01}
{3424644000 0 1 +01}
{3427668000 3600 0 +01}
{3454884000 0 1 +01}
{3458512800 3600 0 +01}
{3485728800 0 1 +01}
{3488752800 3600 0 +01}
{3515968800 0 1 +01}
{3519597600 3600 0 +01}
{3546813600 0 1 +01}
{3549837600 3600 0 +01}
{3577658400 0 1 +01}
{3580682400 3600 0 +01}
{3607898400 0 1 +01}
{3611527200 3600 0 +01}
{3638743200 0 1 +01}
{3641767200 3600 0 +01}
{3669588000 0 1 +01}
{3672612000 3600 0 +01}
{3699828000 0 1 +01}
{3703456800 3600 0 +01}
}
|
Changes to library/tzdata/America/Dawson.
| ︙ | ︙ | |||
89 90 91 92 93 94 95 |
{1478422800 -28800 0 PST}
{1489312800 -25200 1 PDT}
{1509872400 -28800 0 PST}
{1520762400 -25200 1 PDT}
{1541322000 -28800 0 PST}
{1552212000 -25200 1 PDT}
{1572771600 -28800 0 PST}
| | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 89 90 91 92 93 94 95 96 97 |
{1478422800 -28800 0 PST}
{1489312800 -25200 1 PDT}
{1509872400 -28800 0 PST}
{1520762400 -25200 1 PDT}
{1541322000 -28800 0 PST}
{1552212000 -25200 1 PDT}
{1572771600 -28800 0 PST}
{1583661600 -25200 0 MST}
}
|
Changes to library/tzdata/America/Godthab.
1 | # created by tools/tclZIC.tcl - do not edit | > > | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
if {![info exists TZData(America/Nuuk)]} {
LoadTimeZoneFile America/Nuuk
}
set TZData(:America/Godthab) $TZData(:America/Nuuk)
|
Added library/tzdata/America/Nuuk.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Nuuk) {
{-9223372036854775808 -12416 0 LMT}
{-1686083584 -10800 0 -03}
{323845200 -7200 0 -02}
{338950800 -10800 0 -03}
{354675600 -7200 1 -02}
{370400400 -10800 0 -03}
{386125200 -7200 1 -02}
{401850000 -10800 0 -03}
{417574800 -7200 1 -02}
{433299600 -10800 0 -03}
{449024400 -7200 1 -02}
{465354000 -10800 0 -03}
{481078800 -7200 1 -02}
{496803600 -10800 0 -03}
{512528400 -7200 1 -02}
{528253200 -10800 0 -03}
{543978000 -7200 1 -02}
{559702800 -10800 0 -03}
{575427600 -7200 1 -02}
{591152400 -10800 0 -03}
{606877200 -7200 1 -02}
{622602000 -10800 0 -03}
{638326800 -7200 1 -02}
{654656400 -10800 0 -03}
{670381200 -7200 1 -02}
{686106000 -10800 0 -03}
{701830800 -7200 1 -02}
{717555600 -10800 0 -03}
{733280400 -7200 1 -02}
{749005200 -10800 0 -03}
{764730000 -7200 1 -02}
{780454800 -10800 0 -03}
{796179600 -7200 1 -02}
{811904400 -10800 0 -03}
{828234000 -7200 1 -02}
{846378000 -10800 0 -03}
{859683600 -7200 1 -02}
{877827600 -10800 0 -03}
{891133200 -7200 1 -02}
{909277200 -10800 0 -03}
{922582800 -7200 1 -02}
{941331600 -10800 0 -03}
{954032400 -7200 1 -02}
{972781200 -10800 0 -03}
{985482000 -7200 1 -02}
{1004230800 -10800 0 -03}
{1017536400 -7200 1 -02}
{1035680400 -10800 0 -03}
{1048986000 -7200 1 -02}
{1067130000 -10800 0 -03}
{1080435600 -7200 1 -02}
{1099184400 -10800 0 -03}
{1111885200 -7200 1 -02}
{1130634000 -10800 0 -03}
{1143334800 -7200 1 -02}
{1162083600 -10800 0 -03}
{1174784400 -7200 1 -02}
{1193533200 -10800 0 -03}
{1206838800 -7200 1 -02}
{1224982800 -10800 0 -03}
{1238288400 -7200 1 -02}
{1256432400 -10800 0 -03}
{1269738000 -7200 1 -02}
{1288486800 -10800 0 -03}
{1301187600 -7200 1 -02}
{1319936400 -10800 0 -03}
{1332637200 -7200 1 -02}
{1351386000 -10800 0 -03}
{1364691600 -7200 1 -02}
{1382835600 -10800 0 -03}
{1396141200 -7200 1 -02}
{1414285200 -10800 0 -03}
{1427590800 -7200 1 -02}
{1445734800 -10800 0 -03}
{1459040400 -7200 1 -02}
{1477789200 -10800 0 -03}
{1490490000 -7200 1 -02}
{1509238800 -10800 0 -03}
{1521939600 -7200 1 -02}
{1540688400 -10800 0 -03}
{1553994000 -7200 1 -02}
{1572138000 -10800 0 -03}
{1585443600 -7200 1 -02}
{1603587600 -10800 0 -03}
{1616893200 -7200 1 -02}
{1635642000 -10800 0 -03}
{1648342800 -7200 1 -02}
{1667091600 -10800 0 -03}
{1679792400 -7200 1 -02}
{1698541200 -10800 0 -03}
{1711846800 -7200 1 -02}
{1729990800 -10800 0 -03}
{1743296400 -7200 1 -02}
{1761440400 -10800 0 -03}
{1774746000 -7200 1 -02}
{1792890000 -10800 0 -03}
{1806195600 -7200 1 -02}
{1824944400 -10800 0 -03}
{1837645200 -7200 1 -02}
{1856394000 -10800 0 -03}
{1869094800 -7200 1 -02}
{1887843600 -10800 0 -03}
{1901149200 -7200 1 -02}
{1919293200 -10800 0 -03}
{1932598800 -7200 1 -02}
{1950742800 -10800 0 -03}
{1964048400 -7200 1 -02}
{1982797200 -10800 0 -03}
{1995498000 -7200 1 -02}
{2014246800 -10800 0 -03}
{2026947600 -7200 1 -02}
{2045696400 -10800 0 -03}
{2058397200 -7200 1 -02}
{2077146000 -10800 0 -03}
{2090451600 -7200 1 -02}
{2108595600 -10800 0 -03}
{2121901200 -7200 1 -02}
{2140045200 -10800 0 -03}
{2153350800 -7200 1 -02}
{2172099600 -10800 0 -03}
{2184800400 -7200 1 -02}
{2203549200 -10800 0 -03}
{2216250000 -7200 1 -02}
{2234998800 -10800 0 -03}
{2248304400 -7200 1 -02}
{2266448400 -10800 0 -03}
{2279754000 -7200 1 -02}
{2297898000 -10800 0 -03}
{2311203600 -7200 1 -02}
{2329347600 -10800 0 -03}
{2342653200 -7200 1 -02}
{2361402000 -10800 0 -03}
{2374102800 -7200 1 -02}
{2392851600 -10800 0 -03}
{2405552400 -7200 1 -02}
{2424301200 -10800 0 -03}
{2437606800 -7200 1 -02}
{2455750800 -10800 0 -03}
{2469056400 -7200 1 -02}
{2487200400 -10800 0 -03}
{2500506000 -7200 1 -02}
{2519254800 -10800 0 -03}
{2531955600 -7200 1 -02}
{2550704400 -10800 0 -03}
{2563405200 -7200 1 -02}
{2582154000 -10800 0 -03}
{2595459600 -7200 1 -02}
{2613603600 -10800 0 -03}
{2626909200 -7200 1 -02}
{2645053200 -10800 0 -03}
{2658358800 -7200 1 -02}
{2676502800 -10800 0 -03}
{2689808400 -7200 1 -02}
{2708557200 -10800 0 -03}
{2721258000 -7200 1 -02}
{2740006800 -10800 0 -03}
{2752707600 -7200 1 -02}
{2771456400 -10800 0 -03}
{2784762000 -7200 1 -02}
{2802906000 -10800 0 -03}
{2816211600 -7200 1 -02}
{2834355600 -10800 0 -03}
{2847661200 -7200 1 -02}
{2866410000 -10800 0 -03}
{2879110800 -7200 1 -02}
{2897859600 -10800 0 -03}
{2910560400 -7200 1 -02}
{2929309200 -10800 0 -03}
{2942010000 -7200 1 -02}
{2960758800 -10800 0 -03}
{2974064400 -7200 1 -02}
{2992208400 -10800 0 -03}
{3005514000 -7200 1 -02}
{3023658000 -10800 0 -03}
{3036963600 -7200 1 -02}
{3055712400 -10800 0 -03}
{3068413200 -7200 1 -02}
{3087162000 -10800 0 -03}
{3099862800 -7200 1 -02}
{3118611600 -10800 0 -03}
{3131917200 -7200 1 -02}
{3150061200 -10800 0 -03}
{3163366800 -7200 1 -02}
{3181510800 -10800 0 -03}
{3194816400 -7200 1 -02}
{3212960400 -10800 0 -03}
{3226266000 -7200 1 -02}
{3245014800 -10800 0 -03}
{3257715600 -7200 1 -02}
{3276464400 -10800 0 -03}
{3289165200 -7200 1 -02}
{3307914000 -10800 0 -03}
{3321219600 -7200 1 -02}
{3339363600 -10800 0 -03}
{3352669200 -7200 1 -02}
{3370813200 -10800 0 -03}
{3384118800 -7200 1 -02}
{3402867600 -10800 0 -03}
{3415568400 -7200 1 -02}
{3434317200 -10800 0 -03}
{3447018000 -7200 1 -02}
{3465766800 -10800 0 -03}
{3479072400 -7200 1 -02}
{3497216400 -10800 0 -03}
{3510522000 -7200 1 -02}
{3528666000 -10800 0 -03}
{3541971600 -7200 1 -02}
{3560115600 -10800 0 -03}
{3573421200 -7200 1 -02}
{3592170000 -10800 0 -03}
{3604870800 -7200 1 -02}
{3623619600 -10800 0 -03}
{3636320400 -7200 1 -02}
{3655069200 -10800 0 -03}
{3668374800 -7200 1 -02}
{3686518800 -10800 0 -03}
{3699824400 -7200 1 -02}
{3717968400 -10800 0 -03}
{3731274000 -7200 1 -02}
{3750022800 -10800 0 -03}
{3762723600 -7200 1 -02}
{3781472400 -10800 0 -03}
{3794173200 -7200 1 -02}
{3812922000 -10800 0 -03}
{3825622800 -7200 1 -02}
{3844371600 -10800 0 -03}
{3857677200 -7200 1 -02}
{3875821200 -10800 0 -03}
{3889126800 -7200 1 -02}
{3907270800 -10800 0 -03}
{3920576400 -7200 1 -02}
{3939325200 -10800 0 -03}
{3952026000 -7200 1 -02}
{3970774800 -10800 0 -03}
{3983475600 -7200 1 -02}
{4002224400 -10800 0 -03}
{4015530000 -7200 1 -02}
{4033674000 -10800 0 -03}
{4046979600 -7200 1 -02}
{4065123600 -10800 0 -03}
{4078429200 -7200 1 -02}
{4096573200 -10800 0 -03}
}
|
Changes to library/tzdata/America/Whitehorse.
| ︙ | ︙ | |||
89 90 91 92 93 94 95 |
{1478422800 -28800 0 PST}
{1489312800 -25200 1 PDT}
{1509872400 -28800 0 PST}
{1520762400 -25200 1 PDT}
{1541322000 -28800 0 PST}
{1552212000 -25200 1 PDT}
{1572771600 -28800 0 PST}
| | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 89 90 91 92 93 94 95 96 97 |
{1478422800 -28800 0 PST}
{1489312800 -25200 1 PDT}
{1509872400 -28800 0 PST}
{1520762400 -25200 1 PDT}
{1541322000 -28800 0 PST}
{1552212000 -25200 1 PDT}
{1572771600 -28800 0 PST}
{1583661600 -25200 0 MST}
}
|
Changes to library/tzdata/Asia/Shanghai.
1 2 3 4 5 6 7 8 9 10 11 12 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Shanghai) {
{-9223372036854775808 29143 0 LMT}
{-2177481943 28800 0 CST}
{-933667200 32400 1 CDT}
{-922093200 28800 0 CST}
{-908870400 32400 1 CDT}
{-888829200 28800 0 CST}
{-881049600 32400 1 CDT}
{-767869200 28800 0 CST}
{-745833600 32400 1 CDT}
| > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Shanghai) {
{-9223372036854775808 29143 0 LMT}
{-2177481943 28800 0 CST}
{-1600675200 32400 1 CDT}
{-1585904400 28800 0 CST}
{-933667200 32400 1 CDT}
{-922093200 28800 0 CST}
{-908870400 32400 1 CDT}
{-888829200 28800 0 CST}
{-881049600 32400 1 CDT}
{-767869200 28800 0 CST}
{-745833600 32400 1 CDT}
|
| ︙ | ︙ |
Changes to library/word.tcl.
| ︙ | ︙ | |||
132 133 134 135 136 137 138 |
# Arguments:
# str - String to search.
# start - Index into string specifying starting point.
proc tcl_startOfPreviousWord {str start} {
variable ::tcl::WordBreakRE
set word {-1 -1}
| > | | > | 132 133 134 135 136 137 138 139 140 141 142 143 144 |
# Arguments:
# str - String to search.
# start - Index into string specifying starting point.
proc tcl_startOfPreviousWord {str start} {
variable ::tcl::WordBreakRE
set word {-1 -1}
if {$start > 0} {
regexp -indices -- $WordBreakRE(previous) [string range $str 0 $start-1] \
result word
}
return [lindex $word 0]
}
|
Changes to libtommath/libtommath_VS2008.sln.
| ︙ | ︙ |
Changes to macosx/Tcl.xcode/project.pbxproj.
| ︙ | ︙ | |||
259 260 261 262 263 264 265 |
F96D3E1B08F272A5004A47F5 /* CrtChnlHdlr.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtChnlHdlr.3; sourceTree = "<group>"; };
F96D3E1C08F272A5004A47F5 /* CrtCloseHdlr.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtCloseHdlr.3; sourceTree = "<group>"; };
F96D3E1D08F272A5004A47F5 /* CrtCommand.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtCommand.3; sourceTree = "<group>"; };
F96D3E1E08F272A5004A47F5 /* CrtFileHdlr.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtFileHdlr.3; sourceTree = "<group>"; };
F96D3E1F08F272A5004A47F5 /* CrtInterp.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtInterp.3; sourceTree = "<group>"; };
F96D3E2008F272A5004A47F5 /* CrtMathFnc.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtMathFnc.3; sourceTree = "<group>"; };
F96D3E2108F272A5004A47F5 /* CrtObjCmd.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtObjCmd.3; sourceTree = "<group>"; };
| | | 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 |
F96D3E1B08F272A5004A47F5 /* CrtChnlHdlr.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtChnlHdlr.3; sourceTree = "<group>"; };
F96D3E1C08F272A5004A47F5 /* CrtCloseHdlr.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtCloseHdlr.3; sourceTree = "<group>"; };
F96D3E1D08F272A5004A47F5 /* CrtCommand.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtCommand.3; sourceTree = "<group>"; };
F96D3E1E08F272A5004A47F5 /* CrtFileHdlr.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtFileHdlr.3; sourceTree = "<group>"; };
F96D3E1F08F272A5004A47F5 /* CrtInterp.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtInterp.3; sourceTree = "<group>"; };
F96D3E2008F272A5004A47F5 /* CrtMathFnc.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtMathFnc.3; sourceTree = "<group>"; };
F96D3E2108F272A5004A47F5 /* CrtObjCmd.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtObjCmd.3; sourceTree = "<group>"; };
F96D3E2208F272A5004A47F5 /* CrtAlias.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtAlias.3; sourceTree = "<group>"; };
F96D3E2308F272A5004A47F5 /* CrtTimerHdlr.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtTimerHdlr.3; sourceTree = "<group>"; };
F96D3E2408F272A5004A47F5 /* CrtTrace.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtTrace.3; sourceTree = "<group>"; };
F96D3E2508F272A5004A47F5 /* dde.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = dde.n; sourceTree = "<group>"; };
F96D3E2608F272A5004A47F5 /* DetachPids.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = DetachPids.3; sourceTree = "<group>"; };
F96D3E2708F272A5004A47F5 /* dict.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = dict.n; sourceTree = "<group>"; };
F96D3E2808F272A5004A47F5 /* DictObj.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = DictObj.3; sourceTree = "<group>"; };
F96D3E2908F272A5004A47F5 /* DoOneEvent.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = DoOneEvent.3; sourceTree = "<group>"; };
|
| ︙ | ︙ | |||
1006 1007 1008 1009 1010 1011 1012 | F96D3E1B08F272A5004A47F5 /* CrtChnlHdlr.3 */, F96D3E1C08F272A5004A47F5 /* CrtCloseHdlr.3 */, F96D3E1D08F272A5004A47F5 /* CrtCommand.3 */, F96D3E1E08F272A5004A47F5 /* CrtFileHdlr.3 */, F96D3E1F08F272A5004A47F5 /* CrtInterp.3 */, F96D3E2008F272A5004A47F5 /* CrtMathFnc.3 */, F96D3E2108F272A5004A47F5 /* CrtObjCmd.3 */, | | | 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 | F96D3E1B08F272A5004A47F5 /* CrtChnlHdlr.3 */, F96D3E1C08F272A5004A47F5 /* CrtCloseHdlr.3 */, F96D3E1D08F272A5004A47F5 /* CrtCommand.3 */, F96D3E1E08F272A5004A47F5 /* CrtFileHdlr.3 */, F96D3E1F08F272A5004A47F5 /* CrtInterp.3 */, F96D3E2008F272A5004A47F5 /* CrtMathFnc.3 */, F96D3E2108F272A5004A47F5 /* CrtObjCmd.3 */, F96D3E2208F272A5004A47F5 /* CrtAlias.3 */, F96D3E2308F272A5004A47F5 /* CrtTimerHdlr.3 */, F96D3E2408F272A5004A47F5 /* CrtTrace.3 */, F96D3E2508F272A5004A47F5 /* dde.n */, F93599D30DF1F8F500E04F67 /* define.n */, F96D3E2608F272A5004A47F5 /* DetachPids.3 */, F96D3E2708F272A5004A47F5 /* dict.n */, F96D3E2808F272A5004A47F5 /* DictObj.3 */, |
| ︙ | ︙ |
Changes to macosx/Tcl.xcodeproj/project.pbxproj.
| ︙ | ︙ | |||
258 259 260 261 262 263 264 |
F96D3E1B08F272A5004A47F5 /* CrtChnlHdlr.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtChnlHdlr.3; sourceTree = "<group>"; };
F96D3E1C08F272A5004A47F5 /* CrtCloseHdlr.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtCloseHdlr.3; sourceTree = "<group>"; };
F96D3E1D08F272A5004A47F5 /* CrtCommand.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtCommand.3; sourceTree = "<group>"; };
F96D3E1E08F272A5004A47F5 /* CrtFileHdlr.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtFileHdlr.3; sourceTree = "<group>"; };
F96D3E1F08F272A5004A47F5 /* CrtInterp.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtInterp.3; sourceTree = "<group>"; };
F96D3E2008F272A5004A47F5 /* CrtMathFnc.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtMathFnc.3; sourceTree = "<group>"; };
F96D3E2108F272A5004A47F5 /* CrtObjCmd.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtObjCmd.3; sourceTree = "<group>"; };
| | | 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 |
F96D3E1B08F272A5004A47F5 /* CrtChnlHdlr.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtChnlHdlr.3; sourceTree = "<group>"; };
F96D3E1C08F272A5004A47F5 /* CrtCloseHdlr.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtCloseHdlr.3; sourceTree = "<group>"; };
F96D3E1D08F272A5004A47F5 /* CrtCommand.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtCommand.3; sourceTree = "<group>"; };
F96D3E1E08F272A5004A47F5 /* CrtFileHdlr.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtFileHdlr.3; sourceTree = "<group>"; };
F96D3E1F08F272A5004A47F5 /* CrtInterp.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtInterp.3; sourceTree = "<group>"; };
F96D3E2008F272A5004A47F5 /* CrtMathFnc.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtMathFnc.3; sourceTree = "<group>"; };
F96D3E2108F272A5004A47F5 /* CrtObjCmd.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtObjCmd.3; sourceTree = "<group>"; };
F96D3E2208F272A5004A47F5 /* CrtAlias.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtAlias.3; sourceTree = "<group>"; };
F96D3E2308F272A5004A47F5 /* CrtTimerHdlr.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtTimerHdlr.3; sourceTree = "<group>"; };
F96D3E2408F272A5004A47F5 /* CrtTrace.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtTrace.3; sourceTree = "<group>"; };
F96D3E2508F272A5004A47F5 /* dde.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = dde.n; sourceTree = "<group>"; };
F96D3E2608F272A5004A47F5 /* DetachPids.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = DetachPids.3; sourceTree = "<group>"; };
F96D3E2708F272A5004A47F5 /* dict.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = dict.n; sourceTree = "<group>"; };
F96D3E2808F272A5004A47F5 /* DictObj.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = DictObj.3; sourceTree = "<group>"; };
F96D3E2908F272A5004A47F5 /* DoOneEvent.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = DoOneEvent.3; sourceTree = "<group>"; };
|
| ︙ | ︙ | |||
1006 1007 1008 1009 1010 1011 1012 | F96D3E1B08F272A5004A47F5 /* CrtChnlHdlr.3 */, F96D3E1C08F272A5004A47F5 /* CrtCloseHdlr.3 */, F96D3E1D08F272A5004A47F5 /* CrtCommand.3 */, F96D3E1E08F272A5004A47F5 /* CrtFileHdlr.3 */, F96D3E1F08F272A5004A47F5 /* CrtInterp.3 */, F96D3E2008F272A5004A47F5 /* CrtMathFnc.3 */, F96D3E2108F272A5004A47F5 /* CrtObjCmd.3 */, | | | 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 | F96D3E1B08F272A5004A47F5 /* CrtChnlHdlr.3 */, F96D3E1C08F272A5004A47F5 /* CrtCloseHdlr.3 */, F96D3E1D08F272A5004A47F5 /* CrtCommand.3 */, F96D3E1E08F272A5004A47F5 /* CrtFileHdlr.3 */, F96D3E1F08F272A5004A47F5 /* CrtInterp.3 */, F96D3E2008F272A5004A47F5 /* CrtMathFnc.3 */, F96D3E2108F272A5004A47F5 /* CrtObjCmd.3 */, F96D3E2208F272A5004A47F5 /* CrtAlias.3 */, F96D3E2308F272A5004A47F5 /* CrtTimerHdlr.3 */, F96D3E2408F272A5004A47F5 /* CrtTrace.3 */, F96D3E2508F272A5004A47F5 /* dde.n */, F93599D30DF1F8F500E04F67 /* define.n */, F96D3E2608F272A5004A47F5 /* DetachPids.3 */, F96D3E2708F272A5004A47F5 /* dict.n */, F96D3E2808F272A5004A47F5 /* DictObj.3 */, |
| ︙ | ︙ |
Changes to macosx/tclMacOSXBundle.c.
| ︙ | ︙ | |||
138 139 140 141 142 143 144 |
if (openresourcemap) {
return openresourcemap(bundleRef);
}
return -1;
}
#endif /* HAVE_COREFOUNDATION */
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 138 139 140 141 142 143 144 145 146 147 148 149 150 151 |
if (openresourcemap) {
return openresourcemap(bundleRef);
}
return -1;
}
#endif /* HAVE_COREFOUNDATION */
/*
*----------------------------------------------------------------------
*
* Tcl_MacOSXOpenVersionedBundleResources --
*
* Given the bundle and version name for a shared library (version name
|
| ︙ | ︙ |
Changes to macosx/tclMacOSXFCmd.c.
| ︙ | ︙ | |||
689 690 691 692 693 694 695 |
*/
static void
UpdateStringOfOSType(
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 |
*/
static void
UpdateStringOfOSType(
Tcl_Obj *objPtr) /* OSType object whose string rep to
* update. */
{
const size_t 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);
|
| ︙ | ︙ |
Changes to macosx/tclMacOSXNotify.c.
| ︙ | ︙ | |||
10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 | * Copyright (c) 2005-2009 Daniel A. Steffen <das@users.sourceforge.net> * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #ifdef HAVE_COREFOUNDATION /* Traditional unix select-based notifier is * in tclUnixNotfy.c */ #include <CoreFoundation/CoreFoundation.h> #include <pthread.h> /* #define TCL_MAC_DEBUG_NOTIFIER 1 */ /* * We use the Darwin-native spinlock API rather than pthread mutexes for * notifier locking: this radically simplifies the implementation and lowers * overhead. Note that these are not pure spinlocks, they employ various * strategies to back off and relinquish the processor, making them immune to * most priority-inversion livelocks (c.f. 'man 3 OSSpinLockLock' and Darwin | > > > > > > > > > > > > > > | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 | * Copyright (c) 2005-2009 Daniel A. Steffen <das@users.sourceforge.net> * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" /* * In macOS 10.12 the os_unfair_lock was introduced as a replacement for the * OSSpinLock, and the OSSpinLock was deprecated. */ #if MAC_OS_X_VERSION_MIN_REQUIRED >= 101200 #define USE_OS_UNFAIR_LOCK #include <os/lock.h> #undef TCL_MAC_DEBUG_NOTIFIER #endif #ifdef HAVE_COREFOUNDATION /* Traditional unix select-based notifier is * in tclUnixNotfy.c */ #include <CoreFoundation/CoreFoundation.h> #include <pthread.h> /* #define TCL_MAC_DEBUG_NOTIFIER 1 */ #if !defined(USE_OS_UNFAIR_LOCK) /* * We use the Darwin-native spinlock API rather than pthread mutexes for * notifier locking: this radically simplifies the implementation and lowers * overhead. Note that these are not pure spinlocks, they employ various * strategies to back off and relinquish the processor, making them immune to * most priority-inversion livelocks (c.f. 'man 3 OSSpinLockLock' and Darwin |
| ︙ | ︙ | |||
168 169 170 171 172 173 174 175 176 |
return _spin_lock_try(lock);
}
#define SPINLOCK_INIT 0
#pragma GCC diagnostic pop
#endif /* HAVE_LIBKERN_OSATOMIC_H && HAVE_OSSPINLOCKLOCK */
/*
| > | > > > > > | > > > > > > > > > > > > > | | 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 |
return _spin_lock_try(lock);
}
#define SPINLOCK_INIT 0
#pragma GCC diagnostic pop
#endif /* HAVE_LIBKERN_OSATOMIC_H && HAVE_OSSPINLOCKLOCK */
#endif /* not using os_unfair_lock */
/*
* These locks control access to the global notifier state.
*/
#if defined(USE_OS_UNFAIR_LOCK)
static os_unfair_lock notifierInitLock = OS_UNFAIR_LOCK_INIT;
static os_unfair_lock notifierLock = OS_UNFAIR_LOCK_INIT;
#else
static OSSpinLock notifierInitLock = SPINLOCK_INIT;
static OSSpinLock notifierLock = SPINLOCK_INIT;
#endif
/*
* Macros that abstract notifier locking/unlocking
*/
#if defined(USE_OS_UNFAIR_LOCK)
#define LOCK_NOTIFIER_INIT os_unfair_lock_lock(¬ifierInitLock)
#define UNLOCK_NOTIFIER_INIT os_unfair_lock_unlock(¬ifierInitLock)
#define LOCK_NOTIFIER os_unfair_lock_lock(¬ifierLock)
#define UNLOCK_NOTIFIER os_unfair_lock_unlock(¬ifierLock)
#define LOCK_NOTIFIER_TSD os_unfair_lock_lock(&tsdPtr->tsdLock)
#define UNLOCK_NOTIFIER_TSD os_unfair_lock_unlock(&tsdPtr->tsdLock)
#else
#define LOCK_NOTIFIER_INIT SpinLockLock(¬ifierInitLock)
#define UNLOCK_NOTIFIER_INIT SpinLockUnlock(¬ifierInitLock)
#define LOCK_NOTIFIER SpinLockLock(¬ifierLock)
#define UNLOCK_NOTIFIER SpinLockUnlock(¬ifierLock)
#define LOCK_NOTIFIER_TSD SpinLockLock(&tsdPtr->tsdLock)
#define UNLOCK_NOTIFIER_TSD SpinLockUnlock(&tsdPtr->tsdLock)
#endif
/*
* The debug version of the Notifier only works if using OSSpinLock.
*/
#if defined(TCL_MAC_DEBUG_NOTIFIER) && !defined(USE_OS_UNFAIR_LOCK)
#define TclMacOSXNotifierDbgMsg(m, ...) \
do { \
fprintf(notifierLog?notifierLog:stderr, "tclMacOSXNotify.c:%d: " \
"%s() pid %5d thread %10p: " m "\n", __LINE__, __func__, \
getpid(), pthread_self(), ##__VA_ARGS__); \
fflush(notifierLog?notifierLog:stderr); \
} while (0)
|
| ︙ | ︙ | |||
214 215 216 217 218 219 220 |
#p, TclpWideClicksToNanoseconds(e-s)); \
}
#undef LOCK_NOTIFIER_INIT
#define LOCK_NOTIFIER_INIT SpinLockLockDbg(¬ifierInitLock)
#undef LOCK_NOTIFIER
#define LOCK_NOTIFIER SpinLockLockDbg(¬ifierLock)
#undef LOCK_NOTIFIER_TSD
| | | 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 |
#p, TclpWideClicksToNanoseconds(e-s)); \
}
#undef LOCK_NOTIFIER_INIT
#define LOCK_NOTIFIER_INIT SpinLockLockDbg(¬ifierInitLock)
#undef LOCK_NOTIFIER
#define LOCK_NOTIFIER SpinLockLockDbg(¬ifierLock)
#undef LOCK_NOTIFIER_TSD
#define LOCK_NOTIFIER_TSD SpinLockLockDbg(tsdPtr->tsdLock)
#include <asl.h>
static FILE *notifierLog = NULL;
#ifndef NOTIFIER_LOG
#define NOTIFIER_LOG "/tmp/tclMacOSXNotify.log"
#endif
#define OPEN_NOTIFIER_LOG \
if (!notifierLog) { \
|
| ︙ | ︙ | |||
321 322 323 324 325 326 327 |
* this thread. */
int sleeping; /* True if runloop is inside Tcl_Sleep. */
int runLoopSourcePerformed; /* True after the runLoopSource callack was
* performed. */
int runLoopRunning; /* True if this thread's Tcl runLoop is
* running. */
int runLoopNestingLevel; /* Level of nested runLoop invocations. */
| < < > > > > > | 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 |
* this thread. */
int sleeping; /* True if runloop is inside Tcl_Sleep. */
int runLoopSourcePerformed; /* True after the runLoopSource callack was
* performed. */
int runLoopRunning; /* True if this thread's Tcl runLoop is
* running. */
int runLoopNestingLevel; /* Level of nested runLoop invocations. */
/* Must hold the notifierLock before accessing the following fields: */
/* Start notifierLock section */
int onList; /* True if this thread is on the
* waitingList */
struct ThreadSpecificData *nextPtr, *prevPtr;
/* All threads that are currently waiting on
* an event have their ThreadSpecificData
* structure on a doubly-linked listed formed
* from these pointers. */
/* End notifierLock section */
#if defined(USE_OS_UNFAIR_LOCK)
os_unfair_lock tsdLock;
#else
OSSpinLock tsdLock; /* Must hold this lock before acessing the
* following fields from more than one
* thread. */
#endif
/* Start tsdLock section */
SelectMasks checkMasks; /* This structure is used to build up the
* masks to be used in the next call to
* select. Bits are set in response to calls
* to Tcl_CreateFileHandler. */
SelectMasks readyMasks; /* This array reflects the readable/writable
* conditions that were found to exist by the
|
| ︙ | ︙ | |||
522 523 524 525 526 527 528 |
tsdPtr = TCL_TSD_INIT(&dataKey);
#ifdef WEAK_IMPORT_SPINLOCKLOCK
/*
* Initialize support for weakly imported spinlock API.
*/
| < | 558 559 560 561 562 563 564 565 566 567 568 569 570 571 |
tsdPtr = TCL_TSD_INIT(&dataKey);
#ifdef WEAK_IMPORT_SPINLOCKLOCK
/*
* Initialize support for weakly imported spinlock API.
*/
if (pthread_once(&spinLockLockInitControl, SpinLockLockInit)) {
Tcl_Panic("Tcl_InitNotifier: pthread_once failed");
}
#endif
#ifndef __CONSTANT_CFSTRINGS__
if (!tclEventsOnlyRunLoopMode) {
|
| ︙ | ︙ | |||
559 560 561 562 563 564 565 | } CFRunLoopAddSource(runLoop, runLoopSource, kCFRunLoopCommonModes); CFRunLoopAddSource(runLoop, runLoopSource, tclEventsOnlyRunLoopMode); bzero(&runLoopObserverContext, sizeof(CFRunLoopObserverContext)); runLoopObserverContext.info = tsdPtr; runLoopObserver = CFRunLoopObserverCreate(NULL, | | | > > > > | 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 |
}
CFRunLoopAddSource(runLoop, runLoopSource, kCFRunLoopCommonModes);
CFRunLoopAddSource(runLoop, runLoopSource, tclEventsOnlyRunLoopMode);
bzero(&runLoopObserverContext, sizeof(CFRunLoopObserverContext));
runLoopObserverContext.info = tsdPtr;
runLoopObserver = CFRunLoopObserverCreate(NULL,
kCFRunLoopEntry|kCFRunLoopExit, TRUE,
LONG_MIN, UpdateWaitingListAndServiceEvents,
&runLoopObserverContext);
if (!runLoopObserver) {
Tcl_Panic("Tcl_InitNotifier: could not create "
"CFRunLoopObserver");
}
CFRunLoopAddObserver(runLoop, runLoopObserver, kCFRunLoopCommonModes);
/*
* Create a second CFRunLoopObserver with the same callback as above
* for the tclEventsOnlyRunLoopMode to ensure that the callback can be
* re-entered via Tcl_ServiceAll() in the kCFRunLoopBeforeWaiting case
* (CFRunLoop prevents observer callback re-entry of a given observer
* instance).
*/
runLoopObserverTcl = CFRunLoopObserverCreate(NULL,
kCFRunLoopEntry|kCFRunLoopExit, TRUE,
LONG_MIN, UpdateWaitingListAndServiceEvents,
&runLoopObserverContext);
if (!runLoopObserverTcl) {
Tcl_Panic("Tcl_InitNotifier: could not create "
"CFRunLoopObserver");
}
CFRunLoopAddObserver(runLoop, runLoopObserverTcl,
tclEventsOnlyRunLoopMode);
tsdPtr->runLoop = runLoop;
tsdPtr->runLoopSource = runLoopSource;
tsdPtr->runLoopObserver = runLoopObserver;
tsdPtr->runLoopObserverTcl = runLoopObserverTcl;
tsdPtr->runLoopTimer = NULL;
tsdPtr->waitTime = CF_TIMEINTERVAL_FOREVER;
#if defined(USE_OS_UNFAIR_LOCK)
tsdPtr->tsdLock = OS_UNFAIR_LOCK_INIT;
#else
tsdPtr->tsdLock = SPINLOCK_INIT;
#endif
}
LOCK_NOTIFIER_INIT;
#ifdef HAVE_PTHREAD_ATFORK
/*
* Install pthread_atfork handlers to reinitialize the notifier in the
* child of a fork.
|
| ︙ | ︙ | |||
651 652 653 654 655 656 657 |
notifierThreadRunning = 0;
OPEN_NOTIFIER_LOG;
}
ENABLE_ASL;
notifierCount++;
UNLOCK_NOTIFIER_INIT;
| < | 690 691 692 693 694 695 696 697 698 699 700 701 702 703 |
notifierThreadRunning = 0;
OPEN_NOTIFIER_LOG;
}
ENABLE_ASL;
notifierCount++;
UNLOCK_NOTIFIER_INIT;
return tsdPtr;
}
/*
*----------------------------------------------------------------------
*
* TclMacOSXNotifierAddRunLoopMode --
|
| ︙ | ︙ | |||
1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 |
waitTime = CF_TIMEINTERVAL_FOREVER;
tsdPtr = TCL_TSD_INIT(&dataKey);
if (!tsdPtr->runLoop) {
Tcl_Panic("Tcl_WaitForEvent: Notifier not initialized");
}
if (timePtr) {
Tcl_Time vTime = *timePtr;
/*
* TIP #233 (Virtualized Time). Is virtual time in effect? And do we
* actually have something to scale? If yes to both then we call the
* handler to do this scaling.
*/
if (vTime.sec != 0 || vTime.usec != 0) {
tclScaleTimeProcPtr(&vTime, tclTimeClientData);
waitTime = vTime.sec + 1.0e-6 * vTime.usec;
} else {
/*
| > > > > > < | > > > > | < > > > > > > | | | | | | | | | 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 |
waitTime = CF_TIMEINTERVAL_FOREVER;
tsdPtr = TCL_TSD_INIT(&dataKey);
if (!tsdPtr->runLoop) {
Tcl_Panic("Tcl_WaitForEvent: Notifier not initialized");
}
/*
* A NULL timePtr means wait forever.
*/
if (timePtr) {
Tcl_Time vTime = *timePtr;
/*
* TIP #233 (Virtualized Time). Is virtual time in effect? And do we
* actually have something to scale? If yes to both then we call the
* handler to do this scaling.
*/
if (vTime.sec != 0 || vTime.usec != 0) {
tclScaleTimeProcPtr(&vTime, tclTimeClientData);
waitTime = vTime.sec + 1.0e-6 * vTime.usec;
} else {
/*
* The max block time was set to 0.
*
* If we set the waitTime to 0, then the call to CFRunLoopInMode
* may return without processing all of its sources. The Apple
* documentation says that if the waitTime is 0 "only one pass is
* made through the run loop before returning; if multiple sources
* or timers are ready to fire immediately, only one (possibly two
* if one is a version 0 source) will be fired, regardless of the
* value of returnAfterSourceHandled." This can cause some chanio
* tests to fail. So we use a small positive waitTime unless there
* is another RunLoop running.
*/
polling = 1;
waitTime = tsdPtr->runLoopRunning ? 0 : 0.0001;
}
}
StartNotifierThread();
LOCK_NOTIFIER_TSD;
tsdPtr->polling = polling;
UNLOCK_NOTIFIER_TSD;
tsdPtr->runLoopSourcePerformed = 0;
/*
* If the Tcl runloop is already running (e.g. if Tcl_WaitForEvent was
* called recursively) start a new runloop in a custom runloop mode
* containing only the source for the notifier thread. Otherwise wakeups
* from other sources added to the common runloop mode might get lost or
* 3rd party event handlers might get called when they do not expect to
* be.
*/
runLoopRunning = tsdPtr->runLoopRunning;
tsdPtr->runLoopRunning = 1;
runLoopStatus = CFRunLoopRunInMode(
runLoopRunning ? tclEventsOnlyRunLoopMode : kCFRunLoopDefaultMode,
waitTime, TRUE);
tsdPtr->runLoopRunning = runLoopRunning;
LOCK_NOTIFIER_TSD;
tsdPtr->polling = 0;
UNLOCK_NOTIFIER_TSD;
switch (runLoopStatus) {
case kCFRunLoopRunFinished:
|
| ︙ | ︙ | |||
1449 1450 1451 1452 1453 1454 1455 |
static void
UpdateWaitingListAndServiceEvents(
TCL_UNUSED(CFRunLoopObserverRef),
CFRunLoopActivity activity,
void *info)
{
ThreadSpecificData *tsdPtr = (ThreadSpecificData *)info;
| < | 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 |
static void
UpdateWaitingListAndServiceEvents(
TCL_UNUSED(CFRunLoopObserverRef),
CFRunLoopActivity activity,
void *info)
{
ThreadSpecificData *tsdPtr = (ThreadSpecificData *)info;
if (tsdPtr->sleeping) {
return;
}
switch (activity) {
case kCFRunLoopEntry:
tsdPtr->runLoopNestingLevel++;
if (tsdPtr->numFdBits > 0 || tsdPtr->polling) {
|
| ︙ | ︙ | |||
1471 1472 1473 1474 1475 1476 1477 |
case kCFRunLoopExit:
if (tsdPtr->runLoopNestingLevel == 1) {
LOCK_NOTIFIER;
OnOffWaitingList(tsdPtr, 0, 1);
UNLOCK_NOTIFIER;
}
tsdPtr->runLoopNestingLevel--;
| < < < < < < < < < < < < < | 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 |
case kCFRunLoopExit:
if (tsdPtr->runLoopNestingLevel == 1) {
LOCK_NOTIFIER;
OnOffWaitingList(tsdPtr, 0, 1);
UNLOCK_NOTIFIER;
}
tsdPtr->runLoopNestingLevel--;
break;
default:
break;
}
}
/*
|
| ︙ | ︙ | |||
1517 1518 1519 1520 1521 1522 1523 |
OnOffWaitingList(
ThreadSpecificData *tsdPtr,
int onList,
int signalNotifier)
{
int changeWaitingList;
| | | 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 |
OnOffWaitingList(
ThreadSpecificData *tsdPtr,
int onList,
int signalNotifier)
{
int changeWaitingList;
#if defined(TCL_MAC_DEBUG_NOTIFIER) && !defined(USE_OS_UNFAIR_LOCK)
if (SpinLockTry(¬ifierLock)) {
Tcl_Panic("OnOffWaitingList: notifierLock unlocked");
}
#endif
changeWaitingList = (!onList ^ !tsdPtr->onList);
if (changeWaitingList) {
if (onList) {
|
| ︙ | ︙ | |||
2048 2049 2050 2051 2052 2053 2054 |
*/
static void
AtForkChild(void)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
| > > > > > > > > > | | | > | 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 |
*/
static void
AtForkChild(void)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
/*
* If a child process unlocks an os_unfair_lock that was created in its parent
* the child will exit with an illegal instruction error. So we reinitialize
* the lock in the child rather than attempt to unlock it.
*/
#if defined(USE_OS_UNFAIR_LOCK)
tsdPtr->tsdLock = OS_UNFAIR_LOCK_INIT;
#else
UNLOCK_NOTIFIER_TSD;
UNLOCK_NOTIFIER;
UNLOCK_NOTIFIER_INIT;
#endif
if (tsdPtr->runLoop) {
tsdPtr->runLoop = NULL;
if (!noCFafterFork) {
CFRunLoopSourceInvalidate(tsdPtr->runLoopSource);
CFRelease(tsdPtr->runLoopSource);
if (tsdPtr->runLoopTimer) {
CFRunLoopTimerInvalidate(tsdPtr->runLoopTimer);
|
| ︙ | ︙ |
Changes to tests-perf/test-performance.tcl.
| ︙ | ︙ | |||
45 46 47 48 49 50 51 |
set tcnt [llength $_(itm)]
if {!$tcnt} {
puts ""
return
}
| | | 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 |
set tcnt [llength $_(itm)]
if {!$tcnt} {
puts ""
return
}
set mintm 0x7FFFFFFF
set maxtm 0
set nettm 0
set wtm 0
set wcnt 0
set i 0
foreach tm $_(itm) {
if {[llength $tm] > 6} {
|
| ︙ | ︙ |
Changes to tests/aaa_exit.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # Commands covered: exit, emphasis on finalization hangs # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1993 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. | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
# Commands covered: exit, emphasis on finalization hangs
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1991-1993 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 {"::tcltest" ni [namespace children]} {
package require tcltest 2
namespace import -force ::tcltest::*
}
test exit-1.1 {normal, quick exit} {
set f [open "|[interpreter] << \"exec [interpreter] << {set ::env(TCL_FINALIZE_ON_EXIT) 0;exit}\"" r]
set aft [after 1000 {set done "Quick exit hangs !!!"}]
|
| ︙ | ︙ |
Changes to tests/append.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # Commands covered: append lappend # # This file contains a collection of tests for one or more of the Tcl built-in # commands. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # # Copyright (c) 1991-1993 The Regents of the University of California. # 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. | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
# Commands covered: append lappend
#
# This file contains a collection of tests for one or more of the Tcl built-in
# commands. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# 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 {"::tcltest" ni [namespace children]} {
package require tcltest 2
namespace import -force ::tcltest::*
}
unset -nocomplain x
test append-1.1 {append command} {
unset -nocomplain x
|
| ︙ | ︙ |
Changes to tests/appendComp.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # Commands covered: append lappend # # This file contains a collection of tests for one or more of the Tcl built-in # commands. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # # Copyright (c) 1991-1993 The Regents of the University of California. # 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. | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
# Commands covered: append lappend
#
# This file contains a collection of tests for one or more of the Tcl built-in
# commands. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# 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 {"::tcltest" ni [namespace children]} {
package require tcltest 2
namespace import -force ::tcltest::*
}
catch {unset x}
test appendComp-1.1 {append command} -setup {
unset -nocomplain x
|
| ︙ | ︙ |
Changes to tests/apply.test.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 | # Copyright (c) 1994-1996 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # Copyright (c) 2005-2006 Miguel Sofer # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# Copyright (c) 2005-2006 Miguel Sofer
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.2
namespace import -force ::tcltest::*
}
if {[info commands ::apply] eq {}} {
return
}
|
| ︙ | ︙ |
Changes to tests/async.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # Commands covered: none # # This file contains a collection of tests for Tcl_AsyncCreate and related # library procedures. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1993 The Regents of the University of California. # 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. | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
# Commands covered: none
#
# This file contains a collection of tests for Tcl_AsyncCreate and related
# library procedures. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1993 The Regents of the University of California.
# 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 {"::tcltest" ni [namespace children]} {
package require tcltest
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
|
| ︙ | ︙ |
Changes to tests/autoMkindex.test.
| ︙ | ︙ | |||
160 161 162 163 164 165 166 |
}
} -cleanup {
interp delete slave
} -result "0 {} pub_one ::buried::pub_one pub_two ::buried::pub_two"
# Test auto_mkindex hooks
| | | | | | 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 |
}
} -cleanup {
interp delete slave
} -result "0 {} pub_one ::buried::pub_one pub_two ::buried::pub_two"
# Test auto_mkindex hooks
# Child hook executes interesting code in the interp used to watch code.
test autoMkindex-3.1 {childHook} -setup {
file delete tclIndex
} -body {
auto_mkindex_parser::childhook {
_%@namespace eval ::blt {
proc foo {} {}
_%@namespace export foo
}
}
auto_mkindex_parser::childhook { _%@namespace import -force ::blt::* }
auto_mkindex . autoMkindex.tcl
file exists tclIndex
} -cleanup {
# Reset initCommands to avoid trashing other tests
AutoMkindexTestReset
} -result 1
# The auto_mkindex_parser::command is used to register commands that create
|
| ︙ | ︙ |
Changes to tests/binary.test.
1 2 3 4 5 6 7 8 9 10 11 12 | # This file tests the tclBinary.c file and the "binary" Tcl command. # # This file contains a collection of tests for one or more of the Tcl built-in # commands. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # # Copyright (c) 1997 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. | | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 |
# This file tests the tclBinary.c file and the "binary" Tcl command.
#
# This file contains a collection of tests for one or more of the Tcl built-in
# commands. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
#
# Copyright (c) 1997 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
namespace import -force ::tcltest::*
}
testConstraint bigEndian [expr {$tcl_platform(byteOrder) eq "bigEndian"}]
testConstraint littleEndian [expr {$tcl_platform(byteOrder) eq "littleEndian"}]
testConstraint testbytestring [llength [info commands testbytestring]]
# Big test for correct ordering of data in [expr]
proc testIEEE {} {
variable ieeeValues
binary scan [binary format dd -1.0 1.0] c* c
switch -exact -- $c {
{0 0 0 0 0 0 -16 -65 0 0 0 0 0 0 -16 63} {
|
| ︙ | ︙ | |||
2506 2507 2508 2509 2510 2511 2512 |
} -result "\0\1\2\3\4\0\1\2\3\4"
test binary-71.6 {binary decode hex} -body {
binary decode hex "61 61"
} -result {aa}
test binary-71.7 {binary decode hex} -body {
binary decode hex "61\n\n\n61"
} -result {aa}
| | | | 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 |
} -result "\0\1\2\3\4\0\1\2\3\4"
test binary-71.6 {binary decode hex} -body {
binary decode hex "61 61"
} -result {aa}
test binary-71.7 {binary decode hex} -body {
binary decode hex "61\n\n\n61"
} -result {aa}
test binary-71.8 {binary decode hex} -match glob -body {
binary decode hex -strict "61 61"
} -returnCodes error -result {invalid hexadecimal digit " " * at position 2}
test binary-71.9 {binary decode hex} -body {
set r [binary decode hex "6"]
list [string length $r] $r
} -result {0 {}}
test binary-71.10 {binary decode hex} -body {
string length [binary decode hex " "]
} -result 0
|
| ︙ | ︙ | |||
2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 |
} -result {YWJjYW-*-JjYWJj}
test binary-72.27 {binary encode base64} -body {
binary encode base64 -maxlen 4 -wrapchar -*- abcabcabc
} -result {YWJj-*-YWJj-*-YWJj}
test binary-72.28 {binary encode base64} -body {
binary encode base64 -maxlen 6 -wrapchar 0123456789 abcabcabc
} -result {YWJjYW0123456789JjYWJj}
test binary-73.1 {binary decode base64} -body {
binary decode base64
} -returnCodes error -match glob -result "wrong # args: *"
test binary-73.2 {binary decode base64} -body {
binary decode base64 YWJj
} -result {abc}
test binary-73.3 {binary decode base64} -body {
binary decode base64 {}
} -result {}
test binary-73.4 {binary decode base64} -body {
binary decode base64 [string repeat YWJj 20]
} -result [string repeat abc 20]
| > > > | | | | | | | | 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 |
} -result {YWJjYW-*-JjYWJj}
test binary-72.27 {binary encode base64} -body {
binary encode base64 -maxlen 4 -wrapchar -*- abcabcabc
} -result {YWJj-*-YWJj-*-YWJj}
test binary-72.28 {binary encode base64} -body {
binary encode base64 -maxlen 6 -wrapchar 0123456789 abcabcabc
} -result {YWJjYW0123456789JjYWJj}
test binary-72.29 {binary encode base64} {
string length [binary encode base64 -maxlen 3 -wrapchar \xca abc]
} 5
test binary-73.1 {binary decode base64} -body {
binary decode base64
} -returnCodes error -match glob -result "wrong # args: *"
test binary-73.2 {binary decode base64} -body {
binary decode base64 YWJj
} -result {abc}
test binary-73.3 {binary decode base64} -body {
binary decode base64 {}
} -result {}
test binary-73.4 {binary decode base64} -body {
binary decode base64 [string repeat YWJj 20]
} -result [string repeat abc 20]
test binary-73.5 {binary decode base64} -body {
binary decode base64 AAECAwQAAQID
} -result "\0\1\2\3\4\0\1\2\3"
test binary-73.6 {binary decode base64} -body {
binary decode base64 AA==
} -result "\0"
test binary-73.7 {binary decode base64} -body {
binary decode base64 AAA=
} -result "\0\0"
test binary-73.8 {binary decode base64} -body {
binary decode base64 AAAA
} -result "\0\0\0"
test binary-73.9 {binary decode base64} -body {
binary decode base64 AAAAAA==
} -result "\0\0\0\0"
test binary-73.10 {binary decode base64} -body {
set s "[string repeat YWJj 10]\n[string repeat YWJj 10]"
binary decode base64 $s
} -result [string repeat abc 20]
test binary-73.11 {binary decode base64} -body {
set s "[string repeat YWJj 10]\n [string repeat YWJj 10]"
binary decode base64 $s
} -result [string repeat abc 20]
test binary-73.12 {binary decode base64} -body {
binary decode base64 -strict ":YWJj"
} -returnCodes error -match glob -result {invalid base64 character ":" * at position 0}
test binary-73.13 {binary decode base64} -body {
set s "[string repeat YWJj 10]:[string repeat YWJj 10]"
binary decode base64 -strict $s
} -returnCodes error -match glob -result {invalid base64 character ":" * at position 40}
test binary-73.14 {binary decode base64} -body {
set s "[string repeat YWJj 10]\n [string repeat YWJj 10]"
binary decode base64 -strict $s
} -returnCodes error -match glob -result {invalid base64 character *}
test binary-73.20 {binary decode base64} -body {
set r [binary decode base64 Y]
list [string length $r] $r
|
| ︙ | ︙ | |||
2714 2715 2716 2717 2718 2719 2720 |
test binary-73.29 {binary decode base64} -body {
list [string length [set r [binary decode base64 -strict WFk=\n]]] $r
} -returnCodes error -match glob -result {invalid base64 character *}
test binary-73.30 {binary decode base64} -body {
list [string length [set r [binary decode base64 -strict WFla\n]]] $r
} -returnCodes error -match glob -result {invalid base64 character *}
test binary-73.31 {binary decode base64} -body {
| | | 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 |
test binary-73.29 {binary decode base64} -body {
list [string length [set r [binary decode base64 -strict WFk=\n]]] $r
} -returnCodes error -match glob -result {invalid base64 character *}
test binary-73.30 {binary decode base64} -body {
list [string length [set r [binary decode base64 -strict WFla\n]]] $r
} -returnCodes error -match glob -result {invalid base64 character *}
test binary-73.31 {binary decode base64} -body {
list [string length [set r [binary decode base64 -strict WA==WFla]]] $r
} -returnCodes error -match glob -result {invalid base64 character *}
test binary-73.32 {binary decode base64, bug [00d04c4f12]} -body {
list \
[string length [binary decode base64 =]] \
[string length [binary decode base64 " ="]] \
[string length [binary decode base64 " ="]] \
[string length [binary decode base64 "\r\n\t="]] \
|
| ︙ | ︙ | |||
2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 |
if {[set a [binary decode base64 [set x [binary encode base64 $c]]]] ne $c} {
lappend r "encode & decode is wrong on string `$c` (encoded: $x): `$a` != `$c`"
}
}
}
join $r \n
} -result {}
test binary-74.1 {binary encode uuencode} -body {
binary encode uuencode
} -returnCodes error -match glob -result "wrong # args: *"
test binary-74.2 {binary encode uuencode} -body {
binary encode uuencode abc
} -result {#86)C
| > > > | 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 |
if {[set a [binary decode base64 [set x [binary encode base64 $c]]]] ne $c} {
lappend r "encode & decode is wrong on string `$c` (encoded: $x): `$a` != `$c`"
}
}
}
join $r \n
} -result {}
test binary-73.37 {binary decode base64: Bug ffeb2097af} {
binary decode base64 [binary encode base64 -maxlen 3 -wrapchar : abc]
} abc
test binary-74.1 {binary encode uuencode} -body {
binary encode uuencode
} -returnCodes error -match glob -result "wrong # args: *"
test binary-74.2 {binary encode uuencode} -body {
binary encode uuencode abc
} -result {#86)C
|
| ︙ | ︙ | |||
2793 2794 2795 2796 2797 2798 2799 |
binary encode uuencode \0\0\0\0
} -result {$``````
}
test binary-74.10 {binary encode uuencode} -returnCodes error -body {
binary encode uuencode -foo 30 abcabcabc
} -result {bad option "-foo": must be -maxlen or -wrapchar}
test binary-74.11 {binary encode uuencode} -returnCodes error -body {
| | > > > > > > | | | 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 |
binary encode uuencode \0\0\0\0
} -result {$``````
}
test binary-74.10 {binary encode uuencode} -returnCodes error -body {
binary encode uuencode -foo 30 abcabcabc
} -result {bad option "-foo": must be -maxlen or -wrapchar}
test binary-74.11 {binary encode uuencode} -returnCodes error -body {
binary encode uuencode -maxlen 4 abcabcabc
} -result {line length out of range}
test binary-74.12 {binary encode uuencode} -body {
binary encode uuencode -maxlen 5 -wrapchar \t abcabcabc
} -result #86)C\t#86)C\t#86)C\t
test binary-74.13 {binary encode uuencode} -body {
binary encode uuencode -maxlen 85 -wrapchar \t abcabcabc
} -result )86)C86)C86)C\t
test binary-74.14 {binary encode uuencode} -returnCodes error -body {
binary encode uuencode -maxlen 86 abcabcabc
} -result {line length out of range}
test binary-75.1 {binary decode uuencode} -body {
binary decode uuencode
} -returnCodes error -match glob -result "wrong # args: *"
test binary-75.2 {binary decode uuencode} -body {
binary decode uuencode "#86)C\n"
} -result {abc}
|
| ︙ | ︙ | |||
2839 2840 2841 2842 2843 2844 2845 |
} -result [string repeat abc 20]
test binary-75.11 {binary decode uuencode} -body {
set s ">[string repeat 86)C 10]\n\t>\t[string repeat 86)C 10]\r"
binary decode uuencode $s
} -result [string repeat abc 20]
test binary-75.12 {binary decode uuencode} -body {
binary decode uuencode -strict "|86)C"
| | | | 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 |
} -result [string repeat abc 20]
test binary-75.11 {binary decode uuencode} -body {
set s ">[string repeat 86)C 10]\n\t>\t[string repeat 86)C 10]\r"
binary decode uuencode $s
} -result [string repeat abc 20]
test binary-75.12 {binary decode uuencode} -body {
binary decode uuencode -strict "|86)C"
} -returnCodes error -match glob -result {invalid uuencode character "|" * at position 0}
test binary-75.13 {binary decode uuencode} -body {
set s ">[string repeat 86)C 10]|[string repeat 86)C 10]"
binary decode uuencode -strict $s
} -returnCodes error -match glob -result {invalid uuencode character "|" * at position 41}
test binary-75.14 {binary decode uuencode} -body {
set s ">[string repeat 86)C 10]\na[string repeat 86)C 10]"
binary decode uuencode -strict $s
} -returnCodes error -match glob -result {invalid uuencode character *}
test binary-75.20 {binary decode uuencode} -body {
set r [binary decode uuencode " 8"]
list [string length $r] $r
|
| ︙ | ︙ | |||
2871 2872 2873 2874 2875 2876 2877 |
test binary-75.24 {binary decode uuencode} -body {
set s "#04)\# "
binary decode uuencode $s
} -result ABC
test binary-75.25 {binary decode uuencode} -body {
set s "#04)\#z"
binary decode uuencode $s
| | | 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 |
test binary-75.24 {binary decode uuencode} -body {
set s "#04)\# "
binary decode uuencode $s
} -result ABC
test binary-75.25 {binary decode uuencode} -body {
set s "#04)\#z"
binary decode uuencode $s
} -returnCodes error -match glob -result {invalid uuencode character "z" * at position 5}
test binary-75.26 {binary decode uuencode} -body {
string length [binary decode uuencode " "]
} -result 0
test binary-76.1 {binary string appending growth algorithm} unix {
# Create zero-length byte array first
set f [open /dev/null rb]
|
| ︙ | ︙ | |||
2925 2926 2927 2928 2929 2930 2931 |
test binary-79.1 {Tcl_SetByteArrayLength} testsetbytearraylength {
testsetbytearraylength [string cat A B C] 1
} A
test binary-79.2 {Tcl_SetByteArrayLength} testsetbytearraylength {
testsetbytearraylength [string cat \u0141 B C] 1
} A
| > > > > > > > > > > > > | | 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 |
test binary-79.1 {Tcl_SetByteArrayLength} testsetbytearraylength {
testsetbytearraylength [string cat A B C] 1
} A
test binary-79.2 {Tcl_SetByteArrayLength} testsetbytearraylength {
testsetbytearraylength [string cat \u0141 B C] 1
} A
test binary-80.1 {TclGetBytesFromObj} -constraints testbytestring -returnCodes 1 -body {
testbytestring "\u4E4E"
} -result "expected byte sequence but character 0 was '\u4E4E' (U+004E4E)"
test binary-80.2 {TclGetBytesFromObj} -constraints testbytestring -returnCodes 1 -body {
testbytestring [testbytestring "\x00\xA0\xA0\xA0\xE4\xB9\x8E"]
} -result "expected byte sequence but character 4 was '\u4E4E' (U+004E4E)"
test binary-80.3 {TclGetBytesFromObj} -constraints testbytestring -returnCodes 1 -body {
testbytestring [testbytestring "\xC0\x80\xA0\xA0\xA0\xE4\xB9\x8E"]
} -result "expected byte sequence but character 4 was '\u4E4E' (U+004E4E)"
test binary-80.4 {TclGetBytesFromObj} -constraints testbytestring -returnCodes 1 -body {
testbytestring [testbytestring "\xC0\x80\xA0\xA0\xA0\xF0\x9F\x98\x81"]
} -result "expected byte sequence but character 4 was '\U01F601' (U+01F601)"
# ----------------------------------------------------------------------
# cleanup
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Changes to tests/chan.test.
1 2 3 4 5 6 7 8 9 | # This file contains a collection of tests for the Tcl built-in 'chan' # command. Sourcing this file into Tcl runs the tests and generates # output for errors. No output means no errors were found. # # Copyright (c) 2005 Donal K. Fellows # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 |
# This file contains a collection of tests for the Tcl built-in 'chan'
# command. Sourcing this file into Tcl runs the tests and generates
# output for errors. No output means no errors were found.
#
# Copyright (c) 2005 Donal K. Fellows
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2
namespace import -force ::tcltest::*
}
#
# Note: The tests for the chan methods "create" and "postevent"
# currently reside in the file "ioCmd.test".
|
| ︙ | ︙ |
Changes to tests/chanio.test.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 | # 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. | < | | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 |
# 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 {"::tcltest" ni [namespace children]} {
package require tcltest 2
}
namespace eval ::tcl::test::io {
namespace import ::tcltest::*
variable umaskValue
|
| ︙ | ︙ | |||
35 36 37 38 39 40 41 |
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]]
| < > | 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 |
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 testfevent [llength [info commands testfevent]]
testConstraint testchannelevent [llength [info commands testchannelevent]]
testConstraint testmainthread [llength [info commands testmainthread]]
testConstraint testservicemode [llength [info commands testservicemode]]
testConstraint knownMsvcBug [expr {![info exists ::env(TRAVIS_OS_NAME)] || ![string match windows $::env(TRAVIS_OS_NAME)]}]
# You need a *very* special environment to do some tests. In particular,
# many file systems do not support large-files...
testConstraint largefileSupport [expr {$::tcl_platform(os) ne "Darwin"}]
# some tests can only be run is umask is 2 if "umask" cannot be run, the
|
| ︙ | ︙ | |||
444 445 446 447 448 449 450 |
chan puts $f hi
chan close $f
set f [open $path(test1)]
list [chan gets $f line] $line
} -cleanup {
chan close $f
} -result [list 256 $a]
| | | 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 |
chan puts $f hi
chan close $f
set f [open $path(test1)]
list [chan gets $f line] $line
} -cleanup {
chan close $f
} -result [list 256 $a]
test chan-io-6.7 {Tcl_GetsObj: error in input} -constraints stdio -body {
# if (FilterInputBytes(chanPtr, &gs) != 0)
set f [openpipe w+ $path(cat)]
chan puts -nonewline $f "hi\nwould"
chan flush $f
chan gets $f
chan configure $f -blocking 0
chan gets $f line
|
| ︙ | ︙ | |||
705 706 707 708 709 710 711 |
chan configure $f -translation crlf -buffersize 16
list [chan gets $f line] $line [testchannel inputbuffered $f]
} -cleanup {
chan close $f
} -result [list 15 "123456789012345" 15]
test chan-io-6.31 {Tcl_GetsObj: crlf mode: buffer exhausted, blocked} -setup {
set x ""
| | | 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 |
chan configure $f -translation crlf -buffersize 16
list [chan gets $f line] $line [testchannel inputbuffered $f]
} -cleanup {
chan close $f
} -result [list 15 "123456789012345" 15]
test chan-io-6.31 {Tcl_GetsObj: crlf mode: buffer exhausted, blocked} -setup {
set x ""
} -constraints {stdio testchannel fileevent} -body {
# (FilterInputBytes() != 0)
set f [openpipe w+ $path(cat)]
chan configure $f -translation {crlf lf} -buffering none
chan puts -nonewline $f "bbbbbbbbbbbbbb\r\n123456789012345\r"
chan configure $f -buffersize 16
lappend x [chan gets $f]
chan configure $f -blocking 0
|
| ︙ | ︙ | |||
845 846 847 848 849 850 851 |
lappend x [chan gets $f line] $line [chan gets $f line] $line
lappend x [chan gets $f line] $line [chan gets $f line] $line [chan gets $f line] $line
} -cleanup {
chan close $f
} -result {4 abcd 4 efgh 4 ijkl 4 mnop -1 {}}
test chan-io-6.43 {Tcl_GetsObj: input saw cr} -setup {
set x ""
| | | | | | 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 |
lappend x [chan gets $f line] $line [chan gets $f line] $line
lappend x [chan gets $f line] $line [chan gets $f line] $line [chan gets $f line] $line
} -cleanup {
chan close $f
} -result {4 abcd 4 efgh 4 ijkl 4 mnop -1 {}}
test chan-io-6.43 {Tcl_GetsObj: input saw cr} -setup {
set x ""
} -constraints {stdio testchannel fileevent} -body {
# if (chanPtr->flags & INPUT_SAW_CR)
set f [openpipe w+ $path(cat)]
chan configure $f -translation {auto lf} -buffering none
chan puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r"
chan configure $f -buffersize 16
lappend x [chan gets $f]
chan configure $f -blocking 0
lappend x [chan gets $f line] $line [testchannel queuedcr $f]
chan configure $f -blocking 1
chan puts -nonewline $f "\nabcd\refg\x1a"
lappend x [chan gets $f line] $line [testchannel queuedcr $f]
lappend x [chan gets $f line] $line
} -cleanup {
chan close $f
} -result {bbbbbbbbbbbbbbb 15 123456789abcdef 1 4 abcd 0 3 efg}
test chan-io-6.44 {Tcl_GetsObj: input saw cr, not followed by cr} -setup {
set x ""
} -constraints {stdio testchannel fileevent} -body {
# not (*eol == '\n')
set f [openpipe w+ $path(cat)]
chan configure $f -translation {auto lf} -buffering none
chan puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r"
chan configure $f -buffersize 16
lappend x [chan gets $f]
chan configure $f -blocking 0
lappend x [chan gets $f line] $line [testchannel queuedcr $f]
chan configure $f -blocking 1
chan puts -nonewline $f "abcd\refg\x1a"
lappend x [chan gets $f line] $line [testchannel queuedcr $f]
lappend x [chan gets $f line] $line
} -cleanup {
chan close $f
} -result {bbbbbbbbbbbbbbb 15 123456789abcdef 1 4 abcd 0 3 efg}
test chan-io-6.45 {Tcl_GetsObj: input saw cr, skip right number of bytes} -setup {
set x ""
} -constraints {stdio testchannel fileevent} -body {
# Tcl_ExternalToUtf()
set f [openpipe w+ $path(cat)]
chan configure $f -translation {auto lf} -buffering none
chan configure $f -encoding utf-16
chan puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r"
chan configure $f -buffersize 16
chan gets $f
chan configure $f -blocking 0
lappend x [chan gets $f line] $line [testchannel queuedcr $f]
chan configure $f -blocking 1
chan puts -nonewline $f "\nabcd\refg"
lappend x [chan gets $f line] $line [testchannel queuedcr $f]
} -cleanup {
chan close $f
} -result {15 123456789abcdef 1 4 abcd 0}
test chan-io-6.46 {Tcl_GetsObj: input saw cr, followed by just \n should give eof} -setup {
set x ""
} -constraints {stdio testchannel fileevent} -body {
# memmove()
set f [openpipe w+ $path(cat)]
chan configure $f -translation {auto lf} -buffering none
chan puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r"
chan configure $f -buffersize 16
chan gets $f
chan configure $f -blocking 0
|
| ︙ | ︙ | |||
1017 1018 1019 1020 1021 1022 1023 |
list [chan gets $f line] $line [chan gets $f line] $line [chan gets $f line] $line
} -cleanup {
chan close $f
} -result [list 8 "there\u4e00ok" 11 "\u4e01more bytes" 4 "here"]
test chan-io-6.56 {Tcl_GetsObj: incomplete lines should disable file events} -setup {
update
variable x {}
| | | 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 |
list [chan gets $f line] $line [chan gets $f line] $line [chan gets $f line] $line
} -cleanup {
chan close $f
} -result [list 8 "there\u4e00ok" 11 "\u4e01more bytes" 4 "here"]
test chan-io-6.56 {Tcl_GetsObj: incomplete lines should disable file events} -setup {
update
variable x {}
} -constraints {stdio fileevent} -body {
set f [openpipe w+ $path(cat)]
chan configure $f -buffering none
chan puts -nonewline $f "foobar"
chan configure $f -blocking 0
after 500 [namespace code {
lappend x timeout
}]
|
| ︙ | ︙ | |||
1084 1085 1086 1087 1088 1089 1090 |
lappend x [chan tell $f] [testchannel inputbuffered $f] [chan eof $f]
lappend x [chan gets $f line] $line
} -cleanup {
chan close $f
} -result [list 15 "1234567890123\uff10\uff11" 18 0 1 -1 ""]
test chan-io-7.4 {FilterInputBytes: recover from split up character} -setup {
variable x ""
| | | 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 |
lappend x [chan tell $f] [testchannel inputbuffered $f] [chan eof $f]
lappend x [chan gets $f line] $line
} -cleanup {
chan close $f
} -result [list 15 "1234567890123\uff10\uff11" 18 0 1 -1 ""]
test chan-io-7.4 {FilterInputBytes: recover from split up character} -setup {
variable x ""
} -constraints {stdio fileevent} -body {
set f [openpipe w+ $path(cat)]
chan configure $f -encoding binary -buffering none
chan puts -nonewline $f "1234567890123\x82\x4f\x82\x50\x82"
chan configure $f -encoding shiftjis -blocking 0
chan event $f read [namespace code {
lappend x [chan gets $f line] $line [chan blocked $f]
}]
|
| ︙ | ︙ | |||
1118 1119 1120 1121 1122 1123 1124 |
chan gets $f
testchannel inputbuffered $f
} -cleanup {
chan close $f
} -result 7
test chan-io-8.2 {PeekAhead: only go to device if no more cached data} -setup {
variable x {}
| | | | 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 |
chan gets $f
testchannel inputbuffered $f
} -cleanup {
chan close $f
} -result 7
test chan-io-8.2 {PeekAhead: only go to device if no more cached data} -setup {
variable x {}
} -constraints {stdio testchannel fileevent} -body {
# not (bufPtr->nextPtr == NULL)
set f [openpipe w+ $path(cat)]
chan configure $f -translation lf -encoding ascii -buffering none
chan puts -nonewline $f "123456789012345\r\nbcdefghijklmnopqrstuvwxyz"
chan event $f read [namespace code {
lappend x [chan gets $f line] $line [testchannel inputbuffered $f]
}]
chan configure $f -encoding utf-16 -buffersize 16 -blocking 0
vwait [namespace which -variable x]
chan configure $f -translation auto -encoding ascii -blocking 1
# here
vwait [namespace which -variable x]
return $x
} -cleanup {
chan close $f
} -result {-1 {} 42 15 123456789012345 25}
test chan-io-8.3 {PeekAhead: no cached data available} -constraints {stdio testchannel fileevent} -body {
# (bytesLeft == 0)
set f [openpipe w+ $path(cat)]
chan configure $f -translation {auto binary}
chan puts -nonewline $f "abcdefghijklmno\r"
chan flush $f
list [chan gets $f line] $line [testchannel queuedcr $f]
} -cleanup {
|
| ︙ | ︙ | |||
1164 1165 1166 1167 1168 1169 1170 |
# 30). To check if "\n" follows, calls PeekAhead and determines that
# cached data is available in buffer w/o having to call driver.
chan gets $f
} -cleanup {
chan close $f
} -result $a
unset a
| | | | | 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 |
# 30). To check if "\n" follows, calls PeekAhead and determines that
# cached data is available in buffer w/o having to call driver.
chan gets $f
} -cleanup {
chan close $f
} -result $a
unset a
test chan-io-8.5 {PeekAhead: don't peek if last read was short} -constraints {stdio testchannel fileevent} -body {
# (bufPtr->nextAdded < bufPtr->length)
set f [openpipe w+ $path(cat)]
chan configure $f -translation {auto binary}
chan puts -nonewline $f "abcdefghijklmno\r"
chan flush $f
# here
list [chan gets $f line] $line [testchannel queuedcr $f]
} -cleanup {
chan close $f
} -result {15 abcdefghijklmno 1}
test chan-io-8.6 {PeekAhead: change to non-blocking mode} -constraints {stdio testchannel fileevent} -body {
# ((chanPtr->flags & CHANNEL_NONBLOCKING) == 0)
set f [openpipe w+ $path(cat)]
chan configure $f -translation {auto binary} -buffersize 16
chan puts -nonewline $f "abcdefghijklmno\r"
chan flush $f
# here
list [chan gets $f line] $line [testchannel queuedcr $f]
} -cleanup {
chan close $f
} -result {15 abcdefghijklmno 1}
test chan-io-8.7 {PeekAhead: cleanup} -setup {
set x ""
} -constraints {stdio testchannel fileevent} -body {
# Make sure bytes are removed from buffer.
set f [openpipe w+ $path(cat)]
chan configure $f -translation {auto binary} -buffering none
chan puts -nonewline $f "abcdefghijklmno\r"
# here
lappend x [chan gets $f line] $line [testchannel queuedcr $f]
chan puts -nonewline $f "\x1a"
|
| ︙ | ︙ | |||
1339 1340 1341 1342 1343 1344 1345 |
# here
chan read $f
} -cleanup {
chan close $f
} -result {abcdefghijklmnopqrstuvwxyz}
test chan-io-12.4 {ReadChars: split-up char} -setup {
variable x {}
| | | 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 |
# here
chan read $f
} -cleanup {
chan close $f
} -result {abcdefghijklmnopqrstuvwxyz}
test chan-io-12.4 {ReadChars: split-up char} -setup {
variable x {}
} -constraints {stdio testchannel fileevent} -body {
# (srcRead == 0)
set f [openpipe w+ $path(cat)]
chan configure $f -encoding binary -buffering none -buffersize 16
chan puts -nonewline $f "123456789012345\x96"
chan configure $f -encoding shiftjis -blocking 0
chan event $f read [namespace code {
lappend x [chan read $f] [testchannel inputbuffered $f]
|
| ︙ | ︙ | |||
1361 1362 1363 1364 1365 1366 1367 |
vwait [namespace which -variable x]
return $x
} -cleanup {
chan close $f
} -result [list "123456789012345" 1 "\u672c" 0]
test chan-io-12.5 {ReadChars: chan events on partial characters} -setup {
variable x {}
| | | 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 |
vwait [namespace which -variable x]
return $x
} -cleanup {
chan close $f
} -result [list "123456789012345" 1 "\u672c" 0]
test chan-io-12.5 {ReadChars: chan events on partial characters} -setup {
variable x {}
} -constraints {stdio fileevent} -body {
set path(test1) [makeFile {
chan configure stdout -encoding binary -buffering none
chan gets stdin; chan puts -nonewline "\xe7"
chan gets stdin; chan puts -nonewline "\x89"
chan gets stdin; chan puts -nonewline "\xa6"
} test1]
set f [openpipe r+ $path(test1)]
|
| ︙ | ︙ | |||
1454 1455 1456 1457 1458 1459 1460 |
chan read $f
} -cleanup {
chan close $f
} -result "abcd\ndef\nfgh"
test chan-io-13.6 {TranslateInputEOL: auto mode: saw cr in last segment} -setup {
variable x {}
variable y {}
| | | | 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 |
chan read $f
} -cleanup {
chan close $f
} -result "abcd\ndef\nfgh"
test chan-io-13.6 {TranslateInputEOL: auto mode: saw cr in last segment} -setup {
variable x {}
variable y {}
} -constraints {stdio testchannel fileevent} -body {
# (chanPtr->flags & INPUT_SAW_CR)
# This test may fail on slower machines.
set f [openpipe w+ $path(cat)]
chan configure $f -blocking 0 -buffering none -translation {auto lf}
chan event $f read [namespace code {
lappend x [chan read $f] [testchannel queuedcr $f]
}]
chan puts -nonewline $f "abcdefghj\r"
after 500 [namespace code {set y ok}]
vwait [namespace which -variable y]
chan puts -nonewline $f "\n01234"
after 500 [namespace code {set y ok}]
vwait [namespace which -variable y]
return $x
} -cleanup {
chan close $f
} -result [list "abcdefghj\n" 1 "01234" 0]
test chan-io-13.7 {TranslateInputEOL: auto mode: naked \r} -constraints testchannel -body {
# (src >= srcMax)
set f [open $path(test1) w]
chan configure $f -translation lf
chan puts -nonewline $f "abcd\r"
chan close $f
set f [open $path(test1)]
chan configure $f -translation auto
|
| ︙ | ︙ | |||
1573 1574 1575 1576 1577 1578 1579 |
lappend result [x eval {chan configure stdin -buffering}]
lappend result [x eval {chan configure stdout -buffering}]
lappend result [x eval {chan configure stderr -buffering}]
} -cleanup {
interp delete x
} -result {line line none}
set path(test3) [makeFile {} test3]
| | | 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 |
lappend result [x eval {chan configure stdin -buffering}]
lappend result [x eval {chan configure stdout -buffering}]
lappend result [x eval {chan configure stderr -buffering}]
} -cleanup {
interp delete x
} -result {line line none}
set path(test3) [makeFile {} test3]
test chan-io-14.3 {Tcl_SetStdChannel & Tcl_GetStdChannel} -constraints exec -body {
set f [open $path(test1) w]
chan puts -nonewline $f {
chan close stdin
chan close stdout
chan close stderr
set f [}
chan puts $f [list open $path(test1) r]]
|
| ︙ | ︙ | |||
1670 1671 1672 1673 1674 1675 1676 |
} -cleanup {
interp delete z
} -result {{} {} {can not find channel named "stderr"}}
set path(script) [makeFile {} script]
test chan-io-14.8 {reuse of stdio special channels} -setup {
file delete $path(script)
file delete $path(test1)
| | | 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 |
} -cleanup {
interp delete z
} -result {{} {} {can not find channel named "stderr"}}
set path(script) [makeFile {} script]
test chan-io-14.8 {reuse of stdio special channels} -setup {
file delete $path(script)
file delete $path(test1)
} -constraints stdio -body {
set f [open $path(script) w]
chan puts -nonewline $f {
chan close stderr
set f [}
chan puts $f [list open $path(test1) w]]
chan puts -nonewline $f {
chan puts stderr hello
|
| ︙ | ︙ | |||
1693 1694 1695 1696 1697 1698 1699 |
chan gets $f
} -cleanup {
chan close $f
} -result hello
test chan-io-14.9 {reuse of stdio special channels} -setup {
file delete $path(script)
file delete $path(test1)
| | | 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 |
chan gets $f
} -cleanup {
chan close $f
} -result hello
test chan-io-14.9 {reuse of stdio special channels} -setup {
file delete $path(script)
file delete $path(test1)
} -constraints {stdio fileevent} -body {
set f [open $path(script) w]
chan puts $f {
array set path [lindex $argv 0]
set f [open $path(test1) w]
chan puts $f hello
chan close $f
chan close stderr
|
| ︙ | ︙ | |||
1877 1878 1879 1880 1881 1882 1883 |
set f [open $path(test1) w+]
list [chan configure $f -eofchar] [chan configure $f -translation]
} -cleanup {
chan close $f
} -result {{{} {}} {auto lf}}
test chan-io-20.5 {Tcl_CreateChannel: install channel in empty slot} -setup {
set path(stdout) [makeFile {} stdout]
| | | 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 |
set f [open $path(test1) w+]
list [chan configure $f -eofchar] [chan configure $f -translation]
} -cleanup {
chan close $f
} -result {{{} {}} {auto lf}}
test chan-io-20.5 {Tcl_CreateChannel: install channel in empty slot} -setup {
set path(stdout) [makeFile {} stdout]
} -constraints {stdio knownMsvcBug} -body {
set f [open $path(script) w]
chan puts -nonewline $f {
chan close stdout
set f1 [}
chan puts $f [list open $path(stdout) w]]
chan puts $f {
chan configure $f1 -buffersize 777
|
| ︙ | ︙ | |||
1962 1963 1964 1965 1966 1967 1968 |
} -result {6 6 0 6}
test chan-io-26.1 {Tcl_GetChannelInstanceData} -body {
# "pid" command uses Tcl_GetChannelInstanceData
# Don't care what pid is (but must be a number), just want to exercise it.
set f [openpipe r << exit]
pid $f
| | | 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 |
} -result {6 6 0 6}
test chan-io-26.1 {Tcl_GetChannelInstanceData} -body {
# "pid" command uses Tcl_GetChannelInstanceData
# Don't care what pid is (but must be a number), just want to exercise it.
set f [openpipe r << exit]
pid $f
} -constraints stdio -cleanup {
chan close $f
} -match regexp -result {^\d+$}
# Test flushing. The functions tested here are FlushChannel.
test chan-io-27.1 {FlushChannel, no output buffered} -setup {
file delete $path(test1)
|
| ︙ | ︙ | |||
2037 2038 2039 2040 2041 2042 2043 |
lappend l [file size $path(test1)]
} -result {0 60 72}
set path(pipe) [makeFile {} pipe]
set path(output) [makeFile {} output]
test chan-io-27.6 {FlushChannel, async flushing, async chan close} -setup {
file delete $path(pipe)
file delete $path(output)
| | | 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 |
lappend l [file size $path(test1)]
} -result {0 60 72}
set path(pipe) [makeFile {} pipe]
set path(output) [makeFile {} output]
test chan-io-27.6 {FlushChannel, async flushing, async chan close} -setup {
file delete $path(pipe)
file delete $path(output)
} -constraints {stdio asyncPipeChan Close} -body {
set f [open $path(pipe) w]
chan puts $f "set f \[[list open $path(output) w]]"
chan puts $f {
chan configure $f -translation lf -buffering none -eofchar {}
while {![chan eof stdin]} {
after 20
chan puts -nonewline $f [chan read stdin 1024]
|
| ︙ | ︙ | |||
2107 2108 2109 2110 2111 2112 2113 |
chan gets $f
} -cleanup {
chan close $f
} -result abcdef
test chan-io-28.3 {Chan CloseChannel, not called before output queue is empty} -setup {
file delete $path(pipe)
file delete $path(output)
| | | 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 |
chan gets $f
} -cleanup {
chan close $f
} -result abcdef
test chan-io-28.3 {Chan CloseChannel, not called before output queue is empty} -setup {
file delete $path(pipe)
file delete $path(output)
} -constraints {stdio asyncPipeChan Close nonPortable} -body {
set f [open $path(pipe) w]
chan puts $f {
# Need to not have eof char appended on chan close, because the other
# side of the pipe already chan closed, so that writing would cause an
# error "invalid file".
chan configure stdout -eofchar {}
chan configure stderr -eofchar {}
|
| ︙ | ︙ | |||
2161 2162 2163 2164 2165 2166 2167 |
set x [list $consoleFileNames \
[lsort [list {*}$consoleFileNames $f]] \
$consoleFileNames]
expr {$l eq $x ? "ok" : "{$l} != {$x}"}
} -result ok
test chan-io-28.5 {Tcl_Chan Close vs standard handles} -setup {
file delete $path(script)
| | | 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 |
set x [list $consoleFileNames \
[lsort [list {*}$consoleFileNames $f]] \
$consoleFileNames]
expr {$l eq $x ? "ok" : "{$l} != {$x}"}
} -result ok
test chan-io-28.5 {Tcl_Chan Close vs standard handles} -setup {
file delete $path(script)
} -constraints {stdio unix testchannel} -body {
set f [open $path(script) w]
chan puts $f {
chan close stdin
chan puts [testchannel open]
}
chan close $f
set f [openpipe r $path(script)]
|
| ︙ | ︙ | |||
2378 2379 2380 2381 2382 2383 2384 |
chan close $f1
chan close $f2
file size $path(test1)
} -result 377
test chan-io-29.12 {Tcl_WriteChars on a pipe} -setup {
file delete $path(test1)
file delete $path(pipe)
| | | 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 |
chan close $f1
chan close $f2
file size $path(test1)
} -result 377
test chan-io-29.12 {Tcl_WriteChars on a pipe} -setup {
file delete $path(test1)
file delete $path(pipe)
} -constraints stdio -body {
set f1 [open $path(pipe) w]
chan puts $f1 "set f1 \[[list open $path(longfile) r]]"
chan puts $f1 {
for {set x 0} {$x < 10} {incr x} {
chan puts [chan gets $f1]
}
}
|
| ︙ | ︙ | |||
2405 2406 2407 2408 2409 2410 2411 |
} -cleanup {
chan close $f1
chan close $f2
} -result ok
test chan-io-29.13 {Tcl_WriteChars to a pipe, line buffered} -setup {
file delete $path(test1)
file delete $path(pipe)
| | | 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 |
} -cleanup {
chan close $f1
chan close $f2
} -result ok
test chan-io-29.13 {Tcl_WriteChars to a pipe, line buffered} -setup {
file delete $path(test1)
file delete $path(pipe)
} -constraints stdio -body {
set f1 [open $path(pipe) w]
chan puts $f1 {
chan puts [chan gets stdin]
chan puts [chan gets stdin]
}
chan close $f1
set y ok
|
| ︙ | ︙ | |||
2458 2459 2460 2461 2462 2463 2464 |
set fd [open $path(test1) r]
chan flush $fd
} -returnCodes error -cleanup {
catch {chan close $fd}
} -match glob -result {channel "*" wasn't opened for writing}
test chan-io-29.16 {Tcl_Flush on pipe opened only for reading} -setup {
set fd [openpipe r cat longfile]
| | | 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 |
set fd [open $path(test1) r]
chan flush $fd
} -returnCodes error -cleanup {
catch {chan close $fd}
} -match glob -result {channel "*" wasn't opened for writing}
test chan-io-29.16 {Tcl_Flush on pipe opened only for reading} -setup {
set fd [openpipe r cat longfile]
} -constraints stdio -body {
chan flush $fd
} -returnCodes error -cleanup {
catch {chan close $fd}
} -match glob -result {channel "*" wasn't opened for writing}
test chan-io-29.17 {Tcl_WriteChars buffers, then Tcl_Flush flushes} -setup {
file delete $path(test1)
} -body {
|
| ︙ | ︙ | |||
2534 2535 2536 2537 2538 2539 2540 |
}
lappend z [file size $path(test1)]
chan close $f1
lappend z [file size $path(test1)]
} -result {4096 12288 12600}
test chan-io-29.21 {Tcl_Flush to pipe} -setup {
file delete $path(pipe)
| | | | 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 |
}
lappend z [file size $path(test1)]
chan close $f1
lappend z [file size $path(test1)]
} -result {4096 12288 12600}
test chan-io-29.21 {Tcl_Flush to pipe} -setup {
file delete $path(pipe)
} -constraints stdio -body {
set f1 [open $path(pipe) w]
chan puts $f1 {set x [chan read stdin 6]}
chan puts $f1 {set cnt [string length $x]}
chan puts $f1 {chan puts "read $cnt characters"}
chan close $f1
set f1 [openpipe r+ $path(pipe)]
chan puts $f1 hello
chan flush $f1
chan gets $f1
} -cleanup {
catch {chan close $f1}
} -result "read 6 characters"
test chan-io-29.22 {Tcl_Flush called at other end of pipe} -setup {
file delete $path(pipe)
} -constraints stdio -body {
set f1 [open $path(pipe) w]
chan puts $f1 {
chan configure stdout -buffering full
chan puts hello
chan puts hello
chan flush stdout
chan gets stdin
|
| ︙ | ︙ | |||
2573 2574 2575 2576 2577 2578 2579 |
chan flush $f1
lappend x [chan gets $f1]
} -cleanup {
chan close $f1
} -result {hello hello bye}
test chan-io-29.23 {Tcl_Flush and line buffering at end of pipe} -setup {
file delete $path(pipe)
| | | 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 |
chan flush $f1
lappend x [chan gets $f1]
} -cleanup {
chan close $f1
} -result {hello hello bye}
test chan-io-29.23 {Tcl_Flush and line buffering at end of pipe} -setup {
file delete $path(pipe)
} -constraints stdio -body {
set f1 [open $path(pipe) w]
chan puts $f1 {
chan puts hello
chan puts hello
chan gets stdin
chan puts bye
}
|
| ︙ | ︙ | |||
2610 2611 2612 2613 2614 2615 2616 |
lappend x [chan read -nonewline $f2]
} -cleanup {
chan close $f2
chan close $f
} -result "{} {Line 1\nLine 2}"
test chan-io-29.25 {Implicit flush with Tcl_Flush to command pipelines} -setup {
file delete $path(test3)
| | | | | 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 |
lappend x [chan read -nonewline $f2]
} -cleanup {
chan close $f2
chan close $f
} -result "{} {Line 1\nLine 2}"
test chan-io-29.25 {Implicit flush with Tcl_Flush to command pipelines} -setup {
file delete $path(test3)
} -constraints {stdio fileevent} -body {
set f [openpipe w $path(cat) | [interpreter] $path(cat) > $path(test3)]
chan puts $f "Line 1"
chan puts $f "Line 2"
chan close $f
after 100
set f [open $path(test3) r]
chan read $f
} -cleanup {
chan close $f
} -result "Line 1\nLine 2\n"
test chan-io-29.26 {Tcl_Flush, Tcl_Write on bidirectional pipelines} -constraints {stdio unixExecs} -body {
set f [open "|[list cat -u]" r+]
chan puts $f "Line1"
chan flush $f
chan gets $f
} -cleanup {
chan close $f
} -result {Line1}
test chan-io-29.27 {Tcl_Flush on chan closed pipeline} -setup {
file delete $path(pipe)
set f [open $path(pipe) w]
chan puts $f {exit}
chan close $f
} -constraints stdio -body {
set f [openpipe r+ $path(pipe)]
chan gets $f
chan puts $f output
after 50
#
# The flush below will get a SIGPIPE. This is an expected part of the test
# and indicates that the test operates correctly. If you run this test
|
| ︙ | ︙ | |||
2687 2688 2689 2690 2691 2692 2693 |
chan puts $f hello\nthere\nand\nhere
chan close $f
file size $path(test1)
} -result 25
test chan-io-29.31 {Tcl_WriteChars, background flush} -setup {
file delete $path(pipe)
file delete $path(output)
| | | 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 |
chan puts $f hello\nthere\nand\nhere
chan close $f
file size $path(test1)
} -result 25
test chan-io-29.31 {Tcl_WriteChars, background flush} -setup {
file delete $path(pipe)
file delete $path(output)
} -constraints stdio -body {
set f [open $path(pipe) w]
chan puts $f "set f \[[list open $path(output) w]]"
chan puts $f {chan configure $f -translation lf}
set x [list while {![chan eof stdin]}]
set x "$x {"
chan puts $f $x
chan puts $f { chan puts -nonewline $f [chan read stdin 4096]}
|
| ︙ | ︙ | |||
2720 2721 2722 2723 2724 2725 2726 |
}
if {$counter == 1000} {
set result "file size only [file size $path(output)]"
} else {
set result ok
}
# allow a little time for the background process to chan close.
| | | | 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 |
}
if {$counter == 1000} {
set result "file size only [file size $path(output)]"
} else {
set result ok
}
# allow a little time for the background process to chan close.
# otherwise, the following test fails on the [file delete $path(output)]
# on Windows because a process still has the file open.
after 100 set v 1; vwait v
return $result
} -result ok
test chan-io-29.32 {Tcl_WriteChars, background flush to slow reader} -setup {
file delete $path(pipe)
file delete $path(output)
} -constraints {stdio asyncPipeChan Close} -body {
set f [open $path(pipe) w]
chan puts $f "set f \[[list open $path(output) w]]"
chan puts $f {chan configure $f -translation lf}
set x [list while {![chan eof stdin]}]
set x "$x \{"
chan puts $f $x
chan puts $f { after 20}
|
| ︙ | ︙ | |||
4001 4002 4003 4004 4005 4006 4007 |
if {$z != $l} {
set x "$z != $l"
}
set x
} ok
test chan-io-32.10 {Tcl_Read from a pipe} -setup {
file delete $path(pipe)
| | | | 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 |
if {$z != $l} {
set x "$z != $l"
}
set x
} ok
test chan-io-32.10 {Tcl_Read from a pipe} -setup {
file delete $path(pipe)
} -constraints stdio -body {
set f1 [open $path(pipe) w]
chan puts $f1 {chan puts [chan gets stdin]}
chan close $f1
set f1 [openpipe r+ $path(pipe)]
chan puts $f1 hello
chan flush $f1
chan read $f1
} -cleanup {
chan close $f1
} -result "hello\n"
test chan-io-32.11 {Tcl_Read from a pipe} -setup {
file delete $path(pipe)
set x ""
} -constraints stdio -body {
set f1 [open $path(pipe) w]
chan puts $f1 {chan puts [chan gets stdin]}
chan puts $f1 {chan puts [chan gets stdin]}
chan close $f1
set f1 [openpipe r+ $path(pipe)]
chan puts $f1 hello
chan flush $f1
|
| ︙ | ︙ | |||
4127 4128 4129 4130 4131 4132 4133 |
set z broken
}
chan close $f1
set z
} ok
test chan-io-33.3 {Tcl_Gets from pipe} -setup {
file delete $path(pipe)
| | | 4126 4127 4128 4129 4130 4131 4132 4133 4134 4135 4136 4137 4138 4139 4140 |
set z broken
}
chan close $f1
set z
} ok
test chan-io-33.3 {Tcl_Gets from pipe} -setup {
file delete $path(pipe)
} -constraints stdio -body {
set f1 [open $path(pipe) w]
chan puts $f1 {chan puts [chan gets stdin]}
chan close $f1
set f1 [openpipe r+ $path(pipe)]
chan puts $f1 hello
chan flush $f1
chan gets $f1
|
| ︙ | ︙ | |||
4337 4338 4339 4340 4341 4342 4343 |
chan seek $f1 0 current
list $c1 $r1 [chan tell $f1]
} -cleanup {
chan close $f1
} -result {44 rstuv 49}
test chan-io-34.8 {Tcl_Seek on pipes: not supported} -setup {
set pipe [openpipe]
| | | 4336 4337 4338 4339 4340 4341 4342 4343 4344 4345 4346 4347 4348 4349 4350 |
chan seek $f1 0 current
list $c1 $r1 [chan tell $f1]
} -cleanup {
chan close $f1
} -result {44 rstuv 49}
test chan-io-34.8 {Tcl_Seek on pipes: not supported} -setup {
set pipe [openpipe]
} -constraints stdio -body {
chan seek $pipe 0 current
} -returnCodes error -cleanup {
chan close $pipe
} -match glob -result {error during seek on "*": invalid argument}
test chan-io-34.9 {Tcl_Seek, testing buffered input flushing} -setup {
file delete $path(test3)
} -body {
|
| ︙ | ︙ | |||
4447 4448 4449 4450 4451 4452 4453 |
chan seek $f1 10 start
set c1 [chan tell $f1]
chan seek $f1 10 current
list $c1 [chan tell $f1]
} -cleanup {
chan close $f1
} -result {10 20}
| | | | 4446 4447 4448 4449 4450 4451 4452 4453 4454 4455 4456 4457 4458 4459 4460 4461 4462 4463 4464 4465 4466 |
chan seek $f1 10 start
set c1 [chan tell $f1]
chan seek $f1 10 current
list $c1 [chan tell $f1]
} -cleanup {
chan close $f1
} -result {10 20}
test chan-io-34.16 {Tcl_Tell on pipe: always -1} -constraints stdio -body {
set f1 [openpipe]
chan tell $f1
} -cleanup {
chan close $f1
} -result -1
test chan-io-34.17 {Tcl_Tell on pipe: always -1} stdio {
set f1 [openpipe]
chan puts $f1 {chan puts hello}
chan flush $f1
set c [chan tell $f1]
chan gets $f1
chan close $f1
set c
|
| ︙ | ︙ | |||
4555 4556 4557 4558 4559 4560 4561 |
lappend x [chan eof $f]
chan gets $f
lappend x [chan eof $f]
lappend x [chan eof $f]
} -cleanup {
chan close $f
} -result {0 0 0 0 1 1}
| | | | 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 |
lappend x [chan eof $f]
chan gets $f
lappend x [chan eof $f]
lappend x [chan eof $f]
} -cleanup {
chan close $f
} -result {0 0 0 0 1 1}
test chan-io-35.2 {Tcl_Eof with pipe} -constraints stdio -setup {
file delete $path(pipe)
} -body {
set f1 [open $path(pipe) w]
chan puts $f1 {chan gets stdin}
chan puts $f1 {chan puts hello}
chan close $f1
set f1 [openpipe r+ $path(pipe)]
chan puts $f1 hello
set x [chan eof $f1]
chan flush $f1
lappend x [chan eof $f1]
chan gets $f1
lappend x [chan eof $f1]
chan gets $f1
lappend x [chan eof $f1]
} -cleanup {
chan close $f1
} -result {0 0 0 1}
test chan-io-35.3 {Tcl_Eof with pipe} -constraints stdio -setup {
file delete $path(pipe)
} -body {
set f1 [open $path(pipe) w]
chan puts $f1 {chan gets stdin}
chan puts $f1 {chan puts hello}
chan close $f1
set f1 [openpipe r+ $path(pipe)]
|
| ︙ | ︙ | |||
4612 4613 4614 4615 4616 4617 4618 |
lappend l [chan eof $f]
} -cleanup {
chan close $f
} -result {{} 1}
test chan-io-35.5 {Tcl_Eof, eof detection on nonblocking pipe} -setup {
file delete $path(pipe)
set l ""
| | | 4611 4612 4613 4614 4615 4616 4617 4618 4619 4620 4621 4622 4623 4624 4625 |
lappend l [chan eof $f]
} -cleanup {
chan close $f
} -result {{} 1}
test chan-io-35.5 {Tcl_Eof, eof detection on nonblocking pipe} -setup {
file delete $path(pipe)
set l ""
} -constraints stdio -body {
set f [open $path(pipe) w]
chan puts $f {
exit
}
chan close $f
set f [openpipe r $path(pipe)]
lappend l [chan gets $f]
|
| ︙ | ︙ | |||
4797 4798 4799 4800 4801 4802 4803 |
chan close $f
} -result {21 8 1}
# Test Tcl_InputBlocked
test chan-io-36.1 {Tcl_InputBlocked on nonblocking pipe} -setup {
set x ""
| | | | 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 |
chan close $f
} -result {21 8 1}
# Test Tcl_InputBlocked
test chan-io-36.1 {Tcl_InputBlocked on nonblocking pipe} -setup {
set x ""
} -constraints stdio -body {
set f1 [openpipe]
chan puts $f1 {chan puts hello_from_pipe}
chan flush $f1
chan gets $f1
chan configure $f1 -blocking off -buffering full
chan puts $f1 {chan puts hello}
lappend x [chan gets $f1]
lappend x [chan blocked $f1]
chan flush $f1
after 200
lappend x [chan gets $f1]
lappend x [chan blocked $f1]
lappend x [chan gets $f1]
lappend x [chan blocked $f1]
} -cleanup {
chan close $f1
} -result {{} 1 hello 0 {} 1}
test chan-io-36.2 {Tcl_InputBlocked on blocking pipe} -setup {
set x ""
} -constraints stdio -body {
set f1 [openpipe]
chan configure $f1 -buffering line
chan puts $f1 {chan puts hello_from_pipe}
lappend x [chan gets $f1]
lappend x [chan blocked $f1]
chan puts $f1 {exit}
lappend x [chan gets $f1]
|
| ︙ | ︙ | |||
5091 5092 5093 5094 5095 5096 5097 |
lappend x [chan eof $f1]
} -cleanup {
chan close $f1
} -result {1 0 {} {} 0 1}
test chan-io-39.10 {Tcl_SetChannelOption, blocking mode} -setup {
file delete $path(pipe)
set x ""
| | | 5090 5091 5092 5093 5094 5095 5096 5097 5098 5099 5100 5101 5102 5103 5104 |
lappend x [chan eof $f1]
} -cleanup {
chan close $f1
} -result {1 0 {} {} 0 1}
test chan-io-39.10 {Tcl_SetChannelOption, blocking mode} -setup {
file delete $path(pipe)
set x ""
} -constraints stdio -body {
set f1 [open $path(pipe) w]
chan puts $f1 {
chan gets stdin
after 100
chan puts hi
chan gets stdin
}
|
| ︙ | ︙ | |||
5188 5189 5190 5191 5192 5193 5194 |
} -body {
chan configure $f -encoding foobar
} -returnCodes error -cleanup {
chan close $f
} -result {unknown encoding "foobar"}
test chan-io-39.17 {Tcl_SetChannelOption: -encoding, clearing CHANNEL_NEED_MORE_DATA} -setup {
variable x {}
| | | 5187 5188 5189 5190 5191 5192 5193 5194 5195 5196 5197 5198 5199 5200 5201 |
} -body {
chan configure $f -encoding foobar
} -returnCodes error -cleanup {
chan close $f
} -result {unknown encoding "foobar"}
test chan-io-39.17 {Tcl_SetChannelOption: -encoding, clearing CHANNEL_NEED_MORE_DATA} -setup {
variable x {}
} -constraints {stdio fileevent} -body {
set f [openpipe r+ $path(cat)]
chan configure $f -encoding binary
chan puts -nonewline $f "\xe7"
chan flush $f
chan configure $f -encoding utf-8 -blocking 0
chan event $f readable [namespace code { lappend x [chan read $f] }]
vwait [namespace which -variable x]
|
| ︙ | ︙ | |||
5548 5549 5550 5551 5552 5553 5554 |
chan event $f writable {}
lappend result [chan event $f readable] [chan event $f writable]
} {{script 1} {} {script 1} {write script} {} {write script} {} {}}
test chan-io-43.2 {Tcl_FileeventCmd: deleting when many present} -setup {
set f2 [open "|[list cat -u]" r+]
set f3 [open "|[list cat -u]" r+]
set result {}
| | | | | | 5547 5548 5549 5550 5551 5552 5553 5554 5555 5556 5557 5558 5559 5560 5561 5562 5563 5564 5565 5566 5567 5568 5569 5570 5571 5572 5573 5574 5575 5576 5577 5578 5579 5580 5581 5582 5583 5584 5585 5586 5587 5588 5589 5590 5591 5592 5593 5594 5595 5596 5597 5598 5599 5600 5601 5602 5603 5604 5605 5606 5607 5608 5609 5610 5611 5612 5613 5614 5615 |
chan event $f writable {}
lappend result [chan event $f readable] [chan event $f writable]
} {{script 1} {} {script 1} {write script} {} {write script} {} {}}
test chan-io-43.2 {Tcl_FileeventCmd: deleting when many present} -setup {
set f2 [open "|[list cat -u]" r+]
set f3 [open "|[list cat -u]" r+]
set result {}
} -constraints {stdio unixExecs fileevent} -body {
lappend result [chan event $f r] [chan event $f2 r] [chan event $f3 r]
chan event $f r "chan read f"
chan event $f2 r "chan read f2"
chan event $f3 r "chan read f3"
lappend result [chan event $f r] [chan event $f2 r] [chan event $f3 r]
chan event $f2 r {}
lappend result [chan event $f r] [chan event $f2 r] [chan event $f3 r]
chan event $f3 r {}
lappend result [chan event $f r] [chan event $f2 r] [chan event $f3 r]
chan event $f r {}
lappend result [chan event $f r] [chan event $f2 r] [chan event $f3 r]
} -cleanup {
catch {chan close $f2}
catch {chan close $f3}
} -result {{} {} {} {chan read f} {chan read f2} {chan read f3} {chan read f} {} {chan read f3} {chan read f} {} {} {} {} {}}
test chan-io-44.1 {FileEventProc procedure: normal read event} -setup {
set f2 [open "|[list cat -u]" r+]
set f3 [open "|[list cat -u]" r+]
} -constraints {stdio unixExecs fileevent} -body {
chan event $f2 readable [namespace code {
set x [chan gets $f2]; chan event $f2 readable {}
}]
chan puts $f2 text; chan flush $f2
variable x initial
vwait [namespace which -variable x]
return $x
} -cleanup {
catch {chan close $f2}
catch {chan close $f3}
} -result {text}
test chan-io-44.2 {FileEventProc procedure: error in read event} -setup {
set f2 [open "|[list cat -u]" r+]
set f3 [open "|[list cat -u]" r+]
proc myHandler {msg options} {
variable x $msg
}
set handler [interp bgerror {}]
interp bgerror {} [namespace which myHandler]
} -constraints {stdio unixExecs fileevent} -body {
chan event $f2 readable {error bogus}
chan puts $f2 text; chan flush $f2
variable x initial
vwait [namespace which -variable x]
list $x [chan event $f2 readable]
} -cleanup {
interp bgerror {} $handler
catch {chan close $f2}
catch {chan close $f3}
} -result {bogus {}}
test chan-io-44.3 {FileEventProc procedure: normal write event} -setup {
set f2 [open "|[list cat -u]" r+]
set f3 [open "|[list cat -u]" r+]
} -constraints {stdio unixExecs fileevent} -body {
chan event $f2 writable [namespace code {
lappend x "triggered"
incr count -1
if {$count <= 0} {
chan event $f2 writable {}
}
}]
|
| ︙ | ︙ | |||
5628 5629 5630 5631 5632 5633 5634 |
set f2 [open "|[list cat -u]" r+]
set f3 [open "|[list cat -u]" r+]
proc myHandler {msg options} {
variable x $msg
}
set handler [interp bgerror {}]
interp bgerror {} [namespace which myHandler]
| | | > > < > > | | 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 |
set f2 [open "|[list cat -u]" r+]
set f3 [open "|[list cat -u]" r+]
proc myHandler {msg options} {
variable x $msg
}
set handler [interp bgerror {}]
interp bgerror {} [namespace which myHandler]
} -constraints {stdio unixExecs fileevent} -body {
chan event $f2 writable {error bad-write}
variable x initial
vwait [namespace which -variable x]
list $x [chan event $f2 writable]
} -cleanup {
interp bgerror {} $handler
catch {chan close $f2}
catch {chan close $f3}
} -result {bad-write {}}
test chan-io-44.5 {FileEventProc procedure: end of file} -constraints {
stdio unixExecs fileevent
} -body {
set f4 [openpipe r $path(cat) << foo]
chan event $f4 readable [namespace code {
if {[chan gets $f4 line] < 0} {
lappend x eof
chan event $f4 readable {}
} else {
lappend x $line
}
}]
variable x initial
vwait [namespace which -variable x]
vwait [namespace which -variable x]
set x
} -cleanup {
chan close $f4
} -result {initial foo eof}
chan close $f
makeFile "foo bar" foo
test chan-io-45.1 {DeleteFileEvent, cleanup on chan close} {fileevent} {
set f [open $path(foo) r]
chan event $f readable [namespace code {
|
| ︙ | ︙ | |||
5724 5725 5726 5727 5728 5729 5730 5731 |
append script {
set x "no event"
chan event $f readable [namespace code {
set x "f triggered: [chan gets $f]"
chan event $f readable {}
}]
}
testfevent cmd $script
| > < | > | 5726 5727 5728 5729 5730 5731 5732 5733 5734 5735 5736 5737 5738 5739 5740 5741 5742 5743 |
append script {
set x "no event"
chan event $f readable [namespace code {
set x "f triggered: [chan gets $f]"
chan event $f readable {}
}]
}
set timer [after 10 lappend x timeout]
testfevent cmd $script
vwait x
after cancel $timer
testfevent cmd {chan close $f}
list [testfevent cmd {set x}] [testfevent cmd {info commands after}]
} {{f triggered: foo bar} after}
test chan-io-46.2 {Tcl event loop vs multiple interpreters} testfevent {
testfevent create
testfevent cmd {
variable x 0
|
| ︙ | ︙ | |||
5914 5915 5916 5917 5918 5919 5920 |
variable x not_done
vwait [namespace which -variable x]
list $x $l
} {done {called called called called called called called}}
set path(my_script) [makeFile {} my_script]
test chan-io-48.3 {testing readability conditions} -setup {
set l ""
| | | 5917 5918 5919 5920 5921 5922 5923 5924 5925 5926 5927 5928 5929 5930 5931 |
variable x not_done
vwait [namespace which -variable x]
list $x $l
} {done {called called called called called called called}}
set path(my_script) [makeFile {} my_script]
test chan-io-48.3 {testing readability conditions} -setup {
set l ""
} -constraints {stdio unix nonBlockFiles fileevent} -body {
set f [open $path(bar) w]
chan puts $f abcdefg
chan puts $f abcdefg
chan puts $f abcdefg
chan puts $f abcdefg
chan puts $f abcdefg
chan close $f
|
| ︙ | ︙ | |||
6368 6369 6370 6371 6372 6373 6374 |
lappend l [chan eof $f]
} -cleanup {
chan close $f
} -result [list 7 a\rb\rc 7 {} 7 1]
test chan-io-50.1 {testing handler deletion} -setup {
file delete $path(test1)
| | | | < < < > > | > > > > > > < | < < < > > | > > > > > > | > | > | > > | < < < > > | > > > | > > > > > > | > | < < < > > | > > | 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 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 |
lappend l [chan eof $f]
} -cleanup {
chan close $f
} -result [list 7 a\rb\rc 7 {} 7 1]
test chan-io-50.1 {testing handler deletion} -setup {
file delete $path(test1)
} -constraints testchannelevent -body {
set f [open $path(test1) w]
chan close $f
set f [open $path(test1) r]
testchannelevent $f add readable [namespace code {
variable z called
testchannelevent $f delete 0
}]
variable z not_called
update
set z
} -cleanup {
chan close $f
} -result called
test chan-io-50.2 {testing handler deletion with multiple handlers} -setup {
file delete $path(test1)
chan close [open $path(test1) w]
set z ""
} -constraints {testchannelevent testservicemode} -body {
proc delhandler {f i} {
variable z
lappend z "called delhandler $f $i"
testchannelevent $f delete 0
}
set z ""
set timer [after 50 lappend z timeout]
testservicemode 0
set f [open $path(test1) r]
testchannelevent $f add readable [namespace code [list delhandler $f 1]]
testchannelevent $f add readable [namespace code [list delhandler $f 0]]
testservicemode 1
vwait z
after cancel $timer
string equal $z \
[list [list called delhandler $f 0] [list called delhandler $f 1]]
} -cleanup {
chan close $f
} -result 1
test chan-io-50.3 {testing handler deletion with multiple handlers} -setup {
file delete $path(test1)
chan close [open $path(test1) w]
} -constraints {testchannelevent testservicemode} -body {
proc notcalled {f i} {
variable z
lappend z "notcalled was called!! $f $i"
}
proc delhandler {f i} {
variable z
testchannelevent $f delete 1
lappend z "delhandler $f $i called"
testchannelevent $f delete 0
lappend z "delhandler $f $i deleted myself"
}
set z ""
set timer [after 50 lappend z timeout]
testservicemode 0
set f [open $path(test1) r]
testchannelevent $f add readable [namespace code [list notcalled $f 1]]
testchannelevent $f add readable [namespace code [list delhandler $f 0]]
testservicemode 1
vwait z
after cancel $timer
string equal $z \
[list [list delhandler $f 0 called] \
[list delhandler $f 0 deleted myself]]
} -cleanup {
chan close $f
} -result 1
test chan-io-50.4 {testing handler deletion vs reentrant calls} -setup {
file delete $path(test1)
set f [open $path(test1) w]
chan close $f
} -constraints testchannelevent -body {
set f [open $path(test1) r]
testchannelevent $f add readable [namespace code {
if {$u eq "recursive"} {
testchannelevent $f delete 0
lappend z "delrecursive deleting recursive"
} else {
lappend z "delrecursive calling recursive"
set u recursive
update
}
}]
variable u toplevel
variable z ""
set timer [after 50 lappend z timeout]
vwait z
after cancel $timer
set z
} -cleanup {
chan close $f
update
} -result {{delrecursive calling recursive} {delrecursive deleting recursive}}
test chan-io-50.5 {testing handler deletion vs reentrant calls} -setup {
file delete $path(test1)
set f [open $path(test1) w]
chan close $f
update
} -constraints {testchannelevent testservicemode} -body {
proc notcalled {f} {
variable z
lappend z "notcalled was called!! $f"
}
proc del {f} {
variable u
variable z
if {$u eq "recursive"} {
testchannelevent $f delete 1
testchannelevent $f delete 0
lappend z "del deleted notcalled"
lappend z "del deleted myself"
} else {
set u recursive
lappend z "del calling recursive"
set timer [after 50 lappend z timeout]
set mode [test servicemode 1]
vwait z
after cancel $timer
test servicemode $mode
lappend z "del after update"
}
}
set z ""
set u toplevel
set timer [after 50 lappend z timeout]
testservicemode 0
set f [open $path(test1) r]
testchannelevent $f add readable [namespace code [list notcalled $f]]
testchannelevent $f add readable [namespace code [list del $f]]
testservicemode 1
vwait z
after cancel $timer
set z
} -cleanup {
chan close $f
update
} -result [list {del calling recursive} {del deleted notcalled} \
{del deleted myself} {del after update}]
test chan-io-50.6 {testing handler deletion vs reentrant calls} -setup {
file delete $path(test1)
set f [open $path(test1) w]
chan close $f
} -constraints {testchannelevent testservicemode} -body {
proc first {f} {
variable u
variable z
if {$u eq "toplevel"} {
lappend z "first called"
set mode [testservicemode 1]
set timer [after 50 lappend z timeout]
set u first
vwait z
after cancel $timer
testservicemode $mode
lappend z "first after update"
} else {
lappend z "first called not toplevel"
}
}
proc second {f} {
variable u
|
| ︙ | ︙ | |||
6522 6523 6524 6525 6526 6527 6528 |
} else {
lappend z "second called, cannot happen!"
testchannelevent $f removeall
}
}
set z ""
set u toplevel
| > | > > > > > > | | 6548 6549 6550 6551 6552 6553 6554 6555 6556 6557 6558 6559 6560 6561 6562 6563 6564 6565 6566 6567 6568 6569 6570 |
} else {
lappend z "second called, cannot happen!"
testchannelevent $f removeall
}
}
set z ""
set u toplevel
set timer [after 50 lappend z timeout]
testservicemode 0
set f [open $path(test1) r]
testchannelevent $f add readable [namespace code [list second $f]]
testchannelevent $f add readable [namespace code [list first $f]]
testservicemode 1
vwait z
after cancel $timer
set z
} -cleanup {
chan close $f
} -result [list {first called} {first called not toplevel} \
{second called, first time} {second called, second time} \
{first after update}]
test chan-io-51.1 {Test old socket deletion on Macintosh} -setup {
|
| ︙ | ︙ | |||
6705 6706 6707 6708 6709 6710 6711 |
} -cleanup {
chan close $f1
chan close $f2
} -result {0 0 ok}
test chan-io-52.8 {TclCopyChannel} -setup {
file delete $path(test1)
file delete $path(pipe)
| | | 6738 6739 6740 6741 6742 6743 6744 6745 6746 6747 6748 6749 6750 6751 6752 |
} -cleanup {
chan close $f1
chan close $f2
} -result {0 0 ok}
test chan-io-52.8 {TclCopyChannel} -setup {
file delete $path(test1)
file delete $path(pipe)
} -constraints {stdio fcopy} -body {
set f1 [open $path(pipe) w]
chan configure $f1 -translation lf
chan puts $f1 "
chan puts ready
chan gets stdin
set f1 \[open [list $thisScript] r\]
chan configure \$f1 -translation lf
|
| ︙ | ︙ | |||
6826 6827 6828 6829 6830 6831 6832 |
lappend result ok
}
return $result
} -result {0 0 ok}
test chan-io-53.3 {CopyData: background read underflow} -setup {
file delete $path(test1)
file delete $path(pipe)
| | | 6859 6860 6861 6862 6863 6864 6865 6866 6867 6868 6869 6870 6871 6872 6873 |
lappend result ok
}
return $result
} -result {0 0 ok}
test chan-io-53.3 {CopyData: background read underflow} -setup {
file delete $path(test1)
file delete $path(pipe)
} -constraints {stdio unix fcopy} -body {
set f1 [open $path(pipe) w]
chan puts -nonewline $f1 {
chan puts ready
chan flush stdout ;# Don't assume line buffered!
chan copy stdin stdout -command { set x }
vwait x
set f [}
|
| ︙ | ︙ | |||
6864 6865 6866 6867 6868 6869 6870 |
set big bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb\n
variable x
for {set x 0} {$x < 12} {incr x} {
append big $big
}
file delete $path(test1)
file delete $path(pipe)
| | | 6897 6898 6899 6900 6901 6902 6903 6904 6905 6906 6907 6908 6909 6910 6911 |
set big bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb\n
variable x
for {set x 0} {$x < 12} {incr x} {
append big $big
}
file delete $path(test1)
file delete $path(pipe)
} -constraints {stdio unix fileevent fcopy} -body {
set f1 [open $path(pipe) w]
chan puts $f1 {
chan puts ready
chan copy stdin stdout -command { set x }
vwait x
set f [open $path(test1) w]
chan configure $f -translation lf
|
| ︙ | ︙ | |||
6928 6929 6930 6931 6932 6933 6934 |
set fcopyTestDone ;# 1 for error condition
} 1
test chan-io-53.6 {CopyData: error during chan copy} -setup {
variable fcopyTestDone
file delete $path(pipe)
file delete $path(test1)
catch {unset fcopyTestDone}
| | | 6961 6962 6963 6964 6965 6966 6967 6968 6969 6970 6971 6972 6973 6974 6975 |
set fcopyTestDone ;# 1 for error condition
} 1
test chan-io-53.6 {CopyData: error during chan copy} -setup {
variable fcopyTestDone
file delete $path(pipe)
file delete $path(test1)
catch {unset fcopyTestDone}
} -constraints {stdio fcopy} -body {
set f1 [open $path(pipe) w]
chan puts $f1 "exit 1"
chan close $f1
set in [openpipe r+ $path(pipe)]
set out [open $path(test1) w]
chan copy $in $out -command [namespace code FcopyTestDone]
variable fcopyTestDone
|
| ︙ | ︙ | |||
6962 6963 6964 6965 6966 6967 6968 |
-command [namespace code [list doFcopy $in $out]]]
}
}
test chan-io-53.7 {CopyData: Flooding chan copy from pipe} -setup {
variable fcopyTestDone
file delete $path(pipe)
catch {unset fcopyTestDone}
| | | 6995 6996 6997 6998 6999 7000 7001 7002 7003 7004 7005 7006 7007 7008 7009 |
-command [namespace code [list doFcopy $in $out]]]
}
}
test chan-io-53.7 {CopyData: Flooding chan copy from pipe} -setup {
variable fcopyTestDone
file delete $path(pipe)
catch {unset fcopyTestDone}
} -constraints {stdio fcopy} -body {
set fcopyTestCount 0
set f1 [open $path(pipe) w]
chan puts $f1 {
# Write 10 bytes / 10 msec
proc Write {count} {
chan puts -nonewline "1234567890"
if {[incr count -1]} {
|
| ︙ | ︙ | |||
7012 7013 7014 7015 7016 7017 7018 |
}
# Files we use for our channels
set foo [makeFile ashgdfashdgfasdhgfasdhgf foo]
set bar [makeFile {} bar]
# Channels to copy between
set f [open $foo r] ; fconfigure $f -translation binary
set g [open $bar w] ; fconfigure $g -translation binary -buffering none
| | | 7045 7046 7047 7048 7049 7050 7051 7052 7053 7054 7055 7056 7057 7058 7059 |
}
# Files we use for our channels
set foo [makeFile ashgdfashdgfasdhgfasdhgf foo]
set bar [makeFile {} bar]
# Channels to copy between
set f [open $foo r] ; fconfigure $f -translation binary
set g [open $bar w] ; fconfigure $g -translation binary -buffering none
} -constraints {stdio fcopy} -body {
# Record input size, so that result is always defined
lappend ::RES [file size $bar]
# Run the copy. Should not invoke -command now.
chan copy $f $g -size 2 -command [namespace code cmd]
# Check that -command was not called synchronously
set sbs [file size $bar]
lappend ::RES [expr {($sbs > 0) ? "sync/FAIL" : "sync/OK"}] $sbs
|
| ︙ | ︙ | |||
7052 7053 7054 7055 7056 7057 7058 |
}
# Files we use for our channels
set foo [makeFile ashgdfashdgfasdhgfasdhgf foo]
set bar [makeFile {} bar]
# Channels to copy between
set f [open $foo r] ; chan configure $f -translation binary
set g [open $bar w] ; chan configure $g -translation binary -buffering none
| | | 7085 7086 7087 7088 7089 7090 7091 7092 7093 7094 7095 7096 7097 7098 7099 |
}
# Files we use for our channels
set foo [makeFile ashgdfashdgfasdhgfasdhgf foo]
set bar [makeFile {} bar]
# Channels to copy between
set f [open $foo r] ; chan configure $f -translation binary
set g [open $bar w] ; chan configure $g -translation binary -buffering none
} -constraints {stdio fcopy} -body {
# Initialize and force eof on the input.
chan seek $f 0 end ; chan read $f 1
set ::RES [chan eof $f]
# Run the copy. Should not invoke -command now.
chan copy $f $g -size 2 -command [namespace code cmd]
# Check that -command was not called synchronously
lappend ::RES [expr {([llength $::RES] > 1) ? "sync/FAIL" : "sync/OK"}]
|
| ︙ | ︙ | |||
7110 7111 7112 7113 7114 7115 7116 |
}
proc ::done args {
set ::forever OK
return
}
set ::forever {}
set out [open $out w]
| | | 7143 7144 7145 7146 7147 7148 7149 7150 7151 7152 7153 7154 7155 7156 7157 |
}
proc ::done args {
set ::forever OK
return
}
set ::forever {}
set out [open $out w]
} -constraints {stdio fcopy} -body {
chan copy $pipe $out -size 6 -command ::done
set token [after 5000 {
set ::forever {fcopy hangs}
}]
vwait ::forever
catch {after cancel $token}
set ::forever
|
| ︙ | ︙ | |||
7183 7184 7185 7186 7187 7188 7189 |
}
set a [socket 127.0.0.1 9999]
set b [socket 127.0.0.1 9999]
chan configure $a -translation binary -buffering none
chan configure $b -translation binary -buffering none
chan event $a readable [namespace code "done $a"]
chan event $b readable [namespace code "done $b"]
| | | 7216 7217 7218 7219 7220 7221 7222 7223 7224 7225 7226 7227 7228 7229 7230 |
}
set a [socket 127.0.0.1 9999]
set b [socket 127.0.0.1 9999]
chan configure $a -translation binary -buffering none
chan configure $b -translation binary -buffering none
chan event $a readable [namespace code "done $a"]
chan event $b readable [namespace code "done $b"]
} -constraints {stdio fcopy} -body {
# Now pass data through the server in both directions.
set ::forever {}
chan puts $a AB
vwait ::forever
chan puts $b BA
vwait ::forever
set ::forever
|
| ︙ | ︙ | |||
7405 7406 7407 7408 7409 7410 7411 |
set result
} -cleanup {
chan close $s
chan close $s2
chan close $server
} -result {1 readable 234567890 timer}
| | | 7438 7439 7440 7441 7442 7443 7444 7445 7446 7447 7448 7449 7450 7451 7452 |
set result
} -cleanup {
chan close $s
chan close $s2
chan close $server
} -result {1 readable 234567890 timer}
test chan-io-58.1 {Tcl_NotifyChannel and error when closing} {stdio unixOrWin fileevent} {
set out [open $path(script) w]
chan puts $out {
chan puts "normal message from pipe"
chan puts stderr "error message from pipe"
exit 1
}
proc readit {pipe} {
|
| ︙ | ︙ | |||
7443 7444 7445 7446 7447 7448 7449 |
# fully implements the moving of channels between threads, i.e. 'Threads'.
set f [open $path(longfile) r]
set result [testchannel mthread $f]
chan close $f
string equal $result [testmainthread]
} {1}
| | | 7476 7477 7478 7479 7480 7481 7482 7483 7484 7485 7486 7487 7488 7489 7490 |
# fully implements the moving of channels between threads, i.e. 'Threads'.
set f [open $path(longfile) r]
set result [testchannel mthread $f]
chan close $f
string equal $result [testmainthread]
} {1}
test chan-io-60.1 {writing illegal utf sequences} {fileevent testbytestring} {
# This test will hang in older revisions of the core.
set out [open $path(script) w]
chan puts $out "catch {load $::tcltestlib Tcltest}"
chan puts $out {
chan puts [testbytestring \xe2]
exit 1
}
|
| ︙ | ︙ |
Changes to tests/clock.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # clock.test -- # # This test file covers the 'clock' command that manipulates time. # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 2004 by Kevin B. Kenny. All rights reserved. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
# clock.test --
#
# This test file covers the 'clock' command that manipulates time.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 2004 by Kevin B. Kenny. All rights reserved.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2
namespace import -force ::tcltest::*
}
if {[testConstraint win]} {
if {[catch {
::tcltest::loadTestedCommands
|
| ︙ | ︙ | |||
245 246 247 248 249 250 251 |
return -code error "test case attempts to write/query the registry"
}
if { ![dict exists $reg $path $key] } {
return -code error "test case attempts to read unknown registry entry $path $key"
}
return [dict get $reg $path $key]
}
| < | 245 246 247 248 249 250 251 252 253 254 255 256 257 258 |
return -code error "test case attempts to write/query the registry"
}
if { ![dict exists $reg $path $key] } {
return -code error "test case attempts to read unknown registry entry $path $key"
}
return [dict get $reg $path $key]
}
# Test some of the basics of [clock format]
test clock-1.0 "clock format - wrong # args" {
list [catch {clock format} msg] $msg $::errorCode
} {1 {wrong # args: should be "clock format clockval ?-format string? ?-gmt boolean? ?-locale LOCALE? ?-timezone ZONE?"} {CLOCK wrongNumArgs}}
|
| ︙ | ︙ | |||
35021 35022 35023 35024 35025 35026 35027 35028 35029 35030 35031 35032 35033 35034 |
set f4 [clock add $t -4 month -timezone :UTC]
set x1 [clock format $f1 -format %Y-%m-%d -timezone :UTC]
set x2 [clock format $f2 -format %Y-%m-%d -timezone :UTC]
set x3 [clock format $f3 -format %Y-%m-%d -timezone :UTC]
set x4 [clock format $f4 -format %Y-%m-%d -timezone :UTC]
list $x1 $x2 $x3 $x4
} {2000-02-29 2000-01-31 1999-12-31 1999-11-30}
test clock-30.9 {clock add days} {
set t [clock scan {2000-01-01 12:34:56} -format {%Y-%m-%d %H:%M:%S} \
-timezone :UTC]
set f1 [clock add $t 1 day -timezone :UTC]
set f2 [clock add $t -1 day -timezone :UTC]
set x1 [clock format $f1 -format {%Y-%m-%d %H:%M:%S} -timezone :UTC]
set x2 [clock format $f2 -format {%Y-%m-%d %H:%M:%S} -timezone :UTC]
| > > > > > > > > > > > > > > > > > > | 35020 35021 35022 35023 35024 35025 35026 35027 35028 35029 35030 35031 35032 35033 35034 35035 35036 35037 35038 35039 35040 35041 35042 35043 35044 35045 35046 35047 35048 35049 35050 35051 |
set f4 [clock add $t -4 month -timezone :UTC]
set x1 [clock format $f1 -format %Y-%m-%d -timezone :UTC]
set x2 [clock format $f2 -format %Y-%m-%d -timezone :UTC]
set x3 [clock format $f3 -format %Y-%m-%d -timezone :UTC]
set x4 [clock format $f4 -format %Y-%m-%d -timezone :UTC]
list $x1 $x2 $x3 $x4
} {2000-02-29 2000-01-31 1999-12-31 1999-11-30}
test clock-30.8a {clock add months, negative, over threshold of a year} {
set t [clock scan 2019-01-31 -format %Y-%m-%d -gmt 1]
list [clock format [clock add $t -1 month -gmt 1] -format %Y-%m-%d -gmt 1] \
[clock format [clock add $t -2 month -gmt 1] -format %Y-%m-%d -gmt 1] \
[clock format [clock add $t -3 month -gmt 1] -format %Y-%m-%d -gmt 1] \
[clock format [clock add $t -4 month -gmt 1] -format %Y-%m-%d -gmt 1]
} {2018-12-31 2018-11-30 2018-10-31 2018-09-30}
test clock-30.8b {clock add months, negative, over threshold of a year} {
set t [clock scan 2000-01-28 -format %Y-%m-%d -gmt 1]
for {set i 1} {$i < 24} {incr i 1} {
set f1 [clock add $t -$i month -gmt 1]
set f2 [clock add $f1 $i month -gmt 1]
if {$f2 != $t} {
error "\[clock add $t -$i month -gmt 1\] does not consider\
\[clock add $f1 $i month -gmt 1\] != $t"
}
}
} {}
test clock-30.9 {clock add days} {
set t [clock scan {2000-01-01 12:34:56} -format {%Y-%m-%d %H:%M:%S} \
-timezone :UTC]
set f1 [clock add $t 1 day -timezone :UTC]
set f2 [clock add $t -1 day -timezone :UTC]
set x1 [clock format $f1 -format {%Y-%m-%d %H:%M:%S} -timezone :UTC]
set x2 [clock format $f2 -format {%Y-%m-%d %H:%M:%S} -timezone :UTC]
|
| ︙ | ︙ | |||
35609 35610 35611 35612 35613 35614 35615 |
set time [clock scan "1/1/71" -gmt true]
clock format $time -format {%b %d,%Y %H:%M GMT} -gmt true
} {Jan 01,1971 00:00 GMT}
test clock-34.11 {clock scan tests} {
set time [clock scan "1/1/37" -gmt true]
clock format $time -format {%b %d,%Y %H:%M GMT} -gmt true
} {Jan 01,2037 00:00 GMT}
| < | 35626 35627 35628 35629 35630 35631 35632 35633 35634 35635 35636 35637 35638 35639 |
set time [clock scan "1/1/71" -gmt true]
clock format $time -format {%b %d,%Y %H:%M GMT} -gmt true
} {Jan 01,1971 00:00 GMT}
test clock-34.11 {clock scan tests} {
set time [clock scan "1/1/37" -gmt true]
clock format $time -format {%b %d,%Y %H:%M GMT} -gmt true
} {Jan 01,2037 00:00 GMT}
test clock-34.12 {clock scan, relative times} {
set time [clock scan "Oct 23, 1992 -1 day"]
clock format $time -format {%b %d, %Y}
} "Oct 22, 1992"
test clock-34.13 {clock scan, ISO 8601 base date format} {
set time [clock scan "19921023"]
clock format $time -format {%b %d, %Y}
|
| ︙ | ︙ | |||
35761 35762 35763 35764 35765 35766 35767 |
foreach i {91 92 93 94 95 96} {
set dec1th [clock scan 12/1/$i]
set monday [clock scan "monday 1 week ago" -base $dec1th]
lappend res [clock format $monday -format %Y-%m-%d]
}
set res
} {1991-11-25 1992-11-30 1993-11-29 1994-11-28 1995-11-27 1996-11-25}
| < | 35777 35778 35779 35780 35781 35782 35783 35784 35785 35786 35787 35788 35789 35790 |
foreach i {91 92 93 94 95 96} {
set dec1th [clock scan 12/1/$i]
set monday [clock scan "monday 1 week ago" -base $dec1th]
lappend res [clock format $monday -format %Y-%m-%d]
}
set res
} {1991-11-25 1992-11-30 1993-11-29 1994-11-28 1995-11-27 1996-11-25}
test clock-34.44 {2nd monday in november} {
set res {}
foreach i {91 92 93 94 95 96} {
set nov8th [clock scan 11/8/$i -gmt 1]
set monday [clock scan monday -base $nov8th -gmt 1]
lappend res [clock format $monday -format %Y-%m-%d -gmt 1]
}
|
| ︙ | ︙ | |||
35794 35795 35796 35797 35798 35799 35800 |
set res
} {1991-11-25 1992-11-30 1993-11-29 1994-11-28 1995-11-27 1996-11-25}
test clock-34.47 {ago with multiple relative units} {
set base [clock scan "12/31/1999 00:00:00"]
set res [clock scan "2 days 2 hours ago" -base $base]
expr {$base - $res}
} 180000
| < < < < < | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 35809 35810 35811 35812 35813 35814 35815 35816 35817 35818 35819 35820 35821 35822 35823 35824 35825 35826 35827 35828 35829 35830 35831 35832 35833 35834 35835 35836 35837 35838 35839 35840 35841 35842 35843 35844 35845 35846 35847 35848 35849 35850 35851 35852 35853 35854 35855 35856 35857 35858 35859 35860 35861 35862 35863 35864 35865 35866 35867 35868 35869 35870 35871 35872 35873 35874 35875 35876 35877 35878 35879 35880 35881 35882 35883 35884 35885 35886 35887 35888 35889 35890 35891 35892 35893 35894 35895 35896 35897 35898 35899 35900 35901 35902 35903 35904 35905 35906 35907 35908 35909 35910 35911 |
set res
} {1991-11-25 1992-11-30 1993-11-29 1994-11-28 1995-11-27 1996-11-25}
test clock-34.47 {ago with multiple relative units} {
set base [clock scan "12/31/1999 00:00:00"]
set res [clock scan "2 days 2 hours ago" -base $base]
expr {$base - $res}
} 180000
test clock-34.48 {more than one ToD} {*}{
-body {clock scan {10:00 11:00}}
-returnCodes error
-result {unable to convert date-time string "10:00 11:00": more than one time of day in string}
}
test clock-34.49 {more than one date} {*}{
-body {clock scan {1/1/2001 2/2/2002}}
-returnCodes error
-result {unable to convert date-time string "1/1/2001 2/2/2002": more than one date in string}
}
test clock-34.50 {more than one time zone} {*}{
-body {clock scan {10:00 EST CST}}
-returnCodes error
-result {unable to convert date-time string "10:00 EST CST": more than one time zone in string}
}
test clock-34.51 {more than one weekday} {*}{
-body {clock scan {Monday Tuesday}}
-returnCodes error
-result {unable to convert date-time string "Monday Tuesday": more than one weekday in string}
}
test clock-34.52 {more than one ordinal month} {*}{
-body {clock scan {next January next March}}
-returnCodes error
-result {unable to convert date-time string "next January next March": more than one ordinal month in string}
}
test clock-34.53 {clock scan, ISO 8601 point in time format} {
set time [clock scan "19921023T00:00:00"]
clock format $time -format {%b %d, %Y %H:%M:%S}
} "Oct 23, 1992 00:00:00"
test clock-34.54 {clock scan, ISO 8601 point in time format} {
set time [clock scan "1992-10-23T00:00:00"]
clock format $time -format {%b %d, %Y %H:%M:%S}
} "Oct 23, 1992 00:00:00"
test clock-34.55 {clock scan, ISO 8601 invalid TZ} -body {
set time [clock scan "19921023MST000000"]
clock format $time -format {%b %d, %Y %H:%M:%S}
} -returnCodes error -match glob -result {unable to convert date-time string*}
test clock-34.56 {clock scan, ISO 8601 invalid TZ} -body {
set time [clock scan "19921023M000000"]
clock format $time -format {%b %d, %Y %H:%M:%S}
} -returnCodes error -match glob -result {unable to convert date-time string*}
test clock-34.57 {clock scan, ISO 8601 invalid TZ} -body {
set time [clock scan "1992-10-23M00:00:00"]
clock format $time -format {%b %d, %Y %H:%M:%S}
} -returnCodes error -match glob -result {unable to convert date-time string*}
test clock-34.58 {clock scan, ISO 8601 invalid TZ} -body {
set time [clock scan "1992-10-23MST00:00:00"]
clock format $time -format {%b %d, %Y %H:%M:%S}
} -returnCodes error -match glob -result {unable to convert date-time string*}
test clock-34.59 {clock scan tests (-TZ)} {
set time [clock scan "31 Jan 14 23:59:59 -0100"]
clock format $time -format {%b %d,%Y %H:%M:%S %Z} -gmt true
} {Feb 01,2014 00:59:59 GMT}
test clock-34.60 {clock scan tests (+TZ)} {
set time [clock scan "31 Jan 14 23:59:59 +0100"]
clock format $time -format {%b %d,%Y %H:%M:%S %Z} -gmt true
} {Jan 31,2014 22:59:59 GMT}
test clock-34.61 {clock scan tests (-TZ)} {
set time [clock scan "23:59:59 -0100" -base 0 -gmt true]
clock format $time -format {%b %d,%Y %H:%M:%S %Z} -gmt true
} {Jan 02,1970 00:59:59 GMT}
test clock-34.62 {clock scan tests (+TZ)} {
set time [clock scan "23:59:59 +0100" -base 0 -gmt true]
clock format $time -format {%b %d,%Y %H:%M:%S %Z} -gmt true
} {Jan 01,1970 22:59:59 GMT}
test clock-34.63 {clock scan tests (TZ)} {
set time [clock scan "Mon, 30 Jun 2014 23:59:59 CEST"]
clock format $time -format {%b %d,%Y %H:%M:%S %Z} -gmt true
} {Jun 30,2014 21:59:59 GMT}
test clock-34.64 {clock scan tests (TZ)} {
set time [clock scan "Fri, 31 Jan 2014 23:59:59 CET"]
clock format $time -format {%b %d,%Y %H:%M:%S %Z} -gmt true
} {Jan 31,2014 22:59:59 GMT}
test clock-34.65 {clock scan tests (relspec, day unit not TZ)} {
set time [clock scan "23:59:59 +15 day" -base 2000000 -gmt true]
clock format $time -format {%b %d,%Y %H:%M:%S %Z} -gmt true
} {Feb 08,1970 23:59:59 GMT}
test clock-34.66 {clock scan tests (relspec, day unit not TZ)} {
set time [clock scan "23:59:59 -15 day" -base 2000000 -gmt true]
clock format $time -format {%b %d,%Y %H:%M:%S %Z} -gmt true
} {Jan 09,1970 23:59:59 GMT}
test clock-34.67 {clock scan tests (merid and TZ)} {
set time [clock scan "10:59 pm CET" -base 2000000 -gmt true]
clock format $time -format {%b %d,%Y %H:%M:%S %Z} -gmt true
} {Jan 24,1970 21:59:00 GMT}
test clock-34.68 {clock scan tests (merid and TZ)} {
set time [clock scan "10:59 pm +0100" -base 2000000 -gmt true]
clock format $time -format {%b %d,%Y %H:%M:%S %Z} -gmt true
} {Jan 24,1970 21:59:00 GMT}
# clock seconds
test clock-35.1 {clock seconds tests} {
expr [clock seconds]+1
concat {}
} {}
test clock-35.2 {clock seconds tests} {
|
| ︙ | ︙ | |||
36925 36926 36927 36928 36929 36930 36931 |
clock format [clock seconds] -format %%r
} %r
test clock-67.2 {Bug d19a30db57} -body {
# error, not segfault
tcl::clock::GetJulianDayFromEraYearMonthDay {} 2361222
} -returnCodes error -match glob -result *
| < < < | 36997 36998 36999 37000 37001 37002 37003 37004 37005 37006 37007 37008 37009 37010 37011 37012 37013 37014 37015 37016 37017 37018 37019 37020 37021 37022 37023 37024 37025 |
clock format [clock seconds] -format %%r
} %r
test clock-67.2 {Bug d19a30db57} -body {
# error, not segfault
tcl::clock::GetJulianDayFromEraYearMonthDay {} 2361222
} -returnCodes error -match glob -result *
test clock-67.3 {Bug d19a30db57} -body {
# error, not segfault
tcl::clock::GetJulianDayFromEraYearWeekDay {} 2361222
} -returnCodes error -match glob -result *
test clock-67.4 {Change format %x output on global locale change [Bug 4a0c163d24]} -setup {
package require msgcat
set current [msgcat::mclocale]
} -body {
msgcat::mclocale de_de
set res [regexp {^\d{2}\.\d{2}\.\d{4}$} [clock format 1 -locale current -format %x]]
msgcat::mclocale en_uk
lappend res [regexp {^\d{2}/\d{2}/\d{4}$} [clock format 1 -locale current -format %x]]
} -cleanup {
msgcat::mclocale $current
} -result {1 1}
test clock-67.5 {Change scan %x output on global locale change [Bug 4a0c163d24]} -setup {
package require msgcat
set current [msgcat::mclocale]
} -body {
msgcat::mclocale de_de
set res [clock scan "01.01.1970" -locale current -format %x -gmt 1]
msgcat::mclocale en_uk
|
| ︙ | ︙ |
Changes to tests/cmdIL.test.
1 2 3 4 5 6 7 8 9 10 | # This file contains a collection of tests for the procedures in the file # tclCmdIL.c. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # # Copyright (c) 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. | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 |
# This file contains a collection of tests for the procedures in the file
# tclCmdIL.c. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
#
# Copyright (c) 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 {"::tcltest" ni [namespace children]} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
|
| ︙ | ︙ |
Changes to tests/compExpr-old.test.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 | # # Copyright (c) 1996-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. | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
#
# Copyright (c) 1996-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 {"::tcltest" ni [namespace children]} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
# Big test for correct ordering of data in [expr]
|
| ︙ | ︙ |
Changes to tests/config.test.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 | # Copyright (c) 1991-1993 The Regents of the University of California. # 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. | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
# Copyright (c) 1991-1993 The Regents of the University of California.
# 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 {"::tcltest" ni [namespace children]} {
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}
|
| ︙ | ︙ |
Changes to tests/coroutine.test.
1 2 3 4 5 6 7 8 9 10 11 | # Commands covered: coroutine, yield, yieldto, [info coroutine] # # This file contains a collection of tests for experimental commands that are # found in ::tcl::unsupported. The tests will migrate to normal test files # if/when the commands find their way into the core. # # Copyright (c) 2008 by Miguel Sofer. # # 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 |
# Commands covered: coroutine, yield, yieldto, [info coroutine]
#
# This file contains a collection of tests for experimental commands that are
# found in ::tcl::unsupported. The tests will migrate to normal test files
# if/when the commands find their way into the core.
#
# Copyright (c) 2008 by Miguel Sofer.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
|
| ︙ | ︙ |
Changes to tests/dict.test.
1 2 3 4 5 6 7 8 9 10 11 | # 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. | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
# This test file covers the dictionary object type and the dict command used
# to work with values of that type.
#
# This file contains a collection of tests for one or more of the Tcl built-in
# commands. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
#
# Copyright (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 {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
# Used for constraining memory leak tests
testConstraint memory [llength [info commands memory]]
if {[testConstraint memory]} {
|
| ︙ | ︙ |
Changes to tests/dstring.test.
| ︙ | ︙ | |||
176 177 178 179 180 181 182 |
} -body {
testdstring append x -1
testdstring element #
testdstring get
} -cleanup {
testdstring free
} -result {x #}
| | > > | < | > > > > > > > > > > > > > > > > > > > > | 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 |
} -body {
testdstring append x -1
testdstring element #
testdstring get
} -cleanup {
testdstring free
} -result {x #}
test dstring-2.13 {appending list elements} -constraints testdstring -setup {
testdstring free
} -body {
# This test checks the sophistication in Tcl_DStringAppendElement's
# decision about whether #-quoting can be disabled.
testdstring append "x " -1
testdstring element #
testdstring get
} -cleanup {
testdstring free
} -result {x #}
test dstring-2.14 {appending list elements} -constraints testdstring -setup {
testdstring free
} -body {
testdstring append " " -1
testdstring element #
testdstring get
} -cleanup {
testdstring free
} -result { {#}}
test dstring-2.15 {appending list elements} -constraints testdstring -setup {
testdstring free
} -body {
# This test checks the sophistication in Tcl_DStringAppendElement's
# decision about whether #-quoting can be disabled.
testdstring append "x " -1
testdstring element #
testdstring get
} -cleanup {
testdstring free
} -result {x #}
test dstring-3.1 {nested sublists} -constraints testdstring -setup {
testdstring free
} -body {
testdstring start
testdstring element foo
testdstring element bar
|
| ︙ | ︙ | |||
302 303 304 305 306 307 308 |
testdstring append x -1
testdstring element #
testdstring end
testdstring get
} -cleanup {
testdstring free
} -result {x {x #}}
| | > > | < | > > > > > > > > > > > > > > > > > > > > > > > > > > | 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 |
testdstring append x -1
testdstring element #
testdstring end
testdstring get
} -cleanup {
testdstring free
} -result {x {x #}}
test dstring-3.10 {appending list elements} -constraints testdstring -setup {
testdstring free
} -body {
# This test checks the sophistication in Tcl_DStringAppendElement's
# decision about whether #-quoting can be disabled.
testdstring append x -1
testdstring start
testdstring append "x " -1
testdstring element #
testdstring end
testdstring get
} -cleanup {
testdstring free
} -result {x {x #}}
test dstring-3.11 {appending list elements} -constraints testdstring -setup {
testdstring free
} -body {
testdstring append x -1
testdstring start
testdstring append " " -1
testdstring element #
testdstring end
testdstring get
} -cleanup {
testdstring free
} -result {x { {#}}}
test dstring-3.12 {appending list elements} -constraints testdstring -setup {
testdstring free
} -body {
# This test checks the sophistication in Tcl_DStringAppendElement's
# decision about whether #-quoting can be disabled.
testdstring append x -1
testdstring start
testdstring append "x " -1
testdstring element #
testdstring end
testdstring get
} -cleanup {
testdstring free
} -result {x {x #}}
test dstring-4.1 {truncation} -constraints testdstring -setup {
testdstring free
} -body {
testdstring append "abcdefg" -1
testdstring trunc 3
list [testdstring get] [testdstring length]
|
| ︙ | ︙ |
Changes to tests/encoding.test.
| ︙ | ︙ | |||
279 280 281 282 283 284 285 |
encoding dirs $path
encoding system $system
} -result {invalid encoding file "splat"}
# OpenEncodingFile is fully tested by the rest of the tests in this file.
test encoding-12.1 {LoadTableEncoding: normal encoding} {
| | | | | | | 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 |
encoding dirs $path
encoding system $system
} -result {invalid encoding file "splat"}
# OpenEncodingFile is fully tested by the rest of the tests in this file.
test encoding-12.1 {LoadTableEncoding: normal encoding} {
set x [encoding convertto iso8859-3 \u0120]
append x [encoding convertto iso8859-3 \xD5]
append x [encoding convertfrom iso8859-3 \xD5]
} "\xd5?\u120"
test encoding-12.2 {LoadTableEncoding: single-byte encoding} {
set x [encoding convertto iso8859-3 ab\u0120g]
append x [encoding convertfrom iso8859-3 ab\xD5g]
} "ab\xd5gab\u120g"
test encoding-12.3 {LoadTableEncoding: multi-byte encoding} {
set x [encoding convertto shiftjis ab\u4E4Eg]
append x [encoding convertfrom shiftjis ab\x8c\xc1g]
} "ab\x8c\xc1gab\u4e4eg"
test encoding-12.4 {LoadTableEncoding: double-byte encoding} {
set x [encoding convertto jis0208 \u4e4e\u3b1]
append x [encoding convertfrom jis0208 8C&A]
} "8C&A\u4e4e\u3b1"
test encoding-12.5 {LoadTableEncoding: symbol encoding} {
|
| ︙ | ︙ | |||
387 388 389 390 391 392 393 |
} {1 3 edb882}
test encoding-15.15 {UtfToUtfProc low surrogate character output} {
set x \uDA02
set y [encoding convertto utf-8 \uDA02]
binary scan $y H* z
list [string length $x] [string length $y] $z
} {1 3 eda882}
| | > > > > > | 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 |
} {1 3 edb882}
test encoding-15.15 {UtfToUtfProc low surrogate character output} {
set x \uDA02
set y [encoding convertto utf-8 \uDA02]
binary scan $y H* z
list [string length $x] [string length $y] $z
} {1 3 eda882}
test encoding-15.16 {UtfToUtfProc: Invalid 4-byte UTF-8, see [ed29806ba]} {
set x \xF0\xA0\xA1\xC2
set y [encoding convertfrom utf-8 \xF0\xA0\xA1\xC2]
list [string length $x] $y
} "4 \xF0\xA0\xA1\xC2"
test encoding-15.17 {UtfToUtfProc emoji character output} {
set x \U1F602
set y [encoding convertto utf-8 \U1F602]
binary scan $y H* z
list [string length $y] $z
} {4 f09f9882}
test encoding-16.1 {Utf16ToUtfProc} -body {
|
| ︙ | ︙ |
Changes to tests/env.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # Commands covered: none (tests environment variable implementation) # # This file contains a collection of tests for one or more of the Tcl built-in # commands. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # # Copyright (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. | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
# Commands covered: none (tests environment variable implementation)
#
# This file contains a collection of tests for one or more of the Tcl built-in
# commands. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
#
# Copyright (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 {"::tcltest" ni [namespace children]} {
package require tcltest 2
namespace import -force ::tcltest::*
}
loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
package require tcltests
|
| ︙ | ︙ |
Changes to tests/error.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # Commands covered: error, catch, throw, try # # This file contains a collection of tests for one or more of the Tcl built-in # commands. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # # Copyright (c) 1991-1993 The Regents of the University of California. # 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. | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
# Commands covered: error, catch, throw, try
#
# This file contains a collection of tests for one or more of the Tcl built-in
# commands. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# 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 {"::tcltest" ni [namespace children]} {
package require tcltest 2
namespace import -force ::tcltest::*
}
testConstraint memory [llength [info commands memory]]
customMatch pairwise {apply {{a b} {
string equal [lindex $b 0] [lindex $b 1]
|
| ︙ | ︙ |
Changes to tests/event.test.
| ︙ | ︙ | |||
19 20 21 22 23 24 25 | } testConstraint testfilehandler [llength [info commands testfilehandler]] testConstraint testexithandler [llength [info commands testexithandler]] testConstraint testfilewait [llength [info commands testfilewait]] testConstraint exec [llength [info commands exec]] | > | | > | 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 |
}
testConstraint testfilehandler [llength [info commands testfilehandler]]
testConstraint testexithandler [llength [info commands testexithandler]]
testConstraint testfilewait [llength [info commands testfilewait]]
testConstraint exec [llength [info commands exec]]
testConstraint notOSX [expr {$::tcl_platform(os) ne "Darwin"}]
test event-1.1 {Tcl_CreateFileHandler, reading} -setup {
testfilehandler close
set result ""
} -constraints {testfilehandler notOSX} -body {
testfilehandler create 0 readable off
testfilehandler clear 0
testfilehandler oneevent
lappend result [testfilehandler counts 0]
testfilehandler fillpartial 0
update idletasks
testfilehandler oneevent
lappend result [testfilehandler counts 0]
testfilehandler oneevent
lappend result [testfilehandler counts 0]
} -cleanup {
testfilehandler close
} -result {{0 0} {1 0} {2 0}}
|
| ︙ | ︙ |
Changes to tests/exec.test.
| ︙ | ︙ | |||
20 21 22 23 24 25 26 27 28 29 30 31 32 33 |
loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
package require tcltests
# All tests require the "exec" command.
# Skip them if exec is not defined.
testConstraint exec [llength [info commands exec]]
unset -nocomplain path
# Utilities that are like bourne shell stalwarts, but cross-platform.
set path(echo) [makeFile {
puts -nonewline [lindex $argv 0]
foreach str [lrange $argv 1 end] {
puts -nonewline " $str"
| > > | 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 |
loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
package require tcltests
# All tests require the "exec" command.
# Skip them if exec is not defined.
testConstraint exec [llength [info commands exec]]
testConstraint noosx [expr {![info exists ::env(TRAVIS_OSX_IMAGE)] || ![string match xcode* $::env(TRAVIS_OSX_IMAGE)]}]
unset -nocomplain path
# Utilities that are like bourne shell stalwarts, but cross-platform.
set path(echo) [makeFile {
puts -nonewline [lindex $argv 0]
foreach str [lrange $argv 1 end] {
puts -nonewline " $str"
|
| ︙ | ︙ | |||
665 666 667 668 669 670 671 |
} -constraints {exec tempNotWin} -cleanup {
removeFile $path(fooblah)
} -result contents
# Note that this test cannot be adapted to work on Windows; that platform has
# no kernel support for an analog of O_APPEND. OTOH, that means we can assume
# that there is a POSIX shell...
| | | 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 |
} -constraints {exec tempNotWin} -cleanup {
removeFile $path(fooblah)
} -result contents
# Note that this test cannot be adapted to work on Windows; that platform has
# no kernel support for an analog of O_APPEND. OTOH, that means we can assume
# that there is a POSIX shell...
test exec-19.1 {exec >> uses O_APPEND} -constraints {exec unix notValgrind noosx} -setup {
set tmpfile [makeFile {0} tmpfile.exec-19.1]
} -body {
# Note that we have to allow for the current contents of the temporary
# file, which is why the result is 14 and not 12
exec /bin/sh -c \
{for a in 1 2 3; do sleep 1; echo $a; done} >>$tmpfile &
exec /bin/sh -c \
|
| ︙ | ︙ |
Changes to tests/expr.test.
1 2 3 4 5 6 7 8 9 10 11 12 | # Commands covered: expr # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1996-1997 Sun Microsystems, Inc. # Copyright (c) 1998-2000 by Scriptics 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 |
# Commands covered: expr
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1996-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-2000 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::*
}
::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.
|
| ︙ | ︙ |
Changes to tests/for-old.test.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 | # # Copyright (c) 1991-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. | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
#
# Copyright (c) 1991-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.
if {"::tcltest" ni [namespace children]} {
package require tcltest
namespace import -force ::tcltest::*
}
# Check "for" and its use of continue and break.
catch {unset a i}
|
| ︙ | ︙ |
Changes to tests/for.test.
1 2 3 4 5 6 7 8 9 10 11 | # Commands covered: for, continue, break # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1996 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
# Commands covered: for, continue, break
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1996 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2
namespace import -force ::tcltest::*
}
# Used for constraining memory leak tests
testConstraint memory [llength [info commands memory]]
if {[testConstraint memory]} {
|
| ︙ | ︙ |
Changes to tests/foreach.test.
1 2 3 4 5 6 7 8 9 10 11 12 | # Commands covered: foreach, continue, break # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1997 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 |
# Commands covered: foreach, continue, break
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1991-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.
if {"::tcltest" ni [namespace children]} {
package require tcltest
namespace import -force ::tcltest::*
}
catch {unset a}
catch {unset x}
|
| ︙ | ︙ |
Changes to tests/format.test.
1 2 3 4 5 6 7 8 9 10 11 12 | # Commands covered: format # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1994 The Regents of the University of California. # Copyright (c) 1994-1998 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 |
# Commands covered: format
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1991-1994 The Regents of the University of California.
# Copyright (c) 1994-1998 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
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}]
|
| ︙ | ︙ |
Changes to tests/get.test.
1 2 3 4 5 6 7 8 9 10 11 12 | # Commands covered: none # # This file contains a collection of tests for the procedures in the # file tclGet.c. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1995-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. | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 |
# Commands covered: none
#
# This file contains a collection of tests for the procedures in the
# file tclGet.c. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1995-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 {"::tcltest" ni [namespace children]} {
package require tcltest
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
|
| ︙ | ︙ | |||
105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 |
} {44 44 44 44 54 54 52 46}
test get-3.4 {Tcl_GetDouble with iffy numbers} testdoubleobj {
lmap x {0 0.0 " .0" ".0 " " 0e0 " "09" "- 0" "-0" "0o12" "0b10"} {
catch {testdoubleobj set 1 $x} x
set x
}
} {0.0 0.0 0.0 0.0 0.0 9.0 {expected floating-point number but got "- 0"} 0.0 10.0 2.0}
# cleanup
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
| > > > > > > | 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 |
} {44 44 44 44 54 54 52 46}
test get-3.4 {Tcl_GetDouble with iffy numbers} testdoubleobj {
lmap x {0 0.0 " .0" ".0 " " 0e0 " "09" "- 0" "-0" "0o12" "0b10"} {
catch {testdoubleobj set 1 $x} x
set x
}
} {0.0 0.0 0.0 0.0 0.0 9.0 {expected floating-point number but got "- 0"} 0.0 10.0 2.0}
test get-3.5 {tcl_GetInt with numeric whitespace (i.e. '_')} testgetint {
lmap x {0_0 " 1_0" "0_2 " " 3_3 " 14__23__32___4 " 0x_a " " 0_07 " " 0o_1_0 " " 0_b1_0 " _33 42_ 0_x15 0_o17 0_d19 } {
catch {testgetint $x} x
set x
}
} {0 10 2 33 1423324 10 7 8 {expected integer but got " 0_b1_0 "} {expected integer but got "_33"} {expected integer but got "42_"} {expected integer but got "0_x15"} {expected integer but got "0_o17"} {expected integer but got "0_d19"}}
# cleanup
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Changes to tests/http11.test.
1 2 3 4 5 6 7 8 9 10 11 12 | # http11.test -- -*- tcl-*- # # Test HTTP/1.1 features. # # Copyright (C) 2009 Pat Thoyts <patthoyts@users.sourceforge.net> # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. package require tcltest 2 namespace import -force ::tcltest::* | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 |
# http11.test -- -*- tcl-*-
#
# Test HTTP/1.1 features.
#
# Copyright (C) 2009 Pat Thoyts <patthoyts@users.sourceforge.net>
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
package require tcltest 2
namespace import -force ::tcltest::*
package require http 2.9
# start the server
variable httpd_output
proc create_httpd {} {
proc httpd_read {chan} {
variable httpd_output
if {[gets $chan line] != -1} {
|
| ︙ | ︙ | |||
55 56 57 58 59 60 61 62 63 64 65 66 67 68 |
return [dict get $meta $key]
} else {
return ""
}
}
return $meta
}
proc check_crc {tok args} {
set crc [meta $tok x-crc32]
set data [expr {[llength $args] ? [lindex $args 0] : [http::data $tok]}]
set chk [format %x [zlib crc32 $data]]
if {$crc ne $chk} {
return "crc32 mismatch: $crc ne $chk"
| > > > > > > > > > > > > > > | 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 |
return [dict get $meta $key]
} else {
return ""
}
}
return $meta
}
proc state {tok {key ""}} {
upvar 1 $tok state
if {$key ne ""} {
if {[array names state -exact $key] ne {}} {
return $state($key)
} else {
return ""
}
}
set res [array get state]
dict set res body <elided>
return $res
}
proc check_crc {tok args} {
set crc [meta $tok x-crc32]
set data [expr {[llength $args] ? [lindex $args 0] : [http::data $tok]}]
set chk [format %x [zlib crc32 $data]]
if {$crc ne $chk} {
return "crc32 mismatch: $crc ne $chk"
|
| ︙ | ︙ | |||
237 238 239 240 241 242 243 244 245 246 247 248 249 250 |
list [http::status $tok] [http::code $tok] [check_crc $tok] \
[meta $tok content-encoding] [meta $tok transfer-encoding]
} -cleanup {
http::cleanup $tok
halt_httpd
} -result {ok {HTTP/1.1 200 OK} ok {} chunked}
# -------------------------------------------------------------------------
test http11-2.0 "-channel" -setup {
variable httpd [create_httpd]
set chan [open [makeFile {} testfile.tmp] wb+]
} -body {
set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
| > > > > > > > > > > > > > > > > > > > > > > > | 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 |
list [http::status $tok] [http::code $tok] [check_crc $tok] \
[meta $tok content-encoding] [meta $tok transfer-encoding]
} -cleanup {
http::cleanup $tok
halt_httpd
} -result {ok {HTTP/1.1 200 OK} ok {} chunked}
test http11-1.13 "normal, 1.1 and keepalive as server default, no zip" -setup {
variable httpd [create_httpd]
set zipTmp [http::config -zip]
http::config -zip 0
} -body {
set tok [http::geturl http://localhost:$httpd_port/testdoc.html?transfer= \
-protocol 1.1 -keepalive 1 -timeout 10000]
http::wait $tok
set res1 [list [http::status $tok] [http::code $tok] [check_crc $tok] \
[meta $tok connection] [meta $tok transfer-encoding] [state $tok reusing] [state $tok connection]]
set toj [http::geturl http://localhost:$httpd_port/testdoc.html?transfer= \
-protocol 1.1 -keepalive 1 -timeout 10000]
http::wait $toj
set res2 [list [http::status $toj] [http::code $toj] [check_crc $toj] \
[meta $toj connection] [meta $toj transfer-encoding] [state $toj reusing] [state $toj connection]]
concat $res1 -- $res2
} -cleanup {
http::cleanup $tok
http::cleanup $toj
halt_httpd
http::config -zip $zipTmp
} -result {ok {HTTP/1.1 200 OK} ok {} {} 0 keep-alive -- ok {HTTP/1.1 200 OK} ok {} {} 1 keep-alive}
# -------------------------------------------------------------------------
test http11-2.0 "-channel" -setup {
variable httpd [create_httpd]
set chan [open [makeFile {} testfile.tmp] wb+]
} -body {
set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
|
| ︙ | ︙ |
Changes to tests/httpPipeline.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # 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::* | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | # httpPipeline.test # # Test HTTP/1.1 concurrent requests including # queueing, pipelining and retries. # # Copyright (C) 2018 Keith Nash <kjnash@users.sourceforge.net> # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. package require tcltest 2 namespace import -force ::tcltest::* package require http 2.9 set sourcedir [file normalize [file dirname [info script]]] source [file join $sourcedir httpTest.tcl] source [file join $sourcedir httpTestScript.tcl] # ------------------------------------------------------------------------------ # (1) Define the test scripts that will be used to generate logs for analysis - |
| ︙ | ︙ |
Changes to tests/if-old.test.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 | # Copyright (c) 1991-1993 The Regents of the University of California. # 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. | | | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 |
# Copyright (c) 1991-1993 The Regents of the University of California.
# 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 {"::tcltest" ni [namespace children]} {
package require tcltest
namespace import -force ::tcltest::*
}
test if-old-1.1 {taking proper branch} {
set a {}
if 0 {set a 1} else {set a 2}
|
| ︙ | ︙ |
Changes to tests/if.test.
1 2 3 4 5 6 7 8 9 10 11 12 | # Commands covered: if # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 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. | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 |
# Commands covered: if
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 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 {"::tcltest" ni [namespace children]} {
package require tcltest 2
namespace import -force ::tcltest::*
}
# Basic "if" operation.
catch {unset a}
|
| ︙ | ︙ |
Changes to tests/incr-old.test.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 | # Copyright (c) 1991-1993 The Regents of the University of California. # 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. | | | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 |
# Copyright (c) 1991-1993 The Regents of the University of California.
# 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 {"::tcltest" ni [namespace children]} {
package require tcltest 2
namespace import -force ::tcltest::*
}
catch {unset x}
test incr-old-1.1 {basic incr operation} {
|
| ︙ | ︙ |
Changes to tests/indexObj.test.
1 2 3 4 5 6 7 8 9 10 | # This file is a Tcl script to test out the the procedures in file # tkIndexObj.c, which implement indexed table lookups. The tests here are # organized in the standard fashion for Tcl tests. # # Copyright (c) 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. | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 |
# This file is a Tcl script to test out the the procedures in file
# tkIndexObj.c, which implement indexed table lookups. The tests here are
# organized in the standard fashion for Tcl tests.
#
# Copyright (c) 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 {"::tcltest" ni [namespace children]} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
|
| ︙ | ︙ |
Changes to tests/info.test.
| ︙ | ︙ | |||
2443 2444 2445 2446 2447 2448 2449 |
}
} -body {
info cmdtype ::testinfocmdtype::bar
} -cleanup {
rename ::testinfocmdtype::bar {}
namespace delete ::testinfocmdtype::foo
} -result import
| | | | | | | | 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 |
}
} -body {
info cmdtype ::testinfocmdtype::bar
} -cleanup {
rename ::testinfocmdtype::bar {}
namespace delete ::testinfocmdtype::foo
} -result import
test info-40.10 {info cmdtype: interps} -setup {
apply {i {
rename $i ::testinfocmdtype::child
variable ::testinfocmdtype::child $i
}} [interp create]
} -body {
info cmdtype ::testinfocmdtype::child
} -cleanup {
interp delete $::testinfocmdtype::child
} -result interp
test info-40.11 {info cmdtype: objects} -setup {
apply {{} {
oo::object create obj
} ::testinfocmdtype}
} -body {
info cmdtype ::testinfocmdtype::obj
} -cleanup {
|
| ︙ | ︙ | |||
2514 2515 2516 2517 2518 2519 2520 |
}
} -cleanup {
namespace eval ::testinfocmdtype {
catch {rename foo {}}
catch {rename bar {}}
}
} -result {0 1 ::testinfocmdtype::foo {} ::testinfocmdtype::bar 1 0}
| | | | | | 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 |
}
} -cleanup {
namespace eval ::testinfocmdtype {
catch {rename foo {}}
catch {rename bar {}}
}
} -result {0 1 ::testinfocmdtype::foo {} ::testinfocmdtype::bar 1 0}
test info-40.17 {info cmdtype: aliases in child interpreters} -setup {
set i [interp create]
} -body {
$i alias foo gorp
$i eval {
info cmdtype foo
}
} -cleanup {
interp delete $i
} -result alias
test info-40.18 {info cmdtype: aliases in child interpreters} -setup {
set safe [interp create -safe]
} -body {
$safe alias foo gorp
$safe eval {
info cmdtype foo
}
} -returnCodes error -cleanup {
interp delete $safe
} -result {not allowed to invoke subcommand cmdtype of info}
test info-40.19 {info cmdtype: aliases in child interpreters} -setup {
set safe [interp create -safe]
} -body {
set inner [interp create [list $safe bar]]
interp alias $inner foo $safe gorp
$safe eval {
bar eval {
info cmdtype foo
}
}
} -returnCodes error -cleanup {
interp delete $safe
} -result {not allowed to invoke subcommand cmdtype of info}
test info-40.20 {info cmdtype: aliases in child interpreters} -setup {
set safe [interp create -safe]
} -body {
$safe eval {
interp alias {} foo {} gorp
info cmdtype foo
}
} -returnCodes error -cleanup {
|
| ︙ | ︙ |
Changes to tests/init.test.
| ︙ | ︙ | |||
15 16 17 18 19 20 21 |
namespace import -force ::tcltest::*
}
# Clear out any namespaces called test_ns_*
catch {namespace delete {*}[namespace children :: test_ns_*]}
test init-0.1 {no error on initialization phase (init.tcl)} -setup {
| | | | | 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 |
namespace import -force ::tcltest::*
}
# Clear out any namespaces called test_ns_*
catch {namespace delete {*}[namespace children :: test_ns_*]}
test init-0.1 {no error on initialization phase (init.tcl)} -setup {
interp create child
} -body {
child eval {
list [set v [info exists ::errorInfo]] \
[if {$v} {set ::errorInfo}] \
[set v [info exists ::errorCode]] \
[if {$v} {set ::errorCode}]
}
} -cleanup {
interp delete child
} -result {0 {} 0 {}}
# Six cases - white box testing
test init-1.1 {auto_qualify - absolute cmd - namespace} {
auto_qualify ::foo::bar ::blue
} ::foo::bar
|
| ︙ | ︙ | |||
55 56 57 58 59 60 61 |
test init-1.7 {auto_qualify - multiples colons 1} {
auto_qualify :::foo::::bar ::blue
} ::foo::bar
test init-1.8 {auto_qualify - multiple colons 2} {
auto_qualify :::foo ::bar
} foo
| | | | 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 |
test init-1.7 {auto_qualify - multiples colons 1} {
auto_qualify :::foo::::bar ::blue
} ::foo::bar
test init-1.8 {auto_qualify - multiple colons 2} {
auto_qualify :::foo ::bar
} foo
# We use a child interp and auto_reset and double the tests because there is 2
# places where auto_loading occur (before loading the indexes files and after)
set testInterp [interp create]
tcltest::loadIntoChildInterpreter $testInterp {*}$argv
interp eval $testInterp {
namespace import -force ::tcltest::*
customMatch pairwise {apply {{mode pair} {
if {[llength $pair] != 2} {error "need a pair of values to check"}
string $mode [lindex $pair 0] [lindex $pair 1]
}}}
|
| ︙ | ︙ |
Changes to tests/io.test.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 | # 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. | | | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 |
# 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 {"::tcltest" ni [namespace children]} {
package require tcltest 2
}
namespace eval ::tcl::test::io {
namespace import ::tcltest::*
variable umaskValue
|
| ︙ | ︙ | |||
34 35 36 37 38 39 40 |
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]]
| < > | 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 |
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 testfevent [llength [info commands testfevent]]
testConstraint testchannelevent [llength [info commands testchannelevent]]
testConstraint testmainthread [llength [info commands testmainthread]]
testConstraint testobj [llength [info commands testobj]]
testConstraint testservicemode [llength [info commands testservicemode]]
testConstraint knownMsvcBug [expr {![info exists ::env(TRAVIS_OS_NAME)] || ![string match windows $::env(TRAVIS_OS_NAME)]}]
# You need a *very* special environment to do some tests. In
# particular, many file systems do not support large-files...
testConstraint largefileSupport [expr {$::tcl_platform(os) ne "Darwin"}]
# some tests can only be run is umask is 2
|
| ︙ | ︙ | |||
477 478 479 480 481 482 483 |
puts $f hi
close $f
set f [open $path(test1)]
set x [list [gets $f line] $line]
close $f
set x
} [list 256 $a]
| | | 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 |
puts $f hi
close $f
set f [open $path(test1)]
set x [list [gets $f line] $line]
close $f
set x
} [list 256 $a]
test io-6.7 {Tcl_GetsObj: error in input} stdio {
# if (FilterInputBytes(chanPtr, &gs) != 0)
set f [open "|[list [interpreter] $path(cat)]" w+]
puts -nonewline $f "hi\nwould"
flush $f
gets $f
fconfigure $f -blocking 0
|
| ︙ | ︙ | |||
737 738 739 740 741 742 743 |
close $f
set f [open $path(test1)]
fconfigure $f -translation crlf -buffersize 16
set x [list [gets $f line] $line [testchannel inputbuffered $f]]
close $f
set x
} [list 15 "123456789012345" 15]
| | | 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 |
close $f
set f [open $path(test1)]
fconfigure $f -translation crlf -buffersize 16
set x [list [gets $f line] $line [testchannel inputbuffered $f]]
close $f
set x
} [list 15 "123456789012345" 15]
test io-6.31 {Tcl_GetsObj: crlf mode: buffer exhausted, blocked} {stdio testchannel fileevent} {
# (FilterInputBytes() != 0)
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -translation {crlf lf} -buffering none
puts -nonewline $f "bbbbbbbbbbbbbb\r\n123456789012345\r"
fconfigure $f -buffersize 16
set x [gets $f]
|
| ︙ | ︙ | |||
876 877 878 879 880 881 882 |
set f [open $path(test1)]
fconfigure $f -translation auto
set x [list [gets $f line] $line [gets $f line] $line]
lappend x [gets $f line] $line [gets $f line] $line [gets $f line] $line
close $f
set x
} [list 4 "abcd" 4 "efgh" 4 "ijkl" 4 "mnop" -1 ""]
| | | | | | 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 |
set f [open $path(test1)]
fconfigure $f -translation auto
set x [list [gets $f line] $line [gets $f line] $line]
lappend x [gets $f line] $line [gets $f line] $line [gets $f line] $line
close $f
set x
} [list 4 "abcd" 4 "efgh" 4 "ijkl" 4 "mnop" -1 ""]
test io-6.43 {Tcl_GetsObj: input saw cr} {stdio testchannel fileevent} {
# if (chanPtr->flags & INPUT_SAW_CR)
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -translation {auto lf} -buffering none
puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r"
fconfigure $f -buffersize 16
set x [list [gets $f]]
fconfigure $f -blocking 0
lappend x [gets $f line] $line [testchannel queuedcr $f]
fconfigure $f -blocking 1
puts -nonewline $f "\nabcd\refg\x1a"
lappend x [gets $f line] $line [testchannel queuedcr $f]
lappend x [gets $f line] $line
close $f
set x
} [list "bbbbbbbbbbbbbbb" 15 "123456789abcdef" 1 4 "abcd" 0 3 "efg"]
test io-6.44 {Tcl_GetsObj: input saw cr, not followed by cr} {stdio testchannel fileevent} {
# not (*eol == '\n')
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -translation {auto lf} -buffering none
puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r"
fconfigure $f -buffersize 16
set x [list [gets $f]]
fconfigure $f -blocking 0
lappend x [gets $f line] $line [testchannel queuedcr $f]
fconfigure $f -blocking 1
puts -nonewline $f "abcd\refg\x1a"
lappend x [gets $f line] $line [testchannel queuedcr $f]
lappend x [gets $f line] $line
close $f
set x
} [list "bbbbbbbbbbbbbbb" 15 "123456789abcdef" 1 4 "abcd" 0 3 "efg"]
test io-6.45 {Tcl_GetsObj: input saw cr, skip right number of bytes} {stdio testchannel fileevent} {
# Tcl_ExternalToUtf()
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -translation {auto lf} -buffering none
fconfigure $f -encoding utf-16
puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r"
fconfigure $f -buffersize 16
gets $f
fconfigure $f -blocking 0
set x [list [gets $f line] $line [testchannel queuedcr $f]]
fconfigure $f -blocking 1
puts -nonewline $f "\nabcd\refg"
lappend x [gets $f line] $line [testchannel queuedcr $f]
close $f
set x
} [list 15 "123456789abcdef" 1 4 "abcd" 0]
test io-6.46 {Tcl_GetsObj: input saw cr, followed by just \n should give eof} {stdio testchannel fileevent} {
# memmove()
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -translation {auto lf} -buffering none
puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r"
fconfigure $f -buffersize 16
gets $f
|
| ︙ | ︙ | |||
1052 1053 1054 1055 1056 1057 1058 |
close $f
set f [open $path(test1)]
fconfigure $f -encoding iso2022-jp
set x [list [gets $f line] $line [gets $f line] $line [gets $f line] $line]
close $f
set x
} [list 8 "there\u4e00ok" 11 "\u4e01more bytes" 4 "here"]
| | | 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 |
close $f
set f [open $path(test1)]
fconfigure $f -encoding iso2022-jp
set x [list [gets $f line] $line [gets $f line] $line [gets $f line] $line]
close $f
set x
} [list 8 "there\u4e00ok" 11 "\u4e01more bytes" 4 "here"]
test io-6.56 {Tcl_GetsObj: incomplete lines should disable file events} {stdio fileevent} {
update
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -buffering none
puts -nonewline $f "foobar"
fconfigure $f -blocking 0
variable x {}
after 500 [namespace code { lappend x timeout }]
|
| ︙ | ︙ | |||
1112 1113 1114 1115 1116 1117 1118 |
fconfigure $f -encoding shiftjis
set x [list [gets $f line] $line]
lappend x [tell $f] [testchannel inputbuffered $f] [eof $f]
lappend x [gets $f line] $line
close $f
set x
} [list 15 "1234567890123\uff10\uff11" 18 0 1 -1 ""]
| | | 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 |
fconfigure $f -encoding shiftjis
set x [list [gets $f line] $line]
lappend x [tell $f] [testchannel inputbuffered $f] [eof $f]
lappend x [gets $f line] $line
close $f
set x
} [list 15 "1234567890123\uff10\uff11" 18 0 1 -1 ""]
test io-7.4 {FilterInputBytes: recover from split up character} {stdio fileevent} {
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -encoding binary -buffering none
puts -nonewline $f "1234567890123\x82\x4f\x82\x50\x82"
fconfigure $f -encoding shiftjis -blocking 0
fileevent $f read [namespace code "ready $f"]
variable x {}
proc ready {f} {
|
| ︙ | ︙ | |||
1147 1148 1149 1150 1151 1152 1153 |
fconfigure $f -encoding ascii -translation auto -buffersize 16
# here
gets $f
set x [testchannel inputbuffered $f]
close $f
set x
} "7"
| | | | 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 |
fconfigure $f -encoding ascii -translation auto -buffersize 16
# here
gets $f
set x [testchannel inputbuffered $f]
close $f
set x
} "7"
test io-8.2 {PeekAhead: only go to device if no more cached data} {stdio testchannel fileevent} {
# not (bufPtr->nextPtr == NULL)
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -translation lf -encoding ascii -buffering none
puts -nonewline $f "123456789012345\r\nbcdefghijklmnopqrstuvwxyz"
variable x {}
fileevent $f read [namespace code "ready $f"]
proc ready {f} {
variable x
lappend x [gets $f line] $line [testchannel inputbuffered $f]
}
fconfigure $f -encoding utf-16 -buffersize 16 -blocking 0
vwait [namespace which -variable x]
fconfigure $f -translation auto -encoding ascii -blocking 1
# here
vwait [namespace which -variable x]
close $f
set x
} [list -1 "" 42 15 "123456789012345" 25]
test io-8.3 {PeekAhead: no cached data available} {stdio testchannel fileevent} {
# (bytesLeft == 0)
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -translation {auto binary}
puts -nonewline $f "abcdefghijklmno\r"
flush $f
set x [list [gets $f line] $line [testchannel queuedcr $f]]
|
| ︙ | ︙ | |||
1200 1201 1202 1203 1204 1205 1206 |
# that cached data is available in buffer w/o having to call driver.
set x [gets $f]
close $f
set x
} $a
unset a
| | | | | 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 |
# that cached data is available in buffer w/o having to call driver.
set x [gets $f]
close $f
set x
} $a
unset a
test io-8.5 {PeekAhead: don't peek if last read was short} {stdio testchannel fileevent} {
# (bufPtr->nextAdded < bufPtr->length)
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -translation {auto binary}
puts -nonewline $f "abcdefghijklmno\r"
flush $f
# here
set x [list [gets $f line] $line [testchannel queuedcr $f]]
close $f
set x
} {15 abcdefghijklmno 1}
test io-8.6 {PeekAhead: change to non-blocking mode} {stdio testchannel fileevent} {
# ((chanPtr->flags & CHANNEL_NONBLOCKING) == 0)
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -translation {auto binary} -buffersize 16
puts -nonewline $f "abcdefghijklmno\r"
flush $f
# here
set x [list [gets $f line] $line [testchannel queuedcr $f]]
close $f
set x
} {15 abcdefghijklmno 1}
test io-8.7 {PeekAhead: cleanup} {stdio testchannel fileevent} {
# Make sure bytes are removed from buffer.
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -translation {auto binary} -buffering none
puts -nonewline $f "abcdefghijklmno\r"
# here
set x [list [gets $f line] $line [testchannel queuedcr $f]]
|
| ︙ | ︙ | |||
1389 1390 1391 1392 1393 1394 1395 |
set f [open $path(test1)]
fconfigure $f -buffersize 16
# here
set x [read $f]
close $f
set x
} {abcdefghijklmnopqrstuvwxyz}
| | | 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 |
set f [open $path(test1)]
fconfigure $f -buffersize 16
# here
set x [read $f]
close $f
set x
} {abcdefghijklmnopqrstuvwxyz}
test io-12.4 {ReadChars: split-up char} {stdio testchannel fileevent} {
# (srcRead == 0)
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -encoding binary -buffering none -buffersize 16
puts -nonewline $f "123456789012345\x96"
fconfigure $f -encoding shiftjis -blocking 0
|
| ︙ | ︙ | |||
1414 1415 1416 1417 1418 1419 1420 |
puts -nonewline $f "\x7b"
after 500 ;# Give the cat process time to catch up
fconfigure $f -encoding shiftjis -blocking 0
vwait [namespace which -variable x]
close $f
set x
} [list "123456789012345" 1 "\u672c" 0]
| | | 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 |
puts -nonewline $f "\x7b"
after 500 ;# Give the cat process time to catch up
fconfigure $f -encoding shiftjis -blocking 0
vwait [namespace which -variable x]
close $f
set x
} [list "123456789012345" 1 "\u672c" 0]
test io-12.5 {ReadChars: fileevents on partial characters} {stdio fileevent} {
set path(test1) [makeFile {
fconfigure stdout -encoding binary -buffering none
gets stdin; puts -nonewline "\xe7"
gets stdin; puts -nonewline "\x89"
gets stdin; puts -nonewline "\xa6"
} test1]
set f [open "|[list [interpreter] $path(test1)]" r+]
|
| ︙ | ︙ | |||
1608 1609 1610 1611 1612 1613 1614 |
close $f
set f [open $path(test1)]
fconfigure $f -translation crlf
set x [read $f]
close $f
set x
} "abcd\ndef\nfgh"
| | | 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 |
close $f
set f [open $path(test1)]
fconfigure $f -translation crlf
set x [read $f]
close $f
set x
} "abcd\ndef\nfgh"
test io-13.6 {TranslateInputEOL: auto mode: saw cr in last segment} {stdio testchannel fileevent} {
# (chanPtr->flags & INPUT_SAW_CR)
# This test may fail on slower machines.
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -blocking 0 -buffering none -translation {auto lf}
fileevent $f read [namespace code "ready $f"]
|
| ︙ | ︙ | |||
1634 1635 1636 1637 1638 1639 1640 |
puts -nonewline $f "\n01234"
after 500 [namespace code {set y ok}]
vwait [namespace which -variable y]
close $f
set x
} [list "abcdefghj\n" 1 "01234" 0]
| | | 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 |
puts -nonewline $f "\n01234"
after 500 [namespace code {set y ok}]
vwait [namespace which -variable y]
close $f
set x
} [list "abcdefghj\n" 1 "01234" 0]
test io-13.7 {TranslateInputEOL: auto mode: naked \r} testchannel {
# (src >= srcMax)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "abcd\r"
close $f
set f [open $path(test1)]
|
| ︙ | ︙ | |||
1779 1780 1781 1782 1783 1784 1785 |
lappend l [x eval {fconfigure stdin -buffering}]
lappend l [x eval {fconfigure stdout -buffering}]
lappend l [x eval {fconfigure stderr -buffering}]
interp delete x
set l
} {line line none}
set path(test3) [makeFile {} test3]
| | | 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 |
lappend l [x eval {fconfigure stdin -buffering}]
lappend l [x eval {fconfigure stdout -buffering}]
lappend l [x eval {fconfigure stderr -buffering}]
interp delete x
set l
} {line line none}
set path(test3) [makeFile {} test3]
test io-14.3 {Tcl_SetStdChannel & Tcl_GetStdChannel} exec {
set f [open $path(test1) w]
puts -nonewline $f {
close stdin
close stdout
close stderr
set f [}
puts $f [list open $path(test1) r]]
|
| ︙ | ︙ | |||
1869 1870 1871 1872 1873 1874 1875 |
catch {z eval close stderr} msg2
catch {z eval flush stderr} msg3
set result [list $msg1 $msg2 $msg3]
interp delete z
set result
} {{} {} {can not find channel named "stderr"}}
set path(script) [makeFile {} script]
| | | 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 |
catch {z eval close stderr} msg2
catch {z eval flush stderr} msg3
set result [list $msg1 $msg2 $msg3]
interp delete z
set result
} {{} {} {can not find channel named "stderr"}}
set path(script) [makeFile {} script]
test io-14.8 {reuse of stdio special channels} stdio {
file delete $path(script)
file delete $path(test1)
set f [open $path(script) w]
puts -nonewline $f {
close stderr
set f [}
puts $f [list open $path(test1) w]]
|
| ︙ | ︙ | |||
1891 1892 1893 1894 1895 1896 1897 |
}
close $f
set f [open "|[list [interpreter] $path(script)]" r]
set c [gets $f]
close $f
set c
} hello
| | | 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 |
}
close $f
set f [open "|[list [interpreter] $path(script)]" r]
set c [gets $f]
close $f
set c
} hello
test io-14.9 {reuse of stdio special channels} {stdio fileevent} {
file delete $path(script)
file delete $path(test1)
set f [open $path(script) w]
puts $f {
array set path [lindex $argv 0]
set f [open $path(test1) w]
puts $f hello
|
| ︙ | ︙ | |||
2074 2075 2076 2077 2078 2079 2080 |
test io-20.3 {Tcl_CreateChannel: initial settings} {unix} {
set f [open $path(test1) w+]
set x [list [fconfigure $f -eofchar] [fconfigure $f -translation]]
close $f
set x
} {{{} {}} {auto lf}}
set path(stdout) [makeFile {} stdout]
| | | 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 |
test io-20.3 {Tcl_CreateChannel: initial settings} {unix} {
set f [open $path(test1) w+]
set x [list [fconfigure $f -eofchar] [fconfigure $f -translation]]
close $f
set x
} {{{} {}} {auto lf}}
set path(stdout) [makeFile {} stdout]
test io-20.5 {Tcl_CreateChannel: install channel in empty slot} stdio {
set f [open $path(script) w]
puts -nonewline $f {
close stdout
set f1 [}
puts $f [list open $path(stdout) w]]
puts $f {
fconfigure $f1 -buffersize 777
|
| ︙ | ︙ | |||
2148 2149 2150 2151 2152 2153 2154 |
lappend l [testchannel outputbuffered $f]
lappend l [tell $f]
close $f
file delete $path(test1)
set l
} {6 6 0 6}
| | | 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 |
lappend l [testchannel outputbuffered $f]
lappend l [tell $f]
close $f
file delete $path(test1)
set l
} {6 6 0 6}
test io-26.1 {Tcl_GetChannelInstanceData} stdio {
# "pid" command uses Tcl_GetChannelInstanceData
# Don't care what pid is (but must be a number), just want to exercise it.
set f [open "|[list [interpreter] << exit]"]
expr [pid $f]
close $f
} {}
|
| ︙ | ︙ | |||
2225 2226 2227 2228 2229 2230 2231 |
close $f
lappend l [file size $path(test1)]
set l
} {0 60 72}
set path(pipe) [makeFile {} pipe]
set path(output) [makeFile {} output]
test io-27.6 {FlushChannel, async flushing, async close} \
| | | 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 |
close $f
lappend l [file size $path(test1)]
set l
} {0 60 72}
set path(pipe) [makeFile {} pipe]
set path(output) [makeFile {} output]
test io-27.6 {FlushChannel, async flushing, async close} \
{stdio asyncPipeClose knownMsvcBug} {
# This test may fail on old Unix systems (seen on IRIX64 6.5) with
# obsolete gettimeofday() calls. See Tcl Bugs 3530533, 1942197.
file delete $path(pipe)
file delete $path(output)
set f [open $path(pipe) w]
puts $f "set f \[[list open $path(output) w]]"
puts $f {
|
| ︙ | ︙ | |||
2294 2295 2296 2297 2298 2299 2300 |
interp delete x
set f [open $path(test1) r]
set l [gets $f]
close $f
set l
} abcdef
test io-28.3 {CloseChannel, not called before output queue is empty} \
| | | 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 |
interp delete x
set f [open $path(test1) r]
set l [gets $f]
close $f
set l
} abcdef
test io-28.3 {CloseChannel, not called before output queue is empty} \
{stdio asyncPipeClose nonPortable} {
file delete $path(pipe)
file delete $path(output)
set f [open $path(pipe) w]
puts $f {
# Need to not have eof char appended on close, because the other
# side of the pipe already closed, so that writing would cause an
|
| ︙ | ︙ | |||
2351 2352 2353 2354 2355 2356 2357 |
close $f
lappend l [lsort [testchannel open]]
set x [list $consoleFileNames \
[lsort [list {*}$consoleFileNames $f]] \
$consoleFileNames]
string compare $l $x
} 0
| | | 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 |
close $f
lappend l [lsort [testchannel open]]
set x [list $consoleFileNames \
[lsort [list {*}$consoleFileNames $f]] \
$consoleFileNames]
string compare $l $x
} 0
test io-28.5 {Tcl_Close vs standard handles} {stdio unix testchannel} {
file delete $path(script)
set f [open $path(script) w]
puts $f {
close stdin
puts [testchannel open]
}
close $f
|
| ︙ | ︙ | |||
2490 2491 2492 2493 2494 2495 2496 |
for {set x 0} {$x < 10} {incr x} {
puts -nonewline $f1 [gets $f2]
}
close $f1
close $f2
file size $path(test1)
} 377
| | | 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 |
for {set x 0} {$x < 10} {incr x} {
puts -nonewline $f1 [gets $f2]
}
close $f1
close $f2
file size $path(test1)
} 377
test io-29.12 {Tcl_WriteChars on a pipe} stdio {
file delete $path(test1)
file delete $path(pipe)
set f1 [open $path(pipe) w]
puts $f1 "set f1 \[[list open $path(longfile) r]]"
puts $f1 {
for {set x 0} {$x < 10} {incr x} {
puts [gets $f1]
|
| ︙ | ︙ | |||
2515 2516 2517 2518 2519 2520 2521 |
set y broken
}
}
close $f1
close $f2
set y
} ok
| | | 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 |
set y broken
}
}
close $f1
close $f2
set y
} ok
test io-29.13 {Tcl_WriteChars to a pipe, line buffered} stdio {
file delete $path(test1)
file delete $path(pipe)
set f1 [open $path(pipe) w]
puts $f1 {
puts [gets stdin]
puts [gets stdin]
}
|
| ︙ | ︙ | |||
2566 2567 2568 2569 2570 2571 2572 |
close $fd
set fd [open $path(test1) r]
set x [list [catch {flush $fd} msg] $msg]
close $fd
string compare $x \
[list 1 "channel \"$fd\" wasn't opened for writing"]
} 0
| | | 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 |
close $fd
set fd [open $path(test1) r]
set x [list [catch {flush $fd} msg] $msg]
close $fd
string compare $x \
[list 1 "channel \"$fd\" wasn't opened for writing"]
} 0
test io-29.16 {Tcl_Flush on pipe opened only for reading} stdio {
set fd [open "|[list [interpreter] cat longfile]" r]
set x [list [catch {flush $fd} msg] $msg]
catch {close $fd}
string compare $x \
[list 1 "channel \"$fd\" wasn't opened for writing"]
} 0
test io-29.17 {Tcl_WriteChars buffers, then Tcl_Flush flushes} {
|
| ︙ | ︙ | |||
2640 2641 2642 2643 2644 2645 2646 |
puts $f1 $line
}
lappend z [file size $path(test1)]
close $f1
lappend z [file size $path(test1)]
set z
} {4096 12288 12600}
| | | | 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 |
puts $f1 $line
}
lappend z [file size $path(test1)]
close $f1
lappend z [file size $path(test1)]
set z
} {4096 12288 12600}
test io-29.21 {Tcl_Flush to pipe} stdio {
file delete $path(pipe)
set f1 [open $path(pipe) w]
puts $f1 {set x [read stdin 6]}
puts $f1 {set cnt [string length $x]}
puts $f1 {puts "read $cnt characters"}
close $f1
set f1 [open "|[list [interpreter] $path(pipe)]" r+]
puts $f1 hello
flush $f1
set x [gets $f1]
catch {close $f1}
set x
} "read 6 characters"
test io-29.22 {Tcl_Flush called at other end of pipe} stdio {
file delete $path(pipe)
set f1 [open $path(pipe) w]
puts $f1 {
fconfigure stdout -buffering full
puts hello
puts hello
flush stdout
|
| ︙ | ︙ | |||
2677 2678 2679 2680 2681 2682 2683 |
lappend x [gets $f1]
puts $f1 hello
flush $f1
lappend x [gets $f1]
close $f1
set x
} {hello hello bye}
| | | 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 |
lappend x [gets $f1]
puts $f1 hello
flush $f1
lappend x [gets $f1]
close $f1
set x
} {hello hello bye}
test io-29.23 {Tcl_Flush and line buffering at end of pipe} stdio {
file delete $path(pipe)
set f1 [open $path(pipe) w]
puts $f1 {
puts hello
puts hello
gets stdin
puts bye
|
| ︙ | ︙ | |||
2712 2713 2714 2715 2716 2717 2718 |
flush $f
set f2 [open $path(test3)]
lappend x [read -nonewline $f2]
close $f2
close $f
set x
} "{} {Line 1\nLine 2}"
| | | | | 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 |
flush $f
set f2 [open $path(test3)]
lappend x [read -nonewline $f2]
close $f2
close $f
set x
} "{} {Line 1\nLine 2}"
test io-29.25 {Implicit flush with Tcl_Flush to command pipelines} {stdio fileevent} {
file delete $path(test3)
set f [open "|[list [interpreter] $path(cat) | [interpreter] $path(cat) > $path(test3)]" w]
puts $f "Line 1"
puts $f "Line 2"
close $f
after 100
set f [open $path(test3) r]
set x [read $f]
close $f
set x
} "Line 1\nLine 2\n"
test io-29.26 {Tcl_Flush, Tcl_Write on bidirectional pipelines} {stdio unixExecs} {
set f [open "|[list cat -u]" r+]
puts $f "Line1"
flush $f
set x [gets $f]
close $f
set x
} {Line1}
test io-29.27 {Tcl_Flush on closed pipeline} stdio {
file delete $path(pipe)
set f [open $path(pipe) w]
puts $f {exit}
close $f
set f [open "|[list [interpreter] $path(pipe)]" r+]
gets $f
puts $f output
|
| ︙ | ︙ | |||
2786 2787 2788 2789 2790 2791 2792 |
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf -eofchar {}
puts $f hello\nthere\nand\nhere
close $f
file size $path(test1)
} 25
| | | 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 |
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf -eofchar {}
puts $f hello\nthere\nand\nhere
close $f
file size $path(test1)
} 25
test io-29.31 {Tcl_WriteChars, background flush} stdio {
# This test may fail on old Unix systems (seen on IRIX64 6.5) with
# obsolete gettimeofday() calls. See Tcl Bugs 3530533, 1942197.
file delete $path(pipe)
file delete $path(output)
set f [open $path(pipe) w]
puts $f "set f \[[list open $path(output) w]]"
puts $f {fconfigure $f -translation lf}
|
| ︙ | ︙ | |||
2823 2824 2825 2826 2827 2828 2829 |
}
if {$counter == 1000} {
set result "file size only [file size $path(output)]"
} else {
set result ok
}
# allow a little time for the background process to close.
| | | | 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 |
}
if {$counter == 1000} {
set result "file size only [file size $path(output)]"
} else {
set result ok
}
# allow a little time for the background process to close.
# otherwise, the following test fails on the [file delete $path(output)]
# on Windows because a process still has the file open.
after 100 set v 1; vwait v
set result
} ok
test io-29.32 {Tcl_WriteChars, background flush to slow reader} \
{stdio asyncPipeClose knownMsvcBug} {
# This test may fail on old Unix systems (seen on IRIX64 6.5) with
# obsolete gettimeofday() calls. See Tcl Bugs 3530533, 1942197.
file delete $path(pipe)
file delete $path(output)
set f [open $path(pipe) w]
puts $f "set f \[[list open $path(output) w]]"
puts $f {fconfigure $f -translation lf}
|
| ︙ | ︙ | |||
4089 4090 4091 4092 4093 4094 4095 |
set x ok
set z [file size $path(longfile)]
if {$z != $l} {
set x broken
}
set x
} ok
| | | | | | 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 |
set x ok
set z [file size $path(longfile)]
if {$z != $l} {
set x broken
}
set x
} ok
test io-32.10 {Tcl_Read from a pipe} stdio {
file delete $path(pipe)
set f1 [open $path(pipe) w]
puts $f1 {puts [gets stdin]}
close $f1
set f1 [open "|[list [interpreter] $path(pipe)]" r+]
puts $f1 hello
flush $f1
set x [read $f1]
close $f1
set x
} "hello\n"
test io-32.11 {Tcl_Read from a pipe} stdio {
file delete $path(pipe)
set f1 [open $path(pipe) w]
puts $f1 {puts [gets stdin]}
puts $f1 {puts [gets stdin]}
close $f1
set f1 [open "|[list [interpreter] $path(pipe)]" r+]
puts $f1 hello
flush $f1
set x ""
lappend x [read $f1 6]
puts $f1 hello
flush $f1
lappend x [read $f1]
close $f1
set x
} {{hello
} {hello
}}
test io-32.11.1 {Tcl_Read from a pipe} stdio {
file delete $path(pipe)
set f1 [open $path(pipe) w]
puts $f1 {chan configure stdout -translation crlf}
puts $f1 {puts [gets stdin]}
puts $f1 {puts [gets stdin]}
close $f1
set f1 [open "|[list [interpreter] $path(pipe)]" r+]
puts $f1 hello
flush $f1
set x ""
lappend x [read $f1 6]
puts $f1 hello
flush $f1
lappend x [read $f1]
close $f1
set x
} {{hello
} {hello
}}
test io-32.11.2 {Tcl_Read from a pipe} stdio {
file delete $path(pipe)
set f1 [open $path(pipe) w]
puts $f1 {chan configure stdout -translation crlf}
puts $f1 {puts [gets stdin]}
puts $f1 {puts [gets stdin]}
close $f1
set f1 [open "|[list [interpreter] $path(pipe)]" r+]
|
| ︙ | ︙ | |||
4251 4252 4253 4254 4255 4256 4257 |
set z ok
if {$l != $l} {
set z broken
}
close $f1
set z
} ok
| | | 4251 4252 4253 4254 4255 4256 4257 4258 4259 4260 4261 4262 4263 4264 4265 |
set z ok
if {$l != $l} {
set z broken
}
close $f1
set z
} ok
test io-33.3 {Tcl_Gets from pipe} stdio {
file delete $path(pipe)
set f1 [open $path(pipe) w]
puts $f1 {puts [gets stdin]}
close $f1
set f1 [open "|[list [interpreter] $path(pipe)]" r+]
puts $f1 hello
flush $f1
|
| ︙ | ︙ | |||
4559 4560 4561 4562 4563 4564 4565 |
set c1 [tell $f1]
set r1 [read $f1 5]
seek $f1 0 current
set c2 [tell $f1]
close $f1
list $c1 $r1 $c2
} {44 rstuv 49}
| | | 4559 4560 4561 4562 4563 4564 4565 4566 4567 4568 4569 4570 4571 4572 4573 |
set c1 [tell $f1]
set r1 [read $f1 5]
seek $f1 0 current
set c2 [tell $f1]
close $f1
list $c1 $r1 $c2
} {44 rstuv 49}
test io-34.8 {Tcl_Seek on pipes: not supported} stdio {
set f1 [open "|[list [interpreter]]" r+]
set x [list [catch {seek $f1 0 current} msg] $msg]
close $f1
regsub {".*":} $x {"":} x
string tolower $x
} {1 {error during seek on "": invalid argument}}
test io-34.9 {Tcl_Seek, testing buffered input flushing} {
|
| ︙ | ︙ | |||
4667 4668 4669 4670 4671 4672 4673 |
seek $f1 10 start
set c1 [tell $f1]
seek $f1 10 current
set c2 [tell $f1]
close $f1
list $c1 $c2
} {10 20}
| | | | 4667 4668 4669 4670 4671 4672 4673 4674 4675 4676 4677 4678 4679 4680 4681 4682 4683 4684 4685 4686 4687 |
seek $f1 10 start
set c1 [tell $f1]
seek $f1 10 current
set c2 [tell $f1]
close $f1
list $c1 $c2
} {10 20}
test io-34.16 {Tcl_Tell on pipe: always -1} stdio {
set f1 [open "|[list [interpreter]]" r+]
set c [tell $f1]
close $f1
set c
} -1
test io-34.17 {Tcl_Tell on pipe: always -1} stdio {
set f1 [open "|[list [interpreter]]" r+]
puts $f1 {puts hello}
flush $f1
set c [tell $f1]
gets $f1
close $f1
set c
|
| ︙ | ︙ | |||
4772 4773 4774 4775 4776 4777 4778 |
lappend x [eof $f]
gets $f
lappend x [eof $f]
lappend x [eof $f]
close $f
set x
} {0 0 0 0 1 1}
| | | | 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 |
lappend x [eof $f]
gets $f
lappend x [eof $f]
lappend x [eof $f]
close $f
set x
} {0 0 0 0 1 1}
test io-35.2 {Tcl_Eof with pipe} stdio {
file delete $path(pipe)
set f1 [open $path(pipe) w]
puts $f1 {gets stdin}
puts $f1 {puts hello}
close $f1
set f1 [open "|[list [interpreter] $path(pipe)]" r+]
puts $f1 hello
set x [eof $f1]
flush $f1
lappend x [eof $f1]
gets $f1
lappend x [eof $f1]
gets $f1
lappend x [eof $f1]
close $f1
set x
} {0 0 0 1}
test io-35.3 {Tcl_Eof with pipe} stdio {
file delete $path(pipe)
set f1 [open $path(pipe) w]
puts $f1 {gets stdin}
puts $f1 {puts hello}
close $f1
set f1 [open "|[list [interpreter] $path(pipe)]" r+]
puts $f1 hello
|
| ︙ | ︙ | |||
4824 4825 4826 4827 4828 4829 4830 |
fconfigure $f -blocking off
set l ""
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
} {{} 1}
| | | 4824 4825 4826 4827 4828 4829 4830 4831 4832 4833 4834 4835 4836 4837 4838 |
fconfigure $f -blocking off
set l ""
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
} {{} 1}
test io-35.5 {Tcl_Eof, eof detection on nonblocking pipe} stdio {
file delete $path(pipe)
set f [open $path(pipe) w]
puts $f {
exit
}
close $f
set f [open "|[list [interpreter] $path(pipe)]" r]
|
| ︙ | ︙ | |||
5101 5102 5103 5104 5105 5106 5107 |
set e [eof $f]
close $f
list $c $l $e [scan [string index $in end] %c]
} {9 1 1 13}
# Test Tcl_InputBlocked
| | | | 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 |
set e [eof $f]
close $f
list $c $l $e [scan [string index $in end] %c]
} {9 1 1 13}
# Test Tcl_InputBlocked
test io-36.1 {Tcl_InputBlocked on nonblocking pipe} stdio {
set f1 [open "|[list [interpreter]]" r+]
puts $f1 {puts hello_from_pipe}
flush $f1
gets $f1
fconfigure $f1 -blocking off -buffering full
puts $f1 {puts hello}
set x ""
lappend x [gets $f1]
lappend x [fblocked $f1]
flush $f1
after 200
lappend x [gets $f1]
lappend x [fblocked $f1]
lappend x [gets $f1]
lappend x [fblocked $f1]
close $f1
set x
} {{} 1 hello 0 {} 1}
test io-36.1.1 {Tcl_InputBlocked on nonblocking binary pipe} stdio {
set f1 [open "|[list [interpreter]]" r+]
chan configure $f1 -encoding binary -translation lf -eofchar {}
puts $f1 {
chan configure stdout -encoding binary -translation lf -eofchar {}
puts hello_from_pipe
}
flush $f1
|
| ︙ | ︙ | |||
5143 5144 5145 5146 5147 5148 5149 |
lappend x [gets $f1]
lappend x [fblocked $f1]
lappend x [gets $f1]
lappend x [fblocked $f1]
close $f1
set x
} {{} 1 hello 0 {} 1}
| | | 5143 5144 5145 5146 5147 5148 5149 5150 5151 5152 5153 5154 5155 5156 5157 |
lappend x [gets $f1]
lappend x [fblocked $f1]
lappend x [gets $f1]
lappend x [fblocked $f1]
close $f1
set x
} {{} 1 hello 0 {} 1}
test io-36.2 {Tcl_InputBlocked on blocking pipe} stdio {
set f1 [open "|[list [interpreter]]" r+]
fconfigure $f1 -buffering line
puts $f1 {puts hello_from_pipe}
set x ""
lappend x [gets $f1]
lappend x [fblocked $f1]
puts $f1 {exit}
|
| ︙ | ︙ | |||
5407 5408 5409 5410 5411 5412 5413 |
lappend x [gets $f1]
lappend x [read $f1 1000]
lappend x [fblocked $f1]
lappend x [eof $f1]
close $f1
set x
} {1 0 {} {} 0 1}
| | | 5407 5408 5409 5410 5411 5412 5413 5414 5415 5416 5417 5418 5419 5420 5421 |
lappend x [gets $f1]
lappend x [read $f1 1000]
lappend x [fblocked $f1]
lappend x [eof $f1]
close $f1
set x
} {1 0 {} {} 0 1}
test io-39.10 {Tcl_SetChannelOption, blocking mode} stdio {
file delete $path(pipe)
set f1 [open $path(pipe) w]
puts $f1 {
gets stdin
after 100
puts hi
gets stdin
|
| ︙ | ︙ | |||
5498 5499 5500 5501 5502 5503 5504 |
test io-39.16 {Tcl_SetChannelOption: -encoding, errors} {
file delete $path(test1)
set f [open $path(test1) w]
set result [list [catch {fconfigure $f -encoding foobar} msg] $msg]
close $f
set result
} {1 {unknown encoding "foobar"}}
| | | 5498 5499 5500 5501 5502 5503 5504 5505 5506 5507 5508 5509 5510 5511 5512 |
test io-39.16 {Tcl_SetChannelOption: -encoding, errors} {
file delete $path(test1)
set f [open $path(test1) w]
set result [list [catch {fconfigure $f -encoding foobar} msg] $msg]
close $f
set result
} {1 {unknown encoding "foobar"}}
test io-39.17 {Tcl_SetChannelOption: -encoding, clearing CHANNEL_NEED_MORE_DATA} {stdio fileevent} {
set f [open "|[list [interpreter] $path(cat)]" r+]
fconfigure $f -encoding binary
puts -nonewline $f "\xe7"
flush $f
fconfigure $f -encoding utf-8 -blocking 0
variable x {}
fileevent $f readable [namespace code { lappend x [read $f] }]
|
| ︙ | ︙ | |||
5847 5848 5849 5850 5851 5852 5853 |
lappend result [fileevent $f readable] [fileevent $f writable]
fileevent $f writable {}
lappend result [fileevent $f readable] [fileevent $f writable]
} {{script 1} {} {script 1} {write script} {} {write script} {} {}}
test io-43.2 {Tcl_FileeventCmd: deleting when many present} -setup {
set f2 [open "|[list cat -u]" r+]
set f3 [open "|[list cat -u]" r+]
| | | | | 5847 5848 5849 5850 5851 5852 5853 5854 5855 5856 5857 5858 5859 5860 5861 5862 5863 5864 5865 5866 5867 5868 5869 5870 5871 5872 5873 5874 5875 5876 5877 5878 5879 5880 5881 5882 5883 5884 5885 5886 5887 5888 5889 5890 5891 5892 5893 5894 5895 |
lappend result [fileevent $f readable] [fileevent $f writable]
fileevent $f writable {}
lappend result [fileevent $f readable] [fileevent $f writable]
} {{script 1} {} {script 1} {write script} {} {write script} {} {}}
test io-43.2 {Tcl_FileeventCmd: deleting when many present} -setup {
set f2 [open "|[list cat -u]" r+]
set f3 [open "|[list cat -u]" r+]
} -constraints {stdio unixExecs fileevent} -body {
set result {}
lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r]
fileevent $f r "read f"
fileevent $f2 r "read f2"
fileevent $f3 r "read f3"
lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r]
fileevent $f2 r {}
lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r]
fileevent $f3 r {}
lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r]
fileevent $f r {}
lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r]
} -cleanup {
catch {close $f2}
catch {close $f3}
} -result {{} {} {} {read f} {read f2} {read f3} {read f} {} {read f3} {read f} {} {} {} {} {}}
test io-44.1 {FileEventProc procedure: normal read event} -setup {
set f2 [open "|[list cat -u]" r+]
set f3 [open "|[list cat -u]" r+]
} -constraints {stdio unixExecs fileevent} -body {
fileevent $f2 readable [namespace code {
set x [gets $f2]; fileevent $f2 readable {}
}]
puts $f2 text; flush $f2
variable x initial
vwait [namespace which -variable x]
set x
} -cleanup {
catch {close $f2}
catch {close $f3}
} -result {text}
test io-44.2 {FileEventProc procedure: error in read event} -constraints {
stdio unixExecs fileevent
} -setup {
set f2 [open "|[list cat -u]" r+]
set f3 [open "|[list cat -u]" r+]
proc myHandler {msg options} {
variable x $msg
}
set handler [interp bgerror {}]
|
| ︙ | ︙ | |||
5904 5905 5906 5907 5908 5909 5910 |
interp bgerror {} $handler
catch {close $f2}
catch {close $f3}
} -result {bogus {}}
test io-44.3 {FileEventProc procedure: normal write event} -setup {
set f2 [open "|[list cat -u]" r+]
set f3 [open "|[list cat -u]" r+]
| | | | > > < > > | | 5904 5905 5906 5907 5908 5909 5910 5911 5912 5913 5914 5915 5916 5917 5918 5919 5920 5921 5922 5923 5924 5925 5926 5927 5928 5929 5930 5931 5932 5933 5934 5935 5936 5937 5938 5939 5940 5941 5942 5943 5944 5945 5946 5947 5948 5949 5950 5951 5952 5953 5954 5955 5956 5957 5958 5959 5960 5961 5962 5963 5964 5965 5966 5967 5968 5969 5970 5971 5972 5973 5974 |
interp bgerror {} $handler
catch {close $f2}
catch {close $f3}
} -result {bogus {}}
test io-44.3 {FileEventProc procedure: normal write event} -setup {
set f2 [open "|[list cat -u]" r+]
set f3 [open "|[list cat -u]" r+]
} -constraints {stdio unixExecs fileevent} -body {
fileevent $f2 writable [namespace code {
lappend x "triggered"
incr count -1
if {$count <= 0} {
fileevent $f2 writable {}
}
}]
variable x initial
set count 3
vwait [namespace which -variable x]
vwait [namespace which -variable x]
vwait [namespace which -variable x]
set x
} -cleanup {
catch {close $f2}
catch {close $f3}
} -result {initial triggered triggered triggered}
test io-44.4 {FileEventProc procedure: eror in write event} -constraints {
stdio unixExecs fileevent
} -setup {
set f2 [open "|[list cat -u]" r+]
set f3 [open "|[list cat -u]" r+]
proc myHandler {msg options} {
variable x $msg
}
set handler [interp bgerror {}]
interp bgerror {} [namespace which myHandler]
} -body {
fileevent $f2 writable {error bad-write}
variable x initial
vwait [namespace which -variable x]
list $x [fileevent $f2 writable]
} -cleanup {
interp bgerror {} $handler
catch {close $f2}
catch {close $f3}
} -result {bad-write {}}
test io-44.5 {FileEventProc procedure: end of file} -constraints {
stdio unixExecs fileevent
} -body {
set f4 [open "|[list [interpreter] $path(cat) << foo]" r]
fileevent $f4 readable [namespace code {
if {[gets $f4 line] < 0} {
lappend x eof
fileevent $f4 readable {}
} else {
lappend x $line
}
}]
variable x initial
vwait [namespace which -variable x]
vwait [namespace which -variable x]
set x
} -cleanup {
close $f4
} -result {initial foo eof}
close $f
test io-44.6 {FileEventProc procedure: write-only non-blocking channel} -setup {
} -constraints {stdio fileevent openpipe} -body {
namespace eval refchan {
|
| ︙ | ︙ | |||
6090 6091 6092 6093 6094 6095 6096 6097 |
append script {
set x "no event"
fileevent $f readable [namespace code {
set x "f triggered: [gets $f]"
fileevent $f readable {}
}]
}
testfevent cmd $script
| > < | > | 6093 6094 6095 6096 6097 6098 6099 6100 6101 6102 6103 6104 6105 6106 6107 6108 6109 6110 |
append script {
set x "no event"
fileevent $f readable [namespace code {
set x "f triggered: [gets $f]"
fileevent $f readable {}
}]
}
set timer [after 10 lappend x timeout]
testfevent cmd $script
vwait x
after cancel $timer
testfevent cmd {close $f}
list [testfevent cmd {set x}] [testfevent cmd {info commands after}]
} {{f triggered: foo bar} after}
test io-46.2 {Tcl event loop vs multiple interpreters} testfevent {
testfevent create
testfevent cmd {
variable x 0
|
| ︙ | ︙ | |||
6281 6282 6283 6284 6285 6286 6287 |
}
set l ""
variable x not_done
vwait [namespace which -variable x]
list $x $l
} {done {called called called called called called called}}
set path(my_script) [makeFile {} my_script]
| | | 6285 6286 6287 6288 6289 6290 6291 6292 6293 6294 6295 6296 6297 6298 6299 |
}
set l ""
variable x not_done
vwait [namespace which -variable x]
list $x $l
} {done {called called called called called called called}}
set path(my_script) [makeFile {} my_script]
test io-48.3 {testing readability conditions} {stdio unix nonBlockFiles fileevent} {
set f [open $path(bar) w]
puts $f abcdefg
puts $f abcdefg
puts $f abcdefg
puts $f abcdefg
puts $f abcdefg
close $f
|
| ︙ | ︙ | |||
6779 6780 6781 6782 6783 6784 6785 |
lappend l [gets $f]
lappend l [tell $f]
lappend l [eof $f]
close $f
set l
} [list 7 a\rb\rc 7 {} 7 1]
| | > | < > | > > | > > > > | | > < < < | > > > > > > > > > | < | < | > < < < | | > > > > > > > > > | < | < < | > > | < > > > > > > > > | < | < | > < < < < > > | > | > > > > > > > > > | < | | < | > < < < > | > | | 6783 6784 6785 6786 6787 6788 6789 6790 6791 6792 6793 6794 6795 6796 6797 6798 6799 6800 6801 6802 6803 6804 6805 6806 6807 6808 6809 6810 6811 6812 6813 6814 6815 6816 6817 6818 6819 6820 6821 6822 6823 6824 6825 6826 6827 6828 6829 6830 6831 6832 6833 6834 6835 6836 6837 6838 6839 6840 6841 6842 6843 6844 6845 6846 6847 6848 6849 6850 6851 6852 6853 6854 6855 6856 6857 6858 6859 6860 6861 6862 6863 6864 6865 6866 6867 6868 6869 6870 6871 6872 6873 6874 6875 6876 6877 6878 6879 6880 6881 6882 6883 6884 6885 6886 6887 6888 6889 6890 6891 6892 6893 6894 6895 6896 6897 6898 6899 6900 6901 6902 6903 6904 6905 6906 6907 6908 6909 6910 6911 6912 6913 6914 6915 6916 6917 6918 6919 6920 6921 6922 6923 6924 6925 6926 6927 6928 6929 6930 6931 6932 6933 6934 6935 6936 6937 6938 6939 6940 6941 6942 6943 6944 6945 6946 6947 6948 6949 6950 6951 6952 6953 6954 6955 6956 6957 6958 6959 6960 |
lappend l [gets $f]
lappend l [tell $f]
lappend l [eof $f]
close $f
set l
} [list 7 a\rb\rc 7 {} 7 1]
test io-50.1 {testing handler deletion} -constraints {testchannelevent testservicemode} -setup {
file delete $path(test1)
} -body {
set f [open $path(test1) w]
close $f
update
proc delhandler {f} {
variable z
set z called
testchannelevent $f delete 0
}
set z not_called
set timer [after 50 lappend z timeout]
testservicemode 0
set f [open $path(test1) r]
testchannelevent $f add readable [namespace code [list delhandler $f]]
testservicemode 1
vwait z
after cancel $timer
set z
} -cleanup {
close $f
} -result called
test io-50.2 {testing handler deletion with multiple handlers} -constraints {testchannelevent testservicemode} -setup {
file delete $path(test1)
} -body {
set f [open $path(test1) w]
close $f
proc delhandler {f i} {
variable z
lappend z "called delhandler $i"
testchannelevent $f delete 0
}
set z ""
testservicemode 0
set f [open $path(test1) r]
testchannelevent $f add readable [namespace code [list delhandler $f 1]]
testchannelevent $f add readable [namespace code [list delhandler $f 0]]
testservicemode 1
set timer [after 50 lappend z timeout]
vwait z
after cancel $timer
set z
} -cleanup {
close $f
} -result {{called delhandler 0} {called delhandler 1}}
test io-50.3 {testing handler deletion with multiple handlers} -constraints {testchannelevent testservicemode} -setup {
file delete $path(test1)
} -body {
set f [open $path(test1) w]
close $f
set z ""
proc notcalled {f i} {
variable z
lappend z "notcalled was called!! $f $i"
}
proc delhandler {f i} {
variable z
testchannelevent $f delete 1
lappend z "delhandler $i called"
testchannelevent $f delete 0
lappend z "delhandler $i deleted myself"
}
set z ""
testservicemode 0
set f [open $path(test1) r]
testchannelevent $f add readable [namespace code [list notcalled $f 1]]
testchannelevent $f add readable [namespace code [list delhandler $f 0]]
testservicemode 1
set timer [after 50 lappend z timeout]
vwait z
after cancel $timer
set z
} -cleanup {
close $f
} -result {{delhandler 0 called} {delhandler 0 deleted myself}}
test io-50.4 {testing handler deletion vs reentrant calls} -constraints {testchannelevent testservicemode} -setup {
file delete $path(test1)
update
} -body {
set f [open $path(test1) w]
close $f
update
proc delrecursive {f} {
variable z
variable u
if {"$u" == "recursive"} {
testchannelevent $f delete 0
lappend z "delrecursive deleting recursive"
} else {
lappend z "delrecursive calling recursive"
set u recursive
update
}
}
variable u toplevel
variable z ""
testservicemode 0
set f [open $path(test1) r]
testchannelevent $f add readable [namespace code [list delrecursive $f]]
testservicemode 1
set timer [after 50 lappend z timeout]
vwait z
after cancel $timer
set z
} -cleanup {
close $f
} -result {{delrecursive calling recursive} {delrecursive deleting recursive}}
test io-50.5 {testing handler deletion vs reentrant calls} -constraints {testchannelevent testservicemode} -setup {
file delete $path(test1)
} -body {
set f [open $path(test1) w]
close $f
proc notcalled {f} {
variable z
lappend z "notcalled was called!! $f"
}
proc del {f} {
variable u
variable z
if {"$u" == "recursive"} {
testchannelevent $f delete 1
lappend z "del deleted notcalled"
testchannelevent $f delete 0
lappend z "del deleted myself"
} else {
set u recursive
lappend z "del calling recursive"
set timer [after 50 lappend z timeout]
vwait z
after cancel $timer
lappend z "del after recursive"
}
}
set z ""
set u toplevel
testservicemode 0
set f [open $path(test1) r]
testchannelevent $f add readable [namespace code [list notcalled $f]]
testchannelevent $f add readable [namespace code [list del $f]]
testservicemode 1
set timer [after 50 set z timeout]
vwait z
after cancel $timer
set z
} -cleanup {
close $f
} -result [list {del calling recursive} {del deleted notcalled} \
{del deleted myself} {del after recursive}]
test io-50.6 {testing handler deletion vs reentrant calls} -constraints {testchannelevent testservicemode} -setup {
file delete $path(test1)
} -body {
set f [open $path(test1) w]
close $f
proc first {f} {
variable u
variable z
if {"$u" == "toplevel"} {
lappend z "first called"
set u first
set timer [after 50 lappend z timeout]
vwait z
after cancel $timer
lappend z "first after toplevel"
} else {
lappend z "first called not toplevel"
}
}
proc second {f} {
variable u
variable z
|
| ︙ | ︙ | |||
6934 6935 6936 6937 6938 6939 6940 6941 6942 |
} else {
lappend z "second called, cannot happen!"
testchannelevent $f removeall
}
}
set z ""
set u toplevel
update
close $f
| > > > > > > > < | | | < | 6968 6969 6970 6971 6972 6973 6974 6975 6976 6977 6978 6979 6980 6981 6982 6983 6984 6985 6986 6987 6988 6989 6990 6991 6992 6993 |
} else {
lappend z "second called, cannot happen!"
testchannelevent $f removeall
}
}
set z ""
set u toplevel
testservicemode 0
set f [open $path(test1) r]
testchannelevent $f add readable [namespace code [list second $f]]
testchannelevent $f add readable [namespace code [list first $f]]
testservicemode 1
update
set z
} -cleanup {
close $f
} -result [list {first called} {first called not toplevel} \
{second called, first time} {second called, second time} \
{first after toplevel}]
test io-51.1 {Test old socket deletion on Macintosh} {socket} {
set x 0
set result ""
proc accept {s a p} {
variable x
variable wait
|
| ︙ | ︙ | |||
7131 7132 7133 7134 7135 7136 7137 |
close $f1
close $f2
if {"$s1" == "$s2"} {
lappend result ok
}
set result
} {0 0 ok}
| | | 7170 7171 7172 7173 7174 7175 7176 7177 7178 7179 7180 7181 7182 7183 7184 |
close $f1
close $f2
if {"$s1" == "$s2"} {
lappend result ok
}
set result
} {0 0 ok}
test io-52.8 {TclCopyChannel} {stdio fcopy} {
file delete $path(test1)
file delete $path(pipe)
set f1 [open $path(pipe) w]
fconfigure $f1 -translation lf
puts $f1 "
puts ready
gets stdin
|
| ︙ | ︙ | |||
7411 7412 7413 7414 7415 7416 7417 |
set s1 [file size $thisScript]
set s2 [file size $path(test1)]
if {("$s1" == "$s2") && ($s0 == $s1)} {
lappend result ok
}
set result
} {0 0 ok}
| | | 7450 7451 7452 7453 7454 7455 7456 7457 7458 7459 7460 7461 7462 7463 7464 |
set s1 [file size $thisScript]
set s2 [file size $path(test1)]
if {("$s1" == "$s2") && ($s0 == $s1)} {
lappend result ok
}
set result
} {0 0 ok}
test io-53.3 {CopyData: background read underflow} {stdio unix fcopy} {
file delete $path(test1)
file delete $path(pipe)
set f1 [open $path(pipe) w]
puts -nonewline $f1 {
puts ready
flush stdout ;# Don't assume line buffered!
fcopy stdin stdout -command { set x }
|
| ︙ | ︙ | |||
7443 7444 7445 7446 7447 7448 7449 |
close $f1
after 500
set f [open $path(test1)]
lappend result [read $f]
close $f
set result
} "ready line1 line2 {done\n}"
| | | 7482 7483 7484 7485 7486 7487 7488 7489 7490 7491 7492 7493 7494 7495 7496 |
close $f1
after 500
set f [open $path(test1)]
lappend result [read $f]
close $f
set result
} "ready line1 line2 {done\n}"
test io-53.4 {CopyData: background write overflow} {stdio fileevent fcopy} {
set big bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb\n
variable x
for {set x 0} {$x < 12} {incr x} {
append big $big
}
file delete $path(pipe)
set f1 [open $path(pipe) w]
|
| ︙ | ︙ | |||
7534 7535 7536 7537 7538 7539 7540 |
if ![info exists fcopyTestDone] {
vwait [namespace which -variable fcopyTestDone] ;# The error occurs here in the b.g.
}
close $in
close $out
set fcopyTestDone ;# 1 for error condition
} 1
| | | 7573 7574 7575 7576 7577 7578 7579 7580 7581 7582 7583 7584 7585 7586 7587 |
if ![info exists fcopyTestDone] {
vwait [namespace which -variable fcopyTestDone] ;# The error occurs here in the b.g.
}
close $in
close $out
set fcopyTestDone ;# 1 for error condition
} 1
test io-53.6 {CopyData: error during fcopy} {stdio fcopy} {
variable fcopyTestDone
file delete $path(pipe)
file delete $path(test1)
catch {unset fcopyTestDone}
set f1 [open $path(pipe) w]
puts $f1 "exit 1"
close $f1
|
| ︙ | ︙ | |||
7567 7568 7569 7570 7571 7572 7573 |
set fcopyTestDone 0
} else {
# Delay next fcopy to wait for size>0 input bytes
after 100 [list fcopy $in $out -size 1000 \
-command [namespace code [list doFcopy $in $out]]]
}
}
| | | 7606 7607 7608 7609 7610 7611 7612 7613 7614 7615 7616 7617 7618 7619 7620 |
set fcopyTestDone 0
} else {
# Delay next fcopy to wait for size>0 input bytes
after 100 [list fcopy $in $out -size 1000 \
-command [namespace code [list doFcopy $in $out]]]
}
}
test io-53.7 {CopyData: Flooding fcopy from pipe} {stdio fcopy} {
variable fcopyTestDone
file delete $path(pipe)
catch {unset fcopyTestDone}
set fcopyTestCount 0
set f1 [open $path(pipe) w]
puts $f1 {
# Write 10 bytes / 10 msec
|
| ︙ | ︙ | |||
7619 7620 7621 7622 7623 7624 7625 |
}
# Files we use for our channels
set foo [makeFile ashgdfashdgfasdhgfasdhgf foo]
set bar [makeFile {} bar]
# Channels to copy between
set f [open $foo r] ; fconfigure $f -translation binary
set g [open $bar w] ; fconfigure $g -translation binary -buffering none
| | | 7658 7659 7660 7661 7662 7663 7664 7665 7666 7667 7668 7669 7670 7671 7672 |
}
# Files we use for our channels
set foo [makeFile ashgdfashdgfasdhgfasdhgf foo]
set bar [makeFile {} bar]
# Channels to copy between
set f [open $foo r] ; fconfigure $f -translation binary
set g [open $bar w] ; fconfigure $g -translation binary -buffering none
} -constraints {stdio fcopy} -body {
# Record input size, so that result is always defined
lappend ::RES [file size $bar]
# Run the copy. Should not invoke -command now.
fcopy $f $g -size 2 -command ::cmd
# Check that -command was not called synchronously
set sbs [file size $bar]
lappend ::RES [expr {($sbs > 0) ? "sync/FAIL" : "sync/OK"}] $sbs
|
| ︙ | ︙ | |||
7660 7661 7662 7663 7664 7665 7666 |
}
# Files we use for our channels
set foo [makeFile ashgdfashdgfasdhgfasdhgf foo]
set bar [makeFile {} bar]
# Channels to copy between
set f [open $foo r] ; fconfigure $f -translation binary
set g [open $bar w] ; fconfigure $g -translation binary -buffering none
| | | 7699 7700 7701 7702 7703 7704 7705 7706 7707 7708 7709 7710 7711 7712 7713 |
}
# Files we use for our channels
set foo [makeFile ashgdfashdgfasdhgfasdhgf foo]
set bar [makeFile {} bar]
# Channels to copy between
set f [open $foo r] ; fconfigure $f -translation binary
set g [open $bar w] ; fconfigure $g -translation binary -buffering none
} -constraints {stdio fcopy} -body {
# Initialize and force eof on the input.
seek $f 0 end ; read $f 1
set ::RES [eof $f]
# Run the copy. Should not invoke -command now.
fcopy $f $g -size 2 -command ::cmd
# Check that -command was not called synchronously
lappend ::RES [expr {([llength $::RES] > 1) ? "sync/FAIL" : "sync/OK"}]
|
| ︙ | ︙ | |||
7700 7701 7702 7703 7704 7705 7706 |
}
# Files we use for our channels
set foo [makeFile ashgdfashdgfasdhgfasdhgf foo]
set bar [makeFile {} bar]
# Channels to copy between
set f [open $foo r] ; fconfigure $f -translation binary
set g [open $bar w] ; fconfigure $g -translation binary -buffering none
| | | 7739 7740 7741 7742 7743 7744 7745 7746 7747 7748 7749 7750 7751 7752 7753 |
}
# Files we use for our channels
set foo [makeFile ashgdfashdgfasdhgfasdhgf foo]
set bar [makeFile {} bar]
# Channels to copy between
set f [open $foo r] ; fconfigure $f -translation binary
set g [open $bar w] ; fconfigure $g -translation binary -buffering none
} -constraints {stdio fcopy} -body {
set ::RES {}
# Run the copy. Should not invoke -command now.
fcopy $f $g -size 0 -command ::cmd
# Check that -command was not called synchronously
lappend ::RES [expr {([llength $::RES] > 1) ? "sync/FAIL" : "sync/OK"}]
# Now let the async part happen. Should capture the eof in cmd
# If not break the event loop via timer.
|
| ︙ | ︙ | |||
7757 7758 7759 7760 7761 7762 7763 |
}
proc ::done args {
set ::forever OK
return
}
set ::forever {}
set out [open $out w]
| | | 7796 7797 7798 7799 7800 7801 7802 7803 7804 7805 7806 7807 7808 7809 7810 |
}
proc ::done args {
set ::forever OK
return
}
set ::forever {}
set out [open $out w]
} -constraints {stdio fcopy} -body {
fcopy $pipe $out -size 6 -command ::done
set token [after 5000 {
set ::forever {fcopy hangs}
}]
vwait ::forever
catch {after cancel $token}
set ::forever
|
| ︙ | ︙ | |||
7827 7828 7829 7830 7831 7832 7833 |
}
set a [socket 127.0.0.1 9999]
set b [socket 127.0.0.1 9999]
fconfigure $a -translation binary -buffering none
fconfigure $b -translation binary -buffering none
fileevent $a readable [list ::done $a]
fileevent $b readable [list ::done $b]
| | | 7866 7867 7868 7869 7870 7871 7872 7873 7874 7875 7876 7877 7878 7879 7880 |
}
set a [socket 127.0.0.1 9999]
set b [socket 127.0.0.1 9999]
fconfigure $a -translation binary -buffering none
fconfigure $b -translation binary -buffering none
fileevent $a readable [list ::done $a]
fileevent $b readable [list ::done $b]
} -constraints {stdio fcopy} -body {
# Now pass data through the server in both directions.
set ::forever {}
puts $a AB
vwait ::forever
puts $b BA
vwait ::forever
set ::forever
|
| ︙ | ︙ | |||
7875 7876 7877 7878 7879 7880 7881 |
set done
} -cleanup {
close $outChan
close $inChan
removeFile out
removeFile in
} -result {40 bytes copied}
| | | 7914 7915 7916 7917 7918 7919 7920 7921 7922 7923 7924 7925 7926 7927 7928 |
set done
} -cleanup {
close $outChan
close $inChan
removeFile out
removeFile in
} -result {40 bytes copied}
test io-53.12 {CopyData: foreground short reads, aka bug 3096275} {stdio unix fcopy} {
file delete $path(pipe)
set f1 [open $path(pipe) w]
puts -nonewline $f1 {
fconfigure stdin -translation binary -blocking 0
fconfigure stdout -buffering none -translation binary
fcopy stdin stdout
}
|
| ︙ | ︙ | |||
8290 8291 8292 8293 8294 8295 8296 |
vwait [namespace which -variable result]
close $s
close $s2
close $server
set result
} {1 readable 234567890 timer}
| | | 8329 8330 8331 8332 8333 8334 8335 8336 8337 8338 8339 8340 8341 8342 8343 |
vwait [namespace which -variable result]
close $s
close $s2
close $server
set result
} {1 readable 234567890 timer}
test io-58.1 {Tcl_NotifyChannel and error when closing} {stdio unixOrWin fileevent} {
set out [open $path(script) w]
puts $out {
puts "normal message from pipe"
puts stderr "error message from pipe"
exit 1
}
proc readit {pipe} {
|
| ︙ | ︙ | |||
8330 8331 8332 8333 8334 8335 8336 |
set f [open $path(longfile) r]
set result [testchannel mthread $f]
close $f
string equal $result [testmainthread]
} {1}
| | | 8369 8370 8371 8372 8373 8374 8375 8376 8377 8378 8379 8380 8381 8382 8383 |
set f [open $path(longfile) r]
set result [testchannel mthread $f]
close $f
string equal $result [testmainthread]
} {1}
test io-60.1 {writing illegal utf sequences} {fileevent testbytestring} {
# This test will hang in older revisions of the core.
set out [open $path(script) w]
puts $out "catch {load $::tcltestlib Tcltest}"
puts $out {
puts [testbytestring \xe2]
exit 1
|
| ︙ | ︙ |
Changes to tests/ioCmd.test.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 | # Copyright (c) 1991-1994 The Regents of the University of California. # 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. | | | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 |
# Copyright (c) 1991-1994 The Regents of the University of California.
# 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 {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
|
| ︙ | ︙ |
Changes to tests/ioTrans.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # -*- tcl -*- # Functionality covered: operation of the reflected transformation # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 2007 Andreas Kupries <andreask@activestate.com> # <akupries@shaw.ca> # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
# -*- tcl -*-
# Functionality covered: operation of the reflected transformation
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 2007 Andreas Kupries <andreask@activestate.com>
# <akupries@shaw.ca>
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
|
| ︙ | ︙ | |||
32 33 34 35 36 37 38 |
## Testing the reflected transformation.
# Helper commands to record the arguments to handler methods. Stored in a
# script so that the tests needing this code do not need their own copy but
# can access this variable.
set helperscript {
| | | 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 |
## Testing the reflected transformation.
# Helper commands to record the arguments to handler methods. Stored in a
# script so that the tests needing this code do not need their own copy but
# can access this variable.
set helperscript {
if {"::tcltest" ni [namespace children]} {
package require tcltest 2
namespace import -force ::tcltest::*
}
# This forces the return options to be in the order that the test expects!
variable optorder {
-code !?! -level !?! -errorcode !?! -errorline !?! -errorinfo !?!
|
| ︙ | ︙ |
Changes to tests/join.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # Commands covered: join # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (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. | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
# Commands covered: join
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (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 {"::tcltest" ni [namespace children]} {
package require tcltest
namespace import -force ::tcltest::*
}
test join-1.1 {basic join commands} {
join {a b c} xyz
} axyzbxyzc
|
| ︙ | ︙ |
Changes to tests/lindex.test.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 | # Copyright (c) 1994 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # 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. | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
|
| ︙ | ︙ |
Changes to tests/linsert.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # Commands covered: linsert # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (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. | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
# Commands covered: linsert
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (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 {"::tcltest" ni [namespace children]} {
package require tcltest
namespace import -force ::tcltest::*
}
catch {unset lis}
catch {rename p ""}
|
| ︙ | ︙ |
Changes to tests/list.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # Commands covered: list # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (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. | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
# Commands covered: list
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (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 {"::tcltest" ni [namespace children]} {
package require tcltest
namespace import -force ::tcltest::*
}
# First, a bunch of individual tests
test list-1.1 {basic tests} {list a b c} {a b c}
|
| ︙ | ︙ |
Changes to tests/listObj.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # Functionality covered: operation of the procedures in tclListObj.c that # implement the Tcl type manager for the list object type. # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1995-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. | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
# Functionality covered: operation of the procedures in tclListObj.c that
# implement the Tcl type manager for the list object type.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1995-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 {"::tcltest" ni [namespace children]} {
package require tcltest
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
|
| ︙ | ︙ |
Changes to tests/llength.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # Commands covered: llength # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (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. | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
# Commands covered: llength
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (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 {"::tcltest" ni [namespace children]} {
package require tcltest
namespace import -force ::tcltest::*
}
test llength-1.1 {length of list} {
llength {a b c d}
} 4
|
| ︙ | ︙ |
Changes to tests/load.test.
1 2 3 4 5 6 7 8 9 10 11 12 | # Commands covered: load # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1995 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. | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 |
# Commands covered: load
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1995 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
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
|
| ︙ | ︙ |
Changes to tests/lpop.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # 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. | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
# 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 {"::tcltest" ni [namespace children]} {
package require tcltest
namespace import -force ::tcltest::*
}
unset -nocomplain no; # following tests expecting var "no" does not exists
test lpop-1.1 {error conditions} -returnCodes error -body {
lpop no
|
| ︙ | ︙ |
Changes to tests/lrange.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # Commands covered: lrange # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (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. | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
# Commands covered: lrange
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (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 {"::tcltest" ni [namespace children]} {
package require tcltest
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
|
| ︙ | ︙ |
Changes to tests/lrepeat.test.
1 2 3 4 5 6 7 8 9 10 11 | # Commands covered: lrepeat # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 2003 by Simon Geard. # # 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 |
# Commands covered: lrepeat
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 2003 by Simon Geard.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2
namespace import -force ::tcltest::*
}
## Arg errors
test lrepeat-1.1 {error cases} {
-body {
|
| ︙ | ︙ |
Changes to tests/lreplace.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # Commands covered: lreplace # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (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. | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
# Commands covered: lreplace
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (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 {"::tcltest" ni [namespace children]} {
package require tcltest
namespace import -force ::tcltest::*
}
test lreplace-1.1 {lreplace command} {
lreplace {1 2 3 4 5} 0 0 a
} {a 2 3 4 5}
|
| ︙ | ︙ |
Changes to tests/lsearch.test.
| ︙ | ︙ | |||
145 146 147 148 149 150 151 |
set res {}
for {set i 0} {$i < 100} {incr i} {
lappend res [lsearch -integer -decreasing -sorted \
$decreasingIntegers $i]
}
set res
} $decreasingIntegers
| | | | 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 |
set res {}
for {set i 0} {$i < 100} {incr i} {
lappend res [lsearch -integer -decreasing -sorted \
$decreasingIntegers $i]
}
set res
} $decreasingIntegers
test lsearch-5.3 {binary search finds leftmost occurrences} {
set res {}
for {set i 0} {$i < 10} {incr i} {
lappend res [lsearch -integer -sorted $repeatingIncreasingIntegers $i]
}
set res
} [list 0 5 10 15 20 25 30 35 40 45]
test lsearch-5.4 {binary search -decreasing finds leftmost occurrences} {
set res {}
for {set i 9} {$i >= 0} {incr i -1} {
lappend res [lsearch -sorted -integer -decreasing \
$repeatingDecreasingIntegers $i]
}
set res
} [list 0 5 10 15 20 25 30 35 40 45]
|
| ︙ | ︙ |
Changes to tests/lset.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # This file is a -*- tcl -*- test script # Commands covered: lset # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (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. | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
# This file is a -*- tcl -*- test script
# Commands covered: lset
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (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.
if {"::tcltest" ni [namespace children]} {
package require tcltest
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
|
| ︙ | ︙ |
Changes to tests/lsetComp.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # This file is a -*- tcl -*- test script # Commands covered: lset # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (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. | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
# This file is a -*- tcl -*- test script
# Commands covered: lset
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (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.
if {"::tcltest" ni [namespace children]} {
package require tcltest
namespace import -force ::tcltest::*
}
# Procedure to evaluate a script within a proc, to test compilation
# functionality
|
| ︙ | ︙ |
Changes to tests/macOSXFCmd.test.
1 2 3 4 5 6 7 8 9 10 11 | # This file tests the tclMacOSXFCmd.c file. # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 2003 Tcl Core Team. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
# This file tests the tclMacOSXFCmd.c file.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 2003 Tcl Core Team.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest
namespace import -force ::tcltest::*
}
# These tests really need to be run from a writable directory, which
# it is assumed [temporaryDirectory] is.
set oldcwd [pwd]
|
| ︙ | ︙ |
Changes to tests/macOSXLoad.test.
1 2 3 4 5 6 7 8 9 10 11 12 | # Commands covered: load unload # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1995 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. | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 |
# Commands covered: load unload
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1995 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
namespace import -force ::tcltest::*
}
set oldTSF $::tcltest::testSingleFile
set ::tcltest::testSingleFile false
if {[testConstraint unix] && $tcl_platform(os) eq "Darwin" &&
|
| ︙ | ︙ |
Changes to tests/main.test.
| ︙ | ︙ | |||
609 610 611 612 613 614 615 |
catch {chan configure $f -blocking 0}
} -body {
type $f "chan configure stdin -eofchar \\032
if 1 \{\n\032"
variable wait
chan event $f readable \
[list set [namespace which -variable wait] "child exit"]
| | | 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 |
catch {chan configure $f -blocking 0}
} -body {
type $f "chan configure stdin -eofchar \\032
if 1 \{\n\032"
variable wait
chan event $f readable \
[list set [namespace which -variable wait] "child exit"]
set id [after 5000 [list set [namespace which -variable wait] timeout]]
vwait [namespace which -variable wait]
after cancel $id
set wait
} -cleanup {
if {$wait eq "timeout" && [testConstraint unix]} {
exec kill [pid $f]
}
|
| ︙ | ︙ | |||
632 633 634 635 636 637 638 |
set cmd {makeFile "if 1 \{" script}
catch {set f [open "|[list [interpreter]] < [list [eval $cmd]]" r]}
catch {chan configure $f -blocking 0}
} -body {
variable wait
chan event $f readable \
[list set [namespace which -variable wait] "child exit"]
| | | 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 |
set cmd {makeFile "if 1 \{" script}
catch {set f [open "|[list [interpreter]] < [list [eval $cmd]]" r]}
catch {chan configure $f -blocking 0}
} -body {
variable wait
chan event $f readable \
[list set [namespace which -variable wait] "child exit"]
set id [after 5000 [list set [namespace which -variable wait] timeout]]
vwait [namespace which -variable wait]
after cancel $id
set wait
} -cleanup {
if {$wait eq "timeout" && [testConstraint unix]} {
exec kill [pid $f]
}
|
| ︙ | ︙ |
Changes to tests/mathop.test.
1 2 3 4 5 6 7 8 9 10 11 12 | # Commands covered: ::tcl::mathop::... # # This file contains a collection of tests for one or more of the Tcl built-in # commands. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # # Copyright (c) 2006 Donal K. Fellows # Copyright (c) 2006 Peter Spjuth # # 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 |
# Commands covered: ::tcl::mathop::...
#
# This file contains a collection of tests for one or more of the Tcl built-in
# commands. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
#
# Copyright (c) 2006 Donal K. Fellows
# Copyright (c) 2006 Peter Spjuth
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.1
namespace import -force ::tcltest::*
}
# A namespace to test that operators are exported and that they
# work when imported
namespace eval ::testmathop2 {
|
| ︙ | ︙ |
Changes to tests/misc.test.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 | # Copyright (c) 1992-1993 The Regents of the University of California. # 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. | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
# Copyright (c) 1992-1993 The Regents of the University of California.
# 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 {"::tcltest" ni [namespace children]} {
package require tcltest
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
|
| ︙ | ︙ |
Changes to tests/namespace.test.
| ︙ | ︙ | |||
3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 |
namespace ensemble create
}
} -body {
namespace-56.5 cmd
} -cleanup {
namespace delete namespace-56.5
} -result 1
# cleanup
catch {rename cmd1 {}}
catch {unset l}
catch {unset msg}
catch {unset trigger}
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
namespace ensemble create
}
} -body {
namespace-56.5 cmd
} -cleanup {
namespace delete namespace-56.5
} -result 1
test namespace-57.0 {
an imported alias should be usable in the deletion trace for the alias
see 29e8848eb976
} -body {
variable res {}
namespace eval ns2 {
namespace export *
proc p1 {oldname newname op} {
return success
}
interp alias {} [namespace current]::p2 {} [namespace which p1]
}
namespace eval ns3 {
namespace import ::ns2::p2
}
set ondelete [list apply [list {oldname newname op} {
variable res
catch {
ns3::p2 $oldname $newname $op
} cres
lappend res $cres
} [namespace current]]]
trace add command ::ns2::p2 delete $ondelete
rename ns2::p2 {}
return $res
} -cleanup {
unset res
namespace delete ns2
namespace delete ns3
} -result success
# cleanup
catch {rename cmd1 {}}
catch {unset l}
catch {unset msg}
catch {unset trigger}
|
| ︙ | ︙ |
Changes to tests/notify.test.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 | # generates output for errors. No output means no errors were found. # # Copyright (c) 2003 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. | | | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 |
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 2003 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
|
| ︙ | ︙ |
Changes to tests/nre.test.
1 2 3 4 5 6 7 8 9 10 11 | # Commands covered: proc, apply, [interp alias], [namespce import] # # This file contains a collection of tests for the non-recursive executor that # avoids recursive calls to TEBC. Only the NRE behaviour is tested here, the # actual command functionality is tested in the specific test file. # # Copyright (c) 2008 by Miguel Sofer. # # 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 |
# Commands covered: proc, apply, [interp alias], [namespce import]
#
# This file contains a collection of tests for the non-recursive executor that
# avoids recursive calls to TEBC. Only the NRE behaviour is tested here, the
# actual command functionality is tested in the specific test file.
#
# Copyright (c) 2008 by Miguel Sofer.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
|
| ︙ | ︙ |
Changes to tests/obj.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # Functionality covered: this file contains a collection of tests for the # procedures in tclObj.c that implement Tcl's basic type support and the # type managers for the types boolean, double, and integer. # # Sourcing this file into Tcl runs the tests and generates output for # errors. No output means no errors were found. # # Copyright (c) 1995-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. | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
# Functionality covered: this file contains a collection of tests for the
# procedures in tclObj.c that implement Tcl's basic type support and the
# type managers for the types boolean, double, and integer.
#
# Sourcing this file into Tcl runs the tests and generates output for
# errors. No output means no errors were found.
#
# Copyright (c) 1995-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 {"::tcltest" ni [namespace children]} {
package require tcltest
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
|
| ︙ | ︙ |
Changes to tests/opt.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # Package covered: opt1.0/optparse.tcl # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1993 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. | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
# Package covered: opt1.0/optparse.tcl
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1991-1993 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 {"::tcltest" ni [namespace children]} {
package require tcltest
namespace import -force ::tcltest::*
}
# the package we are going to test
package require opt 0.4.7
|
| ︙ | ︙ |
Changes to tests/package.test.
| ︙ | ︙ | |||
16 17 18 19 20 21 22 |
package require tcltest 2.3.3
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
| | | | 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 |
package require tcltest 2.3.3
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
# Do all this in a child interp to avoid garbaging the package list
set i [interp create]
tcltest::loadIntoChildInterpreter $i {*}$argv
catch [list load {} Tcltest $i]
interp eval $i {
namespace import -force ::tcltest::*
#package forget {*}[package names]
set oldPkgUnknown [package unknown]
package unknown {}
set oldPath $auto_path
|
| ︙ | ︙ | |||
941 942 943 944 945 946 947 |
test package-4.56 {Tcl_PackageCmd procedure, "vsatisfies" option} -body {
package vsatisfies 2.1 x.y-3.2
} -returnCodes error -result {expected version number but got "x.y"}
# No tests for FindPackage; can't think up anything detectable errors.
test package-5.1 {TclFreePackageInfo procedure} {
| | | | | 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 |
test package-4.56 {Tcl_PackageCmd procedure, "vsatisfies" option} -body {
package vsatisfies 2.1 x.y-3.2
} -returnCodes error -result {expected version number but got "x.y"}
# No tests for FindPackage; can't think up anything detectable errors.
test package-5.1 {TclFreePackageInfo procedure} {
interp create child
child eval {
package ifneeded t 2.3 x
package ifneeded t 2.4 y
package ifneeded x 3.1 z
package provide q 4.3
package unknown "will this get freed?"
}
interp delete child
} {}
test package-5.2 {TclFreePackageInfo procedure} -body {
interp create foo
foo eval {
package ifneeded t 2.3 x
package ifneeded t 2.4 y
package ifneeded x 3.1 z
|
| ︙ | ︙ |
Changes to tests/pid.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # Commands covered: pid # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1995 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. | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
# Commands covered: pid
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1995 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
namespace import -force ::tcltest::*
}
testConstraint pidDefined [llength [info commands pid]]
test pid-1.1 {pid command} pidDefined {
|
| ︙ | ︙ |
Changes to tests/proc-old.test.
| ︙ | ︙ | |||
10 11 12 13 14 15 16 | # Copyright (c) 1991-1993 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. | | | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# Copyright (c) 1991-1993 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 {"::tcltest" ni [namespace children]} {
package require tcltest
namespace import -force ::tcltest::*
}
catch {rename t1 ""}
catch {rename foo ""}
|
| ︙ | ︙ |
Changes to tests/process.test.
1 2 3 4 5 6 7 8 9 10 | # process.test -- # # This file contains a collection of tests for the tcl::process ensemble. # Sourcing this file into Tcl runs the tests and generates output for # errors. No output means no errors were found. # # Copyright (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. | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 |
# process.test --
#
# This file contains a collection of tests for the tcl::process ensemble.
# Sourcing this file into Tcl runs the tests and generates output for
# errors. No output means no errors were found.
#
# Copyright (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.
if {"::tcltest" ni [namespace children]} {
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]
|
| ︙ | ︙ |
Changes to tests/pwd.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # Commands covered: pwd # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1993 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. | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
# Commands covered: pwd
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1991-1993 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 {"::tcltest" ni [namespace children]} {
package require tcltest 2
namespace import -force ::tcltest::*
}
test pwd-1.1 {simple pwd} {
catch pwd
} 0
|
| ︙ | ︙ |
Changes to tests/reg.test.
1 2 3 4 5 6 7 8 9 10 11 | # reg.test -- # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # (Don't panic if you are seeing this as part of the reg distribution # and aren't using Tcl -- reg's own regression tester also knows how # to read this file, ignoring the Tcl-isms.) # # Copyright (c) 1998, 1999 Henry Spencer. All rights reserved. | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
# reg.test --
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
# (Don't panic if you are seeing this as part of the reg distribution
# and aren't using Tcl -- reg's own regression tester also knows how
# to read this file, ignoring the Tcl-isms.)
#
# Copyright (c) 1998, 1999 Henry Spencer. All rights reserved.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
# All tests require the testregexp command, return if this
|
| ︙ | ︙ | |||
622 623 624 625 626 627 628 629 630 631 632 633 634 635 |
expectMatch 13.11 LMP "a\\e" "a\033" "a\033"
expectMatch 13.12 P "a\\fb" "a\fb" "a\fb"
expectMatch 13.13 P "a\\nb" "a\nb" "a\nb"
expectMatch 13.14 P "a\\rb" "a\rb" "a\rb"
expectMatch 13.15 P "a\\tb" "a\tb" "a\tb"
expectMatch 13.16 P "a\\u0008x" "a\bx" "a\bx"
expectMatch 13.17 P {a\u008x} "a\bx" "a\bx"
expectMatch 13.18 P "a\\u00088x" "a\b8x" "a\b8x"
expectMatch 13.19 P "a\\U00000008x" "a\bx" "a\bx"
expectMatch 13.20 P {a\U0000008x} "a\bx" "a\bx"
expectMatch 13.21 P "a\\vb" "a\vb" "a\vb"
expectMatch 13.22 MP "a\\x08x" "a\bx" "a\bx"
expectError 13.23 - {a\xq} EESCAPE
expectMatch 13.24 MP "a\\x08x" "a\bx" "a\bx"
| > | 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 |
expectMatch 13.11 LMP "a\\e" "a\033" "a\033"
expectMatch 13.12 P "a\\fb" "a\fb" "a\fb"
expectMatch 13.13 P "a\\nb" "a\nb" "a\nb"
expectMatch 13.14 P "a\\rb" "a\rb" "a\rb"
expectMatch 13.15 P "a\\tb" "a\tb" "a\tb"
expectMatch 13.16 P "a\\u0008x" "a\bx" "a\bx"
expectMatch 13.17 P {a\u008x} "a\bx" "a\bx"
expectError 13.17.1 - {a\ux} EESCAPE
expectMatch 13.18 P "a\\u00088x" "a\b8x" "a\b8x"
expectMatch 13.19 P "a\\U00000008x" "a\bx" "a\bx"
expectMatch 13.20 P {a\U0000008x} "a\bx" "a\bx"
expectMatch 13.21 P "a\\vb" "a\vb" "a\vb"
expectMatch 13.22 MP "a\\x08x" "a\bx" "a\bx"
expectError 13.23 - {a\xq} EESCAPE
expectMatch 13.24 MP "a\\x08x" "a\bx" "a\bx"
|
| ︙ | ︙ |
Changes to tests/regexpComp.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # Commands covered: regexp, regsub # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1998 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. | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
# Commands covered: regexp, regsub
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1998 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
namespace import -force ::tcltest::*
}
# Procedure to evaluate a script within a proc, to test compilation
# functionality
|
| ︙ | ︙ |
Changes to tests/registry.test.
1 2 3 4 5 6 7 8 9 10 11 12 | # registry.test -- # # This file contains a collection of tests for the registry command. # Sourcing this file into Tcl runs the tests and generates output for # errors. No output means no errors were found. # # In order for these tests to run, the registry package must be on the # auto_path or the registry package must have been loaded already. # # Copyright (c) 1997 by Sun Microsystems, Inc. All rights reserved. # Copyright (c) 1998-1999 by Scriptics Corporation. | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 |
# registry.test --
#
# This file contains a collection of tests for the registry command.
# Sourcing this file into Tcl runs the tests and generates output for
# errors. No output means no errors were found.
#
# In order for these tests to run, the registry package must be on the
# auto_path or the registry package must have been loaded already.
#
# Copyright (c) 1997 by Sun Microsystems, Inc. All rights reserved.
# Copyright (c) 1998-1999 by Scriptics Corporation.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2
namespace import -force ::tcltest::*
}
testConstraint reg 0
if {[testConstraint win]} {
if {![catch {
|
| ︙ | ︙ |
Changes to tests/rename.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # Commands covered: rename # # This file contains a collection of tests for one or more of the Tcl built-in # commands. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # # Copyright (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. | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
# Commands covered: rename
#
# This file contains a collection of tests for one or more of the Tcl built-in
# commands. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
#
# Copyright (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 {"::tcltest" ni [namespace children]} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
|
| ︙ | ︙ |
Changes to tests/safe.test.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 | # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. package require Tcl 8.5- | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
# 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 Tcl 8.5-
if {"::tcltest" ni [namespace children]} {
package require tcltest 2
namespace import -force ::tcltest::*
}
foreach i [interp slaves] {
interp delete $i
}
|
| ︙ | ︙ |
Changes to tests/scan.test.
| ︙ | ︙ | |||
551 552 553 554 555 556 557 558 559 560 561 562 563 564 |
} -returnCodes 1 -result {unsigned bignum scans are invalid}
test scan-5.19 {bigint scanning invalid} -setup {
set a {};
} -body {
list [scan "207698809136909011942886895" \
%llu a] $a
} -result {1 207698809136909011942886895}
test scan-6.1 {floating-point scanning} -setup {
set a {}; set b {}; set c {}; set d {}
} -body {
list [scan "2.1 -3.0e8 .99962 a" "%f%g%e%f" a b c d] $a $b $c $d
} -result {3 2.1 -300000000.0 0.99962 {}}
test scan-6.2 {floating-point scanning} -setup {
| > > > > > | 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 |
} -returnCodes 1 -result {unsigned bignum scans are invalid}
test scan-5.19 {bigint scanning invalid} -setup {
set a {};
} -body {
list [scan "207698809136909011942886895" \
%llu a] $a
} -result {1 207698809136909011942886895}
test scan-5.20 {ignore digit separators} -setup {
set a {}; set b {}; set c {};
} -body {
list [scan "10_23_45" %d_%d_%d a b c] $a $b $c
} -result {3 10 23 45}
test scan-6.1 {floating-point scanning} -setup {
set a {}; set b {}; set c {}; set d {}
} -body {
list [scan "2.1 -3.0e8 .99962 a" "%f%g%e%f" a b c d] $a $b $c $d
} -result {3 2.1 -300000000.0 0.99962 {}}
test scan-6.2 {floating-point scanning} -setup {
|
| ︙ | ︙ | |||
596 597 598 599 600 601 602 603 604 605 606 607 608 609 |
list [scan "4.6abc" "%f %f %f %f" a b c d] $a $b $c $d
} -result {1 4.6 {} {} {}}
test scan-6.8 {floating-point scanning} -setup {
set a {}; set b {}; set c {}; set d {}
} -body {
list [scan "4.6 5.2" "%f %f %f %f" a b c d] $a $b $c $d
} -result {2 4.6 5.2 {} {}}
test scan-7.1 {string and character scanning} -setup {
set a {}; set b {}; set c {}; set d {}
} -body {
list [scan "abc defghijk dum " "%s %3s %20s %s" a b c d] $a $b $c $d
} -result {4 abc def ghijk dum}
test scan-7.2 {string and character scanning} -setup {
| > > > > > | 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 |
list [scan "4.6abc" "%f %f %f %f" a b c d] $a $b $c $d
} -result {1 4.6 {} {} {}}
test scan-6.8 {floating-point scanning} -setup {
set a {}; set b {}; set c {}; set d {}
} -body {
list [scan "4.6 5.2" "%f %f %f %f" a b c d] $a $b $c $d
} -result {2 4.6 5.2 {} {}}
test scan-6.8 {disallow diget separator in floating-point} -setup {
set a {}; set b {}; set c {};
} -body {
list [scan "3.14_2.35_98.6" %f_%f_%f a b c ] $a $b $c
} -result {3 3.14 2.35 98.6}
test scan-7.1 {string and character scanning} -setup {
set a {}; set b {}; set c {}; set d {}
} -body {
list [scan "abc defghijk dum " "%s %3s %20s %s" a b c d] $a $b $c $d
} -result {4 abc def ghijk dum}
test scan-7.2 {string and character scanning} -setup {
|
| ︙ | ︙ |
Changes to tests/set-old.test.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 | # Copyright (c) 1991-1993 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. | | | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 |
# Copyright (c) 1991-1993 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 {"::tcltest" ni [namespace children]} {
package require tcltest 2
namespace import -force ::tcltest::*
}
proc ignore args {}
# Simple variable operations.
|
| ︙ | ︙ |
Changes to tests/set.test.
1 2 3 4 5 6 7 8 9 10 11 12 | # Commands covered: set # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 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. | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 |
# Commands covered: set
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 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 {"::tcltest" ni [namespace children]} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
|
| ︙ | ︙ |
Changes to tests/socket.test.
| ︙ | ︙ | |||
56 57 58 59 60 61 62 | # either in Tcl or in the environment; if they are, it attempts to connect to # the server. If the connection is successful, the tests using the remote # server will be performed; otherwise, it will attempt to start the remote # server (via exec) on platforms that support this, on the local host, # listening at port 2048. If all fails, a message is printed and the tests # using the remote server are not performed. | | > | 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 |
# either in Tcl or in the environment; if they are, it attempts to connect to
# the server. If the connection is successful, the tests using the remote
# server will be performed; otherwise, it will attempt to start the remote
# server (via exec) on platforms that support this, on the local host,
# listening at port 2048. If all fails, a message is printed and the tests
# using the remote server are not performed.
if {"::tcltest" ni [namespace children]} {
package require tcltest
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
::tcltest::loadTestedCommands
if {[expr {[info exists ::env(TRAVIS_OSX_IMAGE)] && [string match xcode* $::env(TRAVIS_OSX_IMAGE)]}]} {
return
}
# Some tests require the Thread package or exec command
testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}]
|
| ︙ | ︙ | |||
928 929 930 931 932 933 934 |
test socket_$af-5.1 {byte order problems, socket numbers, htons} -body {
if {![catch {socket -server dodo 0x1} msg]} {
close $msg
return {htons problem, should be disallowed, are you running as SU?}
}
return {couldn't open socket: not owner}
| | | | 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 |
test socket_$af-5.1 {byte order problems, socket numbers, htons} -body {
if {![catch {socket -server dodo 0x1} msg]} {
close $msg
return {htons problem, should be disallowed, are you running as SU?}
}
return {couldn't open socket: not owner}
} -constraints [list socket supported_$af unix notRoot notOSX] -result {couldn't open socket: not owner}
test socket_$af-5.2 {byte order problems, socket numbers, htons} -body {
if {![catch {socket -server dodo 0x10000} msg]} {
close $msg
return {port resolution problem, should be disallowed}
}
return {couldn't open socket: port number too high}
} -constraints [list socket supported_$af] -result {couldn't open socket: port number too high}
test socket_$af-5.3 {byte order problems, socket numbers, htons} -body {
if {![catch {socket -server dodo 21} msg]} {
close $msg
return {htons problem, should be disallowed, are you running as SU?}
}
return {couldn't open socket: not owner}
} -constraints [list socket supported_$af unix notRoot notOSX] -result {couldn't open socket: not owner}
test socket_$af-6.1 {accept callback error} -constraints [list socket supported_$af stdio] -setup {
proc myHandler {msg options} {
variable x $msg
}
set handler [interp bgerror {}]
interp bgerror {} [namespace which myHandler]
|
| ︙ | ︙ | |||
1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 |
puts $s "hello"
gets $s result
}
close $s
thread::release $serverthread
append result " " [llength [thread::names]]
} -result {hello 1} -constraints [list socket supported_$af thread]
# ----------------------------------------------------------------------
removeFile script1
removeFile script2
# cleanup
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 |
puts $s "hello"
gets $s result
}
close $s
thread::release $serverthread
append result " " [llength [thread::names]]
} -result {hello 1} -constraints [list socket supported_$af thread]
proc transf_test {{testmode transfer} {maxIter 1000} {maxTime 10000}} {
try {
set ::count 0
set ::testmode $testmode
set port 0
set srvsock {}
# if binding on port 0 is not possible (system related, blocked on ISPs etc):
if {[catch {close [socket -async $::localhost $port]}]} {
# simplest server on random port (immediatelly closing a connect):
set port [randport]
set srvsock [socket -server {apply {{ch args} {close $ch}}} -myaddr $::localhost $port]
# socket on windows has some issues yet (e. g. bug [b6d0d8cc2c]), so we simply decrease iteration count (to 1/4):
if {$::tcl_platform(platform) eq "windows" && $maxIter > 50} {
set ::count [expr {$maxIter / 4 * 3 - 1}]; # bypass 3/4 iterations
}
}
tcltest::DebugPuts 1 "== test \[$::localhost\]:$port $testmode =="
set ::master [thread::id]
# helper thread creating async connection and initiating transfer (detach) to master:
set ::helper [thread::create]
thread::send -async $::helper [list \
lassign [list $::master $::localhost $port $testmode] \
::master ::localhost ::port ::testmode
]
thread::send -async $::helper {
set ::helper [thread::id]
proc iteration {args} {
set fd [socket -async $::localhost $::port]
if {"helper-writable" in $::testmode} {;# to test both sides during connect
fileevent $fd writable [list apply {{fd} {
if {[thread::id] ne $::helper} {
thread::send -async $::master {set ::count "ERROR: invalid thread, $::helper is expecting"}
close $fd
return
}
}} $fd]
};#
thread::detach $fd
thread::send -async $::master [list transf_master $fd {*}$args]
}
iteration first
}
# master proc commiting transfer attempt (attach) and checking acquire was successful:
proc transf_master {fd args} {
tcltest::DebugPuts 1 "** trma / $::count ** $args **"
thread::attach $fd
if {"master-close" in $::testmode} {;# to test close during connect
set ::count $::count
close $fd
return
};#
fileevent $fd writable [list apply {{fd} {
if {[thread::id] ne $::master} {
thread::send -async $::master {set ::count "ERROR: invalid thread, $::master is expecting"}
close $fd
return
}
set ::count $::count
close $fd
}} $fd]
}
# repeat maxIter times (up to maxTime ms as timeout):
set tout [after $maxTime {set ::count "TIMEOUT"}]
while 1 {
vwait ::count
if {![string is integer $::count]} {
# if timeout just skip (test was successful until now):
if {$::count eq "TIMEOUT"} {::tcltest::Skip "timing issue"}
break
}
if {[incr ::count] >= $maxIter} break
tcltest::DebugPuts 1 "** iter / $::count **"
thread::send -async $::helper [list iteration nr $::count]
}
update
set ::count
} finally {
catch {after cancel $tout}
if {$srvsock ne {}} {close $srvsock}
if {[info exists ::helper]} {thread::release -wait $::helper}
tcltest::DebugPuts 1 "== stop / $::count =="
unset -nocomplain ::count ::testmode ::master ::helper
}
}
test socket_$af-13.2.tr1 {Testing socket transfer between threads during async connect} -body {
transf_test {transfer} 1000
} -result 1000 -constraints [list socket supported_$af thread]
test socket_$af-13.2.tr2 {Testing socket transfer between threads during async connect} -body {
transf_test {transfer helper-writable} 100
} -result 100 -constraints [list socket supported_$af thread]
test socket_$af-13.2.cl1 {Testing socket transfer between threads during async connect} -body {
transf_test {master-close} 100
} -result 100 -constraints [list socket supported_$af thread]
test socket_$af-13.2.cl2 {Testing socket transfer between threads during async connect} -body {
transf_test {master-close helper-writable} 100
} -result 100 -constraints [list socket supported_$af thread]
catch {rename transf_master {}}
rename transf_test {}
# ----------------------------------------------------------------------
removeFile script1
removeFile script2
# cleanup
|
| ︙ | ︙ |
Changes to tests/split.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # Commands covered: split # # This file contains a collection of tests for one or more of the Tcl built-in # commands. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # # Copyright (c) 1991-1993 The Regents of the University of California. # 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. | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
# Commands covered: split
#
# This file contains a collection of tests for one or more of the Tcl built-in
# commands. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# 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 {"::tcltest" ni [namespace children]} {
package require tcltest
namespace import -force ::tcltest::*
}
test split-1.1 {basic split commands} {
split "a\n b\t\r c\n "
} {a {} b {} {} c {} {}}
|
| ︙ | ︙ | |||
67 68 69 70 71 72 73 |
test split-1.13 {basic split commands} {
split "12,34,56," {,}
} {12 34 56 {}}
test split-1.14 {basic split commands} {
split ",12,,,34,56," {,}
} {{} 12 {} {} 34 56 {}}
test split-1.15 {basic split commands} -body {
| | | > > > | 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 |
test split-1.13 {basic split commands} {
split "12,34,56," {,}
} {12 34 56 {}}
test split-1.14 {basic split commands} {
split ",12,,,34,56," {,}
} {{} 12 {} {} 34 56 {}}
test split-1.15 {basic split commands} -body {
split "a\U1F4A9b" {}
} -result "a \U1F4A9 b"
test split-1.16 {basic split commands} -body {
split "a\U1F4A9b" \U1F4A9
} -result "a b"
test split-2.1 {split errors} {
list [catch split msg] $msg $errorCode
} {1 {wrong # args: should be "split string ?splitChars?"} {TCL WRONGARGS}}
test split-2.2 {split errors} {
list [catch {split a b c} msg] $msg $errorCode
} {1 {wrong # args: should be "split string ?splitChars?"} {TCL WRONGARGS}}
|
| ︙ | ︙ |
Changes to tests/string.test.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 | # Copyright (c) 1994 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # 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. | | > | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 |
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# 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.
if {"::tcltest" ni [namespace children]} {
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 fullutf [expr {[string length \U010000] == 1}]
testConstraint testbytestring [llength [info commands testbytestring]]
# Used for constraining memory leak tests
testConstraint memory [llength [info commands memory]]
if {[testConstraint memory]} {
proc getbytes {} {
set lines [split [memory info] \n]
return [lindex $lines 3 3]
|
| ︙ | ︙ | |||
772 773 774 775 776 777 778 |
test string-6.79.$noComp {string is upper, unicode false} {
list [run {string is upper -fail var ABC\xFCue}] $var
} {0 3}
test string-6.80.$noComp {string is wordchar, true} {
run {string is wordchar abc_123}
} 1
test string-6.81.$noComp {string is wordchar, unicode true} {
| | | 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 |
test string-6.79.$noComp {string is upper, unicode false} {
list [run {string is upper -fail var ABC\xFCue}] $var
} {0 3}
test string-6.80.$noComp {string is wordchar, true} {
run {string is wordchar abc_123}
} 1
test string-6.81.$noComp {string is wordchar, unicode true} {
run {string is wordchar abc\xFCab\xDCAB\u5001\U1D7CA}
} 1
test string-6.82.$noComp {string is wordchar, false} {
list [run {string is wordchar -fail var abcd.ef}] $var
} {0 4}
test string-6.83.$noComp {string is wordchar, unicode false} {
list [run {string is wordchar -fail var abc\x80def}] $var
} {0 3}
|
| ︙ | ︙ | |||
1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 |
} {}
test string-20.5.$noComp {string trimright} {
run {string trimright ""}
} {}
test string-20.6.$noComp {string trimright, unicode default} {
run {string trimright ABC\u1361\x85\x00\xA0\u1680\u180E\u2000\u2001\u2002\u2003\u2004\u2005\u2006\u2007\u2008\u2009\u200A\u200B\u2028\u2029\u202F\u205F\u3000}
} ABC\u1361
test string-21.1.$noComp {string wordend} -body {
list [catch {run {string wordend a}} msg] $msg
} -result {1 {wrong # args: should be "string wordend string index"}}
test string-21.2.$noComp {string wordend} -body {
list [catch {run {string wordend a b c}} msg] $msg
} -result {1 {wrong # args: should be "string wordend string index"}}
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
} {}
test string-20.5.$noComp {string trimright} {
run {string trimright ""}
} {}
test string-20.6.$noComp {string trimright, unicode default} {
run {string trimright ABC\u1361\x85\x00\xA0\u1680\u180E\u2000\u2001\u2002\u2003\u2004\u2005\u2006\u2007\u2008\u2009\u200A\u200B\u2028\u2029\u202F\u205F\u3000}
} ABC\u1361
test string-20.7.$noComp {string trim on not valid utf-8 sequence (consider NTS as continuation char), bug [c61818e4c9]} {testbytestring} {
set result {}
set a [testbytestring \xC0\x80\xA0]
set b foo$a
set m [list \x00 U \xA0 V [testbytestring \xA0] W]
lappend result [string map $m $b]
lappend result [string map $m [run {string trimright $b x}]]
lappend result [string map $m [run {string trimright $b \x00}]]
lappend result [string map $m [run {string trimleft $b fox}]]
lappend result [string map $m [run {string trimleft $b fo\x00}]]
lappend result [string map $m [run {string trim $b fox}]]
lappend result [string map $m [run {string trim $b fo\x00}]]
} [list {*}[lrepeat 3 fooUV] {*}[lrepeat 2 UV V]]
test string-20.8.$noComp {[c61818e4c9] [string trimright] fails when UtfPrev is ok} {testbytestring} {
set result {}
set a [testbytestring \xE8\xA0]
set b foo$a
set m [list \xE8 U \xA0 V [testbytestring \xE8] W [testbytestring \xA0] X]]
lappend result [string map $m $b]
lappend result [string map $m [run {string trimright $b x}]]
lappend result [string map $m [run {string trimright $b \xE8}]]
lappend result [string map $m [run {string trimright $b [testbytestring \xE8]}]]
lappend result [string map $m [run {string trimright $b \xA0}]]
lappend result [string map $m [run {string trimright $b [testbytestring \xA0]}]]
lappend result [string map $m [run {string trimright $b \xE8\xA0}]]
lappend result [string map $m [run {string trimright $b [testbytestring \xE8\xA0]}]]
lappend result [string map $m [run {string trimright $b \u0000}]]
} [list {*}[lrepeat 4 fooUV] {*}[lrepeat 2 fooU] {*}[lrepeat 2 foo] fooUV]
test string-21.1.$noComp {string wordend} -body {
list [catch {run {string wordend a}} msg] $msg
} -result {1 {wrong # args: should be "string wordend string index"}}
test string-21.2.$noComp {string wordend} -body {
list [catch {run {string wordend a b c}} msg] $msg
} -result {1 {wrong # args: should be "string wordend string index"}}
|
| ︙ | ︙ | |||
1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 |
} -result 6
test string-21.13.$noComp {string wordend, unicode} -body {
run {string wordend "xyz\u2045de fg" 0}
} -result 3
test string-21.14.$noComp {string wordend, unicode} -body {
run {string wordend "\uC700\uC700 abc" 8}
} -result 6
test string-22.1.$noComp {string wordstart} -body {
list [catch {run {string word a}} msg] $msg
} -result {1 {unknown or ambiguous subcommand "word": must be bytelength, cat, compare, equal, first, index, insert, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}}
test string-22.2.$noComp {string wordstart} -body {
list [catch {run {string wordstart a}} msg] $msg
} -result {1 {wrong # args: should be "string wordstart string index"}}
| > > > > > > | 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 |
} -result 6
test string-21.13.$noComp {string wordend, unicode} -body {
run {string wordend "xyz\u2045de fg" 0}
} -result 3
test string-21.14.$noComp {string wordend, unicode} -body {
run {string wordend "\uC700\uC700 abc" 8}
} -result 6
test string-21.15.$noComp {string wordend, unicode} -body {
run {string wordend "\U1D7CA\U1D7CA abc" 0}
} -result 2
test string-21.16.$noComp {string wordend, unicode} -constraints fullutf -body {
run {string wordend "\U1D7CA\U1D7CA abc" 10}
} -result 6
test string-22.1.$noComp {string wordstart} -body {
list [catch {run {string word a}} msg] $msg
} -result {1 {unknown or ambiguous subcommand "word": must be bytelength, cat, compare, equal, first, index, insert, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}}
test string-22.2.$noComp {string wordstart} -body {
list [catch {run {string wordstart a}} msg] $msg
} -result {1 {wrong # args: should be "string wordstart string index"}}
|
| ︙ | ︙ | |||
1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 |
run {string wordstart "one tw\xC7o three" 7}
} -result 4
test string-22.12.$noComp {string wordstart, unicode} -body {
run {string wordstart "ab\uC700\uC700 cdef ghi" 12}
} -result 10
test string-22.13.$noComp {string wordstart, unicode} -body {
run {string wordstart "\uC700\uC700 abc" 8}
} -result 3
test string-23.0.$noComp {string is boolean, Bug 1187123} testindexobj {
set x 5
catch {testindexobj $x foo bar soom}
run {string is boolean $x}
} 0
| > > > > > > > > > > > | 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 |
run {string wordstart "one tw\xC7o three" 7}
} -result 4
test string-22.12.$noComp {string wordstart, unicode} -body {
run {string wordstart "ab\uC700\uC700 cdef ghi" 12}
} -result 10
test string-22.13.$noComp {string wordstart, unicode} -body {
run {string wordstart "\uC700\uC700 abc" 8}
} -result 3
test string-22.14.$noComp {string wordstart, invalid UTF-8} -constraints testbytestring -body {
# See Bug c61818e4c9
set demo [testbytestring "abc def\xE0\xA9ghi"]
run {string index $demo [string wordstart $demo 10]}
} -result g
test string-22.15.$noComp {string wordstart, unicode} -body {
run {string wordstart "\U1D7CA\U1D7CA abc" 0}
} -result 0
test string-22.16.$noComp {string wordstart, unicode} -constraints fullutf -body {
run {string wordstart "\U1D7CA\U1D7CA abc" 10}
} -result 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
|
| ︙ | ︙ |
Changes to tests/stringObj.test.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 | # # Copyright (c) 1995-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. | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
#
# Copyright (c) 1995-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 {"::tcltest" ni [namespace children]} {
package require tcltest
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
|
| ︙ | ︙ |
Changes to tests/subst.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # Commands covered: subst # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1994 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # Copyright (c) 1998-2000 Ajuba Solutions. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
# Commands covered: subst
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1994 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-2000 Ajuba Solutions.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.1
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testbytestring [llength [info commands testbytestring]]
|
| ︙ | ︙ |
Changes to tests/tailcall.test.
1 2 3 4 5 6 7 8 9 10 11 | # Commands covered: tailcall # # This file contains a collection of tests for experimental commands that are # found in ::tcl::unsupported. The tests will migrate to normal test files # if/when the commands find their way into the core. # # Copyright (c) 2008 by Miguel Sofer. # # 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 |
# Commands covered: tailcall
#
# This file contains a collection of tests for experimental commands that are
# found in ::tcl::unsupported. The tests will migrate to normal test files
# if/when the commands find their way into the core.
#
# Copyright (c) 2008 by Miguel Sofer.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
|
| ︙ | ︙ |
Changes to tests/timer.test.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 | # # Copyright (c) 1997 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. | | | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 |
#
# Copyright (c) 1997 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
namespace import -force ::tcltest::*
}
test timer-1.1 {Tcl_CreateTimerHandler procedure} -setup {
foreach i [after info] {
after cancel $i
|
| ︙ | ︙ |
Changes to tests/unixFCmd.test.
1 2 3 4 5 6 7 8 9 10 11 | # This file tests the tclUnixFCmd.c file. # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1996 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
# This file tests the tclUnixFCmd.c file.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1996 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
|
| ︙ | ︙ |
Changes to tests/unixFile.test.
1 2 3 4 5 6 7 8 9 10 11 | # This file contains tests for the routines in the file tclUnixFile.c # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (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. | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
# This file contains tests for the routines in the file tclUnixFile.c
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (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
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
|
| ︙ | ︙ |
Changes to tests/unixNotfy.test.
1 2 3 4 5 6 7 8 9 10 11 12 | # This file contains tests for tclUnixNotfy.c. # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1997 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. | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 |
# This file contains tests for tclUnixNotfy.c.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1997 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
namespace import -force ::tcltest::*
}
# When run in a Tk shell, these tests hang.
testConstraint noTk [expr {0 != [catch {package present Tk}]}]
testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}]
|
| ︙ | ︙ |
Changes to tests/unload.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # Commands covered: unload # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1995 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # Copyright (c) 2003-2004 by Georgios Petasis # # 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 |
# Commands covered: unload
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1995 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# Copyright (c) 2003-2004 by Georgios Petasis
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
|
| ︙ | ︙ |
Changes to tests/uplevel.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # Commands covered: uplevel # # This file contains a collection of tests for one or more of the Tcl built-in # commands. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # # Copyright (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. | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
# Commands covered: uplevel
#
# This file contains a collection of tests for one or more of the Tcl built-in
# commands. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
#
# Copyright (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 {"::tcltest" ni [namespace children]} {
package require tcltest
namespace import -force ::tcltest::*
}
proc a {x y} {
newset z [expr $x+$y]
return $z
|
| ︙ | ︙ |
Changes to tests/upvar.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # Commands covered: 'upvar', 'namespace upvar' # # This file contains a collection of tests for one or more of the Tcl built-in # commands. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # # Copyright (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. | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
# Commands covered: 'upvar', 'namespace upvar'
#
# This file contains a collection of tests for one or more of the Tcl built-in
# commands. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
#
# Copyright (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 {"::tcltest" ni [namespace children]} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
|
| ︙ | ︙ |
Changes to tests/utf.test.
1 2 3 4 5 6 7 8 9 10 | # This file contains a collection of tests for tclUtf.c # Sourcing this file into Tcl runs the tests and generates output for # errors. No output means no errors were found. # # Copyright (c) 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. | | > > > > > > > > > > > > > > > > > > > > < < < | | | | | | > > > | | | | | | | | | | | | | | | | | | | | | | | | | > > > | | | | | | > > > | | > | | | | < < < < | | | | | | | | | | | | | | | | | | | | > > > | | > > > > > > > > > > > > | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | > > > > > > > > > | > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > | > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | > | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 |
# This file contains a collection of tests for tclUtf.c
# Sourcing this file into Tcl runs the tests and generates output for
# errors. No output means no errors were found.
#
# Copyright (c) 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 {"::tcltest" ni [namespace children]} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint ucs2 [expr {[format %c 0x010000] eq "\uFFFD"}]
testConstraint fullutf [expr {[format %c 0x010000] ne "\uFFFD"}]
testConstraint utf16 [expr {[string length [format %c 0x10000]] == 2}]
testConstraint ucs4 [expr {[testConstraint fullutf]
&& [string length [format %c 0x10000]] == 1}]
testConstraint ucs2_utf16 [expr {![testConstraint ucs4]}]
testConstraint Uesc [expr {"\U0041" eq "A"}]
testConstraint pre388 [expr {"\x741" eq "A"}]
testConstraint pairsTo4bytes [expr {[llength [info commands teststringbytes]]
&& [string length [teststringbytes \uD83D\uDCA9]] == 4}]
testConstraint testbytestring [llength [info commands testbytestring]]
testConstraint testfindfirst [llength [info commands testfindfirst]]
testConstraint testfindlast [llength [info commands testfindlast]]
testConstraint testnumutfchars [llength [info commands testnumutfchars]]
testConstraint teststringobj [llength [info commands teststringobj]]
testConstraint testutfnext [llength [info commands testutfnext]]
testConstraint testutfprev [llength [info commands testutfprev]]
testConstraint tip413 [expr {[string trim \x00] eq {}}]
catch {unset x}
test utf-1.1 {Tcl_UniCharToUtf: 1 byte sequences} testbytestring {
expr {"\x01" eq [testbytestring \x01]}
} 1
test utf-1.2 {Tcl_UniCharToUtf: 2 byte sequences} testbytestring {
expr {"\x00" eq [testbytestring \xC0\x80]}
} 1
test utf-1.3 {Tcl_UniCharToUtf: 2 byte sequences} testbytestring {
expr {"\xE0" eq [testbytestring \xC3\xA0]}
} 1
test utf-1.4 {Tcl_UniCharToUtf: 3 byte sequences} testbytestring {
expr {"\u4E4E" eq [testbytestring \xE4\xB9\x8E]}
} 1
test utf-1.5 {Tcl_UniCharToUtf: overflowed Tcl_UniChar} testbytestring {
expr {[format %c 0x110000] eq [testbytestring \xEF\xBF\xBD]}
} 1
test utf-1.6 {Tcl_UniCharToUtf: negative Tcl_UniChar} testbytestring {
expr {[format %c -1] eq [testbytestring \xEF\xBF\xBD]}
} 1
test utf-1.7.0 {Tcl_UniCharToUtf: 4 byte sequences} {fullutf Uesc testbytestring} {
expr {"\U014E4E" eq [testbytestring \xF0\x94\xB9\x8E]}
} 1
test utf-1.7.1 {Tcl_UniCharToUtf: 4 byte sequences} {ucs2 Uesc testbytestring} {
expr {"\U014E4E" eq [testbytestring \xF0\x94\xB9\x8E]}
} 0
test utf-1.8 {Tcl_UniCharToUtf: 3 byte sequence, high surrogate} testbytestring {
expr {"\uD842" eq [testbytestring \xED\xA1\x82]}
} 1
test utf-1.9 {Tcl_UniCharToUtf: 3 byte sequence, low surrogate} testbytestring {
expr {"\uDC42" eq [testbytestring \xED\xB1\x82]}
} 1
test utf-1.10 {Tcl_UniCharToUtf: 3 byte sequence, high surrogate} testbytestring {
expr {[format %c 0xD842] eq [testbytestring \xED\xA1\x82]}
} 1
test utf-1.11 {Tcl_UniCharToUtf: 3 byte sequence, low surrogate} testbytestring {
expr {[format %c 0xDC42] eq [testbytestring \xED\xB1\x82]}
} 1
test utf-1.12 {Tcl_UniCharToUtf: 4 byte sequence, high/low surrogate} {pairsTo4bytes testbytestring} {
expr {"\uD842\uDC42" eq [testbytestring \xF0\xA0\xA1\x82]}
} 1
test utf-1.13 {Tcl_UniCharToUtf: Invalid surrogate} {Uesc testbytestring} {
expr {"\UD842" eq [testbytestring \xEF\xBF\xBD]}
} 1
test utf-2.1 {Tcl_UtfToUniChar: low ascii} {
string length "abc"
} 3
test utf-2.2 {Tcl_UtfToUniChar: naked trail bytes} testbytestring {
string length [testbytestring \x82\x83\x84]
} 3
test utf-2.3 {Tcl_UtfToUniChar: lead (2-byte) followed by non-trail} testbytestring {
string length [testbytestring \xC2]
} 1
test utf-2.4 {Tcl_UtfToUniChar: lead (2-byte) followed by trail} {
string length \xA2
} 1
test utf-2.5 {Tcl_UtfToUniChar: lead (3-byte) followed by non-trail} testbytestring {
string length [testbytestring \xE2]
} 1
test utf-2.6 {Tcl_UtfToUniChar: lead (3-byte) followed by 1 trail} testbytestring {
string length [testbytestring \xE2\xA2]
} 2
test utf-2.7 {Tcl_UtfToUniChar: lead (3-byte) followed by 2 trail} testbytestring {
string length [testbytestring \xE4\xB9\x8E]
} 1
test utf-2.8.0 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} {testbytestring ucs2_utf16} {
string length [testbytestring \xF0\x90\x80\x80]
} 2
test utf-2.8.1 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} {testbytestring ucs4} {
string length [testbytestring \xF0\x90\x80\x80]
} 1
test utf-2.9.0 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} {testbytestring ucs2} {
string length [testbytestring \xF4\x8F\xBF\xBF]
} 2
test utf-2.9.1 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} {Uesc ucs4} {
string length \U10FFFF
} 1
test utf-2.10 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail, underflow} testbytestring {
string length [testbytestring \xF0\x8F\xBF\xBF]
} 4
test utf-2.11 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail, overflow} testbytestring {
# Would decode to U+110000 but that is outside the Unicode range.
string length [testbytestring \xF4\x90\x80\x80]
} 4
test utf-2.12 {Tcl_UtfToUniChar: longer UTF sequences not supported} testbytestring {
string length [testbytestring \xF8\xA2\xA2\xA2\xA2]
} 5
test utf-3.1 {Tcl_UtfCharComplete} {
} {}
test utf-4.1 {Tcl_NumUtfChars: zero length} testnumutfchars {
testnumutfchars ""
} 0
test utf-4.2 {Tcl_NumUtfChars: length 1} testnumutfchars {
testnumutfchars \xA2
} 1
test utf-4.3 {Tcl_NumUtfChars: long string} {testnumutfchars testbytestring} {
testnumutfchars abc\xA2[testbytestring \xE4\xB9\x8E\xA2\x4E]
} 7
test utf-4.4 {Tcl_NumUtfChars: #x00} testnumutfchars {
testnumutfchars \x00
} 1
test utf-4.5 {Tcl_NumUtfChars: zero length, calc len} testnumutfchars {
testnumutfchars "" 0
} 0
test utf-4.6 {Tcl_NumUtfChars: length 1, calc len} {testnumutfchars testbytestring} {
testnumutfchars \xA2 end
} 1
test utf-4.7 {Tcl_NumUtfChars: long string, calc len} {testnumutfchars testbytestring} {
testnumutfchars abc\xA2[testbytestring \xE4\xB9\x8E\xA2\x4E] end
} 7
test utf-4.8 {Tcl_NumUtfChars: #x00, calc len} testnumutfchars {
testnumutfchars \x00 end
} 1
# Bug [2738427]: Tcl_NumUtfChars(...) no overflow check
test utf-4.9 {Tcl_NumUtfChars: #u20AC, calc len, incomplete} {testnumutfchars testbytestring} {
testnumutfchars [testbytestring \xE2\x82\xAC] end-1
} 2
test utf-4.10 {Tcl_NumUtfChars: #x00, calc len, overcomplete} {testnumutfchars testbytestring} {
testnumutfchars [testbytestring \x00] end+1
} 2
test utf-4.11 {Tcl_NumUtfChars: 3 bytes of 4-byte UTF-8 characater} {testnumutfchars testbytestring} {
testnumutfchars [testbytestring \xF0\x9F\x92\xA9] end-1
} 3
test utf-4.12.0 {Tcl_NumUtfChars: #4-byte UTF-8 character} {testnumutfchars testbytestring ucs2} {
testnumutfchars [testbytestring \xF0\x9F\x92\xA9] end
} 2
test utf-4.12.1 {Tcl_NumUtfChars: #4-byte UTF-8 character} {testnumutfchars testbytestring ucs4} {
testnumutfchars [testbytestring \xF0\x9F\x92\xA9] end
} 1
test utf-4.13 {Tcl_NumUtfChars: end of string} {testnumutfchars testbytestring} {
testnumutfchars foobar[testbytestring \xF2\xC2\xA0] end
} 8
test utf-4.14 {Tcl_NumUtfChars: 3 bytes of 4-byte UTF-8 characater} {testnumutfchars testbytestring} {
testnumutfchars [testbytestring \xF4\x90\x80\x80] end-1
} 3
test utf-5.1 {Tcl_UtfFindFirst} {testfindfirst testbytestring} {
testfindfirst [testbytestring abcbc] 98
} bcbc
test utf-5.2 {Tcl_UtfFindLast} {testfindlast testbytestring} {
testfindlast [testbytestring abcbc] 98
} bc
test utf-6.1 {Tcl_UtfNext} {testutfnext testbytestring} {
# This takes the pointer one past the terminating NUL.
# This is really an invalid call.
testutfnext [testbytestring \x00]
} 1
test utf-6.2 {Tcl_UtfNext} testutfnext {
testutfnext A
} 1
test utf-6.3 {Tcl_UtfNext} testutfnext {
testutfnext AA
} 1
test utf-6.4 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext A[testbytestring \xA0]
} 1
test utf-6.5 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext A[testbytestring \xD0]
} 1
test utf-6.6 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext A[testbytestring \xE8]
} 1
test utf-6.7 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext A[testbytestring \xF2]
} 1
test utf-6.8 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext A[testbytestring \xF8]
} 1
test utf-6.9 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xA0\x00]
} 1
test utf-6.10 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xA0]G
} 1
test utf-6.11 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xA0\xA0\x00]
} 2
test utf-6.12 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xA0\xD0]
} 1
test utf-6.13 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xA0\xE8]
} 1
test utf-6.14 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xA0\xF2]
} 1
test utf-6.15 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xA0\xF8]
} 1
test utf-6.16 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xD0\x00]
} 1
test utf-6.17 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xD0]G
} 1
test utf-6.18 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xD0\xA0]
} 2
test utf-6.19 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xD0\xD0]
} 1
test utf-6.20 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xD0\xE8]
} 1
test utf-6.21 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xD0\xF2]
} 1
test utf-6.22 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xD0\xF8]
} 1
test utf-6.23 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xE8]
} -1
test utf-6.24 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xE8]G
} 1
test utf-6.25 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xE8\xA0\x00]
} 1
test utf-6.26 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xE8\xD0]
} 1
test utf-6.27 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xE8\xE8]
} 1
test utf-6.28 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xE8\xF2]
} 1
test utf-6.29 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xE8\xF8]
} 1
test utf-6.30.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2_utf16} {
testutfnext [testbytestring \xF2]
} 1
test utf-6.30.1 {Tcl_UtfNext} {testutfnext testbytestring ucs4} {
testutfnext [testbytestring \xF2]
} -1
test utf-6.31 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF2]G
} 1
test utf-6.32.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2_utf16} {
testutfnext [testbytestring \xF2\xA0]
} 1
test utf-6.32.1 {Tcl_UtfNext} {testutfnext testbytestring ucs4} {
testutfnext [testbytestring \xF2\xA0]
} -1
test utf-6.33 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF2\xD0]
} 1
test utf-6.34 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF2\xE8]
} 1
test utf-6.35 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF2\xF2]
} 1
test utf-6.36 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF2\xF8]
} 1
test utf-6.37 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF8]
} 1
test utf-6.38 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF8]G
} 1
test utf-6.39 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF8\xA0]
} 1
test utf-6.40 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF8\xD0]
} 1
test utf-6.41 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF8\xE8]
} 1
test utf-6.42 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF8\xF2]
} 1
test utf-6.43 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF8\xF8]
} 1
test utf-6.44 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xD0\xA0]G
} 2
test utf-6.45 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xD0\xA0\xA0]
} 2
test utf-6.46 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xD0\xA0\xD0]
} 2
test utf-6.47 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xD0\xA0\xE8]
} 2
test utf-6.48 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xD0\xA0\xF2]
} 2
test utf-6.49 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xD0\xA0\xF8]
} 2
test utf-6.50 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xE8\xA0]G
} 1
test utf-6.51 {Tcl_UtfNext} testutfnext {
testutfnext \u8820
} 3
test utf-6.52 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xE8\xA0\xD0]
} 1
test utf-6.53 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xE8\xA0\xE8]
} 1
test utf-6.54 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xE8\xA0\xF2]
} 1
test utf-6.55 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xE8\xA0\xF8]
} 1
test utf-6.56 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF2\xA0]G
} 1
test utf-6.57 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF2\xA0\xA0\x00]
} 1
test utf-6.58 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF2\xA0\xD0]
} 1
test utf-6.59 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF2\xA0\xE8]
} 1
test utf-6.60 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF2\xA0\xF2]
} 1
test utf-6.61 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF2\xA0\xF8]
} 1
test utf-6.62 {Tcl_UtfNext} testutfnext {
testutfnext \u8820G
} 3
test utf-6.63 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext \u8820[testbytestring \xA0]
} 3
test utf-6.64 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext \u8820[testbytestring \xD0]
} 3
test utf-6.65 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext \u8820[testbytestring \xE8]
} 3
test utf-6.66 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext \u8820[testbytestring \xF2]
} 3
test utf-6.67 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext \u8820[testbytestring \xF8]
} 3
test utf-6.68 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF2\xA0\xA0]G
} 1
test utf-6.69.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2_utf16} {
testutfnext [testbytestring \xF2\xA0\xA0\xA0]
} 1
test utf-6.69.1 {Tcl_UtfNext} {testutfnext testbytestring ucs4} {
testutfnext [testbytestring \xF2\xA0\xA0\xA0]
} 4
test utf-6.70 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF2\xA0\xA0\xD0]
} 1
test utf-6.71 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF2\xA0\xA0\xE8]
} 1
test utf-6.72 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF2\xA0\xA0\xF2]
} 1
test utf-6.73 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF2\xA0\xA0\xF8]
} 1
test utf-6.74.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2_utf16} {
testutfnext [testbytestring \xF2\xA0\xA0\xA0]G
} 1
test utf-6.74.1 {Tcl_UtfNext} {testutfnext testbytestring ucs4} {
testutfnext [testbytestring \xF2\xA0\xA0\xA0]G
} 4
test utf-6.75.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2_utf16} {
testutfnext [testbytestring \xF2\xA0\xA0\xA0\xA0]
} 1
test utf-6.75.1 {Tcl_UtfNext} {testutfnext testbytestring ucs4} {
testutfnext [testbytestring \xF2\xA0\xA0\xA0\xA0]
} 4
test utf-6.76.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2_utf16} {
testutfnext [testbytestring \xF2\xA0\xA0\xA0\xD0]
} 1
test utf-6.76.1 {Tcl_UtfNext} {testutfnext testbytestring ucs4} {
testutfnext [testbytestring \xF2\xA0\xA0\xA0\xD0]
} 4
test utf-6.77.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2_utf16} {
testutfnext [testbytestring \xF2\xA0\xA0\xA0\xE8]
} 1
test utf-6.77.1 {Tcl_UtfNext} {testutfnext testbytestring ucs4} {
testutfnext [testbytestring \xF2\xA0\xA0\xA0\xE8]
} 4
test utf-6.78.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2_utf16} {
testutfnext [testbytestring \xF2\xA0\xA0\xA0\xF2]
} 1
test utf-6.78.1 {Tcl_UtfNext} {testutfnext testbytestring ucs4} {
testutfnext [testbytestring \xF2\xA0\xA0\xA0\xF2]
} 4
test utf-6.79.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2_utf16} {
testutfnext [testbytestring \xF2\xA0\xA0\xA0G\xF8]
} 1
test utf-6.79.1 {Tcl_UtfNext} {testutfnext testbytestring ucs4} {
testutfnext [testbytestring \xF2\xA0\xA0\xA0G\xF8]
} 4
test utf-6.80 {Tcl_UtfNext - overlong sequences} testutfnext {
testutfnext \x00
} 2
test utf-6.81 {Tcl_UtfNext - overlong sequences} {testutfnext testbytestring} {
testutfnext [testbytestring \xC0\x81]
} 1
test utf-6.82 {Tcl_UtfNext - overlong sequences} {testutfnext testbytestring} {
testutfnext [testbytestring \xC1\x80]
} 1
test utf-6.83 {Tcl_UtfNext - overlong sequences} {testutfnext testbytestring} {
testutfnext [testbytestring \xC2\x80]
} 2
test utf-6.84 {Tcl_UtfNext - overlong sequences} {testutfnext testbytestring} {
testutfnext [testbytestring \xE0\x80\x80]
} 1
test utf-6.85 {Tcl_UtfNext - overlong sequences} {testutfnext testbytestring} {
testutfnext [testbytestring \xE0\xA0\x80]
} 3
test utf-6.86 {Tcl_UtfNext - overlong sequences} {testutfnext testbytestring} {
testutfnext [testbytestring \xF0\x80\x80\x80]
} 1
test utf-6.87.0 {Tcl_UtfNext - overlong sequences} {testutfnext testbytestring ucs2_utf16} {
testutfnext [testbytestring \xF0\x90\x80\x80]
} 1
test utf-6.87.1 {Tcl_UtfNext - overlong sequences} {testutfnext testbytestring ucs4} {
testutfnext [testbytestring \xF0\x90\x80\x80]
} 4
test utf-6.88 {Tcl_UtfNext, pointing to 2th byte of 3-byte valid sequence} {testutfnext testbytestring} {
testutfnext [testbytestring \xA0\xA0\x00]
} 2
test utf-6.89 {Tcl_UtfNext, pointing to 2th byte of 3-byte invalid sequence} {testutfnext testbytestring} {
testutfnext [testbytestring \x80\x80\x00]
} 2
test utf-6.90.0 {Tcl_UtfNext, validity check [493dccc2de]} {testutfnext testbytestring ucs2_utf16} {
testutfnext [testbytestring \xF4\x8F\xBF\xBF]
} 1
test utf-6.90.1 {Tcl_UtfNext, validity check [493dccc2de]} {testutfnext testbytestring ucs4} {
testutfnext [testbytestring \xF4\x8F\xBF\xBF]
} 4
test utf-6.91 {Tcl_UtfNext, validity check [493dccc2de]} {testutfnext testbytestring} {
testutfnext [testbytestring \xF4\x90\x80\x80]
} 1
test utf-6.92 {Tcl_UtfNext, pointing to 2th byte of 4-byte valid sequence} {testutfnext testbytestring} {
testutfnext [testbytestring \xA0\xA0\xA0]
} 3
test utf-6.93 {Tcl_UtfNext, pointing to 2th byte of 4-byte invalid sequence} {testutfnext testbytestring} {
testutfnext [testbytestring \x80\x80\x80]
} 3
test utf-6.94 {Tcl_UtfNext, pointing to 2th byte of 5-byte invalid sequence} {testutfnext testbytestring} {
testutfnext [testbytestring \xA0\xA0\xA0\xA0]
} 3
test utf-6.95 {Tcl_UtfNext, pointing to 2th byte of 5-byte invalid sequence} {testutfnext testbytestring} {
testutfnext [testbytestring \x80\x80\x80\x80]
} 3
test utf-7.1 {Tcl_UtfPrev} testutfprev {
testutfprev {}
} 0
test utf-7.2 {Tcl_UtfPrev} testutfprev {
testutfprev A
} 0
test utf-7.3 {Tcl_UtfPrev} testutfprev {
testutfprev AA
} 1
test utf-7.4 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xF8]
} 1
test utf-7.4.1 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xF8\xA0\xA0\xA0] 2
} 1
test utf-7.4.2 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xF8\xF8\xA0\xA0] 2
} 1
test utf-7.5 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xF2]
} 1
test utf-7.5.1 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xF2\xA0\xA0\xA0] 2
} 1
test utf-7.5.2 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xF2\xF8\xA0\xA0] 2
} 1
test utf-7.6 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xE8]
} 1
test utf-7.6.1 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A\u8820[testbytestring \xA0] 2
} 1
test utf-7.6.2 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xE8\xF8\xA0\xA0] 2
} 1
test utf-7.7 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xD0]
} 1
test utf-7.7.1 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xD0\xA0\xA0\xA0] 2
} 1
test utf-7.7.2 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xD0\xF8\xA0\xA0] 2
} 1
test utf-7.8 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xA0]
} 1
test utf-7.8.1 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xA0\xA0\xA0\xA0] 2
} 1
test utf-7.8.2 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xA0\xF8\xA0\xA0] 2
} 1
test utf-7.9 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xF8\xA0]
} 2
test utf-7.9.1 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xF8\xA0\xA0\xA0] 3
} 2
test utf-7.9.2 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xF8\xA0\xF8\xA0] 3
} 2
test utf-7.10.0 {Tcl_UtfPrev} {testutfprev testbytestring ucs2} {
testutfprev A[testbytestring \xF2\xA0]
} 2
test utf-7.10.1 {Tcl_UtfPrev} {testutfprev testbytestring fullutf} {
testutfprev A[testbytestring \xF2\xA0]
} 1
test utf-7.10.2 {Tcl_UtfPrev} {testutfprev testbytestring ucs2} {
testutfprev A[testbytestring \xF2\xA0\xA0\xA0] 3
} 2
test utf-7.10.3 {Tcl_UtfPrev} {testutfprev testbytestring fullutf} {
testutfprev A[testbytestring \xF2\xA0\xA0\xA0] 3
} 1
test utf-7.10.4 {Tcl_UtfPrev} {testutfprev testbytestring ucs2} {
testutfprev A[testbytestring \xF2\xA0\xF8\xA0] 3
} 2
test utf-7.10.5 {Tcl_UtfPrev} {testutfprev testbytestring fullutf} {
testutfprev A[testbytestring \xF2\xA0\xF8\xA0] 3
} 1
test utf-7.11 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xE8\xA0]
} 1
test utf-7.11.1 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A\u8820[testbytestring \xA0] 3
} 1
test utf-7.11.2 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xE8\xA0\xF8\xA0] 3
} 1
test utf-7.11.3 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xE8\xA0\xF8] 3
} 1
test utf-7.12 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xD0\xA0]
} 1
test utf-7.12.1 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xD0\xA0\xA0\xA0] 3
} 1
test utf-7.12.2 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xD0\xA0\xF8\xA0] 3
} 1
test utf-7.13 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xA0\xA0]
} 2
test utf-7.13.1 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xA0\xA0\xA0\xA0] 3
} 2
test utf-7.13.2 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xA0\xA0\xF8\xA0] 3
} 2
test utf-7.14 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xF8\xA0\xA0]
} 3
test utf-7.14.1 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xF8\xA0\xA0\xA0] 4
} 3
test utf-7.14.2 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xF8\xA0\xA0\xF8] 4
} 3
test utf-7.15.0 {Tcl_UtfPrev} {testutfprev testbytestring ucs2} {
testutfprev A[testbytestring \xF2\xA0\xA0]
} 3
test utf-7.15.1 {Tcl_UtfPrev} {testutfprev testbytestring fullutf} {
testutfprev A[testbytestring \xF2\xA0\xA0]
} 1
test utf-7.15.2 {Tcl_UtfPrev} {testutfprev testbytestring ucs2} {
testutfprev A[testbytestring \xF2\xA0\xA0\xA0] 4
} 3
test utf-7.15.3 {Tcl_UtfPrev} {testutfprev testbytestring fullutf} {
testutfprev A[testbytestring \xF2\xA0\xA0\xA0] 4
} 1
test utf-7.15.4 {Tcl_UtfPrev} {testutfprev testbytestring ucs2} {
testutfprev A[testbytestring \xF2\xA0\xA0\xF8] 4
} 3
test utf-7.15.5 {Tcl_UtfPrev} {testutfprev testbytestring fullutf} {
testutfprev A[testbytestring \xF2\xA0\xA0\xF8] 4
} 1
test utf-7.16 {Tcl_UtfPrev} testutfprev {
testutfprev A\u8820
} 1
test utf-7.16.1 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A\u8820[testbytestring \xA0] 4
} 1
test utf-7.16.2 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A\u8820[testbytestring \xF8] 4
} 1
test utf-7.17 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xD0\xA0\xA0]
} 3
test utf-7.17.1 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xD0\xA0\xA0\xA0] 4
} 3
test utf-7.17.2 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xD0\xA0\xA0\xF8] 4
} 3
test utf-7.18.0 {Tcl_UtfPrev} {testutfprev testbytestring utf16} {
testutfprev A[testbytestring \xA0\xA0\xA0]
} 1
test utf-7.18.1 {Tcl_UtfPrev} {testutfprev testbytestring utf16} {
testutfprev A[testbytestring \xA0\xA0\xA0\xA0] 4
} 1
test utf-7.18.2 {Tcl_UtfPrev} {testutfprev testbytestring utf16} {
testutfprev A[testbytestring \xA0\xA0\xA0\xF8] 4
} 1
test utf-7.19 {Tcl_UtfPrev} {testutfprev testbytestring utf16} {
testutfprev A[testbytestring \xF8\xA0\xA0\xA0]
} 2
test utf-7.20 {Tcl_UtfPrev} {testutfprev testbytestring utf16} {
testutfprev A[testbytestring \xF2\xA0\xA0\xA0]
} 2
test utf-7.21 {Tcl_UtfPrev} {testutfprev testbytestring utf16} {
testutfprev A\u8820[testbytestring \xA0]
} 2
test utf-7.22 {Tcl_UtfPrev} {testutfprev testbytestring utf16} {
testutfprev A[testbytestring \xD0\xA0\xA0\xA0]
} 2
test utf-7.23 {Tcl_UtfPrev} {testutfprev testbytestring utf16} {
testutfprev A[testbytestring \xA0\xA0\xA0\xA0]
} 2
test utf-7.24 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} {
testutfprev A[testbytestring \xC0\x81]
} 2
test utf-7.25 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} {
testutfprev A[testbytestring \xC0\x81] 2
} 1
test utf-7.26 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} {
testutfprev A[testbytestring \xE0\x80\x80]
} 3
test utf-7.27 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} {
testutfprev A[testbytestring \xE0\x80]
} 2
test utf-7.27.1 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} {
testutfprev A[testbytestring \xE0\x80\x80] 3
} 2
test utf-7.28 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} {
testutfprev A[testbytestring \xE0]
} 1
test utf-7.28.1 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} {
testutfprev A[testbytestring \xE0\x80\x80] 2
} 1
test utf-7.29 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring utf16} {
testutfprev A[testbytestring \xF0\x80\x80\x80]
} 2
test utf-7.30 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} {
testutfprev A[testbytestring \xF0\x80\x80\x80] 4
} 3
test utf-7.31 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} {
testutfprev A[testbytestring \xF0\x80\x80\x80] 3
} 2
test utf-7.32 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} {
testutfprev A[testbytestring \xF0\x80\x80\x80] 2
} 1
test utf-7.33 {Tcl_UtfPrev -- overlong sequence} testutfprev {
testutfprev A\x00
} 1
test utf-7.34 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} {
testutfprev A[testbytestring \xC1\x80]
} 2
test utf-7.35 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} {
testutfprev A[testbytestring \xC2\x80]
} 1
test utf-7.36 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} {
testutfprev A[testbytestring \xE0\xA0\x80]
} 1
test utf-7.37 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} {
testutfprev A[testbytestring \xE0\xA0\x80] 3
} 1
test utf-7.38 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} {
testutfprev A[testbytestring \xE0\xA0\x80] 2
} 1
test utf-7.39 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring utf16} {
testutfprev A[testbytestring \xF0\x90\x80\x80]
} 2
test utf-7.40.0 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring ucs2} {
testutfprev A[testbytestring \xF0\x90\x80\x80] 4
} 3
test utf-7.40.1 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring fullutf} {
testutfprev A[testbytestring \xF0\x90\x80\x80] 4
} 1
test utf-7.41.0 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring ucs2} {
testutfprev A[testbytestring \xF0\x90\x80\x80] 3
} 2
test utf-7.41.1 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring fullutf} {
testutfprev A[testbytestring \xF0\x90\x80\x80] 3
} 1
test utf-7.42 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} {
testutfprev A[testbytestring \xF0\x90\x80\x80] 2
} 1
test utf-7.43 {Tcl_UtfPrev -- no lead byte at start} {testutfprev testbytestring} {
testutfprev [testbytestring \xA0]
} 0
test utf-7.44 {Tcl_UtfPrev -- no lead byte at start} {testutfprev testbytestring} {
testutfprev [testbytestring \xA0\xA0]
} 1
test utf-7.45 {Tcl_UtfPrev -- no lead byte at start} {testutfprev testbytestring} {
testutfprev [testbytestring \xA0\xA0\xA0]
} 2
test utf-7.46 {Tcl_UtfPrev -- no lead byte at start} {testutfprev testbytestring utf16} {
testutfprev [testbytestring \xA0\xA0\xA0\xA0]
} 1
test utf-7.47 {Tcl_UtfPrev, pointing to 3th byte of 3-byte valid sequence} {testutfprev testbytestring} {
testutfprev [testbytestring \xE8\xA0]
} 0
test utf-7.47.1 {Tcl_UtfPrev, pointing to 3th byte of 3-byte valid sequence} testutfprev {
testutfprev \u8820 2
} 0
test utf-7.47.2 {Tcl_UtfPrev, pointing to 3th byte of 3-byte invalid sequence} {testutfprev testbytestring} {
testutfprev [testbytestring \xE8\xA0\x00] 2
} 0
test utf-7.48.0 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring utf16} {
testutfprev A[testbytestring \xF4\x8F\xBF\xBF]
} 2
test utf-7.48.1 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring ucs2} {
testutfprev A[testbytestring \xF4\x8F\xBF\xBF] 4
} 3
test utf-7.48.2 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring fullutf} {
testutfprev A[testbytestring \xF4\x8F\xBF\xBF] 4
} 1
test utf-7.48.3 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring ucs2} {
testutfprev A[testbytestring \xF4\x8F\xBF\xBF] 3
} 2
test utf-7.48.4 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring fullutf} {
testutfprev A[testbytestring \xF4\x8F\xBF\xBF] 3
} 1
test utf-7.48.5 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring} {
testutfprev A[testbytestring \xF4\x8F\xBF\xBF] 2
} 1
test utf-7.49.0 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring utf16} {
testutfprev A[testbytestring \xF4\x90\x80\x80]
} 2
test utf-7.49.1 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring} {
testutfprev A[testbytestring \xF4\x90\x80\x80] 4
} 3
test utf-7.49.2 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring} {
testutfprev A[testbytestring \xF4\x90\x80\x80] 3
} 2
test utf-7.49.3 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring} {
testutfprev A[testbytestring \xF4\x90\x80\x80] 2
} 1
test utf-8.1 {Tcl_UniCharAtIndex: index = 0} {
string index abcd 0
} a
test utf-8.2 {Tcl_UniCharAtIndex: index = 0} {
string index \u4E4E\u25A 0
} \u4E4E
test utf-8.3 {Tcl_UniCharAtIndex: index > 0} {
string index abcd 2
} c
test utf-8.4 {Tcl_UniCharAtIndex: index > 0} {
string index \u4E4E\u25A\xFF\u543 2
} \xFF
test utf-8.5.0 {Tcl_UniCharAtIndex: high surrogate} ucs2 {
string index \uD842 0
} \uD842
test utf-8.5.1 {Tcl_UniCharAtIndex: high surrogate} ucs4 {
string index \uD842 0
} \uD842
test utf-8.5.2 {Tcl_UniCharAtIndex: high surrogate} utf16 {
string index \uD842 0
} \uD842
test utf-8.6 {Tcl_UniCharAtIndex: low surrogate} {
string index \uDC42 0
} \uDC42
test utf-8.7.0 {Tcl_UniCharAtIndex: Emoji} ucs2 {
string index \uD83D\uDE00G 0
} \uD83D
test utf-8.7.1 {Tcl_UniCharAtIndex: Emoji} ucs4 {
string index \uD83D\uDE00G 0
} \U1F600
test utf-8.7.2 {Tcl_UniCharAtIndex: Emoji} utf16 {
string index \uD83D\uDE00G 0
} \U1F600
test utf-8.8.0 {Tcl_UniCharAtIndex: Emoji} ucs2 {
string index \uD83D\uDE00G 1
} \uDE00
test utf-8.8.1 {Tcl_UniCharAtIndex: Emoji} ucs4 {
string index \uD83D\uDE00G 1
} G
test utf-8.8.2 {Tcl_UniCharAtIndex: Emoji} utf16 {
string index \uD83D\uDE00G 1
} {}
test utf-8.9.0 {Tcl_UniCharAtIndex: Emoji} ucs2 {
string index \uD83D\uDE00G 2
} G
test utf-8.9.1 {Tcl_UniCharAtIndex: Emoji} ucs4 {
string index \uD83D\uDE00G 2
} {}
test utf-8.9.2 {Tcl_UniCharAtIndex: Emoji} utf16 {
string index \uD83D\uDE00G 2
} G
test utf-8.10.0 {Tcl_UniCharAtIndex: Emoji} {Uesc ucs2} {
string index \U1F600G 0
} \uFFFD
test utf-8.10.1 {Tcl_UniCharAtIndex: Emoji} {Uesc ucs4} {
string index \U1F600G 0
} \U1F600
test utf-8.10.2 {Tcl_UniCharAtIndex: Emoji} {Uesc utf16} {
string index \U1F600G 0
} \U1F600
test utf-8.11.0 {Tcl_UniCharAtIndex: Emoji} {Uesc ucs2} {
string index \U1F600G 1
} G
test utf-8.11.1 {Tcl_UniCharAtIndex: Emoji} {Uesc ucs4} {
string index \U1F600G 1
} G
test utf-8.11.2 {Tcl_UniCharAtIndex: Emoji} {Uesc utf16} {
string index \U1F600G 1
} {}
test utf-8.12.0 {Tcl_UniCharAtIndex: Emoji} {Uesc ucs2} {
string index \U1F600G 2
} {}
test utf-8.12.1 {Tcl_UniCharAtIndex: Emoji} {Uesc ucs4} {
string index \U1F600G 2
} {}
test utf-8.12.2 {Tcl_UniCharAtIndex: Emoji} {Uesc utf16} {
string index \U1F600G 2
} G
test utf-9.1 {Tcl_UtfAtIndex: index = 0} {
string range abcd 0 2
} abc
test utf-9.2 {Tcl_UtfAtIndex: index > 0} {
string range \u4E4E\u25A\xFF\u543klmnop 1 5
} \u25A\xFF\u543kl
test utf-9.3.0 {Tcl_UtfAtIndex: index = 0, Emoji} ucs2 {
string range \uD83D\uDE00G 0 0
} \uD83D
test utf-9.3.1 {Tcl_UtfAtIndex: index = 0, Emoji} ucs4 {
string range \uD83D\uDE00G 0 0
} \U1F600
test utf-9.3.2 {Tcl_UtfAtIndex: index = 0, Emoji} utf16 {
string range \uD83D\uDE00G 0 0
} \U1F600
test utf-9.4.0 {Tcl_UtfAtIndex: index > 0, Emoji} ucs2 {
string range \U1F600G 1 1
} \uDE00
test utf-9.4.1 {Tcl_UtfAtIndex: index > 0, Emoji} ucs4 {
string range \U1F600G 1 1
} G
test utf-9.4.2 {Tcl_UtfAtIndex: index > 0, Emoji} utf16 {
string range \uD83D\uDE00G 1 1
} {}
test utf-9.5.0 {Tcl_UtfAtIndex: index > 0, Emoji} ucs2 {
string range \uD83D\uDE00G 2 2
} G
test utf-9.5.1 {Tcl_UtfAtIndex: index > 0, Emoji} ucs4 {
string range \uD83D\uDE00G 2 2
} {}
test utf-9.5.2 {Tcl_UtfAtIndex: index > 0, Emoji} utf16 {
string range \uD83D\uDE00G 2 2
} G
test utf-9.6.0 {Tcl_UtfAtIndex: index = 0, Emoji} {Uesc ucs2} {
string range \U1f600G 0 0
} \uFFFD
test utf-9.6.1 {Tcl_UtfAtIndex: index = 0, Emoji} {Uesc ucs4} {
string range \U1f600G 0 0
} \U1F600
test utf-9.6.2 {Tcl_UtfAtIndex: index = 0, Emoji} {Uesc utf16} {
string range \U1f600G 0 0
} \U1F600
test utf-9.7.0 {Tcl_UtfAtIndex: index > 0, Emoji} {Uesc ucs2} {
string range \U1f600G 1 1
} G
test utf-9.7.1 {Tcl_UtfAtIndex: index > 0, Emoji} {Uesc ucs4} {
string range \U1f600G 1 1
} G
test utf-9.7.2 {Tcl_UtfAtIndex: index > 0, Emoji} {Uesc utf16} {
string range \U1f600G 1 1
} {}
test utf-9.8.0 {Tcl_UtfAtIndex: index > 0, Emoji} {Uesc ucs2} {
string range \U1f600G 2 2
} {}
test utf-9.8.1 {Tcl_UtfAtIndex: index > 0, Emoji} {Uesc ucs4} {
string range \U1f600G 2 2
} {}
test utf-9.8.2 {Tcl_UtfAtIndex: index > 0, Emoji} {Uesc utf16} {
string range \U1f600G 2 2
} G
test utf-10.1 {Tcl_UtfBackslash: dst == NULL} {
set x \n
} {
}
test utf-10.2 {Tcl_UtfBackslash: \u subst} testbytestring {
expr {"\uA2" eq [testbytestring \xC2\xA2]}
} 1
test utf-10.3 {Tcl_UtfBackslash: longer \u subst} testbytestring {
expr {"\u4E21" eq [testbytestring \xE4\xB8\xA1]}
} 1
test utf-10.4 {Tcl_UtfBackslash: stops at first non-hex} testbytestring {
expr {"\u4E2k" eq "[testbytestring \xD3\xA2]k"}
} 1
test utf-10.5 {Tcl_UtfBackslash: stops after 4 hex chars} testbytestring {
expr {"\u4E216" eq "[testbytestring \xE4\xB8\xA1]6"}
} 1
test utf-10.6 {Tcl_UtfBackslash: stops after 5 hex chars} {Uesc fullutf testbytestring} {
expr {"\U1E2165" eq "[testbytestring \xF0\x9E\x88\x96]5"}
} 1
test utf-10.7 {Tcl_UtfBackslash: stops after 6 hex chars} {Uesc fullutf testbytestring} {
expr {"\U10E2165" eq "[testbytestring \xF4\x8E\x88\x96]5"}
} 1
proc bsCheck {char num {constraints {}}} {
global errNum
test utf-10.$errNum {backslash substitution} $constraints {
scan $char %c value
set value
} $num
incr errNum
}
set errNum 8
bsCheck \b 8
|
| ︙ | ︙ | |||
234 235 236 237 238 239 240 | bsCheck \14 12 bsCheck \141 97 bsCheck b\0 98 bsCheck \x 120 bsCheck \xa 10 bsCheck \xA 10 bsCheck \x41 65 | > | | > | | | | | | | | | | | | | | | | | | | | | | > > > > > > | | | | | > > > > > > | | > > > > > > | 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 |
bsCheck \14 12
bsCheck \141 97
bsCheck b\0 98
bsCheck \x 120
bsCheck \xa 10
bsCheck \xA 10
bsCheck \x41 65
bsCheck \x541 65 pre388 ;# == \x41
bsCheck \x541 84 !pre388 ;# == \x54 1
bsCheck \u 117
bsCheck \uk 117
bsCheck \u41 65
bsCheck \ua 10
bsCheck \uA 10
bsCheck \340 224
bsCheck \uA1 161
bsCheck \u4E21 20001
bsCheck \741 225 pre388 ;# == \341
bsCheck \741 60 !pre388 ;# == \74 1
bsCheck \U 85
bsCheck \Uk 85
bsCheck \U41 65 Uesc
bsCheck \Ua 10 Uesc
bsCheck \UA 10 Uesc
bsCheck \UA1 161 Uesc
bsCheck \U4E21 20001 Uesc
bsCheck \U004E21 20001 Uesc
bsCheck \U00004E21 20001 Uesc
bsCheck \U0000004E21 78 Uesc
bsCheck \U00110000 69632 {Uesc fullutf}
bsCheck \U01100000 69632 {Uesc fullutf}
bsCheck \U11000000 69632 {Uesc fullutf}
bsCheck \U0010FFFF 1114111 {Uesc fullutf}
bsCheck \U010FFFF0 1114111 {Uesc fullutf}
bsCheck \U10FFFF00 1114111 {Uesc fullutf}
bsCheck \UFFFFFFFF 1048575 {Uesc fullutf}
test utf-11.1 {Tcl_UtfToUpper} {
string toupper {}
} {}
test utf-11.2 {Tcl_UtfToUpper} {
string toupper abc
} ABC
test utf-11.3 {Tcl_UtfToUpper} {
string toupper \xE3gh
} \xC3GH
test utf-11.4 {Tcl_UtfToUpper} {
string toupper \u01E3gh
} \u01E2GH
test utf-11.5 {Tcl_UtfToUpper Georgian (new in Unicode 11)} {
string toupper \u10D0\u1C90
} \u1C90\u1C90
test utf-11.6 {Tcl_UtfToUpper beyond U+FFFF} {Uesc fullutf} {
string toupper \U10428
} \U10400
test utf-11.7 {Tcl_UtfToUpper beyond U+FFFF} fullutf {
string toupper \uD801\uDC28
} \uD801\uDC00
test utf-11.8 {Tcl_UtfToUpper low/high surrogate)} {
string toupper \uDC24\uD824
} \uDC24\uD824
test utf-12.1 {Tcl_UtfToLower} {
string tolower {}
} {}
test utf-12.2 {Tcl_UtfToLower} {
string tolower ABC
} abc
test utf-12.3 {Tcl_UtfToLower} {
string tolower \xC3GH
} \xE3gh
test utf-12.4 {Tcl_UtfToLower} {
string tolower \u01E2GH
} \u01E3gh
test utf-12.5 {Tcl_UtfToLower Georgian (new in Unicode 11)} {
string tolower \u10D0\u1C90
} \u10D0\u10D0
test utf-12.6 {Tcl_UtfToLower low/high surrogate)} {
string tolower \uDC24\uD824
} \uDC24\uD824
test utf-12.7 {Tcl_UtfToLower beyond U+FFFF} {Uesc fullutf} {
string tolower \U10400
} \U10428
test utf-12.8 {Tcl_UtfToLower beyond U+FFFF} fullutf {
string tolower \uD801\uDC00
} \uD801\uDC28
test utf-13.1 {Tcl_UtfToTitle} {
string totitle {}
} {}
test utf-13.2 {Tcl_UtfToTitle} {
string totitle abc
} Abc
test utf-13.3 {Tcl_UtfToTitle} {
string totitle \xE3GH
} \xC3gh
test utf-13.4 {Tcl_UtfToTitle} {
string totitle \u01F3AB
} \u01F2ab
test utf-13.5 {Tcl_UtfToTitle Georgian (new in Unicode 11)} {
string totitle \u10D0\u1C90
} \u10D0\u1C90
test utf-13.6 {Tcl_UtfToTitle Georgian (new in Unicode 11)} {
string totitle \u1C90\u10D0
} \u1C90\u10D0
test utf-13.7 {Tcl_UtfToTitle low/high surrogate)} {
string totitle \uDC24\uD824
} \uDC24\uD824
test utf-13.8 {Tcl_UtfToTitle beyond U+FFFF} {Uesc fullutf} {
string totitle \U10428\U10400
} \U10400\U10428
test utf-13.9 {Tcl_UtfToTitle beyond U+FFFF} fullutf {
string totitle \uD801\uDC28\uD801\uDC00
} \uD801\uDC00\uD801\uDC28
test utf-14.1 {Tcl_UtfNcasecmp} {
string compare -nocase a b
} -1
test utf-14.2 {Tcl_UtfNcasecmp} {
string compare -nocase b a
} 1
|
| ︙ | ︙ | |||
349 350 351 352 353 354 355 |
string toupper !
} !
test utf-16.1 {Tcl_UniCharToLower, negative delta} {
string tolower aA
} aa
test utf-16.2 {Tcl_UniCharToLower, positive delta} {
| | | | 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 |
string toupper !
} !
test utf-16.1 {Tcl_UniCharToLower, negative delta} {
string tolower aA
} aa
test utf-16.2 {Tcl_UniCharToLower, positive delta} {
string tolower \u0178\xFF\uA78D\u01C5
} \xFF\xFF\u0265\u01C6
test utf-17.1 {Tcl_UniCharToLower, no delta} {
string tolower !
} !
test utf-18.1 {Tcl_UniCharToTitle, add one for title} {
string totitle \u01C4
|
| ︙ | ︙ | |||
378 379 380 381 382 383 384 |
test utf-19.1 {TclUniCharLen} -body {
list [regexp \\d abc456def foo] $foo
} -cleanup {
unset -nocomplain foo
} -result {1 4}
| | > | > > > > > > > > > | | | | | | | | | | | | | > > > > > > > > | | | | | < < < | < < < < < < < < < < < < | | | | < | | | > > > | < | > | | | | | | | | > | | > | < < | < < | < | | | | | < | | | | | | 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 |
test utf-19.1 {TclUniCharLen} -body {
list [regexp \\d abc456def foo] $foo
} -cleanup {
unset -nocomplain foo
} -result {1 4}
test utf-20.1 {TclUniCharNcmp} ucs4 {
string compare [string range [format %c 0xFFFF] 0 0] [string range [format %c 0x10000] 0 0]
} -1
test utf-20.2 {[4c591fa487] TclUniCharNcmp/TclUtfNcmp} knownBug {
set one [format %c 0xFFFF]
set two [format %c 0x10000]
set first [string compare $one $two]
string range $one 0 0
string range $two 0 0
set second [string compare $one $two]
expr {($first == $second) ? "agree" : "disagree"}
} agree
test utf-21.1 {TclUniCharIsAlnum} {
# this returns 1 with Unicode 7 compliance
string is alnum \u1040\u021F\u0220
} 1
test utf-21.2 {unicode alnum char in regc_locale.c} {
# this returns 1 with Unicode 7 compliance
list [regexp {^[[:alnum:]]+$} \u1040\u021F\u0220] [regexp {^\w+$} \u1040\u021F\u0220_\u203F\u2040\u2054\uFE33\uFE34\uFE4D\uFE4E\uFE4F\uFF3F]
} {1 1}
test utf-21.3 {unicode print char in regc_locale.c} {
# this returns 1 with Unicode 7 compliance
regexp {^[[:print:]]+$} \uFBC1
} 1
test utf-21.4 {TclUniCharIsGraph} {
# [Bug 3464428]
string is graph \u0120
} 1
test utf-21.5 {unicode graph char in regc_locale.c} {
# [Bug 3464428]
regexp {^[[:graph:]]+$} \u0120
} 1
test utf-21.6 {TclUniCharIsGraph} {
# [Bug 3464428]
string is graph \xA0
} 0
test utf-21.7 {unicode graph char in regc_locale.c} {
# [Bug 3464428]
regexp {[[:graph:]]} \x20\xA0\u2028\u2029
} 0
test utf-21.8 {TclUniCharIsPrint} {
# [Bug 3464428]
string is print \x09
} 0
test utf-21.9 {unicode print char in regc_locale.c} {
# [Bug 3464428]
regexp {[[:print:]]} \x09
} 0
test utf-21.10 {unicode print char in regc_locale.c} {
# [Bug 3464428]
regexp {[[:print:]]} \x09
} 0
test utf-21.11 {TclUniCharIsControl} {
# [Bug 3464428]
string is control \x00\x1F\xAD\u0605\u061C\u180E\u2066\uFEFF
} 1
test utf-21.12 {unicode control char in regc_locale.c} {
# [Bug 3464428], [Bug a876646efe]
regexp {^[[:cntrl:]]*$} \x00\x1F\xAD\u0605\u061C\u180E\u2066\uFEFF
} 1
test utf-22.1 {TclUniCharIsWordChar} {
string wordend "xyz123_bar fg" 0
} 10
test utf-22.2 {TclUniCharIsWordChar} {
string wordend "x\u5080z123_bar\u203C fg" 0
} 10
test utf-23.1 {TclUniCharIsAlpha} {
# this returns 1 with Unicode 7 compliance
string is alpha \u021F\u0220\u037F\u052F
} 1
test utf-23.2 {unicode alpha char in regc_locale.c} {
# this returns 1 with Unicode 7 compliance
regexp {^[[:alpha:]]+$} \u021F\u0220\u037F\u052F
} 1
test utf-24.1 {TclUniCharIsDigit} {
# this returns 1 with Unicode 7 compliance
string is digit \u1040\uABF0
} 1
test utf-24.2 {unicode digit char in regc_locale.c} {
# this returns 1 with Unicode 7 compliance
list [regexp {^[[:digit:]]+$} \u1040\uABF0] [regexp {^\d+$} \u1040\uABF0]
} {1 1}
test utf-24.3 {TclUniCharIsSpace} {
# this returns 1 with Unicode 7 compliance
string is space \u1680\u180E\u202F
} 1
test utf-24.4 {unicode space char in regc_locale.c} {
# this returns 1 with Unicode 7 compliance
list [regexp {^[[:space:]]+$} \u1680\u180E\u202F] [regexp {^\s+$} \u1680\u180E\u202F]
} {1 1}
test utf-24.5 {TclUniCharIsSpace} tip413 {
# this returns 1 with Unicode 7/TIP 413 compliance
string is space \x85\u1680\u180E\u200B\u202F\u2060
} 1
test utf-24.6 {unicode space char in regc_locale.c} tip413 {
# this returns 1 with Unicode 7/TIP 413 compliance
list [regexp {^[[:space:]]+$} \x85\u1680\u180E\u200B\u202F\u2060] [regexp {^\s+$} \x85\u1680\u180E\u200B\u202F\u2060]
} {1 1}
proc UniCharCaseCmpTest {order one two {constraints {}}} {
variable count
test utf-25.$count {Tcl_UniCharNcasecmp} -setup {
testobj freeallvars
} -constraints [linsert $constraints 0 teststringobj] -cleanup {
testobj freeallvars
} -body {
teststringobj set 1 $one
teststringobj set 2 $two
teststringobj maxchars 1
teststringobj maxchars 2
set result [string compare -nocase [teststringobj get 1] [teststringobj get 2]]
if {$result eq [string map {< -1 = 0 > 1} $order]} {
set result ok
} else {
set result "'$one' should be $order '$two' (no case)"
}
set result
} -result ok
incr count
}
variable count 1
UniCharCaseCmpTest < a b
UniCharCaseCmpTest > b a
UniCharCaseCmpTest > B a
UniCharCaseCmpTest > aBcB abca
UniCharCaseCmpTest < \uFFFF [format %c 0x10000] ucs4
UniCharCaseCmpTest < \uFFFF \U10000 {Uesc ucs4}
UniCharCaseCmpTest > [format %c 0x10000] \uFFFF ucs4
UniCharCaseCmpTest > \U10000 \uFFFF {Uesc ucs4}
test utf-26.1 {Tcl_UniCharDString} -setup {
testobj freeallvars
} -constraints {teststringobj testbytestring} -cleanup {
testobj freeallvars
} -body {
teststringobj set 1 foo
teststringobj maxchars 1
teststringobj append 1 [testbytestring barsoom\xF2\xC2\x80] 10
scan [string index [teststringobj get 1] 11] %c
} -result 128
unset count
rename UniCharCaseCmpTest {}
# cleanup
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Changes to tests/util.test.
1 2 3 4 5 6 7 8 9 | # This file is a Tcl script to test the code in the file tclUtil.c. # This file is organized in the standard fashion for Tcl tests. # # Copyright (c) 1995-1998 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. | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 |
# This file is a Tcl script to test the code in the file tclUtil.c.
# This file is organized in the standard fashion for Tcl tests.
#
# Copyright (c) 1995-1998 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
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
|
| ︙ | ︙ | |||
380 381 382 383 384 385 386 387 388 389 390 391 392 393 |
} 1
test util-5.50 {Tcl_StringMatch} {
Wrapper_Tcl_StringMatch *. ""
} 0
test util-5.51 {Tcl_StringMatch} {
Wrapper_Tcl_StringMatch "" ""
} 1
test util-6.5 {Tcl_PrintDouble - make sure there's a decimal point} {
concat x[expr 2.0]
} {x2.0}
test util-6.6 {Tcl_PrintDouble - make sure there's a decimal point} {
concat x[expr 3.0e98]
} {x3e+98}
| > > > > | 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 |
} 1
test util-5.50 {Tcl_StringMatch} {
Wrapper_Tcl_StringMatch *. ""
} 0
test util-5.51 {Tcl_StringMatch} {
Wrapper_Tcl_StringMatch "" ""
} 1
test util-5.52 {Tcl_StringMatch} {
Wrapper_Tcl_StringMatch \[a\u0000 a\x80
} 0
test util-6.5 {Tcl_PrintDouble - make sure there's a decimal point} {
concat x[expr 2.0]
} {x2.0}
test util-6.6 {Tcl_PrintDouble - make sure there's a decimal point} {
concat x[expr 3.0e98]
} {x3e+98}
|
| ︙ | ︙ | |||
429 430 431 432 433 434 435 |
testdstring free
testdstring append {\ } -1
testdstring append \{ -1
testdstring element foo
llength [testdstring get]
} 2
test util-8.5 {TclNeedSpace - correct UTF8 handling} testdstring {
| < < < < < | < | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
testdstring free
testdstring append {\ } -1
testdstring append \{ -1
testdstring element foo
llength [testdstring get]
} 2
test util-8.5 {TclNeedSpace - correct UTF8 handling} testdstring {
testdstring free
testdstring append {\\ } -1
testdstring element foo
list [llength [testdstring get]] [string length [testdstring get]]
} {2 6}
test util-8.6 {TclNeedSpace - correct UTF8 handling} testdstring {
testdstring free
testdstring append {\\ } -1
testdstring append \{ -1
testdstring element foo
testdstring append \} -1
list [llength [testdstring get]] [string length [testdstring get]]
} {2 8}
test util-8.7 {TclNeedSpace - watch out for escaped space} {
testdstring free
testdstring append {\ } -1
testdstring start
testdstring end
# Should make {\ {}}
list [llength [testdstring get]] [string index [testdstring get] 3]
} {2 \{}
test util-8.8 {TclNeedSpace - watch out for escaped space} {
testdstring free
testdstring append {\\ } -1
testdstring start
testdstring end
# Should make {\\ {}}
list [llength [testdstring get]] [string index [testdstring get] 3]
} {2 \{}
test util-8.9 {TclNeedSpace - watch out for escaped space} {
testdstring free
testdstring append {\\\ } -1
testdstring start
testdstring end
# Should make {\\\ {}}
list [llength [testdstring get]] [string index [testdstring get] 5]
} {2 \{}
test util-8.10 {TclNeedSpace - watch out for escaped space} {
testdstring free
testdstring append {\\\\\\\ } -1
testdstring start
testdstring end
# Should make {\\\\\\\ {}}
list [llength [testdstring get]] [string index [testdstring get] 9]
} {2 \{}
test util-8.11 {TclNeedSpace - watch out for escaped space} {
testdstring free
testdstring append {\\\\\\\\ } -1
testdstring start
testdstring end
# Should make {\\\\\\\\ {}}
list [llength [testdstring get]] [string index [testdstring get] 9]
} {2 \{}
test util-9.0.0 {Tcl_GetIntForIndex} {
string index abcd 0
} a
test util-9.0.1 {Tcl_GetIntForIndex} {
string index abcd 0x0
} a
|
| ︙ | ︙ |
Changes to tests/while-old.test.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 | # Copyright (c) 1991-1993 The Regents of the University of California. # 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. | | | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 |
# Copyright (c) 1991-1993 The Regents of the University of California.
# 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 {"::tcltest" ni [namespace children]} {
package require tcltest
namespace import -force ::tcltest::*
}
test while-old-1.1 {basic while loops} {
set count 0
while {$count < 10} {set count [expr $count+1]}
|
| ︙ | ︙ |
Changes to tests/winConsole.test.
1 2 3 4 5 6 7 8 9 10 11 | # This file tests the tclWinConsole.c file. # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (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. | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
# This file tests the tclWinConsole.c file.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (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.
if {"::tcltest" ni [namespace children]} {
package require tcltest
namespace import -force ::tcltest::*
}
test winConsole-1.1 {Console file channel: non-blocking gets} {win interactive} {
set oldmode [fconfigure stdin]
|
| ︙ | ︙ |
Changes to tests/winFCmd.test.
1 2 3 4 5 6 7 8 9 10 11 12 | # This file tests the tclWinFCmd.c file. # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1996-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. | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 |
# This file tests the tclWinFCmd.c file.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1996-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 {"::tcltest" ni [namespace children]} {
package require tcltest
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
|
| ︙ | ︙ |
Changes to tests/winNotify.test.
1 2 3 4 5 6 7 8 9 10 11 12 | # This file tests the tclWinNotify.c file. # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1997 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. | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 |
# This file tests the tclWinNotify.c file.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1997 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
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
|
| ︙ | ︙ |
Changes to tests/winTime.test.
1 2 3 4 5 6 7 8 9 10 11 12 | # This file tests the tclWinTime.c file. # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 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. | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 |
# This file tests the tclWinTime.c file.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 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 {"::tcltest" ni [namespace children]} {
package require tcltest
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
|
| ︙ | ︙ |
Changes to tests/zlib.test.
| ︙ | ︙ | |||
916 917 918 919 920 921 922 |
set ::total
} -cleanup {
close $srv
rename bgerror {}
rename zlibRead {}
} -result {error {invalid block type}}
| | | | 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 |
set ::total
} -cleanup {
close $srv
rename bgerror {}
rename zlibRead {}
} -result {error {invalid block type}}
test zlib-11.1 "Bug #3390073: mis-applied gzip filtering" -setup {
set file [makeFile {} test.input]
} -constraints zlib -body {
set f [open $file wb]
puts -nonewline [zlib push gzip $f] [string repeat "hello" 1000]
close $f
set f [open $file rb]
set d [read $f]
close $f
set d [zlib gunzip $d]
list [regexp -all "hello" $d] [string length [regsub -all "hello" $d {}]]
} -cleanup {
removeFile $file
} -result {1000 0}
test zlib-11.2 "Bug #3390073: mis-applied gzip filtering" -setup {
set file [makeFile {} test.input]
} -constraints zlib -body {
set f [open $file wb]
puts -nonewline [zlib push gzip $f -header {filename /foo/bar}] \
[string repeat "hello" 1000]
close $f
set f [open $file rb]
|
| ︙ | ︙ | |||
1001 1002 1003 1004 1005 1006 1007 |
close $fout
}
file size $filedst
} -cleanup {
removeFile $filesrc
removeFile $filedst
} -result 56
| | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 |
close $fout
}
file size $filedst
} -cleanup {
removeFile $filesrc
removeFile $filedst
} -result 56
set zlibbinf ""
proc _zlibbinf {} {
# inlined zlib.bin file creator:
variable zlibbinf
if {$zlibbinf eq ""} {
set zlibbinf [makeFile {} test-zlib-13.bin]
set f [open $zlibbinf wb]
puts -nonewline $f [zlib decompress [binary decode base64 {
eJx7e+6s1+EAgYaLjK3ratptGmOck0vT/y/ZujHAd0qJelDBXfUPJ3tfrtLbpX+wOOFHmtn03/tizm
/+tXROXU3d203b79p5X6/0cvUyFzTsqOj4sa9r8SrZI5zT7265e2Xzq595Fb9LbpgffVy7cZaJ/d15
4U9L7LLM2vdqut8+aSU/r6q9Ltv6+T9mBhTgIK97bH33m/O1C1eBwf9FDKNgaIDaj9wA+5hToA==
}]]
close $f
}
return $zlibbinf
}
test zlib-13.1 {Ticket [8af92dfb66] - zlib stream mis-expansion} -constraints zlib -setup {
set pathin [_zlibbinf]
set chanin [open $pathin rb]
set pathout [makeFile {} test-zlib-13.deflated]
set chanout [open $pathout wb]
zlib push inflate $chanin
fcopy $chanin $chanout
close $chanin
close $chanout
} -body {
file size $pathout
} -cleanup {
removeFile $pathout
unset chanin pathin chanout pathout
} -result 458752
test zlib-13.2 {Ticket [f70ce1fead] - zlib multi-stream expansion} -constraints zlib -setup {
# Start from the basic asset
set pathin [_zlibbinf]
set chanin [open $pathin rb]
# Create a multi-stream by copying the asset twice into it.
set pathout [makeFile {} test-zlib-13.multi]
set chanout [open $pathout wb]
fcopy $chanin $chanout
seek $chanin 0 start
fcopy $chanin $chanout
close $chanin
close $chanout
# The multi-stream file shall be our input
set pathin $pathout
set chanin [open $pathin rb]
# And our destinations
set pathout1 [makeFile {} test-zlib-13.multi-1]
set pathout2 [makeFile {} test-zlib-13.multi-2]
} -body {
# Decode first stream
set chanout [open $pathout1 wb]
zlib push inflate $chanin
fcopy $chanin $chanout
chan pop $chanin
close $chanout
# Decode second stream
set chanout [open $pathout2 wb]
zlib push inflate $chanin
fcopy $chanin $chanout
chan pop $chanin
close $chanout
#
list [file size $pathout1] [file size $pathout2]
} -cleanup {
close $chanin
removeFile $pathout
removeFile $pathout1
removeFile $pathout2
unset chanin pathin chanout pathout pathout1 pathout2
} -result {458752 458752}
if {$zlibbinf ne ""} {
removeFile $zlibbinf
}
unset zlibbinf
rename _zlibbinf {}
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Changes to tools/encoding/Makefile.
1 | # | | | 1 2 3 4 5 6 7 8 9 | # # This file is a Makefile to compile all the encoding files. # # Run "make" to compile all the encoding files (*.txt,*.esc) into the # format that Tcl can use (*.enc). It is your responsibility to move the # encoding files to the appropriate place ($TCL_ROOT/library/encoding # # The .txt files in this directory come from the Unicode CD and are covered # by the following copyright notice: |
| ︙ | ︙ | |||
22 23 24 25 26 27 28 | # # Recipient is granted the right to make copies in any form for # internal distribution and to freely use the information supplied # in the creation of products supporting Unicode. Unicode, Inc. # specifically excludes the right to re-distribute this file directly # to third parties or other organizations whether for profit or not. # | | | | | | | 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 | # # Recipient is granted the right to make copies in any form for # internal distribution and to freely use the information supplied # in the creation of products supporting Unicode. Unicode, Inc. # specifically excludes the right to re-distribute this file directly # to third parties or other organizations whether for profit or not. # # In other words: Don't put this file on the Internet. People who want to # get it over the Internet should do so directly from ftp://unicode.org. They # can therefore be assured of getting the most recent and accurate version. # #---------------------------------------------------------------------------- # # The txt2enc program built by this makefile is used to compile individual # .txt files into .enc files, the format that Tcl understands for encoding # files. This compilation to a different format is allowed by the above # restriction. # # The files shiftjis.txt and jis0208.txt were modified from the original # ones provided on the Unicode CD. The double-width backslash character # 0x815F in these two Japanese encodings was being mapped to Unicode 005C # (REVERSE SOLIDUS), the normal backslash character. They have been # changed to map 0x815F to Unicode FF3C (FULLWIDTH REVERSE SOLIDUS) and let # the regular backslash character map to itself. This follows how cp932 # behaves. # # Copyright (c) 1998 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # SCCS: @(#) Makefile 1.1 98/01/28 11:41:36 # EUC_ENCODINGS = euc-cn.txt euc-kr.txt euc-jp.txt encodings: clean txt2enc $(EUC_ENCODINGS) @echo Compiling encoding files. @for p in *.esc; do \ base=`echo $$p | sed 's/\..*$$//'`; \ echo $$base.enc; \ echo "# Encoding file: $$base, escape-driven" > $$base.enc; \ echo "E" >> $$base.enc; \ cat $$p >> $$base.enc; \ done @for p in *.txt; do \ enc=`echo $$p | sed 's/\..*$$/\.enc/'`; \ echo $$enc; \ ./txt2enc -e 0 -u 1 $$p > $$enc; \ done @echo @echo Compiling special versions of encoding files. @for p in ascii.txt; do \ enc=`echo $$p | sed 's/\..*$$/\.enc/'`; \ echo $$enc; \ ./txt2enc -m $$p > $$enc; \ done @for p in jis0208.txt; do \ |
| ︙ | ︙ |
Changes to tools/encoding/big5.txt.
| ︙ | ︙ | |||
37 38 39 40 41 42 43 | # # General notes: # # This table contains the data Metis and Taligent currently have on how # BIG5 characters map into Unicode. # # WARNING! It is currently impossible to provide round-trip compatibility | | | | | | | | | 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 | # # General notes: # # This table contains the data Metis and Taligent currently have on how # BIG5 characters map into Unicode. # # WARNING! It is currently impossible to provide round-trip compatibility # between BIG5 and Unicode. # # A number of characters are not currently mapped because # of conflicts with other mappings. They are as follows: # # BIG5 Description Comments # # 0xA15A SPACING UNDERSCORE duplicates A1C4 # 0xA1C3 SPACING HEAVY OVERSCORE not in Unicode # 0xA1C5 SPACING HEAVY UNDERSCORE not in Unicode # 0xA1FE LT DIAG UP RIGHT TO LOW LEFT duplicates A2AC # 0xA240 LT DIAG UP LEFT TO LOW RIGHT duplicates A2AD # 0xA2CC HANGZHOU NUMERAL TEN conflicts with A451 mapping # 0xA2CE HANGZHOU NUMERAL THIRTY conflicts with A4CA mapping # # We currently map all of these characters to U+FFFD REPLACEMENT CHARACTER. # It is also possible to map these characters to their duplicates, or to # the user zone. # # Notes: # # 1. In addition to the above, there is some uncertainty about the # mappings in the range C6A1 - C8FE, and F9DD - F9FE. The ETEN # version of BIG5 organizes the former range differently, and adds # additional characters in the latter range. The correct mappings # these ranges need to be determined. # # 2. There is an uncertainty in the mapping of the Big Five character # 0xA3BC. This character occurs within the Big Five block of tone marks # for bopomofo and is intended to be the tone mark for the first tone in # Mandarin Chinese. We have selected the mapping U+02C9 MODIFIER LETTER # MACRON (Mandarin Chinese first tone) to reflect this semantic. # However, because bopomofo uses the absense of a tone mark to indicate # the first Mandarin tone, most implementations of Big Five represent # this character with a blank space, and so a mapping such as U+2003 EM SPACE # might be preferred. # # # # Format: Three tab-separated columns # Column #1 is the BIG5 code (in hex as 0xXXXX) # Column #2 is the Unicode (in hex as 0xXXXX) # Column #3 is the Unicode name (follows a comment sign, '#') # The official names for Unicode characters U+4E00 # to U+9FA5, inclusive, is "CJK UNIFIED IDEOGRAPH-XXXX", |
| ︙ | ︙ |
tools/encoding/ebcdic.txt became a regular file.
| ︙ | ︙ |
Changes to tools/encoding/jis0212.txt.
| ︙ | ︙ | |||
57 58 59 60 61 62 63 | # # Any comments or problems, contact <John_Jenkins@taligent.com> # # Notes: # # 1. JIS X 0212 apparently unified the following two symbols # into a single character at 0x2922: | | | | 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 | # # Any comments or problems, contact <John_Jenkins@taligent.com> # # Notes: # # 1. JIS X 0212 apparently unified the following two symbols # into a single character at 0x2922: # # LATIN CAPITAL LETTER D WITH STROKE # LATIN CAPITAL LETTER ETH # # However, JIS X 0212 maintains the distinction between # the lowercase forms of these two elements at 0x2942 and 0x2943. # Given the structre of these JIS encodings, it is clear that # 0x2922 and 0x2942 are intended to be a capital/small pair. # Consequently, in the Unicode mapping, 0x2922 is treated as # LATIN CAPITAL LETTER D WITH STROKE. # 0x222F 0x02D8 # BREVE 0x2230 0x02C7 # CARON (Mandarin Chinese third tone) 0x2231 0x00B8 # CEDILLA 0x2232 0x02D9 # DOT ABOVE (Mandarin Chinese light tone) 0x2233 0x02DD # DOUBLE ACUTE ACCENT 0x2234 0x00AF # MACRON 0x2235 0x02DB # OGONEK |
| ︙ | ︙ |
Changes to tools/encoding/ksc5601.txt.
1 2 3 4 5 6 7 | # What is enclosed below is the mapping between KS C 5601-1987 # and Unicode 2.0. It's automatically generated from KSC5601.TXT # (at ftp://ftp.unicode.org/Public/MAPPING/EASTASIA/KSC) which is # actually NOT the mapping between KS C 5601-1992 and Unicode 2.0 # BUT the mapping table between UHC(Microsoft Unified Hangul Code) # and Unicode 2.0. Hence, in this pacakge, I renamed it as UHC.TXT # | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 |
# What is enclosed below is the mapping between KS C 5601-1987
# and Unicode 2.0. It's automatically generated from KSC5601.TXT
# (at ftp://ftp.unicode.org/Public/MAPPING/EASTASIA/KSC) which is
# actually NOT the mapping between KS C 5601-1992 and Unicode 2.0
# BUT the mapping table between UHC(Microsoft Unified Hangul Code)
# and Unicode 2.0. Hence, in this pacakge, I renamed it as UHC.TXT
#
# The Unix command used is
# egrep '^0x' < KSC5601.TXT | \
# egrep -v '^0x([8-9]...|A0..|..[4-9].|..A0)' | perl tab.pl
#
# where tab.pl is as following
#----------tab.pl
# $n=0;
# while (<>) {
# local($euck, $ucs4, @rest) = split;
# local($u)=hex($ucs4);
# local($k)=hex($euck);
# printf ("0x%04X 0x%04X %s\n",$k-0x8080, $u,join(' ',@rest));
# }
#
# Column #1 : KS C 5601-1987(KS C 5601-1992 excluding addtional Hangul
# syllables defined for Johab encoding in Annex 3)
# in hex as 0xXXXX
# Column #2 : the Unicode (in hex as 0xXXXX)
# Column #3 : the Unicode name (following a comment sign, '#')
# The number of characters enumerated in this table is 8824, the
# as listed in KS C 5601-987
#
#
# The entries are in KS C 5601-1987 order
# You can use the following algorithms to convert the hex form
# of KS C 5601 to other forms
# To get EUCKorea(EUC-KR) code points, add 0x8080.
# To get row(Hang) and column(Yol) as used in KS C 5601-1987 manual,
# first subtract 0x2020. Then
# the high and low bytes correspond to the row(Hang) and the column(Yol),
|
| ︙ | ︙ |
Changes to tools/encoding/macCentEuro.txt.
| ︙ | ︙ | |||
30 31 32 33 34 35 36 | # throughout this document, "Macintosh" can be used to refer to # Macintosh computers and "Unicode" can be used to refer to the # Unicode standard. # # Apple makes no warranty or representation, either express or # implied, with respect to these tables, their quality, accuracy, or # fitness for a particular purpose. In no event will Apple be liable | | | 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 | # throughout this document, "Macintosh" can be used to refer to # Macintosh computers and "Unicode" can be used to refer to the # Unicode standard. # # Apple makes no warranty or representation, either express or # implied, with respect to these tables, their quality, accuracy, or # fitness for a particular purpose. In no event will Apple be liable # for direct, indirect, special, incidental, or consequential damages # resulting from any defect or inaccuracy in this document or the # accompanying tables. # # These mapping tables and character lists are subject to change. # The latest tables should be available from the following: # # <ftp://ftp.unicode.org/Public/MAPPINGS/VENDORS/APPLE/> |
| ︙ | ︙ |
Changes to tools/encoding/macCroatian.txt.
| ︙ | ︙ | |||
32 33 34 35 36 37 38 | # throughout this document, "Macintosh" can be used to refer to # Macintosh computers and "Unicode" can be used to refer to the # Unicode standard. # # Apple makes no warranty or representation, either express or # implied, with respect to these tables, their quality, accuracy, or # fitness for a particular purpose. In no event will Apple be liable | | | 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 | # throughout this document, "Macintosh" can be used to refer to # Macintosh computers and "Unicode" can be used to refer to the # Unicode standard. # # Apple makes no warranty or representation, either express or # implied, with respect to these tables, their quality, accuracy, or # fitness for a particular purpose. In no event will Apple be liable # for direct, indirect, special, incidental, or consequential damages # resulting from any defect or inaccuracy in this document or the # accompanying tables. # # These mapping tables and character lists are subject to change. # The latest tables should be available from the following: # # <ftp://ftp.unicode.org/Public/MAPPINGS/VENDORS/APPLE/> |
| ︙ | ︙ |
Changes to tools/encoding/macCyrillic.txt.
| ︙ | ︙ | |||
33 34 35 36 37 38 39 | # throughout this document, "Macintosh" can be used to refer to # Macintosh computers and "Unicode" can be used to refer to the # Unicode standard. # # Apple makes no warranty or representation, either express or # implied, with respect to these tables, their quality, accuracy, or # fitness for a particular purpose. In no event will Apple be liable | | | 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 | # throughout this document, "Macintosh" can be used to refer to # Macintosh computers and "Unicode" can be used to refer to the # Unicode standard. # # Apple makes no warranty or representation, either express or # implied, with respect to these tables, their quality, accuracy, or # fitness for a particular purpose. In no event will Apple be liable # for direct, indirect, special, incidental, or consequential damages # resulting from any defect or inaccuracy in this document or the # accompanying tables. # # These mapping tables and character lists are subject to change. # The latest tables should be available from the following: # # <ftp://ftp.unicode.org/Public/MAPPINGS/VENDORS/APPLE/> |
| ︙ | ︙ |
Changes to tools/encoding/macGreek.txt.
| ︙ | ︙ | |||
31 32 33 34 35 36 37 | # throughout this document, "Macintosh" can be used to refer to # Macintosh computers and "Unicode" can be used to refer to the # Unicode standard. # # Apple makes no warranty or representation, either express or # implied, with respect to these tables, their quality, accuracy, or # fitness for a particular purpose. In no event will Apple be liable | | | 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 | # throughout this document, "Macintosh" can be used to refer to # Macintosh computers and "Unicode" can be used to refer to the # Unicode standard. # # Apple makes no warranty or representation, either express or # implied, with respect to these tables, their quality, accuracy, or # fitness for a particular purpose. In no event will Apple be liable # for direct, indirect, special, incidental, or consequential damages # resulting from any defect or inaccuracy in this document or the # accompanying tables. # # These mapping tables and character lists are subject to change. # The latest tables should be available from the following: # # <ftp://ftp.unicode.org/Public/MAPPINGS/VENDORS/APPLE/> |
| ︙ | ︙ |
Changes to tools/encoding/macIceland.txt.
| ︙ | ︙ | |||
33 34 35 36 37 38 39 | # throughout this document, "Macintosh" can be used to refer to # Macintosh computers and "Unicode" can be used to refer to the # Unicode standard. # # Apple makes no warranty or representation, either express or # implied, with respect to these tables, their quality, accuracy, or # fitness for a particular purpose. In no event will Apple be liable | | | 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 | # throughout this document, "Macintosh" can be used to refer to # Macintosh computers and "Unicode" can be used to refer to the # Unicode standard. # # Apple makes no warranty or representation, either express or # implied, with respect to these tables, their quality, accuracy, or # fitness for a particular purpose. In no event will Apple be liable # for direct, indirect, special, incidental, or consequential damages # resulting from any defect or inaccuracy in this document or the # accompanying tables. # # These mapping tables and character lists are subject to change. # The latest tables should be available from the following: # # <ftp://ftp.unicode.org/Public/MAPPINGS/VENDORS/APPLE/> |
| ︙ | ︙ |
Changes to tools/encoding/macRoman.txt.
| ︙ | ︙ | |||
37 38 39 40 41 42 43 | # throughout this document, "Macintosh" can be used to refer to # Macintosh computers and "Unicode" can be used to refer to the # Unicode standard. # # Apple makes no warranty or representation, either express or # implied, with respect to these tables, their quality, accuracy, or # fitness for a particular purpose. In no event will Apple be liable | | | 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 | # throughout this document, "Macintosh" can be used to refer to # Macintosh computers and "Unicode" can be used to refer to the # Unicode standard. # # Apple makes no warranty or representation, either express or # implied, with respect to these tables, their quality, accuracy, or # fitness for a particular purpose. In no event will Apple be liable # for direct, indirect, special, incidental, or consequential damages # resulting from any defect or inaccuracy in this document or the # accompanying tables. # # These mapping tables and character lists are subject to change. # The latest tables should be available from the following: # # <ftp://ftp.unicode.org/Public/MAPPINGS/VENDORS/APPLE/> |
| ︙ | ︙ |
Changes to tools/encoding/macTurkish.txt.
| ︙ | ︙ | |||
30 31 32 33 34 35 36 | # throughout this document, "Macintosh" can be used to refer to # Macintosh computers and "Unicode" can be used to refer to the # Unicode standard. # # Apple makes no warranty or representation, either express or # implied, with respect to these tables, their quality, accuracy, or # fitness for a particular purpose. In no event will Apple be liable | | | 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 | # throughout this document, "Macintosh" can be used to refer to # Macintosh computers and "Unicode" can be used to refer to the # Unicode standard. # # Apple makes no warranty or representation, either express or # implied, with respect to these tables, their quality, accuracy, or # fitness for a particular purpose. In no event will Apple be liable # for direct, indirect, special, incidental, or consequential damages # resulting from any defect or inaccuracy in this document or the # accompanying tables. # # These mapping tables and character lists are subject to change. # The latest tables should be available from the following: # # <ftp://ftp.unicode.org/Public/MAPPINGS/VENDORS/APPLE/> |
| ︙ | ︙ |
Changes to tools/encoding/shiftjis.txt.
| ︙ | ︙ | |||
43 44 45 46 47 48 49 | # The entries are ordered by their Shift-JIS codes as follows: # Single-byte characters precede double-byte characters # The single-byte and double-byte blocks are in ascending # hexadecimal order # There is an alternative order some people might be preferred, # where all the entries are in order of the top (or only) byte. # This alternate order can be generated from the one given here | | | 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 | # The entries are ordered by their Shift-JIS codes as follows: # Single-byte characters precede double-byte characters # The single-byte and double-byte blocks are in ascending # hexadecimal order # There is an alternative order some people might be preferred, # where all the entries are in order of the top (or only) byte. # This alternate order can be generated from the one given here # by a simple sort. # # The kanji mappings are a normative part of ISO/IEC 10646. The # non-kanji mappings are provisional, pending definition of # official mappings by Japanese standards bodies # # Any comments or problems, contact <John_Jenkins@taligent.com> # |
| ︙ | ︙ |
Changes to tools/encoding/tis-620.txt.
| ︙ | ︙ | |||
172 173 174 175 176 177 178 | 0xA4 0x0E04 #THAI CHARACTER KHO KHWAI 0xA5 0x0E05 #THAI CHARACTER KHO KHON 0xA6 0x0E06 #THAI CHARACTER KHO RAKHANG 0xA7 0x0E07 #THAI CHARACTER NGO NGU 0xA8 0x0E08 #THAI CHARACTER CHO CHAN 0xA9 0x0E09 #THAI CHARACTER CHO CHING 0xAA 0x0E0A #THAI CHARACTER CHO CHANG | | | 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 | 0xA4 0x0E04 #THAI CHARACTER KHO KHWAI 0xA5 0x0E05 #THAI CHARACTER KHO KHON 0xA6 0x0E06 #THAI CHARACTER KHO RAKHANG 0xA7 0x0E07 #THAI CHARACTER NGO NGU 0xA8 0x0E08 #THAI CHARACTER CHO CHAN 0xA9 0x0E09 #THAI CHARACTER CHO CHING 0xAA 0x0E0A #THAI CHARACTER CHO CHANG 0xAB 0x0E0B #THAI CHARACTER SO SO 0xAC 0x0E0C #THAI CHARACTER CHO CHOE 0xAD 0x0E0D #THAI CHARACTER YO YING 0xAE 0x0E0E #THAI CHARACTER DO CHADA 0xAF 0x0E0F #THAI CHARACTER TO PATAK 0xB0 0x0E10 #THAI CHARACTER THO THAN 0xB1 0x0E11 #THAI CHARACTER THO NANGMONTHO 0xB2 0x0E12 #THAI CHARACTER THO PHUTHAO |
| ︙ | ︙ |
Changes to tools/encoding/txt2enc.c.
| ︙ | ︙ | |||
172 173 174 175 176 177 178 |
str = rest;
}
if (enc < 32 || uni < 32) {
continue;
}
hi = enc >> 8;
| | | 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 |
str = rest;
}
if (enc < 32 || uni < 32) {
continue;
}
hi = enc >> 8;
lo = enc & 0xFF;
if (toUnicode[hi] == NULL) {
toUnicode[hi] = (Rune *) malloc(256 * sizeof(Rune));
memset(toUnicode[hi], 0, 256 * sizeof(Rune));
}
toUnicode[hi][lo] = uni;
}
|
| ︙ | ︙ | |||
204 205 206 207 208 209 210 |
toUnicode[0] = (Rune *) malloc(256 * sizeof(Rune));
memset(toUnicode[0], 0, 256 * sizeof(Rune));
}
for (i = 0; i < 0x20; i++) {
toUnicode[0][i] = i;
}
if (fixmissing) {
| | | 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 |
toUnicode[0] = (Rune *) malloc(256 * sizeof(Rune));
memset(toUnicode[0], 0, 256 * sizeof(Rune));
}
for (i = 0; i < 0x20; i++) {
toUnicode[0][i] = i;
}
if (fixmissing) {
for (i = 0x7F; i < 0xA0; i++) {
if (toUnicode[i] == NULL && toUnicode[0][i] == 0) {
toUnicode[0][i] = i;
}
}
}
}
|
| ︙ | ︙ | |||
230 231 232 233 234 235 236 |
printf("%c\n%04X %d %d\n", "SDM"[type], fallbackChar, symbol, used);
for (hi = 0; hi < 256; hi++) {
if (toUnicode[hi] != NULL) {
printf("%02X\n", hi);
for (lo = 0; lo < 256; lo++) {
printf("%04X", toUnicode[hi][lo]);
| | | 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 |
printf("%c\n%04X %d %d\n", "SDM"[type], fallbackChar, symbol, used);
for (hi = 0; hi < 256; hi++) {
if (toUnicode[hi] != NULL) {
printf("%02X\n", hi);
for (lo = 0; lo < 256; lo++) {
printf("%04X", toUnicode[hi][lo]);
if ((lo & 0x0F) == 0x0F) {
putchar('\n');
}
}
}
}
for (hi = 0; hi < 256; hi++) {
|
| ︙ | ︙ |
Changes to tools/genStubs.tcl.
| ︙ | ︙ | |||
481 482 483 484 485 486 487 |
set line "$rtype"
} elseif {[string range $rtype end-5 end] eq "MP_WUR"} {
set line "$scspec [string trim [string range $rtype 0 end-6]]"
} else {
set line "$scspec $rtype"
}
set count [expr {2 - ([string length $line] / 8)}]
| > | > | 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 |
set line "$rtype"
} elseif {[string range $rtype end-5 end] eq "MP_WUR"} {
set line "$scspec [string trim [string range $rtype 0 end-6]]"
} else {
set line "$scspec $rtype"
}
set count [expr {2 - ([string length $line] / 8)}]
if {$count >= 0} {
append line [string range "\t\t\t" 0 $count]
}
set pad [expr {24 - [string length $line]}]
if {$pad <= 0} {
append line " "
set pad 0
}
if {$args eq ""} {
append line $fname
|
| ︙ | ︙ |
Changes to tools/mkdepend.tcl.
| ︙ | ︙ | |||
94 95 96 97 98 99 100 |
if {![info exists target]} {
# this is ourself
set target $fname
puts stderr "processing [file tail $fname]"
} else {
# don't include ourselves as a dependency of ourself.
if {![string compare $fname $target]} {continue}
| | | 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 |
if {![info exists target]} {
# this is ourself
set target $fname
puts stderr "processing [file tail $fname]"
} else {
# don't include ourselves as a dependency of ourself.
if {![string compare $fname $target]} {continue}
# store in an array so multiple occurrences are not counted.
set depends($target|$fname) ""
}
}
}
set result {}
foreach n [array names depends] {
|
| ︙ | ︙ |
Changes to unix/Makefile.in.
| ︙ | ︙ | |||
49 50 51 52 53 54 55 56 57 58 59 60 61 62 | # Directory in which to install libtcl.so or libtcl.a: LIB_INSTALL_DIR = $(INSTALL_ROOT)$(libdir) DLL_INSTALL_DIR = @DLL_INSTALL_DIR@ # Path name to use when installing library scripts. SCRIPT_INSTALL_DIR = $(INSTALL_ROOT)$(TCL_LIBRARY) # Directory in which to install the include file tcl.h: INCLUDE_INSTALL_DIR = $(INSTALL_ROOT)$(includedir) # Path to the private tcl header dir: PRIVATE_INCLUDE_DIR = @PRIVATE_INCLUDE_DIR@ # Directory in which to (optionally) install the private tcl headers: | > > > | 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 | # Directory in which to install libtcl.so or libtcl.a: LIB_INSTALL_DIR = $(INSTALL_ROOT)$(libdir) DLL_INSTALL_DIR = @DLL_INSTALL_DIR@ # Path name to use when installing library scripts. SCRIPT_INSTALL_DIR = $(INSTALL_ROOT)$(TCL_LIBRARY) # Path name to use when installing Tcl modules. MODULE_INSTALL_DIR = $(SCRIPT_INSTALL_DIR)/../tcl9 # Directory in which to install the include file tcl.h: INCLUDE_INSTALL_DIR = $(INSTALL_ROOT)$(includedir) # Path to the private tcl header dir: PRIVATE_INCLUDE_DIR = @PRIVATE_INCLUDE_DIR@ # Directory in which to (optionally) install the private tcl headers: |
| ︙ | ︙ | |||
107 108 109 110 111 112 113 | CFLAGS = @CFLAGS_DEFAULT@ @CFLAGS@ # Flags to pass to the linker LDFLAGS_DEBUG = @LDFLAGS_DEBUG@ LDFLAGS_OPTIMIZE = @LDFLAGS_OPTIMIZE@ LDFLAGS = @LDFLAGS_DEFAULT@ @LDFLAGS@ | < < < < < | 110 111 112 113 114 115 116 117 118 119 120 121 122 123 | CFLAGS = @CFLAGS_DEFAULT@ @CFLAGS@ # Flags to pass to the linker LDFLAGS_DEBUG = @LDFLAGS_DEBUG@ LDFLAGS_OPTIMIZE = @LDFLAGS_OPTIMIZE@ LDFLAGS = @LDFLAGS_DEFAULT@ @LDFLAGS@ # If you use the setenv, putenv, or unsetenv procedures to modify environment # variables in your application and you'd like those modifications to appear # in the "env" Tcl variable, switch the comments on the two lines below so # that Tcl provides these procedures instead of your standard C library. ENV_FLAGS = #ENV_FLAGS = -DTclSetEnv=setenv -DTcl_PutEnv=putenv -DTclUnsetEnv=unsetenv |
| ︙ | ︙ | |||
276 277 278 279 280 281 282 |
#--------------------------------------------------------------------------
# The information below should be usable as is. The configure script won't
# modify it and you shouldn't need to modify it either.
#--------------------------------------------------------------------------
STUB_CC_SWITCHES = -I"${BUILD_DIR}" -I${UNIX_DIR} -I${GENERIC_DIR} -I${TOMMATH_DIR} \
${CFLAGS} ${CFLAGS_WARNING} ${SHLIB_CFLAGS} \
| | | | 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 |
#--------------------------------------------------------------------------
# The information below should be usable as is. The configure script won't
# modify it and you shouldn't need to modify it either.
#--------------------------------------------------------------------------
STUB_CC_SWITCHES = -I"${BUILD_DIR}" -I${UNIX_DIR} -I${GENERIC_DIR} -I${TOMMATH_DIR} \
${CFLAGS} ${CFLAGS_WARNING} ${SHLIB_CFLAGS} \
${AC_FLAGS} ${ENV_FLAGS} ${EXTRA_CFLAGS} \
@EXTRA_CC_SWITCHES@
CC_SWITCHES = $(STUB_CC_SWITCHES) ${NO_DEPRECATED_FLAGS} -DMP_FIXED_CUTOFFS -DMP_NO_STDINT
APP_CC_SWITCHES = $(CC_SWITCHES) @EXTRA_APP_CC_SWITCHES@
LIBS = @TCL_LIBS@
DEPEND_SWITCHES = ${CFLAGS} -I${UNIX_DIR} -I${GENERIC_DIR} \
${AC_FLAGS} ${EXTRA_CFLAGS} @EXTRA_CC_SWITCHES@
TCLSH_OBJS = tclAppInit.o
TCLTEST_OBJS = tclTestInit.o tclTest.o tclTestObj.o tclTestProcBodyObj.o \
tclThreadTest.o tclUnixTest.o
XTTEST_OBJS = xtTestInit.o tclTest.o tclTestObj.o tclTestProcBodyObj.o \
|
| ︙ | ︙ | |||
994 995 996 997 998 999 1000 | "$(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/" | | | < < | > | | | > > > > > > > > | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
"$(CONFIG_INSTALL_DIR)/tclooConfig.sh"
@if test "$(STUB_LIB_FILE)" != "" ; then \
echo "Installing $(STUB_LIB_FILE) to $(LIB_INSTALL_DIR)/"; \
@INSTALL_STUB_LIB@ ; \
fi
@EXTRA_INSTALL_BINARIES@
@echo "Installing pkg-config file to $(LIB_INSTALL_DIR)/pkgconfig/"
@$(INSTALL_DATA_DIR) "$(LIB_INSTALL_DIR)/pkgconfig"
@$(INSTALL_DATA) tcl.pc "$(LIB_INSTALL_DIR)/pkgconfig/tcl.pc"
install-libraries-zipfs-shared: libraries
@for i in "$(SCRIPT_INSTALL_DIR)"; do \
if [ ! -d "$$i" ] ; then \
echo "Making directory $$i"; \
$(INSTALL_DATA_DIR) "$$i"; \
fi; \
done
@echo "Installing library files to $(SCRIPT_INSTALL_DIR)/"
@for i in $(UNIX_DIR)/tclAppInit.c @LDAIX_SRC@ @DTRACE_SRC@; do \
$(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"; \
done
install-libraries-zipfs-static: install-libraries-zipfs-shared
$(INSTALL_DATA) ${TCL_ZIP_FILE} "$(LIB_INSTALL_DIR)"
install-libraries: libraries
@for i in "$(SCRIPT_INSTALL_DIR)" "$(MODULE_INSTALL_DIR)"; \
do \
if [ ! -d "$$i" ] ; then \
echo "Making directory $$i"; \
$(INSTALL_DATA_DIR) "$$i"; \
fi; \
done
@for i in opt0.4 cookiejar0.2 encoding; do \
if [ ! -d "$(SCRIPT_INSTALL_DIR)/$$i" ] ; then \
echo "Making directory $(SCRIPT_INSTALL_DIR)/$$i"; \
$(INSTALL_DATA_DIR) "$(SCRIPT_INSTALL_DIR)/$$i"; \
else true; \
fi; \
done;
@for i in 9.0 9.0/platform; \
do \
if [ ! -d "$(MODULE_INSTALL_DIR)/$$i" ] ; then \
echo "Making directory $(MODULE_INSTALL_DIR)/$$i"; \
$(INSTALL_DATA_DIR) "$(MODULE_INSTALL_DIR)/$$i"; \
fi; \
done
@echo "Installing library files to $(SCRIPT_INSTALL_DIR)/"
@for i in $(TOP_DIR)/library/*.tcl $(TOP_DIR)/library/tclIndex \
$(UNIX_DIR)/tclAppInit.c @LDAIX_SRC@ @DTRACE_SRC@ ; do \
$(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"; \
done
@echo "Installing package cookiejar 0.2 files to $(SCRIPT_INSTALL_DIR)/cookiejar0.2/"
@for i in $(TOP_DIR)/library/cookiejar/*.tcl; do \
$(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)/cookiejar0.2"; \
done
@for i in $(TOP_DIR)/library/cookiejar/*.gz; do \
$(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)/cookiejar0.2"; \
done
@echo "Installing package http 2.9.3 as a Tcl Module"
@$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl \
"$(MODULE_INSTALL_DIR)/9.0/http-2.9.3.tm"
@echo "Installing package opt 0.4.7"
@for i in $(TOP_DIR)/library/opt/*.tcl; do \
$(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)/opt0.4"; \
done
@echo "Installing package msgcat 1.7.1 as a Tcl Module"
@$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl \
"$(MODULE_INSTALL_DIR)/9.0/msgcat-1.7.1.tm"
@echo "Installing package tcltest 2.5.3 as a Tcl Module"
@$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl \
"$(MODULE_INSTALL_DIR)/9.0/tcltest-2.5.3.tm"
@echo "Installing package platform 1.0.14 as a Tcl Module"
@$(INSTALL_DATA) $(TOP_DIR)/library/platform/platform.tcl \
"$(MODULE_INSTALL_DIR)/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)/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; \
for j in $$i/*; do \
if [ -d $$j ] ; then \
jj=`basename $$j`; \
if [ ! -d "$(SCRIPT_INSTALL_DIR)/tzdata/$$ii/$$jj" ] ; then \
$(INSTALL_DATA_DIR) "$(SCRIPT_INSTALL_DIR)/tzdata/$$ii/$$jj"; \
fi; \
for k in $$j/*; do \
$(INSTALL_DATA) $$k "$(SCRIPT_INSTALL_DIR)/tzdata/$$ii/$$jj"; \
done; \
else \
$(INSTALL_DATA) $$j "$(SCRIPT_INSTALL_DIR)/tzdata/$$ii"; \
fi; \
done; \
else \
$(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)/tzdata"; \
fi; \
done
install-msgs:
@for i in msgs; do \
if [ ! -d "$(SCRIPT_INSTALL_DIR)/$$i" ] ; then \
echo "Making directory $(SCRIPT_INSTALL_DIR)/$$i"; \
$(INSTALL_DATA_DIR) "$(SCRIPT_INSTALL_DIR)/$$i"; \
fi; \
done
@echo "Installing message catalog files to $(SCRIPT_INSTALL_DIR)/msgs/"
@for i in $(TOP_DIR)/library/msgs/*.msg; do \
$(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)/msgs"; \
done
install-doc: doc
@for i in "$(MAN_INSTALL_DIR)" "$(MAN1_INSTALL_DIR)" "$(MAN3_INSTALL_DIR)" "$(MANN_INSTALL_DIR)"; do \
if [ ! -d "$$i" ] ; then \
echo "Making directory $$i"; \
$(INSTALL_DATA_DIR) "$$i"; \
|
| ︙ | ︙ | |||
1526 1527 1528 1529 1530 1531 1532 | 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)\"" \ | | | 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 | tclZipfs.o: $(GENERIC_DIR)/tclZipfs.c $(CC) -c $(CC_SWITCHES) \ -DCFG_RUNTIME_DLLFILE="\"$(TCL_LIB_FILE)\"" \ -DCFG_RUNTIME_ZIPFILE="\"$(TCL_ZIP_FILE)\"" \ -DCFG_RUNTIME_LIBDIR="\"$(libdir)\"" \ -DCFG_RUNTIME_SCRDIR="\"$(TCL_LIBRARY)\"" \ -I$(ZLIB_DIR) -I$(ZLIB_DIR)/contrib/minizip \ $(GENERIC_DIR)/tclZipfs.c tclTest.o: $(GENERIC_DIR)/tclTest.c $(IOHDR) $(TCLREHDRS) $(CC) -c $(APP_CC_SWITCHES) $(GENERIC_DIR)/tclTest.c tclTestObj.o: $(GENERIC_DIR)/tclTestObj.c $(MATHHDRS) $(CC) -c $(APP_CC_SWITCHES) $(GENERIC_DIR)/tclTestObj.c |
| ︙ | ︙ | |||
2241 2242 2243 2244 2245 2246 2247 | $(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 $@ | > > > > | | > | 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 |
$(UNIX_DIR)/aclocal.m4
cd $(UNIX_DIR); autoconf
$(MAC_OSX_DIR)/configure: $(MAC_OSX_DIR)/configure.ac $(UNIX_DIR)/configure
cd $(MAC_OSX_DIR); autoconf
$(UNIX_DIR)/tclConfig.h.in: $(MAC_OSX_DIR)/configure
cd $(MAC_OSX_DIR); autoheader; touch $@
$(TOP_DIR)/manifest.uuid:
printf "git." >$(TOP_DIR)/manifest.uuid
git rev-parse HEAD >>$(TOP_DIR)/manifest.uuid
dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in $(UNIX_DIR)/tcl.pc.in genstubs \
$(MAC_OSX_DIR)/configure $(TOP_DIR)/manifest.uuid dist-packages ${NATIVE_TCLSH}
rm -rf $(DISTDIR)
$(INSTALL_DATA_DIR) $(DISTDIR)/unix
$(DIST_INSTALL_DATA) $(TOP_DIR)/manifest.uuid $(DISTDIR)
$(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 \
|
| ︙ | ︙ | |||
2338 2339 2340 2341 2342 2343 2344 | $(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 \ | | | 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 | $(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/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 |
| ︙ | ︙ |
Changes to unix/configure.
| ︙ | ︙ | |||
5035 5036 5037 5038 5039 5040 5041 |
TCL_LIB_VERSIONS_OK=ok
CFLAGS_DEBUG=-g
if test "$GCC" = yes; then :
CFLAGS_OPTIMIZE=-O2
CFLAGS_WARNING="-Wall -Wextra -Wwrite-strings -Wpointer-arith"
case "${CC}" in
| | | 5035 5036 5037 5038 5039 5040 5041 5042 5043 5044 5045 5046 5047 5048 5049 |
TCL_LIB_VERSIONS_OK=ok
CFLAGS_DEBUG=-g
if test "$GCC" = yes; then :
CFLAGS_OPTIMIZE=-O2
CFLAGS_WARNING="-Wall -Wextra -Wwrite-strings -Wpointer-arith"
case "${CC}" in
*++|*++-*)
;;
*)
CFLAGS_WARNING="${CFLAGS_WARNING} -Wc++-compat -Wdeclaration-after-statement"
;;
esac
|
| ︙ | ︙ | |||
5308 5309 5310 5311 5312 5313 5314 | DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" LDFLAGS="$LDFLAGS -export-dynamic" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; CYGWIN_*) | | | 5308 5309 5310 5311 5312 5313 5314 5315 5316 5317 5318 5319 5320 5321 5322 |
DL_OBJS="tclLoadDl.o"
DL_LIBS="-ldl"
LDFLAGS="$LDFLAGS -export-dynamic"
CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
;;
CYGWIN_*)
SHLIB_CFLAGS="-fno-common"
SHLIB_LD='${CC} -shared'
SHLIB_SUFFIX=".dll"
DL_OBJS="tclLoadDl.o"
PLAT_OBJS='${CYGWIN_OBJS}'
PLAT_SRCS='${CYGWIN_SRCS}'
DL_LIBS="-ldl"
CC_SEARCH_FLAGS=""
|
| ︙ | ︙ | |||
5521 5522 5523 5524 5525 5526 5527 |
case `${CC} -dumpmachine` in
hppa64*)
# 64-bit gcc in use. Fix flags for GNU ld.
do64bit_ok=yes
SHLIB_LD='${CC} -shared'
if test $doRpath = yes; then :
| | | 5521 5522 5523 5524 5525 5526 5527 5528 5529 5530 5531 5532 5533 5534 5535 |
case `${CC} -dumpmachine` in
hppa64*)
# 64-bit gcc in use. Fix flags for GNU ld.
do64bit_ok=yes
SHLIB_LD='${CC} -shared'
if test $doRpath = yes; then :
CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'
fi
LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
;;
*)
{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: 64bit mode not supported with GCC on $system" >&5
$as_echo "$as_me: WARNING: 64bit mode not supported with GCC on $system" >&2;}
;;
|
| ︙ | ︙ | |||
5611 5612 5613 5614 5615 5616 5617 | *" mkstemp.$ac_objext "* ) ;; *) LIBOBJS="$LIBOBJS mkstemp.$ac_objext" ;; esac if test $doRpath = yes; then : | | | | 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 |
*" mkstemp.$ac_objext "* ) ;;
*) LIBOBJS="$LIBOBJS mkstemp.$ac_objext"
;;
esac
if test $doRpath = yes; then :
CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'
LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}'
fi
;;
IRIX-6.*)
SHLIB_CFLAGS=""
SHLIB_LD="ld -n32 -shared -rdata_shared"
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
case " $LIBOBJS " in
*" mkstemp.$ac_objext "* ) ;;
*) LIBOBJS="$LIBOBJS mkstemp.$ac_objext"
;;
esac
if test $doRpath = yes; then :
CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'
LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}'
fi
if test "$GCC" = yes; then :
CFLAGS="$CFLAGS -mabi=n32"
LDFLAGS="$LDFLAGS -mabi=n32"
|
| ︙ | ︙ | |||
5666 5667 5668 5669 5670 5671 5672 | *" mkstemp.$ac_objext "* ) ;; *) LIBOBJS="$LIBOBJS mkstemp.$ac_objext" ;; esac if test $doRpath = yes; then : | | | 5666 5667 5668 5669 5670 5671 5672 5673 5674 5675 5676 5677 5678 5679 5680 |
*" mkstemp.$ac_objext "* ) ;;
*) LIBOBJS="$LIBOBJS mkstemp.$ac_objext"
;;
esac
if test $doRpath = yes; then :
CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'
LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}'
fi
# Check to enable 64-bit flags for compiler/linker
if test "$do64bit" = yes; then :
|
| ︙ | ︙ | |||
5691 5692 5693 5694 5695 5696 5697 | LDFLAGS_ARCH="-64" fi fi ;; Linux*|GNU*|NetBSD-Debian) | | | | 5691 5692 5693 5694 5695 5696 5697 5698 5699 5700 5701 5702 5703 5704 5705 5706 5707 5708 5709 5710 5711 5712 5713 5714 5715 5716 5717 5718 5719 5720 |
LDFLAGS_ARCH="-64"
fi
fi
;;
Linux*|GNU*|NetBSD-Debian)
SHLIB_CFLAGS="-fPIC -fno-common"
SHLIB_SUFFIX=".so"
CFLAGS_OPTIMIZE="-O2"
# egcs-2.91.66 on Redhat Linux 6.0 generates lots of warnings
# when you inline the string and math operations. Turn this off to
# get rid of the warnings.
#CFLAGS_OPTIMIZE="${CFLAGS_OPTIMIZE} -D__NO_STRING_INLINES -D__NO_MATH_INLINES"
SHLIB_LD='${CC} ${CFLAGS} ${LDFLAGS} -shared'
DL_OBJS="tclLoadDl.o"
DL_LIBS="-ldl"
LDFLAGS="$LDFLAGS -Wl,--export-dynamic"
if test $doRpath = yes; then :
CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'
fi
LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
if test "`uname -m`" = "alpha"; then :
CFLAGS="$CFLAGS -mieee"
fi
if test $do64bit = yes; then :
|
| ︙ | ︙ | |||
5773 5774 5775 5776 5777 5778 5779 |
CFLAGS_OPTIMIZE=-02
SHLIB_LD='${CC} -shared'
DL_OBJS="tclLoadDl.o"
DL_LIBS="-mshared -ldl"
LD_FLAGS="-Wl,--export-dynamic"
if test $doRpath = yes; then :
| | | | | 5773 5774 5775 5776 5777 5778 5779 5780 5781 5782 5783 5784 5785 5786 5787 5788 5789 5790 5791 5792 5793 5794 5795 5796 5797 5798 5799 5800 5801 5802 5803 5804 5805 5806 5807 |
CFLAGS_OPTIMIZE=-02
SHLIB_LD='${CC} -shared'
DL_OBJS="tclLoadDl.o"
DL_LIBS="-mshared -ldl"
LD_FLAGS="-Wl,--export-dynamic"
if test $doRpath = yes; then :
CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'
LD_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'
fi
;;
OpenBSD-*)
arch=`arch -s`
case "$arch" in
alpha|sparc64)
SHLIB_CFLAGS="-fPIC"
;;
*)
SHLIB_CFLAGS="-fpic"
;;
esac
SHLIB_LD='${CC} ${SHLIB_CFLAGS} -shared'
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
if test $doRpath = yes; then :
CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'
fi
LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so.${SHLIB_VERSION}'
LDFLAGS="-Wl,-export-dynamic"
CFLAGS_OPTIMIZE="-O2"
# On OpenBSD: Compile with -pthread
# Don't link with -lpthread
|
| ︙ | ︙ | |||
5817 5818 5819 5820 5821 5822 5823 |
SHLIB_LD='${CC} ${SHLIB_CFLAGS} -shared'
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
LDFLAGS="$LDFLAGS -export-dynamic"
if test $doRpath = yes; then :
| | < | | | 5817 5818 5819 5820 5821 5822 5823 5824 5825 5826 5827 5828 5829 5830 5831 5832 5833 5834 5835 5836 5837 5838 5839 5840 5841 5842 5843 5844 5845 5846 5847 5848 5849 |
SHLIB_LD='${CC} ${SHLIB_CFLAGS} -shared'
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
LDFLAGS="$LDFLAGS -export-dynamic"
if test $doRpath = yes; then :
CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'
fi
LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
# The -pthread needs to go in the CFLAGS, not LIBS
LIBS=`echo $LIBS | sed s/-pthread//`
CFLAGS="$CFLAGS -pthread"
LDFLAGS="$LDFLAGS -pthread"
;;
DragonFly-*|FreeBSD-*)
# This configuration from FreeBSD Ports.
SHLIB_LD="${CC} -shared"
SHLIB_LD_LIBS="${SHLIB_LD_LIBS} -Wl,-soname,\$@"
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
if test $doRpath = yes; then :
CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'
LD_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'
fi
# The -pthread needs to go in the LDFLAGS, not LIBS
LIBS=`echo $LIBS | sed s/-pthread//`
CFLAGS="$CFLAGS $PTHREAD_CFLAGS"
LDFLAGS="$LDFLAGS $PTHREAD_LIBS"
case $system in
FreeBSD-3.*)
|
| ︙ | ︙ | |||
6188 6189 6190 6191 6192 6193 6194 | fi SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" if test $doRpath = yes; then : | | | 6187 6188 6189 6190 6191 6192 6193 6194 6195 6196 6197 6198 6199 6200 6201 |
fi
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
if test $doRpath = yes; then :
CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'
LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}'
fi
if test "$GCC" = yes; then :
CFLAGS="$CFLAGS -mieee"
else
CFLAGS="$CFLAGS -DHAVE_TZSET -std1 -ieee"
|
| ︙ | ︙ | |||
6215 6216 6217 6218 6219 6220 6221 | LDFLAGS="$LDFLAGS -pthread" fi ;; QNX-6*) # QNX RTP # This may work for all QNX, but it was only reported for v6. | < | 6214 6215 6216 6217 6218 6219 6220 6221 6222 6223 6224 6225 6226 6227 | LDFLAGS="$LDFLAGS -pthread" fi ;; QNX-6*) # QNX RTP # This may work for all QNX, but it was only reported for v6. SHLIB_LD="ld -Bshareable -x" SHLIB_LD_LIBS="" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" # dlopen is in -lc on QNX DL_LIBS="" CC_SEARCH_FLAGS="" |
| ︙ | ︙ | |||
6559 6560 6561 6562 6563 6564 6565 6566 |
if test "$DL_OBJS" != "tclLoadNone.o" -a "$GCC" = yes; then :
case $system in
AIX-*) ;;
BSD/OS*) ;;
CYGWIN_*) ;;
IRIX*) ;;
| > > > | | | 6557 6558 6559 6560 6561 6562 6563 6564 6565 6566 6567 6568 6569 6570 6571 6572 6573 6574 6575 6576 |
if test "$DL_OBJS" != "tclLoadNone.o" -a "$GCC" = yes; then :
case $system in
AIX-*) ;;
BSD/OS*) ;;
CYGWIN_*) ;;
HP_UX*) ;;
Darwin-*) ;;
IRIX*) ;;
Linux*|GNU*) ;;
NetBSD-*|OpenBSD-*) ;;
OSF1-V*) ;;
SCO_SV-3.2*) ;;
*) SHLIB_CFLAGS="-fPIC" ;;
esac
fi
if test "$tcl_cv_cc_visibility_hidden" != yes; then :
|
| ︙ | ︙ | |||
8890 8891 8892 8893 8894 8895 8896 8897 |
$as_echo_n "(cached) " >&6
else
if test "$cross_compiling" = yes; then :
tcl_cv_strstr_unbroken=unknown
else
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
int main() {
| > > > < | 8891 8892 8893 8894 8895 8896 8897 8898 8899 8900 8901 8902 8903 8904 8905 8906 8907 8908 |
$as_echo_n "(cached) " >&6
else
if test "$cross_compiling" = yes; then :
tcl_cv_strstr_unbroken=unknown
else
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <stdlib.h>
#include <string.h>
int main() {
exit(strstr("\0test", "test") ? 1 : 0);
}
_ACEOF
if ac_fn_c_try_run "$LINENO"; then :
tcl_cv_strstr_unbroken=ok
else
tcl_cv_strstr_unbroken=broken
|
| ︙ | ︙ | |||
8949 8950 8951 8952 8953 8954 8955 8956 |
$as_echo_n "(cached) " >&6
else
if test "$cross_compiling" = yes; then :
tcl_cv_strtoul_unbroken=unknown
else
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
int main() {
| > > > < | 8952 8953 8954 8955 8956 8957 8958 8959 8960 8961 8962 8963 8964 8965 8966 8967 8968 8969 |
$as_echo_n "(cached) " >&6
else
if test "$cross_compiling" = yes; then :
tcl_cv_strtoul_unbroken=unknown
else
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <stdlib.h>
#include <string.h>
int main() {
char *term, *string = "0";
exit(strtoul(string,&term,0) != 0 || term != string+1);
}
_ACEOF
if ac_fn_c_try_run "$LINENO"; then :
tcl_cv_strtoul_unbroken=ok
else
|
| ︙ | ︙ | |||
9507 9508 9509 9510 9511 9512 9513 9514 9515 9516 9517 9518 9519 9520 |
if test "$cross_compiling" = yes; then :
tcl_cv_putenv_copy=no
else
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <stdlib.h>
#define OURVAR "havecopy=yes"
int main (int argc, char *argv[])
{
char *foo, *bar;
foo = (char *)strdup(OURVAR);
putenv(foo);
strcpy((char *)(strchr(foo, '=') + 1), "no");
| > | 9512 9513 9514 9515 9516 9517 9518 9519 9520 9521 9522 9523 9524 9525 9526 |
if test "$cross_compiling" = yes; then :
tcl_cv_putenv_copy=no
else
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <stdlib.h>
#include <string.h>
#define OURVAR "havecopy=yes"
int main (int argc, char *argv[])
{
char *foo, *bar;
foo = (char *)strdup(OURVAR);
putenv(foo);
strcpy((char *)(strchr(foo, '=') + 1), "no");
|
| ︙ | ︙ | |||
10457 10458 10459 10460 10461 10462 10463 |
TCL_LIB_SPEC="-F${libdir} -framework Tcl"
libdir="${libdir}/Tcl.framework/Versions/\${VERSION}"
TCL_LIBRARY="${libdir}/Resources/Scripts"
includedir="${libdir}/Headers"
PRIVATE_INCLUDE_DIR="${libdir}/PrivateHeaders"
HTML_DIR="${libdir}/Resources/Documentation/Reference/Tcl"
EXTRA_INSTALL="install-private-headers html-tcl"
| | | 10463 10464 10465 10466 10467 10468 10469 10470 10471 10472 10473 10474 10475 10476 10477 |
TCL_LIB_SPEC="-F${libdir} -framework Tcl"
libdir="${libdir}/Tcl.framework/Versions/\${VERSION}"
TCL_LIBRARY="${libdir}/Resources/Scripts"
includedir="${libdir}/Headers"
PRIVATE_INCLUDE_DIR="${libdir}/PrivateHeaders"
HTML_DIR="${libdir}/Resources/Documentation/Reference/Tcl"
EXTRA_INSTALL="install-private-headers html-tcl"
EXTRA_BUILD_HTML='@ln -fs contents.htm "$(HTML_INSTALL_DIR)/TclTOC.html"'
EXTRA_INSTALL_BINARIES='@echo "Installing Info.plist to $(LIB_INSTALL_DIR)/Resources/" && $(INSTALL_DATA_DIR) "$(LIB_INSTALL_DIR)/Resources" && $(INSTALL_DATA) Tcl-Info.plist "$(LIB_INSTALL_DIR)/Resources/Info.plist"'
EXTRA_INSTALL_BINARIES="$EXTRA_INSTALL_BINARIES"' && echo "Installing license.terms to $(LIB_INSTALL_DIR)/Resources/" && $(INSTALL_DATA) "$(TOP_DIR)/license.terms" "$(LIB_INSTALL_DIR)/Resources"'
EXTRA_INSTALL_BINARIES="$EXTRA_INSTALL_BINARIES"' && echo "Finalizing Tcl.framework" && rm -f "$(LIB_INSTALL_DIR)/../Current" && ln -s "$(VERSION)" "$(LIB_INSTALL_DIR)/../Current" && for f in "$(LIB_FILE)" tclConfig.sh Resources Headers PrivateHeaders; do rm -f "$(LIB_INSTALL_DIR)/../../$$f" && ln -s "Versions/Current/$$f" "$(LIB_INSTALL_DIR)/../.."; done && f="$(STUB_LIB_FILE)" && rm -f "$(LIB_INSTALL_DIR)/../../$$f" && ln -s "Versions/$(VERSION)/$$f" "$(LIB_INSTALL_DIR)/../.."'
# Don't use AC_DEFINE for the following as the framework version define
# needs to go into the Makefile even when using autoheader, so that we
# can pick up a potential make override of VERSION. Also, don't put this
# into CFLAGS as it should not go into tclConfig.sh
|
| ︙ | ︙ | |||
10500 10501 10502 10503 10504 10505 10506 |
if test "$FRAMEWORK_BUILD" = "1" ; then
test -z "$TCL_PACKAGE_PATH" && \
TCL_PACKAGE_PATH="~/Library/Tcl /Library/Tcl ~/Library/Frameworks /Library/Frameworks"
test -z "$TCL_MODULE_PATH" && \
TCL_MODULE_PATH="~/Library/Tcl /Library/Tcl"
elif test "$prefix/lib" != "$libdir"; then
| | | | | 10506 10507 10508 10509 10510 10511 10512 10513 10514 10515 10516 10517 10518 10519 10520 10521 10522 10523 10524 10525 10526 10527 10528 10529 10530 10531 10532 10533 10534 10535 |
if test "$FRAMEWORK_BUILD" = "1" ; then
test -z "$TCL_PACKAGE_PATH" && \
TCL_PACKAGE_PATH="~/Library/Tcl /Library/Tcl ~/Library/Frameworks /Library/Frameworks"
test -z "$TCL_MODULE_PATH" && \
TCL_MODULE_PATH="~/Library/Tcl /Library/Tcl"
elif test "$prefix/lib" != "$libdir"; then
test -z "$TCL_PACKAGE_PATH" && TCL_PACKAGE_PATH="{${libdir}} {${prefix}/lib} ${TCL_PACKAGE_PATH}"
else
test -z "$TCL_PACKAGE_PATH" && TCL_PACKAGE_PATH="{${prefix}/lib} ${TCL_PACKAGE_PATH}"
fi
#--------------------------------------------------------------------
# The statements below define various symbols relating to Tcl
# stub support.
#--------------------------------------------------------------------
# Replace ${VERSION} with contents of ${TCL_VERSION}
# double-eval to account for TCL_TRIM_DOTS.
#
eval "TCL_STUB_LIB_FILE=libtclstub${TCL_UNSHARED_LIB_SUFFIX}"
eval "TCL_STUB_LIB_FILE=\"${TCL_STUB_LIB_FILE}\""
eval "TCL_STUB_LIB_DIR=\"${libdir}\""
if test "${TCL_LIB_VERSIONS_OK}" = "ok"; then
TCL_STUB_LIB_FLAG="-ltclstub${TCL_VERSION}"
else
TCL_STUB_LIB_FLAG="-ltclstub`echo ${TCL_VERSION} | tr -d .`"
fi
|
| ︙ | ︙ |
Changes to unix/configure.ac.
| ︙ | ︙ | |||
384 385 386 387 388 389 390 | #-------------------------------------------------------------------- # On some systems strstr is broken: it returns a pointer even even if # the original string is empty. #-------------------------------------------------------------------- SC_TCL_CHECK_BROKEN_FUNC(strstr, [ | < < | 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 |
#--------------------------------------------------------------------
# On some systems strstr is broken: it returns a pointer even even if
# the original string is empty.
#--------------------------------------------------------------------
SC_TCL_CHECK_BROKEN_FUNC(strstr, [
exit(strstr("\0test", "test") ? 1 : 0);
])
#--------------------------------------------------------------------
# Check for strtoul function. This is tricky because under some
# versions of AIX strtoul returns an incorrect terminator
# pointer for the string "0".
#--------------------------------------------------------------------
SC_TCL_CHECK_BROKEN_FUNC(strtoul, [
char *term, *string = "0";
exit(strtoul(string,&term,0) != 0 || term != string+1);
])
#--------------------------------------------------------------------
# Check for various typedefs and provide substitutes if
# they don't exist.
|
| ︙ | ︙ | |||
541 542 543 544 545 546 547 548 549 550 551 552 553 554 |
#--------------------------------------------------------------------
# Does putenv() copy or not? We need to know to avoid memory leaks.
#--------------------------------------------------------------------
AC_CACHE_CHECK([for a putenv() that copies the buffer], tcl_cv_putenv_copy, [
AC_TRY_RUN([
#include <stdlib.h>
#define OURVAR "havecopy=yes"
int main (int argc, char *argv[])
{
char *foo, *bar;
foo = (char *)strdup(OURVAR);
putenv(foo);
strcpy((char *)(strchr(foo, '=') + 1), "no");
| > | 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 |
#--------------------------------------------------------------------
# Does putenv() copy or not? We need to know to avoid memory leaks.
#--------------------------------------------------------------------
AC_CACHE_CHECK([for a putenv() that copies the buffer], tcl_cv_putenv_copy, [
AC_TRY_RUN([
#include <stdlib.h>
#include <string.h>
#define OURVAR "havecopy=yes"
int main (int argc, char *argv[])
{
char *foo, *bar;
foo = (char *)strdup(OURVAR);
putenv(foo);
strcpy((char *)(strchr(foo, '=') + 1), "no");
|
| ︙ | ︙ | |||
914 915 916 917 918 919 920 |
TCL_LIB_SPEC="-F${libdir} -framework Tcl"
libdir="${libdir}/Tcl.framework/Versions/\${VERSION}"
TCL_LIBRARY="${libdir}/Resources/Scripts"
includedir="${libdir}/Headers"
PRIVATE_INCLUDE_DIR="${libdir}/PrivateHeaders"
HTML_DIR="${libdir}/Resources/Documentation/Reference/Tcl"
EXTRA_INSTALL="install-private-headers html-tcl"
| | | 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 |
TCL_LIB_SPEC="-F${libdir} -framework Tcl"
libdir="${libdir}/Tcl.framework/Versions/\${VERSION}"
TCL_LIBRARY="${libdir}/Resources/Scripts"
includedir="${libdir}/Headers"
PRIVATE_INCLUDE_DIR="${libdir}/PrivateHeaders"
HTML_DIR="${libdir}/Resources/Documentation/Reference/Tcl"
EXTRA_INSTALL="install-private-headers html-tcl"
EXTRA_BUILD_HTML='@ln -fs contents.htm "$(HTML_INSTALL_DIR)/TclTOC.html"'
EXTRA_INSTALL_BINARIES='@echo "Installing Info.plist to $(LIB_INSTALL_DIR)/Resources/" && $(INSTALL_DATA_DIR) "$(LIB_INSTALL_DIR)/Resources" && $(INSTALL_DATA) Tcl-Info.plist "$(LIB_INSTALL_DIR)/Resources/Info.plist"'
EXTRA_INSTALL_BINARIES="$EXTRA_INSTALL_BINARIES"' && echo "Installing license.terms to $(LIB_INSTALL_DIR)/Resources/" && $(INSTALL_DATA) "$(TOP_DIR)/license.terms" "$(LIB_INSTALL_DIR)/Resources"'
EXTRA_INSTALL_BINARIES="$EXTRA_INSTALL_BINARIES"' && echo "Finalizing Tcl.framework" && rm -f "$(LIB_INSTALL_DIR)/../Current" && ln -s "$(VERSION)" "$(LIB_INSTALL_DIR)/../Current" && for f in "$(LIB_FILE)" tclConfig.sh Resources Headers PrivateHeaders; do rm -f "$(LIB_INSTALL_DIR)/../../$$f" && ln -s "Versions/Current/$$f" "$(LIB_INSTALL_DIR)/../.."; done && f="$(STUB_LIB_FILE)" && rm -f "$(LIB_INSTALL_DIR)/../../$$f" && ln -s "Versions/$(VERSION)/$$f" "$(LIB_INSTALL_DIR)/../.."'
# Don't use AC_DEFINE for the following as the framework version define
# needs to go into the Makefile even when using autoheader, so that we
# can pick up a potential make override of VERSION. Also, don't put this
# into CFLAGS as it should not go into tclConfig.sh
|
| ︙ | ︙ | |||
957 958 959 960 961 962 963 |
if test "$FRAMEWORK_BUILD" = "1" ; then
test -z "$TCL_PACKAGE_PATH" && \
TCL_PACKAGE_PATH="~/Library/Tcl /Library/Tcl ~/Library/Frameworks /Library/Frameworks"
test -z "$TCL_MODULE_PATH" && \
TCL_MODULE_PATH="~/Library/Tcl /Library/Tcl"
elif test "$prefix/lib" != "$libdir"; then
| | | | | 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 |
if test "$FRAMEWORK_BUILD" = "1" ; then
test -z "$TCL_PACKAGE_PATH" && \
TCL_PACKAGE_PATH="~/Library/Tcl /Library/Tcl ~/Library/Frameworks /Library/Frameworks"
test -z "$TCL_MODULE_PATH" && \
TCL_MODULE_PATH="~/Library/Tcl /Library/Tcl"
elif test "$prefix/lib" != "$libdir"; then
test -z "$TCL_PACKAGE_PATH" && TCL_PACKAGE_PATH="{${libdir}} {${prefix}/lib} ${TCL_PACKAGE_PATH}"
else
test -z "$TCL_PACKAGE_PATH" && TCL_PACKAGE_PATH="{${prefix}/lib} ${TCL_PACKAGE_PATH}"
fi
#--------------------------------------------------------------------
# The statements below define various symbols relating to Tcl
# stub support.
#--------------------------------------------------------------------
# Replace ${VERSION} with contents of ${TCL_VERSION}
# double-eval to account for TCL_TRIM_DOTS.
#
eval "TCL_STUB_LIB_FILE=libtclstub${TCL_UNSHARED_LIB_SUFFIX}"
eval "TCL_STUB_LIB_FILE=\"${TCL_STUB_LIB_FILE}\""
eval "TCL_STUB_LIB_DIR=\"${libdir}\""
if test "${TCL_LIB_VERSIONS_OK}" = "ok"; then
TCL_STUB_LIB_FLAG="-ltclstub${TCL_VERSION}"
else
TCL_STUB_LIB_FLAG="-ltclstub`echo ${TCL_VERSION} | tr -d .`"
fi
|
| ︙ | ︙ |
Changes to unix/installManPage.
| ︙ | ︙ | |||
39 40 41 42 43 44 45 |
ManPage=$1
Dir=$2
if test -f $ManPage ; then : ; else
echo "source manual page file must exist"
exit 1
fi
| | | 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 |
ManPage=$1
Dir=$2
if test -f $ManPage ; then : ; else
echo "source manual page file must exist"
exit 1
fi
if test -d "$Dir" ; then : ; else
echo "target directory must exist"
exit 1
fi
test -z "$SymOrLoc" && SymOrLoc="$Dir/"
########################################################################
### Extract Target Names from Manual Page
|
| ︙ | ︙ | |||
110 111 112 113 114 115 116 | Name=`basename $ManPage .$Section` SrcDir=`dirname $ManPage` ######################################################################## ### Process Page to Create Target Pages ### | | | | | | | | 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 |
Name=`basename $ManPage .$Section`
SrcDir=`dirname $ManPage`
########################################################################
### Process Page to Create Target Pages
###
Specials="DString Thread Notifier RegExp library packagens pkgMkIndex safesock FindPhoto FontId MeasureChar"
for n in $Specials; do
if [ "$Name" = "$n" ] ; then
Names="$n $Names"
fi
done
First=""
for Target in $Names; do
Target=$Target.$Section$Suffix
rm -f "$Dir/$Target" "$Dir/$Target.*"
if test -z "$First" ; then
First=$Target
sed -e "/man\.macros/r $SrcDir/man.macros" -e "/man\.macros/d" \
$ManPage > "$Dir/$First"
chmod 644 "$Dir/$First"
$Gzip "$Dir/$First"
else
ln "$SymOrLoc$First$Gz" "$Dir/$Target$Gz"
fi
done
########################################################################
exit 0
|
Changes to unix/tcl.m4.
| ︙ | ︙ | |||
964 965 966 967 968 969 970 |
ECHO_VERSION='`echo ${VERSION}`'
TCL_LIB_VERSIONS_OK=ok
CFLAGS_DEBUG=-g
AS_IF([test "$GCC" = yes], [
CFLAGS_OPTIMIZE=-O2
CFLAGS_WARNING="-Wall -Wextra -Wwrite-strings -Wpointer-arith"
case "${CC}" in
| | | 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 |
ECHO_VERSION='`echo ${VERSION}`'
TCL_LIB_VERSIONS_OK=ok
CFLAGS_DEBUG=-g
AS_IF([test "$GCC" = yes], [
CFLAGS_OPTIMIZE=-O2
CFLAGS_WARNING="-Wall -Wextra -Wwrite-strings -Wpointer-arith"
case "${CC}" in
*++|*++-*)
;;
*)
CFLAGS_WARNING="${CFLAGS_WARNING} -Wc++-compat -Wdeclaration-after-statement"
;;
esac
], [
|
| ︙ | ︙ | |||
1080 1081 1082 1083 1084 1085 1086 | DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" LDFLAGS="$LDFLAGS -export-dynamic" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; CYGWIN_*) | | | 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 |
DL_OBJS="tclLoadDl.o"
DL_LIBS="-ldl"
LDFLAGS="$LDFLAGS -export-dynamic"
CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
;;
CYGWIN_*)
SHLIB_CFLAGS="-fno-common"
SHLIB_LD='${CC} -shared'
SHLIB_SUFFIX=".dll"
DL_OBJS="tclLoadDl.o"
PLAT_OBJS='${CYGWIN_OBJS}'
PLAT_SRCS='${CYGWIN_SRCS}'
DL_LIBS="-ldl"
CC_SEARCH_FLAGS=""
|
| ︙ | ︙ | |||
1176 1177 1178 1179 1180 1181 1182 |
AS_IF([test "$GCC" = yes], [
case `${CC} -dumpmachine` in
hppa64*)
# 64-bit gcc in use. Fix flags for GNU ld.
do64bit_ok=yes
SHLIB_LD='${CC} -shared'
AS_IF([test $doRpath = yes], [
| | | 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 |
AS_IF([test "$GCC" = yes], [
case `${CC} -dumpmachine` in
hppa64*)
# 64-bit gcc in use. Fix flags for GNU ld.
do64bit_ok=yes
SHLIB_LD='${CC} -shared'
AS_IF([test $doRpath = yes], [
CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'])
LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
;;
*)
AC_MSG_WARN([64bit mode not supported with GCC on $system])
;;
esac
], [
|
| ︙ | ︙ | |||
1211 1212 1213 1214 1215 1216 1217 | SHLIB_CFLAGS="" SHLIB_LD="ld -shared -rdata_shared" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" AC_LIBOBJ(mkstemp) AS_IF([test $doRpath = yes], [ | | | | 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 |
SHLIB_CFLAGS=""
SHLIB_LD="ld -shared -rdata_shared"
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
AC_LIBOBJ(mkstemp)
AS_IF([test $doRpath = yes], [
CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'
LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}'])
;;
IRIX-6.*)
SHLIB_CFLAGS=""
SHLIB_LD="ld -n32 -shared -rdata_shared"
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
AC_LIBOBJ(mkstemp)
AS_IF([test $doRpath = yes], [
CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'
LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}'])
AS_IF([test "$GCC" = yes], [
CFLAGS="$CFLAGS -mabi=n32"
LDFLAGS="$LDFLAGS -mabi=n32"
], [
case $system in
IRIX-6.3)
|
| ︙ | ︙ | |||
1248 1249 1250 1251 1252 1253 1254 | SHLIB_CFLAGS="" SHLIB_LD="ld -n32 -shared -rdata_shared" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" AC_LIBOBJ(mkstemp) AS_IF([test $doRpath = yes], [ | | | | | 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 |
SHLIB_CFLAGS=""
SHLIB_LD="ld -n32 -shared -rdata_shared"
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
AC_LIBOBJ(mkstemp)
AS_IF([test $doRpath = yes], [
CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'
LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}'])
# Check to enable 64-bit flags for compiler/linker
AS_IF([test "$do64bit" = yes], [
AS_IF([test "$GCC" = yes], [
AC_MSG_WARN([64bit mode not supported by gcc])
], [
do64bit_ok=yes
SHLIB_LD="ld -64 -shared -rdata_shared"
CFLAGS="$CFLAGS -64"
LDFLAGS_ARCH="-64"
])
])
;;
Linux*|GNU*|NetBSD-Debian)
SHLIB_CFLAGS="-fPIC -fno-common"
SHLIB_SUFFIX=".so"
CFLAGS_OPTIMIZE="-O2"
# egcs-2.91.66 on Redhat Linux 6.0 generates lots of warnings
# when you inline the string and math operations. Turn this off to
# get rid of the warnings.
#CFLAGS_OPTIMIZE="${CFLAGS_OPTIMIZE} -D__NO_STRING_INLINES -D__NO_MATH_INLINES"
SHLIB_LD='${CC} ${CFLAGS} ${LDFLAGS} -shared'
DL_OBJS="tclLoadDl.o"
DL_LIBS="-ldl"
LDFLAGS="$LDFLAGS -Wl,--export-dynamic"
AS_IF([test $doRpath = yes], [
CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'])
LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
AS_IF([test "`uname -m`" = "alpha"], [CFLAGS="$CFLAGS -mieee"])
AS_IF([test $do64bit = yes], [
AC_CACHE_CHECK([if compiler accepts -m64 flag], tcl_cv_cc_m64, [
hold_cflags=$CFLAGS
CFLAGS="$CFLAGS -m64"
AC_TRY_LINK(,, tcl_cv_cc_m64=yes, tcl_cv_cc_m64=no)
|
| ︙ | ︙ | |||
1311 1312 1313 1314 1315 1316 1317 |
SHLIB_SUFFIX=".so"
CFLAGS_OPTIMIZE=-02
SHLIB_LD='${CC} -shared'
DL_OBJS="tclLoadDl.o"
DL_LIBS="-mshared -ldl"
LD_FLAGS="-Wl,--export-dynamic"
AS_IF([test $doRpath = yes], [
| | | | | 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 |
SHLIB_SUFFIX=".so"
CFLAGS_OPTIMIZE=-02
SHLIB_LD='${CC} -shared'
DL_OBJS="tclLoadDl.o"
DL_LIBS="-mshared -ldl"
LD_FLAGS="-Wl,--export-dynamic"
AS_IF([test $doRpath = yes], [
CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'
LD_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'])
;;
OpenBSD-*)
arch=`arch -s`
case "$arch" in
alpha|sparc64)
SHLIB_CFLAGS="-fPIC"
;;
*)
SHLIB_CFLAGS="-fpic"
;;
esac
SHLIB_LD='${CC} ${SHLIB_CFLAGS} -shared'
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
AS_IF([test $doRpath = yes], [
CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'])
LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so.${SHLIB_VERSION}'
LDFLAGS="-Wl,-export-dynamic"
CFLAGS_OPTIMIZE="-O2"
# On OpenBSD: Compile with -pthread
# Don't link with -lpthread
LIBS=`echo $LIBS | sed s/-lpthread//`
|
| ︙ | ︙ | |||
1351 1352 1353 1354 1355 1356 1357 |
SHLIB_CFLAGS="-fPIC"
SHLIB_LD='${CC} ${SHLIB_CFLAGS} -shared'
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
LDFLAGS="$LDFLAGS -export-dynamic"
AS_IF([test $doRpath = yes], [
| | < | | | 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 |
SHLIB_CFLAGS="-fPIC"
SHLIB_LD='${CC} ${SHLIB_CFLAGS} -shared'
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
LDFLAGS="$LDFLAGS -export-dynamic"
AS_IF([test $doRpath = yes], [
CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'])
LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
# The -pthread needs to go in the CFLAGS, not LIBS
LIBS=`echo $LIBS | sed s/-pthread//`
CFLAGS="$CFLAGS -pthread"
LDFLAGS="$LDFLAGS -pthread"
;;
DragonFly-*|FreeBSD-*)
# This configuration from FreeBSD Ports.
SHLIB_LD="${CC} -shared"
SHLIB_LD_LIBS="${SHLIB_LD_LIBS} -Wl,-soname,\$[@]"
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
AS_IF([test $doRpath = yes], [
CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'
LD_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'])
# The -pthread needs to go in the LDFLAGS, not LIBS
LIBS=`echo $LIBS | sed s/-pthread//`
CFLAGS="$CFLAGS $PTHREAD_CFLAGS"
LDFLAGS="$LDFLAGS $PTHREAD_LIBS"
case $system in
FreeBSD-3.*)
# Version numbers are dot-stripped by system policy.
|
| ︙ | ︙ | |||
1536 1537 1538 1539 1540 1541 1542 | ], [ SHLIB_LD='ld -non_shared -expect_unresolved "*"' ]) SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" AS_IF([test $doRpath = yes], [ | | < | 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 |
], [
SHLIB_LD='ld -non_shared -expect_unresolved "*"'
])
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
AS_IF([test $doRpath = yes], [
CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'
LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}'])
AS_IF([test "$GCC" = yes], [CFLAGS="$CFLAGS -mieee"], [
CFLAGS="$CFLAGS -DHAVE_TZSET -std1 -ieee"])
# see pthread_intro(3) for pthread support on osf1, k.furukawa
CFLAGS="$CFLAGS -DHAVE_PTHREAD_ATTR_SETSTACKSIZE"
CFLAGS="$CFLAGS -DTCL_THREAD_STACK_MIN=PTHREAD_STACK_MIN*64"
LIBS=`echo $LIBS | sed s/-lpthreads//`
AS_IF([test "$GCC" = yes], [
LIBS="$LIBS -lpthread -lmach -lexc"
], [
CFLAGS="$CFLAGS -pthread"
LDFLAGS="$LDFLAGS -pthread"
])
;;
QNX-6*)
# QNX RTP
# This may work for all QNX, but it was only reported for v6.
SHLIB_LD="ld -Bshareable -x"
SHLIB_LD_LIBS=""
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
# dlopen is in -lc on QNX
DL_LIBS=""
CC_SEARCH_FLAGS=""
|
| ︙ | ︙ | |||
1782 1783 1784 1785 1786 1787 1788 1789 |
# standard manufacturer compiler.
AS_IF([test "$DL_OBJS" != "tclLoadNone.o" -a "$GCC" = yes], [
case $system in
AIX-*) ;;
BSD/OS*) ;;
CYGWIN_*) ;;
IRIX*) ;;
| > > > | | | 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 |
# standard manufacturer compiler.
AS_IF([test "$DL_OBJS" != "tclLoadNone.o" -a "$GCC" = yes], [
case $system in
AIX-*) ;;
BSD/OS*) ;;
CYGWIN_*) ;;
HP_UX*) ;;
Darwin-*) ;;
IRIX*) ;;
Linux*|GNU*) ;;
NetBSD-*|OpenBSD-*) ;;
OSF1-V*) ;;
SCO_SV-3.2*) ;;
*) SHLIB_CFLAGS="-fPIC" ;;
esac])
AS_IF([test "$tcl_cv_cc_visibility_hidden" != yes], [
AC_DEFINE(MODULE_SCOPE, [extern],
[No Compiler support for module scope symbols])
|
| ︙ | ︙ | |||
2472 2473 2474 2475 2476 2477 2478 |
#
#--------------------------------------------------------------------
AC_DEFUN([SC_TCL_CHECK_BROKEN_FUNC],[
AC_CHECK_FUNC($1, tcl_ok=1, tcl_ok=0)
if test ["$tcl_ok"] = 1; then
AC_CACHE_CHECK([proper ]$1[ implementation], [tcl_cv_]$1[_unbroken],
| > > > | | 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 |
#
#--------------------------------------------------------------------
AC_DEFUN([SC_TCL_CHECK_BROKEN_FUNC],[
AC_CHECK_FUNC($1, tcl_ok=1, tcl_ok=0)
if test ["$tcl_ok"] = 1; then
AC_CACHE_CHECK([proper ]$1[ implementation], [tcl_cv_]$1[_unbroken],
AC_TRY_RUN([[
#include <stdlib.h>
#include <string.h>
int main() {]$2[}]],[tcl_cv_]$1[_unbroken]=ok,
[tcl_cv_]$1[_unbroken]=broken,[tcl_cv_]$1[_unbroken]=unknown))
if test ["$tcl_cv_]$1[_unbroken"] = "ok"; then
tcl_ok=1
else
tcl_ok=0
fi
fi
|
| ︙ | ︙ |
Changes to unix/tclConfig.h.in.
1 2 3 4 5 6 7 8 9 10 11 12 |
/* ../unix/tclConfig.h.in. Generated from configure.ac by autoheader. */
#ifndef _TCLCONFIG
#define _TCLCONFIG
/* Is gettimeofday() actually declared in <sys/time.h>? */
#undef GETTOD_NOT_DECLARED
/* Define to 1 if you have the <AvailabilityMacros.h> header file. */
#undef HAVE_AVAILABILITYMACROS_H
| > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 |
/* ../unix/tclConfig.h.in. Generated from configure.ac by autoheader. */
#ifndef _TCLCONFIG
#define _TCLCONFIG
/* Define if building universal (internal helper macro) */
#undef AC_APPLE_UNIVERSAL_BUILD
/* Is gettimeofday() actually declared in <sys/time.h>? */
#undef GETTOD_NOT_DECLARED
/* Define to 1 if you have the <AvailabilityMacros.h> header file. */
#undef HAVE_AVAILABILITYMACROS_H
|
| ︙ | ︙ | |||
228 229 230 231 232 233 234 | /* Define to 1 if the system has the type `struct sockaddr_storage'. */ #undef HAVE_STRUCT_SOCKADDR_STORAGE /* Is 'struct stat64' in <sys/stat.h>? */ #undef HAVE_STRUCT_STAT64 | | | | 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 | /* Define to 1 if the system has the type `struct sockaddr_storage'. */ #undef HAVE_STRUCT_SOCKADDR_STORAGE /* Is 'struct stat64' in <sys/stat.h>? */ #undef HAVE_STRUCT_STAT64 /* Define to 1 if `st_blksize' is a member of `struct stat'. */ #undef HAVE_STRUCT_STAT_ST_BLKSIZE /* Define to 1 if `st_blocks' is a member of `struct stat'. */ #undef HAVE_STRUCT_STAT_ST_BLOCKS /* Define to 1 if you have the <sys/epoll.h> header file. */ #undef HAVE_SYS_EPOLL_H /* Define to 1 if you have the <sys/eventfd.h> header file. */ #undef HAVE_SYS_EVENTFD_H |
| ︙ | ︙ | |||
302 303 304 305 306 307 308 309 310 311 312 313 314 315 | #undef HAVE_ZLIB /* Is this a Mac I see before me? */ #undef MAC_OSX_TCL /* No Compiler support for module scope symbols */ #undef MODULE_SCOPE /* Is no debugging enabled? */ #undef NDEBUG /* Use compat implementation of getaddrinfo() and friends */ #undef NEED_FAKE_RFC2553 | > > > | 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 | #undef HAVE_ZLIB /* Is this a Mac I see before me? */ #undef MAC_OSX_TCL /* No Compiler support for module scope symbols */ #undef MODULE_SCOPE /* Default libtommath precision. */ #undef MP_PREC /* Is no debugging enabled? */ #undef NDEBUG /* Use compat implementation of getaddrinfo() and friends */ #undef NEED_FAKE_RFC2553 |
| ︙ | ︙ | |||
377 378 379 380 381 382 383 384 385 386 387 388 389 390 | #undef PACKAGE_NAME /* Define to the full name and version of this package. */ #undef PACKAGE_STRING /* Define to the one symbol short name of this package. */ #undef PACKAGE_TARNAME /* Define to the version of this package. */ #undef PACKAGE_VERSION /* Is this a static build? */ #undef STATIC_BUILD | > > > | 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 | #undef PACKAGE_NAME /* Define to the full name and version of this package. */ #undef PACKAGE_STRING /* Define to the one symbol short name of this package. */ #undef PACKAGE_TARNAME /* Define to the home page for this package. */ #undef PACKAGE_URL /* Define to the version of this package. */ #undef PACKAGE_VERSION /* Is this a static build? */ #undef STATIC_BUILD |
| ︙ | ︙ | |||
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 | #undef TCL_WIDE_CLICKS /* Do 'long' and 'long long' have the same size (64-bit)? */ #undef TCL_WIDE_INT_IS_LONG /* What type should be used to define wide integers? */ #undef TCL_WIDE_INT_TYPE /* Define to 1 if you can safely include both <sys/time.h> and <time.h>. */ #undef TIME_WITH_SYS_TIME /* Is getcwd Posix-compliant? */ #undef USEGETWD /* May we include <dirent2.h>? */ #undef USE_DIRENT2_H /* Are we building with DTrace support? */ #undef USE_DTRACE /* Should we use FIONBIO? */ #undef USE_FIONBIO /* Should we use vfork() instead of fork()? */ #undef USE_VFORK | > > > | | > > > > > > | > > | 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 | #undef TCL_WIDE_CLICKS /* Do 'long' and 'long long' have the same size (64-bit)? */ #undef TCL_WIDE_INT_IS_LONG /* What type should be used to define wide integers? */ #undef TCL_WIDE_INT_TYPE /* Tcl with external libtommath */ #undef TCL_WITH_EXTERNAL_TOMMATH /* Define to 1 if you can safely include both <sys/time.h> and <time.h>. */ #undef TIME_WITH_SYS_TIME /* Is getcwd Posix-compliant? */ #undef USEGETWD /* May we include <dirent2.h>? */ #undef USE_DIRENT2_H /* Are we building with DTrace support? */ #undef USE_DTRACE /* Should we use FIONBIO? */ #undef USE_FIONBIO /* Should we use vfork() instead of fork()? */ #undef USE_VFORK /* Define WORDS_BIGENDIAN to 1 if your processor stores words with the most significant byte first (like Motorola and SPARC, unlike Intel). */ #if defined AC_APPLE_UNIVERSAL_BUILD # if defined __BIG_ENDIAN__ # define WORDS_BIGENDIAN 1 # endif #else # ifndef WORDS_BIGENDIAN # undef WORDS_BIGENDIAN # endif #endif /* Are we building with zipfs enabled? */ #undef ZIPFS_BUILD /* Are Darwin SUSv3 extensions available? */ #undef _DARWIN_C_SOURCE |
| ︙ | ︙ | |||
507 508 509 510 511 512 513 | /* Define to `int' if <sys/types.h> does not define. */ #undef mode_t /* Define to `int' if <sys/types.h> does not define. */ #undef pid_t | | | 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 | /* Define to `int' if <sys/types.h> does not define. */ #undef mode_t /* Define to `int' if <sys/types.h> does not define. */ #undef pid_t /* Define to `unsigned int' if <sys/types.h> does not define. */ #undef size_t /* Define as int if socklen_t is not available */ #undef socklen_t /* Define to `int' if <sys/types.h> doesn't define. */ #undef uid_t |
| ︙ | ︙ |
Changes to unix/tclConfig.sh.in.
| ︙ | ︙ | |||
17 18 19 20 21 22 23 | # C compiler to use for compilation. TCL_CC='@CC@' # -D flags for use with the C compiler. TCL_DEFS='@DEFS@' | < < < < | 17 18 19 20 21 22 23 24 25 26 27 28 29 30 | # C compiler to use for compilation. TCL_CC='@CC@' # -D flags for use with the C compiler. TCL_DEFS='@DEFS@' # Default flags used in an optimized and debuggable build, respectively. TCL_CFLAGS_DEBUG='@CFLAGS_DEBUG@' TCL_CFLAGS_OPTIMIZE='@CFLAGS_OPTIMIZE@' # Default linker flags used in an optimized and debuggable build, respectively. TCL_LDFLAGS_DEBUG='@LDFLAGS_DEBUG@' TCL_LDFLAGS_OPTIMIZE='@LDFLAGS_OPTIMIZE@' |
| ︙ | ︙ |
Changes to unix/tclLoadDyld.c.
| ︙ | ︙ | |||
606 607 608 609 610 611 612 |
/*
* Fat binary, try to find mach_header for our architecture
*/
if ((size_t) codeSize >= sizeof(struct fat_header) +
fh_nfat_arch * sizeof(struct fat_arch)) {
| | | 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 |
/*
* Fat binary, try to find mach_header for our architecture
*/
if ((size_t) codeSize >= sizeof(struct fat_header) +
fh_nfat_arch * sizeof(struct fat_arch)) {
void *fatarchs = (char *)buffer + sizeof(struct fat_header);
const NXArchInfo *arch = NXGetLocalArchInfo();
struct fat_arch *fa;
if (fh->magic != FAT_MAGIC) {
swap_fat_arch((struct fat_arch *)fatarchs, fh_nfat_arch, arch->byteorder);
}
fa = NXFindBestFatArch(arch->cputype | arch_abi,
|
| ︙ | ︙ |
Changes to unix/tclSelectNotfy.c.
| ︙ | ︙ | |||
212 213 214 215 216 217 218 |
#if defined(__CYGWIN__)
#ifdef __cplusplus
extern "C" {
#endif
typedef struct {
void *hwnd; /* Messaging window. */
unsigned int *message; /* Message payload. */
| | | > | | | | | | | 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 |
#if defined(__CYGWIN__)
#ifdef __cplusplus
extern "C" {
#endif
typedef struct {
void *hwnd; /* Messaging window. */
unsigned int *message; /* Message payload. */
size_t wParam; /* Event-specific "word" parameter. */
size_t lParam; /* Event-specific "long" parameter. */
int time; /* Event timestamp. */
int x; /* Event location (where meaningful). */
int y;
int lPrivate;
} MSG;
typedef struct {
unsigned int style;
void *lpfnWndProc;
int cbClsExtra;
int cbWndExtra;
void *hInstance;
void *hIcon;
void *hCursor;
void *hbrBackground;
const void *lpszMenuName;
const void *lpszClassName;
} WNDCLASSW;
#ifdef __clang__
#pragma clang diagnostic ignored "-Wignored-attributes"
#endif
extern void __stdcall CloseHandle(void *);
extern void *__stdcall CreateEventW(void *, unsigned char, unsigned char,
void *);
extern void *__stdcall CreateWindowExW(void *, const void *, const void *,
unsigned int, int, int, int, int, void *, void *, void *,
void *);
extern unsigned int __stdcall DefWindowProcW(void *, int, void *, void *);
extern unsigned char __stdcall DestroyWindow(void *);
extern int __stdcall DispatchMessageW(const MSG *);
extern unsigned char __stdcall GetMessageW(MSG *, void *, int, int);
extern void __stdcall MsgWaitForMultipleObjects(unsigned int, void *,
unsigned char, unsigned int, unsigned int);
extern unsigned char __stdcall PeekMessageW(MSG *, void *, int, int, int);
extern unsigned char __stdcall PostMessageW(void *, unsigned int, void *,
void *);
extern void __stdcall PostQuitMessage(int);
extern void *__stdcall RegisterClassW(const WNDCLASSW *);
extern unsigned char __stdcall ResetEvent(void *);
extern unsigned char __stdcall TranslateMessage(const MSG *);
/*
* Threaded-cygwin specific constants and functions in this file:
*/
static const wchar_t className[] = L"TclNotifier";
static unsigned int __stdcall NotifierProc(void *hwnd, unsigned int message,
void *wParam, void *lParam);
#ifdef __cplusplus
}
#endif
#endif /* TCL_THREADS && __CYGWIN__ */
|
| ︙ | ︙ | |||
318 319 320 321 322 323 324 | clazz.lpfnWndProc = (void *)NotifierProc; clazz.hIcon = NULL; clazz.hCursor = NULL; RegisterClassW(&clazz); tsdPtr->hwnd = CreateWindowExW(NULL, clazz.lpszClassName, clazz.lpszClassName, 0, 0, 0, 0, 0, NULL, NULL, | | | 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 | clazz.lpfnWndProc = (void *)NotifierProc; clazz.hIcon = NULL; clazz.hCursor = NULL; RegisterClassW(&clazz); tsdPtr->hwnd = CreateWindowExW(NULL, clazz.lpszClassName, clazz.lpszClassName, 0, 0, 0, 0, 0, NULL, NULL, clazz.hInstance, NULL); tsdPtr->event = CreateEventW(NULL, 1 /* manual */, 0 /* !signaled */, NULL); #else pthread_cond_init(&tsdPtr->waitCV, NULL); #endif /* __CYGWIN__ */ tsdPtr->waitCVinitialized = 1; } |
| ︙ | ︙ | |||
594 595 596 597 598 599 600 |
}
Tcl_Free(filePtr);
}
}
#if defined(__CYGWIN__)
| | | 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 |
}
Tcl_Free(filePtr);
}
}
#if defined(__CYGWIN__)
static unsigned int __stdcall
NotifierProc(
void *hwnd,
unsigned int message,
void *wParam,
void *lParam)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
|
| ︙ | ︙ | |||
645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 |
{
if (tclNotifierHooks.waitForEventProc) {
return tclNotifierHooks.waitForEventProc(timePtr);
} else {
FileHandler *filePtr;
int mask;
Tcl_Time vTime;
#if TCL_THREADS
int waitForFiles;
# ifdef __CYGWIN__
MSG msg;
# endif /* __CYGWIN__ */
#else /* !TCL_THREADS */
/*
* Impl. notes: timeout & timeoutPtr are used if, and only if threads
* are not enabled. They are the arguments for the regular select()
* used when the core is not thread-enabled.
*/
struct timeval timeout, *timeoutPtr;
int numFound;
#endif /* TCL_THREADS */
| > < | 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 |
{
if (tclNotifierHooks.waitForEventProc) {
return tclNotifierHooks.waitForEventProc(timePtr);
} else {
FileHandler *filePtr;
int mask;
Tcl_Time vTime;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
#if TCL_THREADS
int waitForFiles;
# ifdef __CYGWIN__
MSG msg;
# endif /* __CYGWIN__ */
#else /* !TCL_THREADS */
/*
* Impl. notes: timeout & timeoutPtr are used if, and only if threads
* are not enabled. They are the arguments for the regular select()
* used when the core is not thread-enabled.
*/
struct timeval timeout, *timeoutPtr;
int numFound;
#endif /* TCL_THREADS */
/*
* Set up the timeout structure. Note that if there are no events to
* check for, we return with a negative result rather than blocking
* forever.
*/
|
| ︙ | ︙ | |||
765 766 767 768 769 770 771 |
FD_ZERO(&tsdPtr->readyMasks.readable);
FD_ZERO(&tsdPtr->readyMasks.writable);
FD_ZERO(&tsdPtr->readyMasks.exception);
if (!tsdPtr->eventReady) {
#ifdef __CYGWIN__
if (!PeekMessageW(&msg, NULL, 0, 0, 0)) {
| | | 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 |
FD_ZERO(&tsdPtr->readyMasks.readable);
FD_ZERO(&tsdPtr->readyMasks.writable);
FD_ZERO(&tsdPtr->readyMasks.exception);
if (!tsdPtr->eventReady) {
#ifdef __CYGWIN__
if (!PeekMessageW(&msg, NULL, 0, 0, 0)) {
unsigned int timeout;
if (timePtr) {
timeout = timePtr->sec * 1000 + timePtr->usec / 1000;
} else {
timeout = 0xFFFFFFFF;
}
pthread_mutex_unlock(¬ifierMutex);
|
| ︙ | ︙ | |||
800 801 802 803 804 805 806 |
#ifdef __CYGWIN__
while (PeekMessageW(&msg, NULL, 0, 0, 0)) {
/*
* Retrieve and dispatch the message.
*/
| | | | 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 |
#ifdef __CYGWIN__
while (PeekMessageW(&msg, NULL, 0, 0, 0)) {
/*
* Retrieve and dispatch the message.
*/
unsigned int result = GetMessageW(&msg, NULL, 0, 0);
if (result == 0) {
PostQuitMessage(msg.wParam);
/* What to do here? */
} else if (result != (unsigned int) -1) {
TranslateMessage(&msg);
DispatchMessageW(&msg);
}
}
ResetEvent(tsdPtr->event);
#endif /* __CYGWIN__ */
|
| ︙ | ︙ |
Changes to unix/tclUnixCompat.c.
| ︙ | ︙ | |||
378 379 380 381 382 383 384 |
*/
if (tsdPtr->gbuf == NULL) {
tsdPtr->gbuflen = (int) sysconf(_SC_GETGR_R_SIZE_MAX);
if (tsdPtr->gbuflen < 1) {
tsdPtr->gbuflen = 1024;
}
| | | 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 |
*/
if (tsdPtr->gbuf == NULL) {
tsdPtr->gbuflen = (int) sysconf(_SC_GETGR_R_SIZE_MAX);
if (tsdPtr->gbuflen < 1) {
tsdPtr->gbuflen = 1024;
}
tsdPtr->gbuf = (char *)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) {
|
| ︙ | ︙ | |||
458 459 460 461 462 463 464 |
*/
if (tsdPtr->gbuf == NULL) {
tsdPtr->gbuflen = (int) sysconf(_SC_GETGR_R_SIZE_MAX);
if (tsdPtr->gbuflen < 1) {
tsdPtr->gbuflen = 1024;
}
| | | 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 |
*/
if (tsdPtr->gbuf == NULL) {
tsdPtr->gbuflen = (int) sysconf(_SC_GETGR_R_SIZE_MAX);
if (tsdPtr->gbuflen < 1) {
tsdPtr->gbuflen = 1024;
}
tsdPtr->gbuf = (char *)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) {
|
| ︙ | ︙ | |||
897 898 899 900 901 902 903 |
*/
}
len = sizeof(char *) * (i + 1); /* Leave place for the array. */
if (len > buflen) {
return -1;
}
| | | 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 |
*/
}
len = sizeof(char *) * (i + 1); /* Leave place for the array. */
if (len > buflen) {
return -1;
}
newBuffer = (char **)buf;
p = buf + len;
for (j = 0; j < i; j++) {
int sz = (elsize<0 ? (int) strlen(src[j]) + 1 : elsize);
len += sz;
if (len > buflen) {
|
| ︙ | ︙ |
Changes to unix/tclUnixFCmd.c.
| ︙ | ︙ | |||
1834 1835 1836 1837 1838 1839 1840 |
oldMode = *modePtr;
who = op = what = op_found = who_found = 0;
for (i = 0 ; *(modeStringPtr+n+i) != '\0' ; i++ ) {
if (!who_found) {
/* who */
switch (*(modeStringPtr+n+i)) {
case 'u':
| | | | | 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 |
oldMode = *modePtr;
who = op = what = op_found = who_found = 0;
for (i = 0 ; *(modeStringPtr+n+i) != '\0' ; i++ ) {
if (!who_found) {
/* who */
switch (*(modeStringPtr+n+i)) {
case 'u':
who |= 0x9C0;
continue;
case 'g':
who |= 0x438;
continue;
case 'o':
who |= 0x207;
continue;
case 'a':
who |= 0xFFF;
continue;
}
}
who_found = 1;
if (who == 0) {
who = 0xFFF;
}
if (!op_found) {
/* op */
switch (*(modeStringPtr+n+i)) {
case '+':
op = 1;
op_found = 1;
|
| ︙ | ︙ | |||
1882 1883 1884 1885 1886 1887 1888 | case 'w': what |= 0x92; continue; case 'x': what |= 0x49; continue; case 's': | | | 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 | case 'w': what |= 0x92; continue; case 'x': what |= 0x49; continue; case 's': what |= 0xC00; continue; case 't': what |= 0x200; continue; case ',': break; default: |
| ︙ | ︙ |
Changes to unix/tclUnixFile.c.
| ︙ | ︙ | |||
101 102 103 104 105 106 107 |
/*
* Search through all the directories named in the PATH variable to see if
* argv[0] is in one of them. If so, use that file name.
*/
while (1) {
| | | 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 |
/*
* Search through all the directories named in the PATH variable to see if
* argv[0] is in one of them. If so, use that file name.
*/
while (1) {
while (TclIsSpaceProcM(*p)) {
p++;
}
name = p;
while ((*p != ':') && (*p != 0)) {
p++;
}
TclDStringClear(&buffer);
|
| ︙ | ︙ | |||
725 726 727 728 729 730 731 |
#else
if (getcwd(buffer, MAXPATHLEN+1) == NULL) { /* INTL: Native. */
return NULL;
}
#endif /* USEGETWD */
if ((clientData == NULL) || strcmp(buffer, (const char *) clientData)) {
| | | 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 |
#else
if (getcwd(buffer, MAXPATHLEN+1) == NULL) { /* INTL: Native. */
return NULL;
}
#endif /* USEGETWD */
if ((clientData == NULL) || strcmp(buffer, (const char *) clientData)) {
char *newCd = (char *)Tcl_Alloc(strlen(buffer) + 1);
strcpy(newCd, buffer);
return newCd;
}
/*
* No change to pwd.
|
| ︙ | ︙ |
Changes to unix/tclUnixInit.c.
| ︙ | ︙ | |||
50 51 52 53 54 55 56 |
static const char *const processors[NUMPROCESSORS] = {
"intel", "mips", "alpha", "ppc", "shx", "arm", "ia64", "alpha64", "msil",
"amd64", "ia32_on_win64"
};
typedef struct {
union {
| | | | | | | | | | | | 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 |
static const char *const processors[NUMPROCESSORS] = {
"intel", "mips", "alpha", "ppc", "shx", "arm", "ia64", "alpha64", "msil",
"amd64", "ia32_on_win64"
};
typedef struct {
union {
unsigned int dwOemId;
struct {
int wProcessorArchitecture;
int wReserved;
};
};
unsigned int dwPageSize;
void *lpMinimumApplicationAddress;
void *lpMaximumApplicationAddress;
void *dwActiveProcessorMask;
unsigned int dwNumberOfProcessors;
unsigned int dwProcessorType;
unsigned int dwAllocationGranularity;
int wProcessorLevel;
int wProcessorRevision;
} SYSTEM_INFO;
typedef struct {
unsigned int dwOSVersionInfoSize;
unsigned int dwMajorVersion;
unsigned int dwMinorVersion;
unsigned int dwBuildNumber;
unsigned int dwPlatformId;
wchar_t szCSDVersion[128];
} OSVERSIONINFOW;
#endif
#ifdef HAVE_COREFOUNDATION
#include <CoreFoundation/CoreFoundation.h>
#endif
|
| ︙ | ︙ | |||
129 130 131 132 133 134 135 |
* default encoding directory. Indented by one TAB are the encoding names that
* are common alternative spellings. Indented by two TABs are the accumulated
* "bug fixes" that have been added to deal with the wide variability seen
* among existing platforms.
*/
static const LocaleTable localeTable[] = {
| | | | | 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 |
* default encoding directory. Indented by one TAB are the encoding names that
* are common alternative spellings. Indented by two TABs are the accumulated
* "bug fixes" that have been added to deal with the wide variability seen
* among existing platforms.
*/
static const LocaleTable localeTable[] = {
{"", "iso8859-1"},
{"ansi-1251", "cp1251"},
{"ansi_x3.4-1968", "iso8859-1"},
{"ascii", "ascii"},
{"big5", "big5"},
{"cp1250", "cp1250"},
{"cp1251", "cp1251"},
{"cp1252", "cp1252"},
{"cp1253", "cp1253"},
{"cp1254", "cp1254"},
|
| ︙ | ︙ | |||
168 169 170 171 172 173 174 |
{"cp949", "cp949"},
{"cp950", "cp950"},
{"dingbats", "dingbats"},
{"ebcdic", "ebcdic"},
{"euc-cn", "euc-cn"},
{"euc-jp", "euc-jp"},
{"euc-kr", "euc-kr"},
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 |
{"cp949", "cp949"},
{"cp950", "cp950"},
{"dingbats", "dingbats"},
{"ebcdic", "ebcdic"},
{"euc-cn", "euc-cn"},
{"euc-jp", "euc-jp"},
{"euc-kr", "euc-kr"},
{"eucjp", "euc-jp"},
{"euckr", "euc-kr"},
{"euctw", "euc-cn"},
{"gb12345", "gb12345"},
{"gb1988", "gb1988"},
{"gb2312", "gb2312"},
{"gb2312-1980", "gb2312"},
{"gb2312-raw", "gb2312-raw"},
{"greek8", "cp869"},
{"ibm1250", "cp1250"},
{"ibm1251", "cp1251"},
{"ibm1252", "cp1252"},
{"ibm1253", "cp1253"},
{"ibm1254", "cp1254"},
{"ibm1255", "cp1255"},
{"ibm1256", "cp1256"},
{"ibm1257", "cp1257"},
{"ibm1258", "cp1258"},
{"ibm437", "cp437"},
{"ibm737", "cp737"},
{"ibm775", "cp775"},
{"ibm850", "cp850"},
{"ibm852", "cp852"},
{"ibm855", "cp855"},
{"ibm857", "cp857"},
{"ibm860", "cp860"},
{"ibm861", "cp861"},
{"ibm862", "cp862"},
{"ibm863", "cp863"},
{"ibm864", "cp864"},
{"ibm865", "cp865"},
{"ibm866", "cp866"},
{"ibm869", "cp869"},
{"ibm874", "cp874"},
{"ibm932", "cp932"},
{"ibm936", "cp936"},
{"ibm949", "cp949"},
{"ibm950", "cp950"},
{"iso-2022", "iso2022"},
{"iso-2022-jp", "iso2022-jp"},
{"iso-2022-kr", "iso2022-kr"},
{"iso-8859-1", "iso8859-1"},
{"iso-8859-10", "iso8859-10"},
{"iso-8859-13", "iso8859-13"},
{"iso-8859-14", "iso8859-14"},
{"iso-8859-15", "iso8859-15"},
{"iso-8859-16", "iso8859-16"},
{"iso-8859-2", "iso8859-2"},
{"iso-8859-3", "iso8859-3"},
{"iso-8859-4", "iso8859-4"},
{"iso-8859-5", "iso8859-5"},
{"iso-8859-6", "iso8859-6"},
{"iso-8859-7", "iso8859-7"},
{"iso-8859-8", "iso8859-8"},
{"iso-8859-9", "iso8859-9"},
{"iso2022", "iso2022"},
{"iso2022-jp", "iso2022-jp"},
{"iso2022-kr", "iso2022-kr"},
{"iso8859-1", "iso8859-1"},
{"iso8859-10", "iso8859-10"},
{"iso8859-13", "iso8859-13"},
{"iso8859-14", "iso8859-14"},
{"iso8859-15", "iso8859-15"},
{"iso8859-16", "iso8859-16"},
{"iso8859-2", "iso8859-2"},
{"iso8859-3", "iso8859-3"},
{"iso8859-4", "iso8859-4"},
{"iso8859-5", "iso8859-5"},
{"iso8859-6", "iso8859-6"},
{"iso8859-7", "iso8859-7"},
{"iso8859-8", "iso8859-8"},
{"iso8859-9", "iso8859-9"},
{"iso88591", "iso8859-1"},
{"iso885915", "iso8859-15"},
{"iso88592", "iso8859-2"},
{"iso88595", "iso8859-5"},
{"iso88596", "iso8859-6"},
{"iso88597", "iso8859-7"},
{"iso88598", "iso8859-8"},
{"iso88599", "iso8859-9"},
#ifdef hpux
{"ja", "shiftjis"},
#else
{"ja", "euc-jp"},
#endif
{"ja_jp", "euc-jp"},
{"ja_jp.euc", "euc-jp"},
{"ja_jp.eucjp", "euc-jp"},
{"ja_jp.jis", "iso2022-jp"},
{"ja_jp.mscode", "shiftjis"},
{"ja_jp.sjis", "shiftjis"},
{"ja_jp.ujis", "euc-jp"},
{"japan", "euc-jp"},
#ifdef hpux
{"japanese", "shiftjis"},
#else
{"japanese", "euc-jp"},
#endif
{"japanese-sjis", "shiftjis"},
{"japanese-ujis", "euc-jp"},
{"japanese.euc", "euc-jp"},
{"japanese.sjis", "shiftjis"},
{"jis0201", "jis0201"},
{"jis0208", "jis0208"},
{"jis0212", "jis0212"},
{"jp_jp", "shiftjis"},
{"ko", "euc-kr"},
{"ko_kr", "euc-kr"},
{"ko_kr.euc", "euc-kr"},
{"ko_kw.euckw", "euc-kr"},
{"koi8-r", "koi8-r"},
{"koi8-u", "koi8-u"},
{"korean", "euc-kr"},
{"ksc5601", "ksc5601"},
{"maccenteuro", "macCentEuro"},
{"maccroatian", "macCroatian"},
{"maccyrillic", "macCyrillic"},
{"macdingbats", "macDingbats"},
{"macgreek", "macGreek"},
{"maciceland", "macIceland"},
{"macjapan", "macJapan"},
{"macroman", "macRoman"},
{"macromania", "macRomania"},
{"macthai", "macThai"},
{"macturkish", "macTurkish"},
{"macukraine", "macUkraine"},
{"roman8", "iso8859-1"},
{"ru", "iso8859-5"},
{"ru_ru", "iso8859-5"},
{"ru_su", "iso8859-5"},
{"shiftjis", "shiftjis"},
{"sjis", "shiftjis"},
{"symbol", "symbol"},
{"tis-620", "tis-620"},
{"tis620", "tis-620"},
{"turkish8", "cp857"},
{"utf8", "utf-8"},
{"zh", "cp936"},
{"zh_cn.gb2312", "euc-cn"},
{"zh_cn.gbk", "euc-cn"},
{"zh_cz.gb2312", "euc-cn"},
{"zh_tw", "euc-tw"},
{"zh_tw.big5", "big5"},
};
#ifdef HAVE_COREFOUNDATION
static int MacOSXGetLibraryPath(Tcl_Interp *interp,
int maxPathLen, char *tclLibPath);
#endif /* HAVE_COREFOUNDATION */
#if defined(__APPLE__) && (defined(TCL_LOAD_FROM_MEMORY) || ( \
|
| ︙ | ︙ | |||
869 870 871 872 873 874 875 |
Tcl_SetVar2(interp, "tcl_platform", "platform", "unix", TCL_GLOBAL_ONLY);
#endif
unameOK = 0;
#ifdef __CYGWIN__
unameOK = 1;
if (!osInfoInitialized) {
| | | > | 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 |
Tcl_SetVar2(interp, "tcl_platform", "platform", "unix", TCL_GLOBAL_ONLY);
#endif
unameOK = 0;
#ifdef __CYGWIN__
unameOK = 1;
if (!osInfoInitialized) {
void *handle = GetModuleHandleW(L"NTDLL");
int(__stdcall *getversion)(void *) =
(int(__stdcall *)(void *))GetProcAddress(handle, "RtlGetVersion");
osInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFOW);
if (!getversion || getversion(&osInfo)) {
GetVersionExW(&osInfo);
}
osInfoInitialized = 1;
}
GetSystemInfo(&sysInfo);
Tcl_SetVar2(interp, "tcl_platform", "os",
"Windows NT", TCL_GLOBAL_ONLY);
sprintf(buffer, "%d.%d", osInfo.dwMajorVersion, osInfo.dwMinorVersion);
Tcl_SetVar2(interp, "tcl_platform", "osVersion", buffer, TCL_GLOBAL_ONLY);
if (sysInfo.wProcessorArchitecture < NUMPROCESSORS) {
Tcl_SetVar2(interp, "tcl_platform", "machine",
processors[sysInfo.wProcessorArchitecture],
TCL_GLOBAL_ONLY);
}
|
| ︙ | ︙ |
Changes to unix/tclUnixPort.h.
| ︙ | ︙ | |||
82 83 84 85 86 87 88 | #else typedef off_t Tcl_SeekOffset; # define TclOSseek lseek # define TclOSopen open #endif #ifdef __CYGWIN__ | < < < < < < < < < < | | | | | 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 |
#else
typedef off_t Tcl_SeekOffset;
# define TclOSseek lseek
# define TclOSopen open
#endif
#ifdef __CYGWIN__
#ifdef __cplusplus
extern "C" {
#endif
/* Make some symbols available without including <windows.h> */
# define CP_UTF8 65001
# define GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS 0x00000004
# define SOCKET unsigned int
# define WSAEWOULDBLOCK 10035
typedef unsigned short WCHAR;
#ifdef __clang__
#pragma clang diagnostic push
#pragma clang diagnostic ignored "-Wignored-attributes"
#endif
__declspec(dllimport) extern __stdcall int GetModuleHandleExW(unsigned int, const void *, void *);
__declspec(dllimport) extern __stdcall int GetModuleFileNameW(void *, const void *, int);
__declspec(dllimport) extern __stdcall int WideCharToMultiByte(int, int, const void *, int,
char *, int, const char *, void *);
__declspec(dllimport) extern __stdcall int MultiByteToWideChar(int, int, const char *, int,
WCHAR *, int);
__declspec(dllimport) extern __stdcall void OutputDebugStringW(const WCHAR *);
__declspec(dllimport) extern __stdcall int IsDebuggerPresent(void);
__declspec(dllimport) extern __stdcall int GetLastError(void);
__declspec(dllimport) extern __stdcall int GetFileAttributesW(const WCHAR *);
__declspec(dllimport) extern __stdcall int SetFileAttributesW(const WCHAR *, int);
__declspec(dllimport) extern int cygwin_conv_path(int, const void *, void *, int);
#ifdef __clang__
#pragma clang diagnostic pop
#endif
# define timezone _timezone
extern int TclOSstat(const char *name, void *statBuf);
extern int TclOSlstat(const char *name, void *statBuf);
#ifdef __cplusplus
}
#endif
#elif defined(HAVE_STRUCT_STAT64) && !defined(__APPLE__)
# define TclOSstat(name, buf) stat64(name, (struct stat64 *)buf)
# define TclOSlstat(name,buf) lstat64(name, (struct stat64 *)buf)
#else
# define TclOSstat(name, buf) stat(name, (struct stat *)buf)
# define TclOSlstat(name, buf) lstat(name, (struct stat *)buf)
#endif
/*
*---------------------------------------------------------------------------
* Miscellaneous includes that might be missing.
*---------------------------------------------------------------------------
*/
|
| ︙ | ︙ |
Changes to unix/tclUnixSock.c.
| ︙ | ︙ | |||
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 | #define SOCKET_BUFSIZE 4096 /* * Static routines for this file: */ static int TcpConnect(Tcl_Interp *interp, TcpState *state); static void TcpAccept(void *data, int mask); static int TcpBlockModeProc(void *data, int mode); static int TcpCloseProc(void *instanceData, Tcl_Interp *interp); static int TcpClose2Proc(void *instanceData, Tcl_Interp *interp, int flags); static int TcpGetHandleProc(void *instanceData, int direction, void **handlePtr); static int TcpGetOptionProc(void *instanceData, Tcl_Interp *interp, const char *optionName, Tcl_DString *dsPtr); static int TcpInputProc(void *instanceData, char *buf, int toRead, int *errorCode); static int TcpOutputProc(void *instanceData, const char *buf, int toWrite, int *errorCode); static void TcpWatchProc(void *instanceData, int mask); static int WaitForConnect(TcpState *statePtr, int *errorCodePtr); static void WrapNotify(void *clientData, int mask); /* * This structure describes the channel type structure for TCP socket * based IO: | > > | 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 | #define SOCKET_BUFSIZE 4096 /* * Static routines for this file: */ static void TcpAsyncCallback(void *clientData, int mask); static int TcpConnect(Tcl_Interp *interp, TcpState *state); static void TcpAccept(void *data, int mask); static int TcpBlockModeProc(void *data, int mode); static int TcpCloseProc(void *instanceData, Tcl_Interp *interp); static int TcpClose2Proc(void *instanceData, Tcl_Interp *interp, int flags); static int TcpGetHandleProc(void *instanceData, int direction, void **handlePtr); static int TcpGetOptionProc(void *instanceData, Tcl_Interp *interp, const char *optionName, Tcl_DString *dsPtr); static int TcpInputProc(void *instanceData, char *buf, int toRead, int *errorCode); static int TcpOutputProc(void *instanceData, const char *buf, int toWrite, int *errorCode); static void TcpThreadActionProc(void *instanceData, int action); static void TcpWatchProc(void *instanceData, int mask); static int WaitForConnect(TcpState *statePtr, int *errorCodePtr); static void WrapNotify(void *clientData, int mask); /* * This structure describes the channel type structure for TCP socket * based IO: |
| ︙ | ︙ | |||
166 167 168 169 170 171 172 |
TcpWatchProc, /* Initialize notifier. */
TcpGetHandleProc, /* Get OS handles out of channel. */
TcpClose2Proc, /* Close2 proc. */
TcpBlockModeProc, /* Set blocking or non-blocking mode.*/
NULL, /* flush proc. */
NULL, /* handler proc. */
NULL, /* wide seek proc. */
| | | 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 |
TcpWatchProc, /* Initialize notifier. */
TcpGetHandleProc, /* Get OS handles out of channel. */
TcpClose2Proc, /* Close2 proc. */
TcpBlockModeProc, /* Set blocking or non-blocking mode.*/
NULL, /* flush proc. */
NULL, /* handler proc. */
NULL, /* wide seek proc. */
TcpThreadActionProc, /* thread action proc. */
NULL /* truncate proc. */
};
/*
* The following variable holds the network name of this host.
*/
|
| ︙ | ︙ | |||
972 973 974 975 976 977 978 979 980 981 982 983 984 985 |
if (len > 0) {
return Tcl_BadChannelOption(interp, optionName,
"connecting peername sockname");
}
return TCL_OK;
}
/*
* ----------------------------------------------------------------------
*
* TcpWatchProc --
*
* Initialize the notifier to watch the fd from this channel.
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
if (len > 0) {
return Tcl_BadChannelOption(interp, optionName,
"connecting peername sockname");
}
return TCL_OK;
}
/*
* ----------------------------------------------------------------------
*
* TcpThreadActionProc --
*
* Handles detach/attach for asynchronously connecting socket.
*
* Reassigning the file handler associated with thread-related channel
* notification, responsible for callbacks (signaling that asynchronous
* connection attempt has succeeded or failed).
*
* Results:
* None.
*
* ----------------------------------------------------------------------
*/
static void
TcpThreadActionProc(
void *instanceData,
int action)
{
TcpState *statePtr = (TcpState *)instanceData;
if (GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT)) {
/*
* Async-connecting socket must get reassigned handler if it have been
* transferred to another thread. Remove the handler if the socket is
* not managed by this thread anymore and create new handler (TSD related)
* so the callback will run in the correct thread, bug [f583715154].
*/
switch (action) {
case TCL_CHANNEL_THREAD_REMOVE:
CLEAR_BITS(statePtr->flags, TCP_ASYNC_PENDING);
Tcl_DeleteFileHandler(statePtr->fds.fd);
break;
case TCL_CHANNEL_THREAD_INSERT:
Tcl_CreateFileHandler(statePtr->fds.fd,
TCL_WRITABLE | TCL_EXCEPTION, TcpAsyncCallback, statePtr);
SET_BITS(statePtr->flags, TCP_ASYNC_PENDING);
break;
}
}
}
/*
* ----------------------------------------------------------------------
*
* TcpWatchProc --
*
* Initialize the notifier to watch the fd from this channel.
|
| ︙ | ︙ |
Changes to unix/tclUnixThrd.c.
| ︙ | ︙ | |||
157 158 159 160 161 162 163 |
struct timespec *ptime)
{
pthread_cond_timedwait(pcondPtr, &pmutexPtr->mutex, ptime);
}
#endif /* HAVE_PTHREAD_MUTEX_RECURSIVE */
/*
| | | | | | 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 |
struct timespec *ptime)
{
pthread_cond_timedwait(pcondPtr, &pmutexPtr->mutex, ptime);
}
#endif /* HAVE_PTHREAD_MUTEX_RECURSIVE */
/*
* globalLock is used to serialize creation of mutexes, condition variables,
* and thread local storage. This is the only place that can count on the
* ability to statically initialize the mutex.
*/
static pthread_mutex_t globalLock = PTHREAD_MUTEX_INITIALIZER;
/*
* initLock is used to serialize initialization and finalization of Tcl. It
* cannot use any dynamically allocated storage.
*/
static pthread_mutex_t initLock = PTHREAD_MUTEX_INITIALIZER;
/*
* allocLock is used by Tcl's version of malloc for synchronization. For
* obvious reasons, cannot use any dynamically allocated storage.
*/
static PMutex allocLock;
static pthread_once_t allocLockInitOnce = PTHREAD_ONCE_INIT;
static void
allocLockInit(void)
|
| ︙ | ︙ | |||
254 255 256 257 258 259 260 |
#endif /* HAVE_PTHREAD_ATTR_SETSTACKSIZE */
if (!(flags & TCL_THREAD_JOINABLE)) {
pthread_attr_setdetachstate(&attr, PTHREAD_CREATE_DETACHED);
}
if (pthread_create(&theThread, &attr,
| | | | | 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 |
#endif /* HAVE_PTHREAD_ATTR_SETSTACKSIZE */
if (!(flags & TCL_THREAD_JOINABLE)) {
pthread_attr_setdetachstate(&attr, PTHREAD_CREATE_DETACHED);
}
if (pthread_create(&theThread, &attr,
(void * (*)(void *))(void *)proc, (void *)clientData) &&
pthread_create(&theThread, NULL,
(void * (*)(void *))(void *)proc, (void *)clientData)) {
result = TCL_ERROR;
} else {
*idPtr = (Tcl_ThreadId)theThread;
result = TCL_OK;
}
pthread_attr_destroy(&attr);
return result;
#else
return TCL_ERROR;
#endif /* TCL_THREADS */
|
| ︙ | ︙ | |||
411 412 413 414 415 416 417 |
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
| | | 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 |
void
TclFinalizeLock(void)
{
#if TCL_THREADS
/*
* You do not need to destroy mutexes that were created with the
* PTHREAD_MUTEX_INITIALIZER macro. These mutexes do not need any
* destruction: globalLock, allocLock, and initLock.
*/
pthread_mutex_unlock(&initLock);
#endif
}
/*
|
| ︙ | ︙ | |||
446 447 448 449 450 451 452 |
pthread_mutex_unlock(&initLock);
#endif
}
/*
*----------------------------------------------------------------------
*
| | | | | | | | | | | 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 |
pthread_mutex_unlock(&initLock);
#endif
}
/*
*----------------------------------------------------------------------
*
* TclpGlobalLock
*
* This procedure is used to grab a lock that serializes creation and
* finalization of serialization objects. This interface is only needed
* in finalization; it is hidden during creation of the objects.
*
* This lock must be different than the initLock because the initLock is
* held during creation of synchronization objects.
*
* Results:
* None.
*
* Side effects:
* Acquire the global mutex.
*
*----------------------------------------------------------------------
*/
void
TclpGlobalLock(void)
{
#if TCL_THREADS
pthread_mutex_lock(&globalLock);
#endif
}
/*
*----------------------------------------------------------------------
*
* TclpGlobalUnlock
*
* This procedure is used to release a lock that serializes creation and
* finalization of synchronization objects.
*
* Results:
* None.
*
* Side effects:
* Release the global mutex.
*
*----------------------------------------------------------------------
*/
void
TclpGlobalUnlock(void)
{
#if TCL_THREADS
pthread_mutex_unlock(&globalLock);
#endif
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetAllocMutex
*
* This procedure returns a pointer to a statically initialized mutex for
* use by the memory allocator. The allocator must use this lock, because
* all other locks are allocated...
*
* Results:
* A pointer to a mutex that is suitable for passing to Tcl_MutexLock and
* Tcl_MutexUnlock.
*
* Side effects:
|
| ︙ | ︙ | |||
559 560 561 562 563 564 565 |
void
Tcl_MutexLock(
Tcl_Mutex *mutexPtr) /* Really (PMutex **) */
{
PMutex *pmutexPtr;
if (*mutexPtr == NULL) {
| | | | | 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 |
void
Tcl_MutexLock(
Tcl_Mutex *mutexPtr) /* Really (PMutex **) */
{
PMutex *pmutexPtr;
if (*mutexPtr == NULL) {
pthread_mutex_lock(&globalLock);
if (*mutexPtr == NULL) {
/*
* Double inside global lock check to avoid a race condition.
*/
pmutexPtr = (PMutex *)Tcl_Alloc(sizeof(PMutex));
PMutexInit(pmutexPtr);
*mutexPtr = (Tcl_Mutex) pmutexPtr;
TclRememberMutex(mutexPtr);
}
pthread_mutex_unlock(&globalLock);
}
pmutexPtr = *((PMutex **) mutexPtr);
PMutexLock(pmutexPtr);
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
610 611 612 613 614 615 616 | *---------------------------------------------------------------------- * * TclpFinalizeMutex -- * * This procedure is invoked to clean up one mutex. This is only safe to * call at the end of time. * | | | 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 | *---------------------------------------------------------------------- * * TclpFinalizeMutex -- * * This procedure is invoked to clean up one mutex. This is only safe to * call at the end of time. * * This assumes the Global Lock is held. * * Results: * None. * * Side effects: * The mutex list is deallocated. * |
| ︙ | ︙ | |||
667 668 669 670 671 672 673 |
const Tcl_Time *timePtr) /* Timeout on waiting period */
{
pthread_cond_t *pcondPtr;
PMutex *pmutexPtr;
struct timespec ptime;
if (*condPtr == NULL) {
| | | | | | 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 |
const Tcl_Time *timePtr) /* Timeout on waiting period */
{
pthread_cond_t *pcondPtr;
PMutex *pmutexPtr;
struct timespec ptime;
if (*condPtr == NULL) {
pthread_mutex_lock(&globalLock);
/*
* Double check inside mutex to avoid race, then initialize condition
* variable if necessary.
*/
if (*condPtr == NULL) {
pcondPtr = (pthread_cond_t *)Tcl_Alloc(sizeof(pthread_cond_t));
pthread_cond_init(pcondPtr, NULL);
*condPtr = (Tcl_Condition) pcondPtr;
TclRememberCondition(condPtr);
}
pthread_mutex_unlock(&globalLock);
}
pmutexPtr = *((PMutex **)mutexPtr);
pcondPtr = *((pthread_cond_t **)condPtr);
if (timePtr == NULL) {
PCondWait(pcondPtr, pmutexPtr);
} else {
Tcl_Time now;
/*
* Make sure to take into account the microsecond component of the
|
| ︙ | ︙ | |||
725 726 727 728 729 730 731 |
*----------------------------------------------------------------------
*/
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 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 |
*----------------------------------------------------------------------
*/
void
Tcl_ConditionNotify(
Tcl_Condition *condPtr)
{
pthread_cond_t *pcondPtr = *((pthread_cond_t **)condPtr);
if (pcondPtr != NULL) {
pthread_cond_broadcast(pcondPtr);
} else {
/*
* No-one has used the condition variable, so there are no waiters.
*/
}
}
/*
*----------------------------------------------------------------------
*
* TclpFinalizeCondition --
*
* This procedure is invoked to clean up a condition variable. This is
* only safe to call at the end of time.
*
* This assumes the Global Lock is held.
*
* Results:
* None.
*
* Side effects:
* The condition variable is deallocated.
*
*----------------------------------------------------------------------
*/
void
TclpFinalizeCondition(
Tcl_Condition *condPtr)
{
pthread_cond_t *pcondPtr = *(pthread_cond_t **)condPtr;
if (pcondPtr != NULL) {
pthread_cond_destroy(pcondPtr);
Tcl_Free(pcondPtr);
*condPtr = NULL;
}
}
|
| ︙ | ︙ | |||
800 801 802 803 804 805 806 |
return &lockPtr->tlock;
}
void
TclpFreeAllocMutex(
Tcl_Mutex *mutex) /* The alloc mutex to free. */
{
| | | 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 |
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);
}
|
| ︙ | ︙ | |||
883 884 885 886 887 888 889 |
Tcl_Panic("unable to delete key!");
}
TclpSysFree(keyPtr);
}
void
| | | | | | 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 |
Tcl_Panic("unable to delete key!");
}
TclpSysFree(keyPtr);
}
void
TclpThreadSetGlobalTSD(
void *tsdKeyPtr,
void *ptr)
{
pthread_key_t *ptkeyPtr = (pthread_key_t *)tsdKeyPtr;
if (pthread_setspecific(*ptkeyPtr, ptr)) {
Tcl_Panic("unable to set global TSD value");
}
}
void *
TclpThreadGetGlobalTSD(
void *tsdKeyPtr)
{
pthread_key_t *ptkeyPtr = (pthread_key_t *)tsdKeyPtr;
return pthread_getspecific(*ptkeyPtr);
}
#endif /* TCL_THREADS */
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to win/Makefile.in.
| ︙ | ︙ | |||
45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 | # Directory in which to install the .a or .so binary for the Tcl library: LIB_INSTALL_DIR = $(INSTALL_ROOT)$(libdir) # Path name to use when installing library scripts. SCRIPT_INSTALL_DIR = $(INSTALL_ROOT)$(TCL_LIBRARY) # Directory in which to install the include file tcl.h: INCLUDE_INSTALL_DIR = $(INSTALL_ROOT)$(includedir) # Directory in which to (optionally) install the private tcl headers: PRIVATE_INCLUDE_INSTALL_DIR = $(INSTALL_ROOT)$(includedir) # Top-level directory in which to install manual entries: MAN_INSTALL_DIR = $(INSTALL_ROOT)$(mandir) # Directory in which to install manual entry for tclsh: MAN1_INSTALL_DIR = $(MAN_INSTALL_DIR)/man1 # Directory in which to install manual entries for Tcl's C library procedures: MAN3_INSTALL_DIR = $(MAN_INSTALL_DIR)/man3 # Directory in which to install manual entries for the built-in Tcl commands: MANN_INSTALL_DIR = $(MAN_INSTALL_DIR)/mann | > > > < < < | 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 | # Directory in which to install the .a or .so binary for the Tcl library: LIB_INSTALL_DIR = $(INSTALL_ROOT)$(libdir) # Path name to use when installing library scripts. SCRIPT_INSTALL_DIR = $(INSTALL_ROOT)$(TCL_LIBRARY) # Path name to use when installing Tcl modules. MODULE_INSTALL_DIR = $(SCRIPT_INSTALL_DIR)/../tcl9 # Directory in which to install the include file tcl.h: INCLUDE_INSTALL_DIR = $(INSTALL_ROOT)$(includedir) # Directory in which to (optionally) install the private tcl headers: PRIVATE_INCLUDE_INSTALL_DIR = $(INSTALL_ROOT)$(includedir) # Top-level directory in which to install manual entries: MAN_INSTALL_DIR = $(INSTALL_ROOT)$(mandir) # Directory in which to install manual entry for tclsh: MAN1_INSTALL_DIR = $(MAN_INSTALL_DIR)/man1 # Directory in which to install manual entries for Tcl's C library procedures: MAN3_INSTALL_DIR = $(MAN_INSTALL_DIR)/man3 # Directory in which to install manual entries for the built-in Tcl commands: MANN_INSTALL_DIR = $(MAN_INSTALL_DIR)/mann # warning flags CFLAGS_WARNING = @CFLAGS_WARNING@ # The default switches for optimization or debugging CFLAGS_DEBUG = @CFLAGS_DEBUG@ CFLAGS_OPTIMIZE = @CFLAGS_OPTIMIZE@ |
| ︙ | ︙ | |||
113 114 115 116 117 118 119 120 121 122 123 124 125 126 | bindir_native = $(shell $(CYGPATH) '$(bindir)') includedir_native = $(shell $(CYGPATH) '$(includedir)') mandir_native = $(shell $(CYGPATH) '$(mandir)') TCL_LIBRARY_NATIVE = $(shell $(CYGPATH) '$(TCL_LIBRARY)') GENERIC_DIR_NATIVE = $(shell $(CYGPATH) '$(GENERIC_DIR)') WIN_DIR_NATIVE = $(shell $(CYGPATH) '$(WIN_DIR)') ROOT_DIR_NATIVE = $(shell $(CYGPATH) '$(ROOT_DIR)') ROOT_DIR_WIN_NATIVE = $(shell cd '$(ROOT_DIR)' ; pwd -W 2>/dev/null || pwd -P) ZLIB_DIR_NATIVE = $(shell $(CYGPATH) '$(ZLIB_DIR)') MINIZIP_DIR_NATIVE = $(shell $(CYGPATH) '$(MINIZIP_DIR)') TOMMATH_DIR_NATIVE = $(shell $(CYGPATH) '$(TOMMATH_DIR)') # Fully qualify library path so that `make test` # does not depend on the current directory. | > > > | 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 | bindir_native = $(shell $(CYGPATH) '$(bindir)') includedir_native = $(shell $(CYGPATH) '$(includedir)') mandir_native = $(shell $(CYGPATH) '$(mandir)') TCL_LIBRARY_NATIVE = $(shell $(CYGPATH) '$(TCL_LIBRARY)') GENERIC_DIR_NATIVE = $(shell $(CYGPATH) '$(GENERIC_DIR)') WIN_DIR_NATIVE = $(shell $(CYGPATH) '$(WIN_DIR)') ROOT_DIR_NATIVE = $(shell $(CYGPATH) '$(ROOT_DIR)') SCRIPT_INSTALL_DIR_NATIVE = $(shell $(CYGPATH) '$(SCRIPT_INSTALL_DIR)') INCLUDE_INSTALL_DIR_NATIVE = $(shell $(CYGPATH) '$(INCLUDE_INSTALL_DIR)') MAN_INSTALL_DIR_NATIVE = $(shell $(CYGPATH) '$(MAN_INSTALL_DIR)') ROOT_DIR_WIN_NATIVE = $(shell cd '$(ROOT_DIR)' ; pwd -W 2>/dev/null || pwd -P) ZLIB_DIR_NATIVE = $(shell $(CYGPATH) '$(ZLIB_DIR)') MINIZIP_DIR_NATIVE = $(shell $(CYGPATH) '$(MINIZIP_DIR)') TOMMATH_DIR_NATIVE = $(shell $(CYGPATH) '$(TOMMATH_DIR)') # Fully qualify library path so that `make test` # does not depend on the current directory. |
| ︙ | ︙ | |||
247 248 249 250 251 252 253 |
zutil.$(HOST_OBJEXT) \
minizip.$(HOST_OBJEXT)
ZIP_INSTALL_OBJS = @ZIP_INSTALL_OBJS@
CC_SWITCHES = -I"${GENERIC_DIR_NATIVE}" -I"${TOMMATH_DIR_NATIVE}" \
-I"${ZLIB_DIR_NATIVE}" -I"${WIN_DIR_NATIVE}" \
| | | 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 |
zutil.$(HOST_OBJEXT) \
minizip.$(HOST_OBJEXT)
ZIP_INSTALL_OBJS = @ZIP_INSTALL_OBJS@
CC_SWITCHES = -I"${GENERIC_DIR_NATIVE}" -I"${TOMMATH_DIR_NATIVE}" \
-I"${ZLIB_DIR_NATIVE}" -I"${WIN_DIR_NATIVE}" \
${CFLAGS} ${CFLAGS_WARNING} ${SHLIB_CFLAGS} -DMP_PREC=4 \
${AC_FLAGS} ${COMPILE_DEBUG_FLAGS} ${NO_DEPRECATED_FLAGS}
CC_OBJNAME = @CC_OBJNAME@
CC_EXENAME = @CC_EXENAME@
STUB_CC_SWITCHES = ${CFLAGS} ${CFLAGS_WARNING} ${SHLIB_CFLAGS} \
-I"${GENERIC_DIR_NATIVE}" -I"${TOMMATH_DIR_NATIVE}" \
|
| ︙ | ︙ | |||
646 647 648 649 650 651 652 |
tclMainW.${OBJEXT}: tclMain.c
$(CC) -c $(CC_SWITCHES) -DBUILD_tcl -DUNICODE -D_UNICODE @DEPARG@ $(CC_OBJNAME)
# TIP #430, ZipFS Support
tclZipfs.${OBJEXT}: $(GENERIC_DIR)/tclZipfs.c
$(CC) -c $(CC_SWITCHES) -DBUILD_tcl \
| | | 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 |
tclMainW.${OBJEXT}: tclMain.c
$(CC) -c $(CC_SWITCHES) -DBUILD_tcl -DUNICODE -D_UNICODE @DEPARG@ $(CC_OBJNAME)
# TIP #430, ZipFS Support
tclZipfs.${OBJEXT}: $(GENERIC_DIR)/tclZipfs.c
$(CC) -c $(CC_SWITCHES) -DBUILD_tcl \
-DCFG_RUNTIME_PATH="\"$(bindir_native)\"" \
-DCFG_RUNTIME_DLLFILE="\"$(TCL_DLL_FILE)\"" \
-DCFG_RUNTIME_ZIPFILE="\"$(TCL_ZIP_FILE)\"" \
-DCFG_RUNTIME_LIBDIR="\"$(bindir_native)\"" \
-DCFG_RUNTIME_SCRDIR="\"$(TCL_LIBRARY_NATIVE)\"" \
$(ZLIB_INCLUDE) -I$(MINIZIP_DIR_NATIVE) @DEPARG@ $(CC_OBJNAME)
|
| ︙ | ︙ | |||
668 669 670 671 672 673 674 |
tclPkgConfig.${OBJEXT}: tclPkgConfig.c
$(CC) -c $(CC_SWITCHES) \
-DCFG_INSTALL_LIBDIR="\"$(LIB_INSTALL_DIR_NATIVE)\"" \
-DCFG_INSTALL_BINDIR="\"$(BIN_INSTALL_DIR_NATIVE)\"" \
-DCFG_INSTALL_SCRDIR="\"$(SCRIPT_INSTALL_DIR_NATIVE)\"" \
-DCFG_INSTALL_INCDIR="\"$(INCLUDE_INSTALL_DIR_NATIVE)\"" \
| | | 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 |
tclPkgConfig.${OBJEXT}: tclPkgConfig.c
$(CC) -c $(CC_SWITCHES) \
-DCFG_INSTALL_LIBDIR="\"$(LIB_INSTALL_DIR_NATIVE)\"" \
-DCFG_INSTALL_BINDIR="\"$(BIN_INSTALL_DIR_NATIVE)\"" \
-DCFG_INSTALL_SCRDIR="\"$(SCRIPT_INSTALL_DIR_NATIVE)\"" \
-DCFG_INSTALL_INCDIR="\"$(INCLUDE_INSTALL_DIR_NATIVE)\"" \
-DCFG_INSTALL_DOCDIR="\"$(MAN_INSTALL_DIR_NATIVE)\"" \
\
-DCFG_RUNTIME_LIBDIR="\"$(libdir_native)\"" \
-DCFG_RUNTIME_BINDIR="\"$(bindir_native)\"" \
-DCFG_RUNTIME_SCRDIR="\"$(TCL_LIBRARY_NATIVE)\"" \
-DCFG_RUNTIME_INCDIR="\"$(includedir_native)\"" \
-DCFG_RUNTIME_DOCDIR="\"$(mandir_native)\"" \
-DCFG_RUNTIME_DLLFILE="\"$(TCL_DLL_FILE)\"" \
|
| ︙ | ︙ | |||
793 794 795 796 797 798 799 | $(INSTALL_PACKAGE_TARGETS) $(INSTALL_EXTRA_TARGETS) install: $(INSTALL_TARGETS) install-binaries: binaries @for i in "$(LIB_INSTALL_DIR)" "$(BIN_INSTALL_DIR)"; \ do \ | | | | | | | | | | | | | | | | > > > > > > > > | | | | | | | | | | | | | | | | 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 |
$(INSTALL_PACKAGE_TARGETS) $(INSTALL_EXTRA_TARGETS)
install: $(INSTALL_TARGETS)
install-binaries: binaries
@for i in "$(LIB_INSTALL_DIR)" "$(BIN_INSTALL_DIR)"; \
do \
if [ ! -d "$$i" ] ; then \
echo "Making directory $$i"; \
$(MKDIR) "$$i"; \
chmod 755 "$$i"; \
else true; \
fi; \
done;
@for i in dde${DDEDOTVER} reg${REGDOTVER}; \
do \
if [ ! -d "$(LIB_INSTALL_DIR)/$$i" ] ; then \
echo "Making directory $(LIB_INSTALL_DIR)/$$i"; \
$(MKDIR) "$(LIB_INSTALL_DIR)/$$i"; \
else true; \
fi; \
done;
@for i in $(TCL_DLL_FILE) $(ZLIB_DLL_FILE) $(TOMMATH_DLL_FILE) $(TCLSH); \
do \
if [ -f $$i ]; then \
echo "Installing $$i to $(BIN_INSTALL_DIR)/"; \
$(COPY) $$i "$(BIN_INSTALL_DIR)"; \
fi; \
done
@for i in tclConfig.sh tclooConfig.sh $(TCL_LIB_FILE) $(TCL_STUB_LIB_FILE); \
do \
if [ -f $$i ]; then \
echo "Installing $$i to $(LIB_INSTALL_DIR)/"; \
$(COPY) $$i "$(LIB_INSTALL_DIR)"; \
fi; \
done
@if [ -f $(DDE_DLL_FILE) ]; then \
echo Installing $(DDE_DLL_FILE); \
$(COPY) $(DDE_DLL_FILE) "$(LIB_INSTALL_DIR)/dde${DDEDOTVER}"; \
$(COPY) $(ROOT_DIR)/library/dde/pkgIndex.tcl \
"$(LIB_INSTALL_DIR)/dde${DDEDOTVER}"; \
fi
@if [ -f $(DDE_LIB_FILE) ]; then \
echo Installing $(DDE_LIB_FILE); \
$(COPY) $(DDE_LIB_FILE) "$(LIB_INSTALL_DIR)/dde${DDEDOTVER}"; \
fi
@if [ -f $(REG_DLL_FILE) ]; then \
echo Installing $(REG_DLL_FILE); \
$(COPY) $(REG_DLL_FILE) "$(LIB_INSTALL_DIR)/reg${REGDOTVER}"; \
$(COPY) $(ROOT_DIR)/library/reg/pkgIndex.tcl \
"$(LIB_INSTALL_DIR)/reg${REGDOTVER}"; \
fi
@if [ -f $(REG_LIB_FILE) ]; then \
echo Installing $(REG_LIB_FILE); \
$(COPY) $(REG_LIB_FILE) "$(LIB_INSTALL_DIR)/reg${REGDOTVER}"; \
fi
install-libraries-zipfs-shared: libraries
install-libraries-zipfs-static: install-libraries-zipfs-shared
$(COPY) ${TCL_ZIP_FILE} "$(LIB_INSTALL_DIR)"
install-libraries: libraries install-tzdata install-msgs
@for i in "$(prefix)/lib" "$(INCLUDE_INSTALL_DIR)" \
"$(SCRIPT_INSTALL_DIR)" "$(MODULE_INSTALL_DIR)"; \
do \
if [ ! -d "$$i" ] ; then \
echo "Making directory $$i"; \
$(MKDIR) "$$i"; \
else true; \
fi; \
done;
@for i in opt0.4 cookiejar0.2 encoding; \
do \
if [ ! -d "$(SCRIPT_INSTALL_DIR)/$$i" ] ; then \
echo "Making directory $(SCRIPT_INSTALL_DIR)/$$i"; \
$(MKDIR) "$(SCRIPT_INSTALL_DIR)/$$i"; \
else true; \
fi; \
done;
@for i in 9.0 9.0/platform; \
do \
if [ ! -d "$(MODULE_INSTALL_DIR)/$$i" ] ; then \
echo "Making directory $(MODULE_INSTALL_DIR)/$$i"; \
$(MKDIR) "$(MODULE_INSTALL_DIR)/$$i"; \
else true; \
fi; \
done;
@echo "Installing library files to $(SCRIPT_INSTALL_DIR)";
@for i in $(ROOT_DIR)/library/*.tcl $(ROOT_DIR)/library/tclIndex; \
do \
$(COPY) "$$i" "$(SCRIPT_INSTALL_DIR)"; \
done;
@echo "Installing package cookiejar 0.2"
@for j in $(ROOT_DIR)/library/cookiejar/*.{tcl,txt.gz}; \
do \
$(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/cookiejar0.2"; \
done;
@echo "Installing package http 2.9.3 as a Tcl Module";
@$(COPY) $(ROOT_DIR)/library/http/http.tcl "$(MODULE_INSTALL_DIR)/9.0/http-2.9.3.tm";
@echo "Installing package opt 0.4.7";
@for j in $(ROOT_DIR)/library/opt/*.tcl; \
do \
$(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/opt0.4"; \
done;
@echo "Installing package msgcat 1.7.1 as a Tcl Module";
@$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl "$(MODULE_INSTALL_DIR)/9.0/msgcat-1.7.1.tm";
@echo "Installing package tcltest 2.5.3 as a Tcl Module";
@$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl "$(MODULE_INSTALL_DIR)/9.0/tcltest-2.5.3.tm";
@echo "Installing package platform 1.0.14 as a Tcl Module";
@$(COPY) $(ROOT_DIR)/library/platform/platform.tcl "$(MODULE_INSTALL_DIR)/9.0/platform-1.0.14.tm";
@echo "Installing package platform::shell 1.1.4 as a Tcl Module";
@$(COPY) $(ROOT_DIR)/library/platform/shell.tcl "$(MODULE_INSTALL_DIR)/9.0/platform/shell-1.1.4.tm";
@echo "Installing encodings";
@for i in $(ROOT_DIR)/library/encoding/*.enc; do \
$(COPY) "$$i" "$(SCRIPT_INSTALL_DIR)/encoding"; \
done;
install-tzdata:
@echo "Installing time zone data"
@$(TCL_EXE) "$(ROOT_DIR)/tools/installData.tcl" \
"$(ROOT_DIR)/library/tzdata" "$(SCRIPT_INSTALL_DIR_NATIVE)/tzdata"
install-msgs:
@echo "Installing message catalogs"
$(TCL_EXE) "$(ROOT_DIR)/tools/installData.tcl" \
"$(ROOT_DIR)/library/msgs" "$(SCRIPT_INSTALL_DIR_NATIVE)/msgs"
install-doc: doc
install-headers:
@for i in "$(INCLUDE_INSTALL_DIR)"; \
do \
if [ ! -d "$$i" ] ; then \
|
| ︙ | ︙ |
Changes to win/configure.
| ︙ | ︙ | |||
665 666 667 668 669 670 671 | CC_EXENAME CC_OBJNAME DEPARG EXTRA_CFLAGS CFG_TCL_EXPORT_FILE_SUFFIX CFG_TCL_UNSHARED_LIB_SUFFIX CFG_TCL_SHARED_LIB_SUFFIX | < | 665 666 667 668 669 670 671 672 673 674 675 676 677 678 | CC_EXENAME CC_OBJNAME DEPARG EXTRA_CFLAGS CFG_TCL_EXPORT_FILE_SUFFIX CFG_TCL_UNSHARED_LIB_SUFFIX CFG_TCL_SHARED_LIB_SUFFIX TCL_BIN_DIR TCL_SRC_DIR TCL_DLL_FILE TCL_BUILD_STUB_LIB_PATH TCL_BUILD_STUB_LIB_SPEC TCL_INCLUDE_SPEC TCL_STUB_LIB_PATH |
| ︙ | ︙ | |||
4157 4158 4159 4160 4161 4162 4163 |
if test "${SHARED_BUILD}" = "0" ; then
# static
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: using static flags" >&5
$as_echo "using static flags" >&6; }
runtime=
LIBRARIES="\${STATIC_LIBRARIES}"
| | | | | | | 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 |
if test "${SHARED_BUILD}" = "0" ; then
# static
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: using static flags" >&5
$as_echo "using static flags" >&6; }
runtime=
LIBRARIES="\${STATIC_LIBRARIES}"
EXESUFFIX="s.exe"
else
# dynamic
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: using shared flags" >&5
$as_echo "using shared flags" >&6; }
# ad-hoc check to see if CC supports -shared.
if "${CC}" -shared 2>&1 | egrep ': -shared not supported' >/dev/null; then
as_fn_error $? "${CC} does not support the -shared option.
You will need to upgrade to a newer version of the toolchain." "$LINENO" 5
fi
runtime=
# Add SHLIB_LD_LIBS to the Make rule, not here.
EXESUFFIX=".exe"
LIBRARIES="\${SHARED_LIBRARIES}"
fi
# Link with gcc since ld does not link to default libs like
# -luser32 and -lmsvcrt by default.
SHLIB_LD='${CC} -shared'
SHLIB_LD_LIBS='${LIBS}'
MAKE_DLL="\${SHLIB_LD} \$(LDFLAGS) -o \$@ ${extra_ldflags} \
-Wl,--out-implib,\$(patsubst %.dll,lib%.a,\$@)"
# DLLSUFFIX is separate because it is the building block for
# users of tclConfig.sh that may build shared or static.
DLLSUFFIX=".dll"
LIBSUFFIX=".a"
LIBFLAGSUFFIX=""
SHLIB_SUFFIX=.dll
EXTRA_CFLAGS="${extra_cflags}"
CFLAGS_DEBUG=-g
CFLAGS_OPTIMIZE="-O2 -fomit-frame-pointer"
CFLAGS_WARNING="-Wall -Wextra -Wwrite-strings -Wpointer-arith"
|
| ︙ | ︙ | |||
4275 4276 4277 4278 4279 4280 4281 |
else
if test "${SHARED_BUILD}" = "0" ; then
# static
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: using static flags" >&5
$as_echo "using static flags" >&6; }
runtime=-MT
LIBRARIES="\${STATIC_LIBRARIES}"
| | | | | | | 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 |
else
if test "${SHARED_BUILD}" = "0" ; then
# static
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: using static flags" >&5
$as_echo "using static flags" >&6; }
runtime=-MT
LIBRARIES="\${STATIC_LIBRARIES}"
EXESUFFIX="s.exe"
else
# dynamic
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: using shared flags" >&5
$as_echo "using shared flags" >&6; }
runtime=-MD
# Add SHLIB_LD_LIBS to the Make rule, not here.
LIBRARIES="\${SHARED_LIBRARIES}"
EXESUFFIX=".exe"
case "x`echo \${VisualStudioVersion}`" in
x1[4-9]*)
lflags="${lflags} -nodefaultlib:libucrt.lib"
;;
*)
;;
esac
fi
MAKE_DLL="\${SHLIB_LD} \$(LDFLAGS) -out:\$@"
# DLLSUFFIX is separate because it is the building block for
# users of tclConfig.sh that may build shared or static.
DLLSUFFIX=".dll"
LIBSUFFIX=".lib"
LIBFLAGSUFFIX=""
if test "$do64bit" != "no" ; then
case "$do64bit" in
amd64|x64|yes)
MACHINE="AMD64" ; # assume AMD64 as default 64-bit build
;;
ia64)
|
| ︙ | ︙ | |||
5151 5152 5153 5154 5155 5156 5157 |
tcl_ok=no
fi
# FIXME: Currently, LDFLAGS_DEFAULT is not used, it should work like CFLAGS_DEFAULT.
if test "$tcl_ok" = "no"; then
CFLAGS_DEFAULT='$(CFLAGS_OPTIMIZE)'
LDFLAGS_DEFAULT='$(LDFLAGS_OPTIMIZE)'
| < < | 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 |
tcl_ok=no
fi
# FIXME: Currently, LDFLAGS_DEFAULT is not used, it should work like CFLAGS_DEFAULT.
if test "$tcl_ok" = "no"; then
CFLAGS_DEFAULT='$(CFLAGS_OPTIMIZE)'
LDFLAGS_DEFAULT='$(LDFLAGS_OPTIMIZE)'
$as_echo "#define NDEBUG 1" >>confdefs.h
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
$as_echo "no" >&6; }
$as_echo "#define TCL_CFG_OPTIMIZED 1" >>confdefs.h
else
CFLAGS_DEFAULT='$(CFLAGS_DEBUG)'
LDFLAGS_DEFAULT='$(LDFLAGS_DEBUG)'
if test "$tcl_ok" = "yes"; then
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: yes (standard debugging)" >&5
$as_echo "yes (standard debugging)" >&6; }
fi
fi
|
| ︙ | ︙ | |||
5198 5199 5200 5201 5202 5203 5204 |
else
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: enabled $tcl_ok debugging" >&5
$as_echo "enabled $tcl_ok debugging" >&6; }
fi
fi
| < < | 5195 5196 5197 5198 5199 5200 5201 5202 5203 5204 5205 5206 5207 5208 |
else
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: enabled $tcl_ok debugging" >&5
$as_echo "enabled $tcl_ok debugging" >&6; }
fi
fi
#--------------------------------------------------------------------
# Embed the manifest if we can determine how
#--------------------------------------------------------------------
{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether to embed manifest" >&5
$as_echo_n "checking whether to embed manifest... " >&6; }
|
| ︙ | ︙ | |||
5265 5266 5267 5268 5269 5270 5271 |
TCL_SHARED_BUILD=${SHARED_BUILD}
#--------------------------------------------------------------------
# Perform final evaluations of variables with possible substitutions.
#--------------------------------------------------------------------
| < < < < | < < | | < < < | < < < < | < | | | 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 |
TCL_SHARED_BUILD=${SHARED_BUILD}
#--------------------------------------------------------------------
# Perform final evaluations of variables with possible substitutions.
#--------------------------------------------------------------------
eval "TCL_SRC_DIR=\"`cd $srcdir/..; $CYGPATH $(pwd)`\""
eval "TCL_DLL_FILE=tcl${VER}${DLLSUFFIX}"
eval "TCL_STUB_LIB_FILE=\"${LIBPREFIX}tclstub${VER}${LIBSUFFIX}\""
eval "TCL_STUB_LIB_FLAG=\"-ltclstub${VER}${LIBFLAGSUFFIX}\""
eval "TCL_BUILD_STUB_LIB_SPEC=\"-L`$CYGPATH $(pwd)` ${TCL_STUB_LIB_FLAG}\""
eval "TCL_STUB_LIB_SPEC=\"-L${libdir} ${TCL_STUB_LIB_FLAG}\""
eval "TCL_BUILD_STUB_LIB_PATH=\"`$CYGPATH $(pwd)`/${TCL_STUB_LIB_FILE}\""
eval "TCL_STUB_LIB_PATH=\"${libdir}/${TCL_STUB_LIB_FILE}\""
eval "TCL_LIB_FILE=\"${LIBPREFIX}tcl${VER}${LIBSUFFIX}\""
eval "TCL_BUILD_LIB_SPEC=\"-L`$CYGPATH $(pwd)` -ltcl${VER}${FLAGSUFFIX}\""
eval "TCL_LIB_SPEC=\"-L${libdir} -ltcl${VER}${FLAGSUFFIX}\""
# Install time header dir can be set via --includedir
eval "TCL_INCLUDE_SPEC=\"-I${includedir}\""
TCL_SHARED_LIB_SUFFIX="\${NODOT_VERSION}${DLLSUFFIX}"
TCL_UNSHARED_LIB_SUFFIX="\${NODOT_VERSION}${LIBSUFFIX}"
TCL_EXPORT_FILE_SUFFIX="\${NODOT_VERSION}${LIBSUFFIX}"
CFG_TCL_SHARED_LIB_SUFFIX=${TCL_SHARED_LIB_SUFFIX}
CFG_TCL_UNSHARED_LIB_SUFFIX=${TCL_UNSHARED_LIB_SUFFIX}
CFG_TCL_EXPORT_FILE_SUFFIX=${TCL_EXPORT_FILE_SUFFIX}
#--------------------------------------------------------------------
# Adjust the defines for how the resources are built depending
# on symbols and static vs. shared.
#--------------------------------------------------------------------
if test ${SHARED_BUILD} = 0 ; then
RC_DEFINES="${RC_DEFINE} STATIC_BUILD"
else
RC_DEFINES=""
fi
#--------------------------------------------------------------------
# The statements below define the symbol TCL_PACKAGE_PATH, which
# gives a list of directories that may contain packages. The list
# consists of one directory for machine-dependent binaries and
# another for platform-independent scripts.
#--------------------------------------------------------------------
if test "$prefix/lib" != "$libdir"; then
TCL_PACKAGE_PATH="{${libdir}} {${prefix}/lib}"
else
TCL_PACKAGE_PATH="{${prefix}/lib}"
fi
# The tclsh.exe.manifest requires these
# TCL_WIN_VERSION is the 4 dotted pair Windows version format which needs
# the release level, and must account for interim release versioning
case "$TCL_PATCH_LEVEL" in
*a*) TCL_RELEASE_LEVEL=0 ;;
|
| ︙ | ︙ | |||
5356 5357 5358 5359 5360 5361 5362 | # empty on win | < | 5337 5338 5339 5340 5341 5342 5343 5344 5345 5346 5347 5348 5349 5350 | # empty on win |
| ︙ | ︙ |
Changes to win/configure.ac.
| ︙ | ︙ | |||
314 315 316 317 318 319 320 | # Set the default compiler switches based on the --enable-symbols # option. This macro depends on C flags, and should be called # after SC_CONFIG_CFLAGS macro is called. #-------------------------------------------------------------------- SC_ENABLE_SYMBOLS | < < < < < < | < < | | < < < | < < < < | < | | | 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 |
# Set the default compiler switches based on the --enable-symbols
# option. This macro depends on C flags, and should be called
# after SC_CONFIG_CFLAGS macro is called.
#--------------------------------------------------------------------
SC_ENABLE_SYMBOLS
#--------------------------------------------------------------------
# Embed the manifest if we can determine how
#--------------------------------------------------------------------
SC_EMBED_MANIFEST
#------------------------------------------------------------------------
# tclConfig.sh refers to this by a different name
#------------------------------------------------------------------------
TCL_SHARED_BUILD=${SHARED_BUILD}
#--------------------------------------------------------------------
# Perform final evaluations of variables with possible substitutions.
#--------------------------------------------------------------------
eval "TCL_SRC_DIR=\"`cd $srcdir/..; $CYGPATH $(pwd)`\""
eval "TCL_DLL_FILE=tcl${VER}${DLLSUFFIX}"
eval "TCL_STUB_LIB_FILE=\"${LIBPREFIX}tclstub${VER}${LIBSUFFIX}\""
eval "TCL_STUB_LIB_FLAG=\"-ltclstub${VER}${LIBFLAGSUFFIX}\""
eval "TCL_BUILD_STUB_LIB_SPEC=\"-L`$CYGPATH $(pwd)` ${TCL_STUB_LIB_FLAG}\""
eval "TCL_STUB_LIB_SPEC=\"-L${libdir} ${TCL_STUB_LIB_FLAG}\""
eval "TCL_BUILD_STUB_LIB_PATH=\"`$CYGPATH $(pwd)`/${TCL_STUB_LIB_FILE}\""
eval "TCL_STUB_LIB_PATH=\"${libdir}/${TCL_STUB_LIB_FILE}\""
eval "TCL_LIB_FILE=\"${LIBPREFIX}tcl${VER}${LIBSUFFIX}\""
eval "TCL_BUILD_LIB_SPEC=\"-L`$CYGPATH $(pwd)` -ltcl${VER}${FLAGSUFFIX}\""
eval "TCL_LIB_SPEC=\"-L${libdir} -ltcl${VER}${FLAGSUFFIX}\""
# Install time header dir can be set via --includedir
eval "TCL_INCLUDE_SPEC=\"-I${includedir}\""
TCL_SHARED_LIB_SUFFIX="\${NODOT_VERSION}${DLLSUFFIX}"
TCL_UNSHARED_LIB_SUFFIX="\${NODOT_VERSION}${LIBSUFFIX}"
TCL_EXPORT_FILE_SUFFIX="\${NODOT_VERSION}${LIBSUFFIX}"
CFG_TCL_SHARED_LIB_SUFFIX=${TCL_SHARED_LIB_SUFFIX}
CFG_TCL_UNSHARED_LIB_SUFFIX=${TCL_UNSHARED_LIB_SUFFIX}
CFG_TCL_EXPORT_FILE_SUFFIX=${TCL_EXPORT_FILE_SUFFIX}
#--------------------------------------------------------------------
# Adjust the defines for how the resources are built depending
# on symbols and static vs. shared.
#--------------------------------------------------------------------
if test ${SHARED_BUILD} = 0 ; then
RC_DEFINES="${RC_DEFINE} STATIC_BUILD"
else
RC_DEFINES=""
fi
#--------------------------------------------------------------------
# The statements below define the symbol TCL_PACKAGE_PATH, which
# gives a list of directories that may contain packages. The list
# consists of one directory for machine-dependent binaries and
# another for platform-independent scripts.
#--------------------------------------------------------------------
if test "$prefix/lib" != "$libdir"; then
TCL_PACKAGE_PATH="{${libdir}} {${prefix}/lib}"
else
TCL_PACKAGE_PATH="{${prefix}/lib}"
fi
# The tclsh.exe.manifest requires these
# TCL_WIN_VERSION is the 4 dotted pair Windows version format which needs
# the release level, and must account for interim release versioning
case "$TCL_PATCH_LEVEL" in
*a*) TCL_RELEASE_LEVEL=0 ;;
|
| ︙ | ︙ | |||
435 436 437 438 439 440 441 | AC_SUBST(TCL_INCLUDE_SPEC) AC_SUBST(TCL_BUILD_STUB_LIB_SPEC) AC_SUBST(TCL_BUILD_STUB_LIB_PATH) AC_SUBST(TCL_DLL_FILE) AC_SUBST(TCL_SRC_DIR) AC_SUBST(TCL_BIN_DIR) | < | 419 420 421 422 423 424 425 426 427 428 429 430 431 432 | AC_SUBST(TCL_INCLUDE_SPEC) AC_SUBST(TCL_BUILD_STUB_LIB_SPEC) AC_SUBST(TCL_BUILD_STUB_LIB_PATH) AC_SUBST(TCL_DLL_FILE) AC_SUBST(TCL_SRC_DIR) AC_SUBST(TCL_BIN_DIR) AC_SUBST(CFG_TCL_SHARED_LIB_SUFFIX) AC_SUBST(CFG_TCL_UNSHARED_LIB_SUFFIX) AC_SUBST(CFG_TCL_EXPORT_FILE_SUFFIX) # win/tcl.m4 doesn't set (CFLAGS) AC_SUBST(CFLAGS_DEFAULT) AC_SUBST(EXTRA_CFLAGS) |
| ︙ | ︙ |
Changes to win/makefile.vc.
| ︙ | ︙ | |||
684 685 686 687 688 689 690 | @TCL_PATCH_LEVEL@ $(TCL_PATCH_LEVEL) @CC@ $(CC) @DEFS@ $(pkgcflags) @CFLAGS_DEBUG@ -nologo -c -W3 -YX -Fp$(TMP_DIR)\ -MDd @CFLAGS_OPTIMIZE@ -nologo -c -W3 -YX -Fp$(TMP_DIR)\ -MD @LDFLAGS_DEBUG@ -nologo -machine:$(MACHINE) -debug -debugtype:cv @LDFLAGS_OPTIMIZE@ -nologo -machine:$(MACHINE) -release -opt:ref -opt:icf,3 | < | 684 685 686 687 688 689 690 691 692 693 694 695 696 697 | @TCL_PATCH_LEVEL@ $(TCL_PATCH_LEVEL) @CC@ $(CC) @DEFS@ $(pkgcflags) @CFLAGS_DEBUG@ -nologo -c -W3 -YX -Fp$(TMP_DIR)\ -MDd @CFLAGS_OPTIMIZE@ -nologo -c -W3 -YX -Fp$(TMP_DIR)\ -MD @LDFLAGS_DEBUG@ -nologo -machine:$(MACHINE) -debug -debugtype:cv @LDFLAGS_OPTIMIZE@ -nologo -machine:$(MACHINE) -release -opt:ref -opt:icf,3 @TCL_LIB_FILE@ $(PROJECT)$(VERSION)$(SUFX).lib @TCL_NEEDS_EXP_FILE@ @LIBS@ $(baselibs) $(PRJ_LIBS) @prefix@ $(_INSTALLDIR) @exec_prefix@ $(BIN_INSTALL_DIR) @SHLIB_CFLAGS@ @STLIB_CFLAGS@ |
| ︙ | ︙ | |||
915 916 917 918 919 920 921 | install-libraries: tclConfig tcl-nmake install-msgs install-tzdata @if not exist "$(SCRIPT_INSTALL_DIR)" \ $(MKDIR) "$(SCRIPT_INSTALL_DIR)" @if not exist "$(SCRIPT_INSTALL_DIR)\opt0.4$(NULL)" \ $(MKDIR) "$(SCRIPT_INSTALL_DIR)\opt0.4" @if not exist "$(SCRIPT_INSTALL_DIR)\cookiejar0.2$(NULL)" \ $(MKDIR) "$(SCRIPT_INSTALL_DIR)\cookiejar0.2" | | | | | | | | 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 | install-libraries: tclConfig tcl-nmake install-msgs install-tzdata @if not exist "$(SCRIPT_INSTALL_DIR)" \ $(MKDIR) "$(SCRIPT_INSTALL_DIR)" @if not exist "$(SCRIPT_INSTALL_DIR)\opt0.4$(NULL)" \ $(MKDIR) "$(SCRIPT_INSTALL_DIR)\opt0.4" @if not exist "$(SCRIPT_INSTALL_DIR)\cookiejar0.2$(NULL)" \ $(MKDIR) "$(SCRIPT_INSTALL_DIR)\cookiejar0.2" @if not exist "$(MODULE_INSTALL_DIR)$(NULL)" \ $(MKDIR) "$(MODULE_INSTALL_DIR)" @if not exist "$(MODULE_INSTALL_DIR)\9.0$(NULL)" \ $(MKDIR) "$(MODULE_INSTALL_DIR)\9.0" @if not exist "$(MODULE_INSTALL_DIR)\9.0\platform$(NULL)" \ $(MKDIR) "$(MODULE_INSTALL_DIR)\9.0\platform" @echo Installing header files @$(CPY) "$(GENERICDIR)\tcl.h" "$(INCLUDE_INSTALL_DIR)\" @$(CPY) "$(GENERICDIR)\tclDecls.h" "$(INCLUDE_INSTALL_DIR)\" @$(CPY) "$(GENERICDIR)\tclOO.h" "$(INCLUDE_INSTALL_DIR)\" @$(CPY) "$(GENERICDIR)\tclOODecls.h" "$(INCLUDE_INSTALL_DIR)\" @$(CPY) "$(GENERICDIR)\tclPlatDecls.h" "$(INCLUDE_INSTALL_DIR)\" @$(CPY) "$(GENERICDIR)\tclTomMath.h" "$(INCLUDE_INSTALL_DIR)\" |
| ︙ | ︙ | |||
957 958 959 960 961 962 963 | @$(CPY) "$(ROOT)\library\cookiejar\*.gz" \ "$(SCRIPT_INSTALL_DIR)\cookiejar0.2\" @echo Installing package opt $(PKG_OPT_VER) @$(CPY) "$(ROOT)\library\opt\*.tcl" \ "$(SCRIPT_INSTALL_DIR)\opt0.4\" @echo Installing package http $(PKG_HTTP_VER) as a Tcl Module @$(COPY) "$(ROOT)\library\http\http.tcl" \ | | | | | | | 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 | @$(CPY) "$(ROOT)\library\cookiejar\*.gz" \ "$(SCRIPT_INSTALL_DIR)\cookiejar0.2\" @echo Installing package opt $(PKG_OPT_VER) @$(CPY) "$(ROOT)\library\opt\*.tcl" \ "$(SCRIPT_INSTALL_DIR)\opt0.4\" @echo Installing package http $(PKG_HTTP_VER) as a Tcl Module @$(COPY) "$(ROOT)\library\http\http.tcl" \ "$(MODULE_INSTALL_DIR)\9.0\http-$(PKG_HTTP_VER).tm" @echo Installing package msgcat $(PKG_MSGCAT_VER) as a Tcl Module @$(COPY) "$(ROOT)\library\msgcat\msgcat.tcl" \ "$(MODULE_INSTALL_DIR)\9.0\msgcat-$(PKG_MSGCAT_VER).tm" @echo Installing package tcltest $(PKG_TCLTEST_VER) as a Tcl Module @$(COPY) "$(ROOT)\library\tcltest\tcltest.tcl" \ "$(MODULE_INSTALL_DIR)\9.0\tcltest-$(PKG_TCLTEST_VER).tm" @echo Installing package platform $(PKG_PLATFORM_VER) as a Tcl Module @$(COPY) "$(ROOT)\library\platform\platform.tcl" \ "$(MODULE_INSTALL_DIR)\9.0\platform-$(PKG_PLATFORM_VER).tm" @echo Installing package platform::shell $(PKG_SHELL_VER) as a Tcl Module @$(COPY) "$(ROOT)\library\platform\shell.tcl" \ "$(MODULE_INSTALL_DIR)\9.0\platform\shell-$(PKG_SHELL_VER).tm" @echo Installing $(TCLDDELIBNAME) !if $(STATIC_BUILD) !if !$(TCL_USE_STATIC_PACKAGES) @$(CPY) "$(TCLDDELIB)" "$(LIB_INSTALL_DIR)\" !endif !else @$(CPY) "$(TCLDDELIB)" "$(LIB_INSTALL_DIR)\dde$(DDEDOTVERSION)\" |
| ︙ | ︙ |
Changes to win/rules.vc.
| ︙ | ︙ | |||
298 299 300 301 302 303 304 | TCLINSTALL = 1 TCLDIR = $(_INSTALLDIR)\.. # NOTE: we will be resetting _INSTALLDIR to _INSTALLDIR/lib for extensions # later so the \.. accounts for the /lib _TCLDIR = $(_INSTALLDIR)\.. _TCL_H = $(_TCLDIR)\include\tcl.h | | | | 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 | TCLINSTALL = 1 TCLDIR = $(_INSTALLDIR)\.. # NOTE: we will be resetting _INSTALLDIR to _INSTALLDIR/lib for extensions # later so the \.. accounts for the /lib _TCLDIR = $(_INSTALLDIR)\.. _TCL_H = $(_TCLDIR)\include\tcl.h !else # exist(...) && !$(NEED_TCL_SOURCE) !if [echo _TCLDIR = \> nmakehlp.out] \ || [nmakehlp -L generic\tcl.h >> nmakehlp.out] !error *** Could not locate Tcl source directory. !endif !include nmakehlp.out TCLINSTALL = 0 TCLDIR = $(_TCLDIR) _TCL_H = $(_TCLDIR)\generic\tcl.h !endif # exist(...) && !$(NEED_TCL_SOURCE) !endif # TCLDIR !ifndef _TCL_H MSG =^ Failed to find tcl.h. The TCLDIR macro is set incorrectly or is not set and default path does not contain tcl.h. !error $(MSG) |
| ︙ | ︙ | |||
533 534 535 536 537 538 539 |
NMAKEHLPC = nmakehlp.c
!if !$(DOING_TCL)
!if $(TCLINSTALL)
!if exist("$(_TCLDIR)\lib\nmake\nmakehlp.c")
NMAKEHLPC = $(_TCLDIR)\lib\nmake\nmakehlp.c
!endif
| | | 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 |
NMAKEHLPC = nmakehlp.c
!if !$(DOING_TCL)
!if $(TCLINSTALL)
!if exist("$(_TCLDIR)\lib\nmake\nmakehlp.c")
NMAKEHLPC = $(_TCLDIR)\lib\nmake\nmakehlp.c
!endif
!else # !$(TCLINSTALL)
!if exist("$(_TCLDIR)\win\nmakehlp.c")
NMAKEHLPC = $(_TCLDIR)\win\nmakehlp.c
!endif
!endif # $(TCLINSTALL)
!endif # !$(DOING_TCL)
!endif # NMAKEHLPC
|
| ︙ | ︙ | |||
680 681 682 683 684 685 686 687 688 689 690 691 692 693 | # USE_THREAD_ALLOC - 1 -> Use a shared global free pool for allocation. # 0 -> Use the non-thread allocator. # UNCHECKED - 1 -> when doing a debug build with symbols, use the release # C runtime, 0 -> use the debug C runtime. # USE_STUBS - 1 -> compile to use stubs interfaces, 0 -> direct linking # CONFIG_CHECK - 1 -> check current build configuration against Tcl # configuration (ignored for Tcl itself) # Further, LINKERFLAGS are modified based on above. # Default values for all the above STATIC_BUILD = 0 TCL_THREADS = 1 DEBUG = 0 SYMBOLS = 0 | > > > > | 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 | # USE_THREAD_ALLOC - 1 -> Use a shared global free pool for allocation. # 0 -> Use the non-thread allocator. # UNCHECKED - 1 -> when doing a debug build with symbols, use the release # C runtime, 0 -> use the debug C runtime. # USE_STUBS - 1 -> compile to use stubs interfaces, 0 -> direct linking # CONFIG_CHECK - 1 -> check current build configuration against Tcl # configuration (ignored for Tcl itself) # _USE_64BIT_TIME_T - forces a build using 64-bit time_t for 32-bit build # (CRT library should support this, not needed for Tcl 9.x) # TCL_UTF_MAX=4 - forces a build allowing 4-byte UTF-8 sequences internally. # (Not needed for Tcl 9.x) # Further, LINKERFLAGS are modified based on above. # Default values for all the above STATIC_BUILD = 0 TCL_THREADS = 1 DEBUG = 0 SYMBOLS = 0 |
| ︙ | ︙ | |||
722 723 724 725 726 727 728 | !if [nmakehlp -f $(OPTS) "nomsvcrt"] !message *** Doing nomsvcrt MSVCRT = 0 !else !if [nmakehlp -f $(OPTS) "msvcrt"] !message *** Doing msvcrt | < | < < < < | | > > > > > | > > > > | 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 | !if [nmakehlp -f $(OPTS) "nomsvcrt"] !message *** Doing nomsvcrt MSVCRT = 0 !else !if [nmakehlp -f $(OPTS) "msvcrt"] !message *** Doing msvcrt !else !if $(STATIC_BUILD) MSVCRT = 0 !endif !endif !endif # [nmakehlp -f $(OPTS) "nomsvcrt"] !if [nmakehlp -f $(OPTS) "staticpkg"] && $(STATIC_BUILD) !message *** Doing staticpkg TCL_USE_STATIC_PACKAGES = 1 !endif !if [nmakehlp -f $(OPTS) "nothreads"] !message *** Compile explicitly for non-threaded tcl TCL_THREADS = 0 USE_THREAD_ALLOC= 0 !endif !if "$(TCL_MAJOR_VERSION)" == "8" !if [nmakehlp -f $(OPTS) "time64bit"] !message *** Force 64-bit time_t _USE_64BIT_TIME_T = 1 !endif !if [nmakehlp -f $(OPTS) "utfmax"] !message *** Force allowing 4-byte UTF-8 sequences internally TCL_UTF_MAX = 4 !endif !endif # Yes, it's weird that the "symbols" option controls DEBUG and # the "pdbs" option controls SYMBOLS. That's historical. !if [nmakehlp -f $(OPTS) "symbols"] !message *** Doing symbols DEBUG = 1 |
| ︙ | ︙ | |||
1031 1032 1033 1034 1035 1036 1037 | !if "$(MACHINE)" != "IX86" BUILDDIRTOP =$(BUILDDIRTOP)_$(MACHINE) !endif !if $(VCVER) > 6 BUILDDIRTOP =$(BUILDDIRTOP)_VC$(VCVER) !endif | | | 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 | !if "$(MACHINE)" != "IX86" BUILDDIRTOP =$(BUILDDIRTOP)_$(MACHINE) !endif !if $(VCVER) > 6 BUILDDIRTOP =$(BUILDDIRTOP)_VC$(VCVER) !endif !if !$(DEBUG) || $(TCL_VERSION) > 86 || $(DEBUG) && $(UNCHECKED) SUFX = $(SUFX:g=) !endif TMP_DIRFULL = .\$(BUILDDIRTOP)\$(PROJECT)_ThreadedDynamicStaticX !if !$(STATIC_BUILD) TMP_DIRFULL = $(TMP_DIRFULL:Static=) |
| ︙ | ︙ | |||
1095 1096 1097 1098 1099 1100 1101 | TCLLIBNAME = $(PROJECT)$(VERSION)$(SUFX).$(EXT) TCLLIB = $(OUT_DIR)\$(TCLLIBNAME) TCLSTUBLIBNAME = $(STUBPREFIX)$(VERSION).lib TCLSTUBLIB = $(OUT_DIR)\$(TCLSTUBLIBNAME) TCL_INCLUDES = -I"$(WIN_DIR)" -I"$(GENERICDIR)" | | | 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 | TCLLIBNAME = $(PROJECT)$(VERSION)$(SUFX).$(EXT) TCLLIB = $(OUT_DIR)\$(TCLLIBNAME) TCLSTUBLIBNAME = $(STUBPREFIX)$(VERSION).lib TCLSTUBLIB = $(OUT_DIR)\$(TCLSTUBLIBNAME) TCL_INCLUDES = -I"$(WIN_DIR)" -I"$(GENERICDIR)" !else # !$(DOING_TCL) !if $(TCLINSTALL) # Building against an installed Tcl # When building extensions, we need to locate tclsh. Depending on version # of Tcl we are building against, this may or may not have a "t" suffix. # Try various possibilities in turn. TCLSH = $(_TCLDIR)\bin\tclsh$(TCL_VERSION)$(SUFX:t=).exe |
| ︙ | ︙ | |||
1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 | !if $(DOING_TCL) || $(DOING_TK) LIB_INSTALL_DIR = $(_INSTALLDIR)\lib BIN_INSTALL_DIR = $(_INSTALLDIR)\bin DOC_INSTALL_DIR = $(_INSTALLDIR)\doc !if $(DOING_TCL) SCRIPT_INSTALL_DIR = $(_INSTALLDIR)\lib\$(PROJECT)$(TCL_MAJOR_VERSION).$(TCL_MINOR_VERSION) !else # DOING_TK SCRIPT_INSTALL_DIR = $(_INSTALLDIR)\lib\$(PROJECT)$(TK_MAJOR_VERSION).$(TK_MINOR_VERSION) !endif DEMO_INSTALL_DIR = $(SCRIPT_INSTALL_DIR)\demos INCLUDE_INSTALL_DIR = $(_INSTALLDIR)\include !else # extension other than Tk | > | 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 | !if $(DOING_TCL) || $(DOING_TK) LIB_INSTALL_DIR = $(_INSTALLDIR)\lib BIN_INSTALL_DIR = $(_INSTALLDIR)\bin DOC_INSTALL_DIR = $(_INSTALLDIR)\doc !if $(DOING_TCL) SCRIPT_INSTALL_DIR = $(_INSTALLDIR)\lib\$(PROJECT)$(TCL_MAJOR_VERSION).$(TCL_MINOR_VERSION) MODULE_INSTALL_DIR = $(_INSTALLDIR)\lib\tcl$(TCL_MAJOR_VERSION) !else # DOING_TK SCRIPT_INSTALL_DIR = $(_INSTALLDIR)\lib\$(PROJECT)$(TK_MAJOR_VERSION).$(TK_MINOR_VERSION) !endif DEMO_INSTALL_DIR = $(SCRIPT_INSTALL_DIR)\demos INCLUDE_INSTALL_DIR = $(_INSTALLDIR)\include !else # extension other than Tk |
| ︙ | ︙ | |||
1316 1317 1318 1319 1320 1321 1322 | !if $(TCL_NO_DEPRECATED) OPTDEFINES = $(OPTDEFINES) /DTCL_NO_DEPRECATED !endif !if $(USE_STUBS) # Note we do not define USE_TCL_STUBS even when building tk since some # test targets in tk do not use stubs | | | 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 | !if $(TCL_NO_DEPRECATED) OPTDEFINES = $(OPTDEFINES) /DTCL_NO_DEPRECATED !endif !if $(USE_STUBS) # Note we do not define USE_TCL_STUBS even when building tk since some # test targets in tk do not use stubs !if !$(DOING_TCL) USE_STUBS_DEFS = /DUSE_TCL_STUBS=1 /DUSE_TCLOO_STUBS=1 !if $(NEED_TK) USE_STUBS_DEFS = $(USE_STUBS_DEFS) /DUSE_TK_STUBS !endif !endif !endif # USE_STUBS |
| ︙ | ︙ | |||
1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 |
!endif
!if "$(MACHINE)" == "AMD64"
OPTDEFINES = $(OPTDEFINES) /DTCL_CFG_DO64BIT
!endif
!if $(VCVERSION) < 1300
OPTDEFINES = $(OPTDEFINES) /DNO_STRTOI64=1
!endif
# Like the TEA system only set this non empty for non-Tk extensions
# Note: some extensions use PACKAGE_NAME and others use PACKAGE_TCLNAME
# so we pass both
!if !$(DOING_TCL) && !$(DOING_TK)
PKGNAMEFLAGS = /DPACKAGE_NAME="\"$(PRJ_PACKAGE_TCLNAME)\"" \
/DPACKAGE_TCLNAME="\"$(PRJ_PACKAGE_TCLNAME)\"" \
| > > > > > > > > > > > > | 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 |
!endif
!if "$(MACHINE)" == "AMD64"
OPTDEFINES = $(OPTDEFINES) /DTCL_CFG_DO64BIT
!endif
!if $(VCVERSION) < 1300
OPTDEFINES = $(OPTDEFINES) /DNO_STRTOI64=1
!endif
!if "$(TCL_MAJOR_VERSION)" == "8"
!if "$(_USE_64BIT_TIME_T)" == "1"
OPTDEFINES = $(OPTDEFINES) /D_USE_64BIT_TIME_T=1
!endif
!if "$(TCL_UTF_MAX)" == "4"
OPTDEFINES = $(OPTDEFINES) /DTCL_UTF_MAX=4
!endif
# _ATL_XP_TARGETING - Newer SDK's need this to build for XP
COMPILERFLAGS = /D_ATL_XP_TARGETING
!endif
# Like the TEA system only set this non empty for non-Tk extensions
# Note: some extensions use PACKAGE_NAME and others use PACKAGE_TCLNAME
# so we pass both
!if !$(DOING_TCL) && !$(DOING_TK)
PKGNAMEFLAGS = /DPACKAGE_NAME="\"$(PRJ_PACKAGE_TCLNAME)\"" \
/DPACKAGE_TCLNAME="\"$(PRJ_PACKAGE_TCLNAME)\"" \
|
| ︙ | ︙ | |||
1739 1740 1741 1742 1743 1744 1745 | !endif ################################################################ # 14. Sanity check selected options against Tcl build options # When building an extension, certain configuration options should # match the ones used when Tcl was built. Here we check and # warn on a mismatch. | | | | 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 |
!endif
################################################################
# 14. Sanity check selected options against Tcl build options
# When building an extension, certain configuration options should
# match the ones used when Tcl was built. Here we check and
# warn on a mismatch.
!if !$(DOING_TCL)
!if $(TCLINSTALL) # Building against an installed Tcl
!if exist("$(_TCLDIR)\lib\nmake\tcl.nmake")
TCLNMAKECONFIG = "$(_TCLDIR)\lib\nmake\tcl.nmake"
!endif
!else # !$(TCLINSTALL) - building against Tcl source
!if exist("$(OUT_DIR)\tcl.nmake")
TCLNMAKECONFIG = "$(OUT_DIR)\tcl.nmake"
!endif
!endif # TCLINSTALL
!if $(CONFIG_CHECK)
!ifdef TCLNMAKECONFIG
|
| ︙ | ︙ | |||
1768 1769 1770 1771 1772 1773 1774 | !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 | | | 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 | !if defined(CORE_DEBUG) && $(CORE_DEBUG) != $(DEBUG) !message WARNING: Value of DEBUG ($(DEBUG)) does not match its Tcl library configuration ($(DEBUG)). !endif !endif !endif # TCLNMAKECONFIG !endif # !$(DOING_TCL) #---------------------------------------------------------- # Display stats being used. #---------------------------------------------------------- !if !$(DOING_TCL) |
| ︙ | ︙ |
Changes to win/tcl.dsp.
| ︙ | ︙ | |||
344 345 346 347 348 349 350 | # End Source File # Begin Source File SOURCE=..\doc\CrtObjCmd.3 # End Source File # Begin Source File | | | 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 | # End Source File # Begin Source File SOURCE=..\doc\CrtObjCmd.3 # End Source File # Begin Source File SOURCE=..\doc\CrtAlias.3 # End Source File # Begin Source File SOURCE=..\doc\CrtTimerHdlr.3 # End Source File # Begin Source File |
| ︙ | ︙ |
Changes to win/tcl.m4.
| ︙ | ︙ | |||
276 277 278 279 280 281 282 |
if test -f $TCL_BIN_DIR/Makefile ; then
TCL_LIB_SPEC=${TCL_BUILD_LIB_SPEC}
TCL_STUB_LIB_SPEC=${TCL_BUILD_STUB_LIB_SPEC}
TCL_STUB_LIB_PATH=${TCL_BUILD_STUB_LIB_PATH}
fi
| < < < < < < < < < | 276 277 278 279 280 281 282 283 284 285 286 287 288 289 |
if test -f $TCL_BIN_DIR/Makefile ; then
TCL_LIB_SPEC=${TCL_BUILD_LIB_SPEC}
TCL_STUB_LIB_SPEC=${TCL_BUILD_STUB_LIB_SPEC}
TCL_STUB_LIB_PATH=${TCL_BUILD_STUB_LIB_PATH}
fi
eval "TCL_STUB_LIB_FILE=\"${TCL_STUB_LIB_FILE}\""
eval "TCL_STUB_LIB_FLAG=\"${TCL_STUB_LIB_FLAG}\""
eval "TCL_STUB_LIB_SPEC=\"${TCL_STUB_LIB_SPEC}\""
AC_SUBST(TCL_VERSION)
AC_SUBST(TCL_BIN_DIR)
AC_SUBST(TCL_SRC_DIR)
|
| ︙ | ︙ | |||
406 407 408 409 410 411 412 | # --enable-symbols # # Defines the following vars: # CFLAGS_DEFAULT Sets to $(CFLAGS_DEBUG) if true # Sets to $(CFLAGS_OPTIMIZE) if false # LDFLAGS_DEFAULT Sets to $(LDFLAGS_DEBUG) if true # Sets to $(LDFLAGS_OPTIMIZE) if false | < < < | 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 |
# --enable-symbols
#
# Defines the following vars:
# CFLAGS_DEFAULT Sets to $(CFLAGS_DEBUG) if true
# Sets to $(CFLAGS_OPTIMIZE) if false
# LDFLAGS_DEFAULT Sets to $(LDFLAGS_DEBUG) if true
# Sets to $(LDFLAGS_OPTIMIZE) if false
#
#------------------------------------------------------------------------
AC_DEFUN([SC_ENABLE_SYMBOLS], [
AC_MSG_CHECKING([for build with symbols])
AC_ARG_ENABLE(symbols, [ --enable-symbols build with debugging symbols (default: off)], [tcl_ok=$enableval], [tcl_ok=no])
# FIXME: Currently, LDFLAGS_DEFAULT is not used, it should work like CFLAGS_DEFAULT.
if test "$tcl_ok" = "no"; then
CFLAGS_DEFAULT='$(CFLAGS_OPTIMIZE)'
LDFLAGS_DEFAULT='$(LDFLAGS_OPTIMIZE)'
AC_DEFINE(NDEBUG, 1, [Is no debugging enabled?])
AC_MSG_RESULT([no])
AC_DEFINE(TCL_CFG_OPTIMIZED)
else
CFLAGS_DEFAULT='$(CFLAGS_DEBUG)'
LDFLAGS_DEFAULT='$(LDFLAGS_DEBUG)'
if test "$tcl_ok" = "yes"; then
AC_MSG_RESULT([yes (standard debugging)])
fi
fi
AC_SUBST(CFLAGS_DEFAULT)
AC_SUBST(LDFLAGS_DEFAULT)
|
| ︙ | ︙ | |||
647 648 649 650 651 652 653 |
LIBPREFIX="lib"
if test "${SHARED_BUILD}" = "0" ; then
# static
AC_MSG_RESULT([using static flags])
runtime=
LIBRARIES="\${STATIC_LIBRARIES}"
| | | | | | | 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 |
LIBPREFIX="lib"
if test "${SHARED_BUILD}" = "0" ; then
# static
AC_MSG_RESULT([using static flags])
runtime=
LIBRARIES="\${STATIC_LIBRARIES}"
EXESUFFIX="s.exe"
else
# dynamic
AC_MSG_RESULT([using shared flags])
# ad-hoc check to see if CC supports -shared.
if "${CC}" -shared 2>&1 | egrep ': -shared not supported' >/dev/null; then
AC_MSG_ERROR([${CC} does not support the -shared option.
You will need to upgrade to a newer version of the toolchain.])
fi
runtime=
# Add SHLIB_LD_LIBS to the Make rule, not here.
EXESUFFIX=".exe"
LIBRARIES="\${SHARED_LIBRARIES}"
fi
# Link with gcc since ld does not link to default libs like
# -luser32 and -lmsvcrt by default.
SHLIB_LD='${CC} -shared'
SHLIB_LD_LIBS='${LIBS}'
MAKE_DLL="\${SHLIB_LD} \$(LDFLAGS) -o \[$]@ ${extra_ldflags} \
-Wl,--out-implib,\$(patsubst %.dll,lib%.a,\[$]@)"
# DLLSUFFIX is separate because it is the building block for
# users of tclConfig.sh that may build shared or static.
DLLSUFFIX=".dll"
LIBSUFFIX=".a"
LIBFLAGSUFFIX=""
SHLIB_SUFFIX=.dll
EXTRA_CFLAGS="${extra_cflags}"
CFLAGS_DEBUG=-g
CFLAGS_OPTIMIZE="-O2 -fomit-frame-pointer"
CFLAGS_WARNING="-Wall -Wextra -Wwrite-strings -Wpointer-arith"
|
| ︙ | ︙ | |||
746 747 748 749 750 751 752 |
esac
else
if test "${SHARED_BUILD}" = "0" ; then
# static
AC_MSG_RESULT([using static flags])
runtime=-MT
LIBRARIES="\${STATIC_LIBRARIES}"
| | | | | | | 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 |
esac
else
if test "${SHARED_BUILD}" = "0" ; then
# static
AC_MSG_RESULT([using static flags])
runtime=-MT
LIBRARIES="\${STATIC_LIBRARIES}"
EXESUFFIX="s.exe"
else
# dynamic
AC_MSG_RESULT([using shared flags])
runtime=-MD
# Add SHLIB_LD_LIBS to the Make rule, not here.
LIBRARIES="\${SHARED_LIBRARIES}"
EXESUFFIX=".exe"
case "x`echo \${VisualStudioVersion}`" in
x1[[4-9]]*)
lflags="${lflags} -nodefaultlib:libucrt.lib"
;;
*)
;;
esac
fi
MAKE_DLL="\${SHLIB_LD} \$(LDFLAGS) -out:\[$]@"
# DLLSUFFIX is separate because it is the building block for
# users of tclConfig.sh that may build shared or static.
DLLSUFFIX=".dll"
LIBSUFFIX=".lib"
LIBFLAGSUFFIX=""
if test "$do64bit" != "no" ; then
case "$do64bit" in
amd64|x64|yes)
MACHINE="AMD64" ; # assume AMD64 as default 64-bit build
;;
ia64)
|
| ︙ | ︙ | |||
1065 1066 1067 1068 1069 1070 1071 |
# Results
# Subst's the following values:
# BUILD_TCLSH
#------------------------------------------------------------------------
AC_DEFUN([SC_BUILD_TCLSH], [
AC_MSG_CHECKING([for tclsh in Tcl build directory])
| | | 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 |
# Results
# Subst's the following values:
# BUILD_TCLSH
#------------------------------------------------------------------------
AC_DEFUN([SC_BUILD_TCLSH], [
AC_MSG_CHECKING([for tclsh in Tcl build directory])
BUILD_TCLSH=${TCL_BIN_DIR}/tclsh${TCL_MAJOR_VERSION}${TCL_MINOR_VERSION}${EXEEXT}
AC_MSG_RESULT($BUILD_TCLSH)
AC_SUBST(BUILD_TCLSH)
])
#--------------------------------------------------------------------
# SC_TCL_CFG_ENCODING TIP #59
#
|
| ︙ | ︙ |
Changes to win/tclAppInit.c.
| ︙ | ︙ | |||
83 84 85 86 87 88 89 |
*----------------------------------------------------------------------
*/
#ifdef TCL_BROKEN_MAINARGS
int
main(
int argc, /* Number of command-line arguments. */
| | | 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 |
*----------------------------------------------------------------------
*/
#ifdef TCL_BROKEN_MAINARGS
int
main(
int argc, /* Number of command-line arguments. */
char **argv1)
{
TCHAR **argv;
TCHAR *p;
#else
int
_tmain(
int argc, /* Number of command-line arguments. */
|
| ︙ | ︙ | |||
108 109 110 111 112 113 114 115 116 117 118 119 120 121 |
setlocale(LC_ALL, "C");
#ifdef TCL_BROKEN_MAINARGS
/*
* Get our args from the c-runtime. Ignore command line.
*/
setargv(&argc, &argv);
#endif
/*
* Forward slashes substituted for backslashes.
*/
| > | 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 |
setlocale(LC_ALL, "C");
#ifdef TCL_BROKEN_MAINARGS
/*
* Get our args from the c-runtime. Ignore command line.
*/
(void)argv1;
setargv(&argc, &argv);
#endif
/*
* Forward slashes substituted for backslashes.
*/
|
| ︙ | ︙ |
Changes to win/tclConfig.sh.in.
| ︙ | ︙ | |||
19 20 21 22 23 24 25 | # C compiler to use for compilation. TCL_CC='@CC@' # -D flags for use with the C compiler. TCL_DEFS='@DEFS@' | < < < < | 19 20 21 22 23 24 25 26 27 28 29 30 31 32 | # C compiler to use for compilation. TCL_CC='@CC@' # -D flags for use with the C compiler. TCL_DEFS='@DEFS@' # Default flags used in an optimized and debuggable build, respectively. TCL_CFLAGS_DEBUG='@CFLAGS_DEBUG@' TCL_CFLAGS_OPTIMIZE='@CFLAGS_OPTIMIZE@' # Default linker flags used in an optimized and debuggable build, respectively. TCL_LDFLAGS_DEBUG='@LDFLAGS_DEBUG@' TCL_LDFLAGS_OPTIMIZE='@LDFLAGS_OPTIMIZE@' |
| ︙ | ︙ |
Changes to win/tclWin32Dll.c.
| ︙ | ︙ | |||
148 149 150 151 152 153 154 | * * Side effects: * None. * *---------------------------------------------------------------------- */ | < > | 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 |
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
void *
TclWinGetTclInstance(void)
{
return hInstance;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
408 409 410 411 412 413 414 |
/*
* The volume doesn't appear to correspond to a drive letter - we remember
* that fact and store '-1' so we don't have to look it up each time.
*/
dlPtr2 = (MountPointMap *)Tcl_Alloc(sizeof(MountPointMap));
| | | 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 |
/*
* The volume doesn't appear to correspond to a drive letter - we remember
* that fact and store '-1' so we don't have to look it up each time.
*/
dlPtr2 = (MountPointMap *)Tcl_Alloc(sizeof(MountPointMap));
dlPtr2->volumeName = (WCHAR *)TclNativeDupInternalRep((void *)mountPoint);
dlPtr2->driveLetter = -1;
dlPtr2->nextPtr = driveLetterLookup;
driveLetterLookup = dlPtr2;
Tcl_MutexUnlock(&mountPointMap);
return -1;
}
|
| ︙ | ︙ | |||
465 466 467 468 469 470 471 | "movl %[rptr], %%edi" "\n\t" "movl %[index], %%eax" "\n\t" "cpuid" "\n\t" "movl %%eax, 0x0(%%edi)" "\n\t" "movl %%ebx, 0x4(%%edi)" "\n\t" "movl %%ecx, 0x8(%%edi)" "\n\t" | | | 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 | "movl %[rptr], %%edi" "\n\t" "movl %[index], %%eax" "\n\t" "cpuid" "\n\t" "movl %%eax, 0x0(%%edi)" "\n\t" "movl %%ebx, 0x4(%%edi)" "\n\t" "movl %%ecx, 0x8(%%edi)" "\n\t" "movl %%edx, 0xC(%%edi)" "\n\t" : /* No outputs */ : [index] "m" (index), [rptr] "m" (regsPtr) : |
| ︙ | ︙ | |||
497 498 499 500 501 502 503 | "leal %[registration], %%edx" "\n\t" "movl %%fs:0, %%eax" "\n\t" "movl %%eax, 0x0(%%edx)" "\n\t" /* link */ "leal 1f, %%eax" "\n\t" "movl %%eax, 0x4(%%edx)" "\n\t" /* handler */ "movl %%ebp, 0x8(%%edx)" "\n\t" /* ebp */ | | | | 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 | "leal %[registration], %%edx" "\n\t" "movl %%fs:0, %%eax" "\n\t" "movl %%eax, 0x0(%%edx)" "\n\t" /* link */ "leal 1f, %%eax" "\n\t" "movl %%eax, 0x4(%%edx)" "\n\t" /* handler */ "movl %%ebp, 0x8(%%edx)" "\n\t" /* ebp */ "movl %%esp, 0xC(%%edx)" "\n\t" /* esp */ "movl %[error], 0x10(%%edx)" "\n\t" /* status */ /* * Link the TCLEXCEPTION_REGISTRATION on the chain */ "movl %%edx, %%fs:0" "\n\t" /* * Do the CPUID instruction, and save the results in the 'regsPtr' * area. */ "movl %[rptr], %%edi" "\n\t" "movl %[index], %%eax" "\n\t" "cpuid" "\n\t" "movl %%eax, 0x0(%%edi)" "\n\t" "movl %%ebx, 0x4(%%edi)" "\n\t" "movl %%ecx, 0x8(%%edi)" "\n\t" "movl %%edx, 0xC(%%edi)" "\n\t" /* * Come here on a normal exit. Recover the TCLEXCEPTION_REGISTRATION and * store a TCL_OK status. */ "movl %%fs:0, %%edx" "\n\t" |
| ︙ | ︙ | |||
544 545 546 547 548 549 550 | /* * Come here however we exited. Restore context from the * TCLEXCEPTION_REGISTRATION in case the stack is unbalanced. */ "2:" "\t" | | | 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 | /* * Come here however we exited. Restore context from the * TCLEXCEPTION_REGISTRATION in case the stack is unbalanced. */ "2:" "\t" "movl 0xC(%%edx), %%esp" "\n\t" "movl 0x8(%%edx), %%ebp" "\n\t" "movl 0x0(%%edx), %%eax" "\n\t" "movl %%eax, %%fs:0" "\n\t" : /* No outputs */ : |
| ︙ | ︙ |
Changes to win/tclWinChan.c.
| ︙ | ︙ | |||
889 890 891 892 893 894 895 |
handle = CreateFileW(nativeName, accessMode, shareMode,
NULL, createMode, flags, (HANDLE) NULL);
if (handle == INVALID_HANDLE_VALUE) {
DWORD err = GetLastError();
| | | 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 |
handle = CreateFileW(nativeName, accessMode, shareMode,
NULL, createMode, flags, (HANDLE) NULL);
if (handle == INVALID_HANDLE_VALUE) {
DWORD err = GetLastError();
if ((err & 0xFFFFL) == ERROR_OPEN_FAILED) {
err = TEST_FLAG(mode, O_CREAT) ? ERROR_FILE_EXISTS
: ERROR_FILE_NOT_FOUND;
}
TclWinConvertError(err);
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't open \"%s\": %s",
|
| ︙ | ︙ | |||
1081 1082 1083 1084 1085 1086 1087 | "leal %[registration], %%edx" "\n\t" "movl %%fs:0, %%eax" "\n\t" "movl %%eax, 0x0(%%edx)" "\n\t" /* link */ "leal 1f, %%eax" "\n\t" "movl %%eax, 0x4(%%edx)" "\n\t" /* handler */ "movl %%ebp, 0x8(%%edx)" "\n\t" /* ebp */ | | | 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 | "leal %[registration], %%edx" "\n\t" "movl %%fs:0, %%eax" "\n\t" "movl %%eax, 0x0(%%edx)" "\n\t" /* link */ "leal 1f, %%eax" "\n\t" "movl %%eax, 0x4(%%edx)" "\n\t" /* handler */ "movl %%ebp, 0x8(%%edx)" "\n\t" /* ebp */ "movl %%esp, 0xC(%%edx)" "\n\t" /* esp */ "movl $0, 0x10(%%edx)" "\n\t" /* status */ /* * Link the TCLEXCEPTION_REGISTRATION on the chain. */ "movl %%edx, %%fs:0" "\n\t" |
| ︙ | ︙ | |||
1121 1122 1123 1124 1125 1126 1127 | /* * Come here however we exited. Restore context from the * TCLEXCEPTION_REGISTRATION in case the stack is unbalanced. */ "2:" "\t" | | | 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 | /* * Come here however we exited. Restore context from the * TCLEXCEPTION_REGISTRATION in case the stack is unbalanced. */ "2:" "\t" "movl 0xC(%%edx), %%esp" "\n\t" "movl 0x8(%%edx), %%ebp" "\n\t" "movl 0x0(%%edx), %%eax" "\n\t" "movl %%eax, %%fs:0" "\n\t" : /* No outputs */ : |
| ︙ | ︙ |
Changes to win/tclWinError.c.
| ︙ | ︙ | |||
345 346 347 348 349 350 351 | * Sets the errno global variable. * *---------------------------------------------------------------------- */ void TclWinConvertError( | | | | | 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 |
* Sets the errno global variable.
*
*----------------------------------------------------------------------
*/
void
TclWinConvertError(
int errCode) /* Win32 error code. */
{
if ((unsigned)errCode >= sizeof(errorTable)/sizeof(errorTable[0])) {
errCode -= WSAEWOULDBLOCK;
if ((unsigned)errCode >= sizeof(wsaErrorTable)/sizeof(wsaErrorTable[0])) {
Tcl_SetErrno(errorTable[1]);
} else {
Tcl_SetErrno(wsaErrorTable[errCode]);
}
} else {
Tcl_SetErrno(errorTable[errCode]);
}
|
| ︙ | ︙ |
Changes to win/tclWinFCmd.c.
| ︙ | ︙ | |||
200 201 202 203 204 205 206 | "leal %[registration], %%edx" "\n\t" "movl %%fs:0, %%eax" "\n\t" "movl %%eax, 0x0(%%edx)" "\n\t" /* link */ "leal 1f, %%eax" "\n\t" "movl %%eax, 0x4(%%edx)" "\n\t" /* handler */ "movl %%ebp, 0x8(%%edx)" "\n\t" /* ebp */ | | | 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 | "leal %[registration], %%edx" "\n\t" "movl %%fs:0, %%eax" "\n\t" "movl %%eax, 0x0(%%edx)" "\n\t" /* link */ "leal 1f, %%eax" "\n\t" "movl %%eax, 0x4(%%edx)" "\n\t" /* handler */ "movl %%ebp, 0x8(%%edx)" "\n\t" /* ebp */ "movl %%esp, 0xC(%%edx)" "\n\t" /* esp */ "movl $0, 0x10(%%edx)" "\n\t" /* status */ /* * Link the TCLEXCEPTION_REGISTRATION on the chain. */ "movl %%edx, %%fs:0" "\n\t" |
| ︙ | ︙ | |||
241 242 243 244 245 246 247 | /* * Come here however we exited. Restore context from the * TCLEXCEPTION_REGISTRATION in case the stack is unbalanced. */ "2:" "\t" | | | 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 | /* * Come here however we exited. Restore context from the * TCLEXCEPTION_REGISTRATION in case the stack is unbalanced. */ "2:" "\t" "movl 0xC(%%edx), %%esp" "\n\t" "movl 0x8(%%edx), %%ebp" "\n\t" "movl 0x0(%%edx), %%eax" "\n\t" "movl %%eax, %%fs:0" "\n\t" : /* No outputs */ : |
| ︙ | ︙ | |||
279 280 281 282 283 284 285 |
return retval;
}
TclWinConvertError(GetLastError());
srcAttr = GetFileAttributesW(nativeSrc);
dstAttr = GetFileAttributesW(nativeDst);
| | | | 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 |
return retval;
}
TclWinConvertError(GetLastError());
srcAttr = GetFileAttributesW(nativeSrc);
dstAttr = GetFileAttributesW(nativeDst);
if (srcAttr == 0xFFFFFFFF) {
if (GetFullPathNameW(nativeSrc, 0, NULL,
NULL) >= MAX_PATH) {
errno = ENAMETOOLONG;
return TCL_ERROR;
}
srcAttr = 0;
}
if (dstAttr == 0xFFFFFFFF) {
if (GetFullPathNameW(nativeDst, 0, NULL,
NULL) >= MAX_PATH) {
errno = ENAMETOOLONG;
return TCL_ERROR;
}
dstAttr = 0;
}
|
| ︙ | ︙ | |||
589 590 591 592 593 594 595 | "leal %[registration], %%edx" "\n\t" "movl %%fs:0, %%eax" "\n\t" "movl %%eax, 0x0(%%edx)" "\n\t" /* link */ "leal 1f, %%eax" "\n\t" "movl %%eax, 0x4(%%edx)" "\n\t" /* handler */ "movl %%ebp, 0x8(%%edx)" "\n\t" /* ebp */ | | | 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 | "leal %[registration], %%edx" "\n\t" "movl %%fs:0, %%eax" "\n\t" "movl %%eax, 0x0(%%edx)" "\n\t" /* link */ "leal 1f, %%eax" "\n\t" "movl %%eax, 0x4(%%edx)" "\n\t" /* handler */ "movl %%ebp, 0x8(%%edx)" "\n\t" /* ebp */ "movl %%esp, 0xC(%%edx)" "\n\t" /* esp */ "movl $0, 0x10(%%edx)" "\n\t" /* status */ /* * Link the TCLEXCEPTION_REGISTRATION on the chain. */ "movl %%edx, %%fs:0" "\n\t" |
| ︙ | ︙ | |||
631 632 633 634 635 636 637 | /* * Come here however we exited. Restore context from the * TCLEXCEPTION_REGISTRATION in case the stack is unbalanced. */ "2:" "\t" | | | 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 | /* * Come here however we exited. Restore context from the * TCLEXCEPTION_REGISTRATION in case the stack is unbalanced. */ "2:" "\t" "movl 0xC(%%edx), %%esp" "\n\t" "movl 0x8(%%edx), %%ebp" "\n\t" "movl 0x0(%%edx), %%eax" "\n\t" "movl %%eax, %%fs:0" "\n\t" : /* No outputs */ : |
| ︙ | ︙ | |||
675 676 677 678 679 680 681 |
return TCL_ERROR;
}
if (Tcl_GetErrno() == EACCES) {
DWORD srcAttr, dstAttr;
srcAttr = GetFileAttributesW(nativeSrc);
dstAttr = GetFileAttributesW(nativeDst);
| | | | 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 |
return TCL_ERROR;
}
if (Tcl_GetErrno() == EACCES) {
DWORD srcAttr, dstAttr;
srcAttr = GetFileAttributesW(nativeSrc);
dstAttr = GetFileAttributesW(nativeDst);
if (srcAttr != 0xFFFFFFFF) {
if (dstAttr == 0xFFFFFFFF) {
dstAttr = 0;
}
if ((srcAttr & FILE_ATTRIBUTE_DIRECTORY) ||
(dstAttr & FILE_ATTRIBUTE_DIRECTORY)) {
if (srcAttr & FILE_ATTRIBUTE_REPARSE_POINT) {
/* Source is a symbolic link -- copy it */
if (TclWinSymLinkCopyDirectory(nativeSrc, nativeDst)==0) {
|
| ︙ | ︙ | |||
766 767 768 769 770 771 772 |
if (DeleteFileW(path) != FALSE) {
return TCL_OK;
}
TclWinConvertError(GetLastError());
if (Tcl_GetErrno() == EACCES) {
attr = GetFileAttributesW(path);
| | | 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 |
if (DeleteFileW(path) != FALSE) {
return TCL_OK;
}
TclWinConvertError(GetLastError());
if (Tcl_GetErrno() == EACCES) {
attr = GetFileAttributesW(path);
if (attr != 0xFFFFFFFF) {
if (attr & FILE_ATTRIBUTE_DIRECTORY) {
if (attr & FILE_ATTRIBUTE_REPARSE_POINT) {
/*
* It is a symbolic link - remove it.
*/
if (TclWinSymLinkDelete(path, 0) == 0) {
return TCL_OK;
|
| ︙ | ︙ | |||
801 802 803 804 805 806 807 |
if (res != 0) {
SetFileAttributesW(path, attr);
}
}
}
} else if (Tcl_GetErrno() == ENOENT) {
attr = GetFileAttributesW(path);
| | | 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 |
if (res != 0) {
SetFileAttributesW(path, attr);
}
}
}
} else if (Tcl_GetErrno() == ENOENT) {
attr = GetFileAttributesW(path);
if (attr != 0xFFFFFFFF) {
if (attr & FILE_ATTRIBUTE_DIRECTORY) {
/*
* Windows 95 reports removing a directory as ENOENT instead
* of EISDIR.
*/
Tcl_SetErrno(EISDIR);
|
| ︙ | ︙ | |||
1054 1055 1056 1057 1058 1059 1060 |
}
}
TclWinConvertError(GetLastError());
if (Tcl_GetErrno() == EACCES) {
attr = GetFileAttributesW(nativePath);
| | | 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 |
}
}
TclWinConvertError(GetLastError());
if (Tcl_GetErrno() == EACCES) {
attr = GetFileAttributesW(nativePath);
if (attr != 0xFFFFFFFF) {
if ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0) {
/*
* Windows 95 reports calling RemoveDirectory on a file as an
* EACCES, not an ENOTDIR.
*/
Tcl_SetErrno(ENOTDIR);
|
| ︙ | ︙ | |||
1199 1200 1201 1202 1203 1204 1205 |
nativeSource = (WCHAR *) Tcl_DStringValue(sourcePtr);
nativeTarget = (WCHAR *)
(targetPtr == NULL ? NULL : Tcl_DStringValue(targetPtr));
oldSourceLen = Tcl_DStringLength(sourcePtr);
sourceAttr = GetFileAttributesW(nativeSource);
| | | 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 |
nativeSource = (WCHAR *) Tcl_DStringValue(sourcePtr);
nativeTarget = (WCHAR *)
(targetPtr == NULL ? NULL : Tcl_DStringValue(targetPtr));
oldSourceLen = Tcl_DStringLength(sourcePtr);
sourceAttr = GetFileAttributesW(nativeSource);
if (sourceAttr == 0xFFFFFFFF) {
nativeErrfile = nativeSource;
goto end;
}
if (sourceAttr & FILE_ATTRIBUTE_REPARSE_POINT) {
/*
* Process the symbolic link
|
| ︙ | ︙ | |||
1516 1517 1518 1519 1520 1521 1522 |
DWORD result;
const WCHAR *nativeName;
int attr;
nativeName = (const WCHAR *)Tcl_FSGetNativePath(fileName);
result = GetFileAttributesW(nativeName);
| | | 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 |
DWORD result;
const WCHAR *nativeName;
int attr;
nativeName = (const WCHAR *)Tcl_FSGetNativePath(fileName);
result = GetFileAttributesW(nativeName);
if (result == 0xFFFFFFFF) {
StatError(interp, fileName);
return TCL_ERROR;
}
attr = (int)(result & attributeArray[objIndex]);
if ((objIndex == WIN_HIDDEN_ATTRIBUTE) && (attr != 0)) {
/*
|
| ︙ | ︙ | |||
1842 1843 1844 1845 1846 1847 1848 |
DWORD fileAttributes, old;
int yesNo, result;
const WCHAR *nativeName;
nativeName = (const WCHAR *)Tcl_FSGetNativePath(fileName);
fileAttributes = old = GetFileAttributesW(nativeName);
| | | 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 |
DWORD fileAttributes, old;
int yesNo, result;
const WCHAR *nativeName;
nativeName = (const WCHAR *)Tcl_FSGetNativePath(fileName);
fileAttributes = old = GetFileAttributesW(nativeName);
if (fileAttributes == 0xFFFFFFFF) {
StatError(interp, fileName);
return TCL_ERROR;
}
result = Tcl_GetBooleanFromObj(interp, attributePtr, &yesNo);
if (result != TCL_OK) {
return result;
|
| ︙ | ︙ |
Changes to win/tclWinInit.c.
| ︙ | ︙ | |||
79 80 81 82 83 84 85 | /* * Windows version dependend functions */ TclWinProcs tclWinProcs; /* | | < | 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 |
/*
* Windows version dependend functions
*/
TclWinProcs tclWinProcs;
/*
* The following arrays contain the human readable strings for the
* processor values.
*/
#define NUMPROCESSORS 11
static const char *const processors[NUMPROCESSORS] = {
"intel", "mips", "alpha", "ppc", "shx", "arm", "ia64", "alpha64", "msil",
"amd64", "ia32_on_win64"
};
|
| ︙ | ︙ | |||
340 341 342 343 344 345 346 |
static void
InitializeDefaultLibraryDir(
char **valuePtr,
size_t *lengthPtr,
Tcl_Encoding *encodingPtr)
{
| | | 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 |
static void
InitializeDefaultLibraryDir(
char **valuePtr,
size_t *lengthPtr,
Tcl_Encoding *encodingPtr)
{
HMODULE 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);
|
| ︙ | ︙ | |||
388 389 390 391 392 393 394 |
static void
InitializeSourceLibraryDir(
char **valuePtr,
size_t *lengthPtr,
Tcl_Encoding *encodingPtr)
{
| | | 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 |
static void
InitializeSourceLibraryDir(
char **valuePtr,
size_t *lengthPtr,
Tcl_Encoding *encodingPtr)
{
HMODULE 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);
|
| ︙ | ︙ | |||
536 537 538 539 540 541 542 |
/*
* Define the tcl_platform array.
*/
Tcl_SetVar2(interp, "tcl_platform", "platform", "windows",
TCL_GLOBAL_ONLY);
| | > | 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 |
/*
* Define the tcl_platform array.
*/
Tcl_SetVar2(interp, "tcl_platform", "platform", "windows",
TCL_GLOBAL_ONLY);
Tcl_SetVar2(interp, "tcl_platform", "os",
"Windows NT", TCL_GLOBAL_ONLY);
wsprintfA(buffer, "%d.%d", osInfo.dwMajorVersion, osInfo.dwMinorVersion);
Tcl_SetVar2(interp, "tcl_platform", "osVersion", buffer, TCL_GLOBAL_ONLY);
if (sys.oemId.wProcessorArchitecture < NUMPROCESSORS) {
Tcl_SetVar2(interp, "tcl_platform", "machine",
processors[sys.oemId.wProcessorArchitecture],
TCL_GLOBAL_ONLY);
}
|
| ︙ | ︙ | |||
621 622 623 624 625 626 627 | * * Side effects: * None. * *---------------------------------------------------------------------- */ | < < | | < < < < < > | | | > | | 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 |
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
# define tenviron2utfdstr(string, len, dsPtr) \
(char *)Tcl_Char16ToUtfDString((const unsigned short *)(string), ((((len) + 2) >> 1) - 1), (dsPtr))
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;
const WCHAR *env;
const char *p1, *p2;
char *envUpper, *nameUpper;
Tcl_DString envString;
/*
* Convert the name to all upper case for the case insensitive comparison.
*/
length = strlen(name);
nameUpper = (char *)Tcl_Alloc(length + 1);
memcpy(nameUpper, name, length+1);
Tcl_UtfToUpper(nameUpper);
Tcl_DStringInit(&envString);
for (i = 0, env = _wenviron[i];
env != NULL;
i++, env = _wenviron[i]) {
/*
* Chop the env string off after the equal sign, then Convert the name
* to all upper case, so we do not have to convert all the characters
* after the equal sign.
*/
Tcl_DStringInit(&envString);
envUpper = Tcl_WCharToUtfDString(env, -1, &envString);
p1 = strchr(envUpper, '=');
if (p1 == NULL) {
continue;
}
length = p1 - envUpper;
Tcl_DStringSetLength(&envString, length+1);
Tcl_UtfToUpper(envUpper);
|
| ︙ | ︙ |
Changes to win/tclWinNotify.c.
| ︙ | ︙ | |||
80 81 82 83 84 85 86 |
Tcl_InitNotifier(void)
{
if (tclNotifierHooks.initNotifierProc) {
return tclNotifierHooks.initNotifierProc();
} else {
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
| | | | | 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 |
Tcl_InitNotifier(void)
{
if (tclNotifierHooks.initNotifierProc) {
return tclNotifierHooks.initNotifierProc();
} else {
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
TclpGlobalLock();
if (!initialized) {
initialized = 1;
InitializeCriticalSection(¬ifierMutex);
}
TclpGlobalUnlock();
/*
* Register Notifier window class if this is the first thread to use
* this module.
*/
EnterCriticalSection(¬ifierMutex);
if (notifierCount == 0) {
WNDCLASSW clazz;
clazz.style = 0;
clazz.cbClsExtra = 0;
clazz.cbWndExtra = 0;
clazz.hInstance = (HINSTANCE)TclWinGetTclInstance();
clazz.hbrBackground = NULL;
clazz.lpszMenuName = NULL;
clazz.lpszClassName = className;
clazz.lpfnWndProc = NotifierProc;
clazz.hIcon = NULL;
clazz.hCursor = NULL;
|
| ︙ | ︙ | |||
191 192 193 194 195 196 197 |
* notifier window class.
*/
EnterCriticalSection(¬ifierMutex);
if (notifierCount) {
notifierCount--;
if (notifierCount == 0) {
| | | 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 |
* notifier window class.
*/
EnterCriticalSection(¬ifierMutex);
if (notifierCount) {
notifierCount--;
if (notifierCount == 0) {
UnregisterClassW(className, (HINSTANCE)TclWinGetTclInstance());
}
}
LeaveCriticalSection(¬ifierMutex);
}
}
/*
|
| ︙ | ︙ | |||
356 357 358 359 360 361 362 |
* synchronous system messages. At some point, we may want to consider
* destroying the window if we leave the modal loop, but for now we'll
* leave it around.
*/
if (mode == TCL_SERVICE_ALL && !tsdPtr->hwnd) {
tsdPtr->hwnd = CreateWindowW(className, className,
| | | 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 |
* synchronous system messages. At some point, we may want to consider
* destroying the window if we leave the modal loop, but for now we'll
* leave it around.
*/
if (mode == TCL_SERVICE_ALL && !tsdPtr->hwnd) {
tsdPtr->hwnd = CreateWindowW(className, className,
WS_TILED, 0, 0, 0, 0, NULL, NULL, (HINSTANCE)TclWinGetTclInstance(),
NULL);
/*
* Send an initial message to the window to ensure that we wake up
* the notifier once we get into the modal loop. This will force
* the notifier to recompute the timeout value and schedule a timer
* if one is needed.
|
| ︙ | ︙ |
Changes to win/tclWinPipe.c.
| ︙ | ︙ | |||
606 607 608 609 610 611 612 |
NULL, createMode, flags, NULL);
Tcl_DStringFree(&ds);
if (handle == INVALID_HANDLE_VALUE) {
DWORD err;
err = GetLastError();
| | | 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 |
NULL, createMode, flags, NULL);
Tcl_DStringFree(&ds);
if (handle == INVALID_HANDLE_VALUE) {
DWORD err;
err = GetLastError();
if ((err & 0xFFFFL) == ERROR_OPEN_FAILED) {
err = (mode & O_CREAT) ? ERROR_FILE_EXISTS : ERROR_FILE_NOT_FOUND;
}
TclWinConvertError(err);
return NULL;
}
/*
|
| ︙ | ︙ | |||
1303 1304 1305 1306 1307 1308 1309 | /* * Ignore matches on directories or data files, return if identified a * known type. */ attr = GetFileAttributesW(nativeFullPath); | | | 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 |
/*
* Ignore matches on directories or data files, return if identified a
* known type.
*/
attr = GetFileAttributesW(nativeFullPath);
if ((attr == 0xFFFFFFFF) || (attr & FILE_ATTRIBUTE_DIRECTORY)) {
continue;
}
Tcl_DStringInit(&ds);
strcpy(fullName, Tcl_WCharToUtfDString(nativeFullPath, -1, &ds));
Tcl_DStringFree(&ds);
ext = strrchr(fullName, '.');
|
| ︙ | ︙ |
Changes to win/tclWinPort.h.
| ︙ | ︙ | |||
10 11 12 13 14 15 16 | * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #ifndef _TCLWINPORT #define _TCLWINPORT | | > | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 | * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #ifndef _TCLWINPORT #define _TCLWINPORT #if !defined(_WIN64) && !defined(__MINGW_USE_VC2005_COMPAT) /* See [Bug 3354324]: file mtime sets wrong time */ # define __MINGW_USE_VC2005_COMPAT #endif #if defined(_MSC_VER) && defined(_WIN64) && !defined(STATIC_BUILD) \ && !defined(MP_32BIT) && !defined(MP_64BIT) # define MP_64BIT #endif |
| ︙ | ︙ | |||
44 45 46 47 48 49 50 | typedef DWORD DWORD_PTR; typedef DWORD_PTR * PDWORD_PTR; #endif /* * Ask for the winsock function typedefs, also. */ | > | > | 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 | typedef DWORD DWORD_PTR; typedef DWORD_PTR * PDWORD_PTR; #endif /* * Ask for the winsock function typedefs, also. */ #ifndef INCL_WINSOCK_API_TYPEDEFS # define INCL_WINSOCK_API_TYPEDEFS 1 #endif #include <winsock2.h> #include <ws2tcpip.h> #ifdef HAVE_WSPIAPI_H # include <wspiapi.h> #endif /* |
| ︙ | ︙ | |||
309 310 311 312 313 314 315 | #endif #ifndef WIFSIGNALED # define WIFSIGNALED(stat) ((*((int *) &(stat))) & 0xC0000000) #endif #ifndef WTERMSIG | | | | 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 | #endif #ifndef WIFSIGNALED # define WIFSIGNALED(stat) ((*((int *) &(stat))) & 0xC0000000) #endif #ifndef WTERMSIG # define WTERMSIG(stat) ((*((int *) &(stat))) & 0x7F) #endif #ifndef WIFSTOPPED # define WIFSTOPPED(stat) 0 #endif #ifndef WSTOPSIG # define WSTOPSIG(stat) (((*((int *) &(stat))) >> 8) & 0xFF) #endif /* * Define constants for waitpid() system call if they aren't defined * by a system header file. */ |
| ︙ | ︙ | |||
481 482 483 484 485 486 487 488 489 490 491 492 493 494 | * MSVC 8.0 started to mark many standard C library functions depreciated * including the *printf family and others. Tell it to shut up. * (_MSC_VER is 1200 for VC6, 1300 or 1310 for vc7.net, 1400 for 8.0) */ #if defined(_MSC_VER) # pragma warning(disable:4146) # pragma warning(disable:4244) # if _MSC_VER >= 1400 # pragma warning(disable:4267) # pragma warning(disable:4996) # endif #endif /* | > > > | 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 | * MSVC 8.0 started to mark many standard C library functions depreciated * including the *printf family and others. Tell it to shut up. * (_MSC_VER is 1200 for VC6, 1300 or 1310 for vc7.net, 1400 for 8.0) */ #if defined(_MSC_VER) # pragma warning(disable:4146) # pragma warning(disable:4244) #if !defined(_WIN64) # pragma warning(disable:4305) #endif # if _MSC_VER >= 1400 # pragma warning(disable:4267) # pragma warning(disable:4996) # endif #endif /* |
| ︙ | ︙ |
Changes to win/tclWinSock.c.
| ︙ | ︙ | |||
364 365 366 367 368 369 370 |
Tcl_Encoding *encodingPtr)
{
WCHAR wbuf[256];
DWORD length = sizeof(wbuf)/sizeof(WCHAR);
Tcl_DString ds;
Tcl_DStringInit(&ds);
| | | 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 |
Tcl_Encoding *encodingPtr)
{
WCHAR wbuf[256];
DWORD length = sizeof(wbuf)/sizeof(WCHAR);
Tcl_DString ds;
Tcl_DStringInit(&ds);
if (GetComputerNameExW(ComputerNamePhysicalDnsFullyQualified, wbuf, &length) != 0) {
/*
* Convert string from native to UTF then change to lowercase.
*/
Tcl_UtfToLower(Tcl_WCharToUtfDString(wbuf, -1, &ds));
} else {
|
| ︙ | ︙ | |||
2481 2482 2483 2484 2485 2486 2487 | * the wrong message number for socket events if the message window is * a subclass of a static control. */ windowClass.style = 0; windowClass.cbClsExtra = 0; windowClass.cbWndExtra = 0; | | | 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 | * the wrong message number for socket events if the message window is * a subclass of a static control. */ windowClass.style = 0; windowClass.cbClsExtra = 0; windowClass.cbWndExtra = 0; windowClass.hInstance = (HINSTANCE)TclWinGetTclInstance(); windowClass.hbrBackground = NULL; windowClass.lpszMenuName = NULL; windowClass.lpszClassName = className; windowClass.lpfnWndProc = SocketProc; windowClass.hIcon = NULL; windowClass.hCursor = NULL; |
| ︙ | ︙ | |||
2612 2613 2614 2615 2616 2617 2618 |
/*
* Make sure the socket event handling window is cleaned-up for, at
* most, this thread.
*/
TclpFinalizeSockets();
| | | 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 |
/*
* Make sure the socket event handling window is cleaned-up for, at
* most, this thread.
*/
TclpFinalizeSockets();
UnregisterClassW(className, (HINSTANCE)TclWinGetTclInstance());
initialized = 0;
Tcl_MutexUnlock(&socketMutex);
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ |
Changes to win/tclWinTest.c.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 | * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #ifndef USE_TCL_STUBS # define USE_TCL_STUBS #endif #include "tclInt.h" | > > > | > | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 | * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #ifndef USE_TCL_STUBS # define USE_TCL_STUBS #endif #include "tclInt.h" #ifdef TCL_WITH_EXTERNAL_TOMMATH # include "tommath.h" #else # include "tclTomMath.h" #endif /* * For TestplatformChmod on Windows */ #ifdef _WIN32 #include <aclapi.h> #endif |
| ︙ | ︙ | |||
423 424 425 426 427 428 429 |
attr = GetFileAttributesA(nativePath);
/*
* nativePath not found
*/
| | | 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 |
attr = GetFileAttributesA(nativePath);
/*
* nativePath not found
*/
if (attr == 0xFFFFFFFF) {
res = -1;
goto done;
}
/*
* If nativePath is not a directory, there is no special handling.
*/
|
| ︙ | ︙ |
Changes to win/tclWinThrd.c.
| ︙ | ︙ | |||
18 19 20 21 22 23 24 | # define _MCW_EM 0x0008001F /* Error masks */ # define _MCW_RC 0x00000300 /* Rounding */ # define _MCW_PC 0x00030000 /* Precision */ _CRTIMP unsigned int __cdecl _controlfp (unsigned int unNew, unsigned int unMask); #endif /* | | | | | 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 | # define _MCW_EM 0x0008001F /* Error masks */ # define _MCW_RC 0x00000300 /* Rounding */ # define _MCW_PC 0x00030000 /* Precision */ _CRTIMP unsigned int __cdecl _controlfp (unsigned int unNew, unsigned int unMask); #endif /* * This is the global lock used to serialize access to other serialization * data structures. */ static CRITICAL_SECTION globalLock; static int initialized = 0; /* * This is the global lock used to serialize initialization and finalization * of Tcl as a whole. */ static CRITICAL_SECTION initLock; /* * allocLock is used by Tcl's version of malloc for synchronization. For |
| ︙ | ︙ | |||
358 359 360 361 362 363 364 | * interpreter has been created, it is safe to create more threads * that create interpreters in parallel. */ initialized = 1; InitializeCriticalSection(&joinLock); InitializeCriticalSection(&initLock); | | | 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 |
* interpreter has been created, it is safe to create more threads
* that create interpreters in parallel.
*/
initialized = 1;
InitializeCriticalSection(&joinLock);
InitializeCriticalSection(&initLock);
InitializeCriticalSection(&globalLock);
}
EnterCriticalSection(&initLock);
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
389 390 391 392 393 394 395 |
{
LeaveCriticalSection(&initLock);
}
/*
*----------------------------------------------------------------------
*
| | | | | | | | | | | 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 |
{
LeaveCriticalSection(&initLock);
}
/*
*----------------------------------------------------------------------
*
* TclpGlobalLock
*
* This procedure is used to grab a lock that serializes creation of
* mutexes, condition variables, and thread local storage keys.
*
* This lock must be different than the initLock because the initLock is
* held during creation of synchronization objects.
*
* Results:
* None.
*
* Side effects:
* Acquire the global mutex.
*
*----------------------------------------------------------------------
*/
void
TclpGlobalLock(void)
{
if (!initialized) {
/*
* There is a fundamental race here that is solved by creating the
* first Tcl interpreter in a single threaded environment. Once the
* interpreter has been created, it is safe to create more threads
* that create interpreters in parallel.
*/
initialized = 1;
InitializeCriticalSection(&joinLock);
InitializeCriticalSection(&initLock);
InitializeCriticalSection(&globalLock);
}
EnterCriticalSection(&globalLock);
}
/*
*----------------------------------------------------------------------
*
* TclpGlobalUnlock
*
* This procedure is used to release a lock that serializes creation and
* deletion of synchronization objects.
*
* Results:
* None.
*
* Side effects:
* Release the global mutex.
*
*----------------------------------------------------------------------
*/
void
TclpGlobalUnlock(void)
{
LeaveCriticalSection(&globalLock);
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetAllocMutex
*
|
| ︙ | ︙ | |||
502 503 504 505 506 507 508 |
*
*----------------------------------------------------------------------
*/
void
TclFinalizeLock(void)
{
| | | | 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 |
*
*----------------------------------------------------------------------
*/
void
TclFinalizeLock(void)
{
TclpGlobalLock();
DeleteCriticalSection(&joinLock);
/*
* Destroy the critical section that we are holding!
*/
DeleteCriticalSection(&globalLock);
initialized = 0;
#if TCL_THREADS
if (allocOnce) {
DeleteCriticalSection(&allocLock.crit);
allocOnce = 0;
}
|
| ︙ | ︙ | |||
557 558 559 560 561 562 563 |
void
Tcl_MutexLock(
Tcl_Mutex *mutexPtr) /* The lock */
{
CRITICAL_SECTION *csPtr;
if (*mutexPtr == NULL) {
| | | | | 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 |
void
Tcl_MutexLock(
Tcl_Mutex *mutexPtr) /* The lock */
{
CRITICAL_SECTION *csPtr;
if (*mutexPtr == NULL) {
TclpGlobalLock();
/*
* Double inside global lock check to avoid a race.
*/
if (*mutexPtr == NULL) {
csPtr = (CRITICAL_SECTION *)Tcl_Alloc(sizeof(CRITICAL_SECTION));
InitializeCriticalSection(csPtr);
*mutexPtr = (Tcl_Mutex)csPtr;
TclRememberMutex(mutexPtr);
}
TclpGlobalUnlock();
}
csPtr = *((CRITICAL_SECTION **)mutexPtr);
EnterCriticalSection(csPtr);
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
671 672 673 674 675 676 677 |
/*
* Self initialize the two parts of the condition. The per-condition and
* per-thread parts need to be handled independently.
*/
if (tsdPtr->flags == WIN_THREAD_UNINIT) {
| | | | | | | | 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 |
/*
* Self initialize the two parts of the condition. The per-condition and
* per-thread parts need to be handled independently.
*/
if (tsdPtr->flags == WIN_THREAD_UNINIT) {
TclpGlobalLock();
/*
* Create the per-thread event and queue pointers.
*/
if (tsdPtr->flags == WIN_THREAD_UNINIT) {
tsdPtr->condEvent = CreateEventW(NULL, TRUE /* manual reset */,
FALSE /* non signaled */, NULL);
tsdPtr->nextPtr = NULL;
tsdPtr->prevPtr = NULL;
tsdPtr->flags = WIN_THREAD_RUNNING;
doExit = 1;
}
TclpGlobalUnlock();
if (doExit) {
/*
* Create a per-thread exit handler to clean up the condEvent. We
* must be careful to do this outside the Global Lock because
* Tcl_CreateThreadExitHandler uses its own ThreadSpecificData,
* and initializing that may drop back into the Global Lock.
*/
Tcl_CreateThreadExitHandler(FinalizeConditionEvent, tsdPtr);
}
}
if (*condPtr == NULL) {
TclpGlobalLock();
/*
* Initialize the per-condition queue pointers and Mutex.
*/
if (*condPtr == NULL) {
winCondPtr = (WinCondition *)Tcl_Alloc(sizeof(WinCondition));
InitializeCriticalSection(&winCondPtr->condLock);
winCondPtr->firstPtr = NULL;
winCondPtr->lastPtr = NULL;
*condPtr = (Tcl_Condition) winCondPtr;
TclRememberCondition(condPtr);
}
TclpGlobalUnlock();
}
csPtr = *((CRITICAL_SECTION **)mutexPtr);
winCondPtr = *((WinCondition **)condPtr);
if (timePtr == NULL) {
wtime = INFINITE;
} else {
wtime = timePtr->sec * 1000 + timePtr->usec / 1000;
|
| ︙ | ︙ | |||
892 893 894 895 896 897 898 | *---------------------------------------------------------------------- * * TclpFinalizeCondition -- * * This procedure is invoked to clean up a condition variable. This is * only safe to call at the end of time. * | | | 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 | *---------------------------------------------------------------------- * * TclpFinalizeCondition -- * * This procedure is invoked to clean up a condition variable. This is * only safe to call at the end of time. * * This assumes the Global Lock is held. * * Results: * None. * * Side effects: * The condition variable is deallocated. * |
| ︙ | ︙ | |||
1061 1062 1063 1064 1065 1066 1067 |
Tcl_Panic("unable to delete key");
}
TclpSysFree(keyPtr);
}
void
| | | | | 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 |
Tcl_Panic("unable to delete key");
}
TclpSysFree(keyPtr);
}
void
TclpThreadSetGlobalTSD(
void *tsdKeyPtr,
void *ptr)
{
DWORD *key = (DWORD *)tsdKeyPtr;
if (!TlsSetValue(*key, ptr)) {
Tcl_Panic("unable to set global TSD value");
}
}
void *
TclpThreadGetGlobalTSD(
void *tsdKeyPtr)
{
DWORD *key = (DWORD *)tsdKeyPtr;
return TlsGetValue(*key);
}
|
| ︙ | ︙ |
Changes to win/tclWinTime.c.
| ︙ | ︙ | |||
491 492 493 494 495 496 497 | */ SYSTEM_INFO systemInfo; int regs[4]; GetSystemInfo(&systemInfo); if (TclWinCPUID(0, regs) == TCL_OK | | | | | 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 |
*/
SYSTEM_INFO systemInfo;
int regs[4];
GetSystemInfo(&systemInfo);
if (TclWinCPUID(0, regs) == TCL_OK
&& regs[1] == 0x756E6547 /* "Genu" */
&& regs[3] == 0x49656E69 /* "ineI" */
&& regs[2] == 0x6C65746E /* "ntel" */
&& TclWinCPUID(1, regs) == TCL_OK
&& ((regs[0]&0x00000F00) == 0x00000F00 /* Pentium 4 */
|| ((regs[0] & 0x00F00000) /* Extended family */
&& (regs[3] & 0x10000000))) /* Hyperthread */
&& (((regs[1]&0x00FF0000) >> 16)/* CPU count */
== (int)systemInfo.dwNumberOfProcessors)) {
timeInfo.perfCounterAvailable = TRUE;
|
| ︙ | ︙ |