Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Overview
| Comment: | Merge trunk. Finish implementation. |
|---|---|
| Timelines: | family | ancestors | descendants | both | rfe-854941 | tip-596 |
| Files: | files | file ages | folders |
| SHA3-256: |
bcae28fe99dd2ded6aa9f8742d089a2b |
| User & Date: | jan.nijtmans 2019-09-30 14:43:32.122 |
Context
|
2019-10-01
| ||
| 14:57 | Fix handling of BUILD_STATIC check-in: 0acefa9964 user: jan.nijtmans tags: rfe-854941, tip-596 | |
|
2019-09-30
| ||
| 14:43 | Merge trunk. Finish implementation. check-in: bcae28fe99 user: jan.nijtmans tags: rfe-854941, tip-596 | |
|
2019-09-29
| ||
| 15:51 | Merge 8.7 check-in: 544afecbbf user: jan.nijtmans tags: trunk | |
|
2019-08-20
| ||
| 15:02 | Fix MSVC build check-in: 9ab95cbae2 user: jan.nijtmans tags: rfe-854941, tip-596 | |
Changes
Changes to .fossil-settings/binary-glob.
|
| | | < < < < | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 | *.a *.dll *.exe *.gif *.gz *.jpg *.lib *.pdf *.png *.xlsx *.zip |
Changes to .gitattributes.
1 | # Set the default behavior, in case people don't have core.autocrlf set. | > | | | | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 | # Set the default behavior, in case people don't have core.autocrlf set. * eol=lf * text=auto # Explicitly declare text files you want to always be normalized and converted # to native line endings on checkout. *.3 text *.c text *.css text *.enc text *.h text *.htm text *.html text *.java text *.js text *.json text *.n text *.svg text *.ts text *.tcl text *.test text # Declare files that will always have CRLF line endings on checkout. *.bat eol=crlf *.sln eol=crlf *.vc eol=crlf # Denote all files that are truly binary and should not be modified. *.a binary *.dll binary *.exe binary *.gif binary *.gz binary *.jpg binary *.lib binary *.pdf binary *.png binary *.xlsx binary *.zip binary |
Changes to .travis.yml.
1 2 3 4 5 6 7 8 9 10 11 12 |
sudo: false
language: c
matrix:
include:
# Testing on Linux with various compilers
- name: "Linux/GCC/Shared"
os: linux
dist: xenial
compiler: gcc
env:
- BUILD_DIR=unix
| < < < < < < < > > > > > | > | | < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 |
sudo: false
language: c
matrix:
include:
# Testing on Linux with various compilers
- name: "Linux/GCC/Shared"
os: linux
dist: xenial
compiler: gcc
env:
- BUILD_DIR=unix
- name: "Linux/GCC/Shared: UTF_MAX=6"
os: linux
dist: xenial
compiler: gcc
env:
- BUILD_DIR=unix
- CFGOPT=CFLAGS=-DTCL_UTF_MAX=6
- name: "Linux/GCC/Shared: UTF_MAX=3"
os: linux
dist: xenial
compiler: gcc
env:
- BUILD_DIR=unix
- CFGOPT=CFLAGS=-DTCL_UTF_MAX=3
- name: "Linux/GCC/Static"
os: linux
dist: xenial
compiler: gcc
env:
- CFGOPT="--disable-shared"
- BUILD_DIR=unix
- name: "Linux/GCC/Debug"
os: linux
dist: xenial
compiler: gcc
env:
- BUILD_DIR=unix
- CFGOPT="--enable-symbols"
# Older versions of GCC...
- name: "Linux/GCC 7/Shared"
os: linux
dist: xenial
compiler: gcc-7
addons:
apt:
|
| ︙ | ︙ | |||
93 94 95 96 97 98 99 100 101 102 103 104 |
# Clang
- name: "Linux/Clang/Shared"
os: linux
dist: xenial
compiler: clang
env:
- BUILD_DIR=unix
- name: "Linux/Clang/Static"
os: linux
dist: xenial
compiler: clang
env:
| > > > > > > > > > > > > > > | < | | < < | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > < < < < < < < < < < < < < > > > > > > > > > < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 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 |
# Clang
- name: "Linux/Clang/Shared"
os: linux
dist: xenial
compiler: clang
env:
- BUILD_DIR=unix
- name: "Linux/Clang/Shared: UTF_MAX=6"
os: linux
dist: xenial
compiler: clang
env:
- BUILD_DIR=unix
- CFGOPT=CFLAGS=-DTCL_UTF_MAX=6
- name: "Linux/Clang/Shared: UTF_MAX=3"
os: linux
dist: xenial
compiler: clang
env:
- BUILD_DIR=unix
- CFGOPT=CFLAGS=-DTCL_UTF_MAX=3
- name: "Linux/Clang/Static"
os: linux
dist: xenial
compiler: clang
env:
- CFGOPT="--disable-shared"
- BUILD_DIR=unix
- name: "Linux/Clang/Debug"
os: linux
dist: xenial
compiler: clang
env:
- BUILD_DIR=unix
- CFGOPT="--enable-symbols"
# Testing on Mac, various styles
- name: "macOS/Xcode 11/Shared/Unix-like"
os: osx
osx_image: xcode11
env:
- BUILD_DIR=unix
- name: "macOS/Xcode 11/Shared"
os: osx
osx_image: xcode11
env:
- BUILD_DIR=macosx
install: []
script: &mactest
- make all
# The styles=develop avoids some weird problems on OSX
- make test styles=develop
- name: "macOS/Xcode 10/Shared"
os: osx
osx_image: xcode10.3
env:
- BUILD_DIR=macosx
install: []
script: *mactest
- name: "macOS/Xcode 9/Shared"
os: osx
osx_image: xcode9
env:
- BUILD_DIR=macosx
install: []
script: *mactest
- name: "macOS/Xcode 8/Shared"
os: osx
osx_image: xcode8
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: xenial
compiler: x86_64-w64-mingw32-gcc
addons: &mingw64
apt:
packages:
- gcc-mingw-w64-base
- binutils-mingw-w64-x86-64
- gcc-mingw-w64-x86-64
- gcc-mingw-w64
- wine
env:
- BUILD_DIR=win
- CFGOPT="--host=x86_64-w64-mingw32 --enable-64bit"
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`"
- name: "Linux-cross-Windows/GCC/Shared/no test: UTF_MAX=6"
os: linux
dist: xenial
compiler: x86_64-w64-mingw32-gcc
addons: *mingw64
env:
- BUILD_DIR=win
- CFGOPT="--host=x86_64-w64-mingw32 --enable-64bit CFLAGS=-DTCL_UTF_MAX=6"
script: *crosstest
- name: "Linux-cross-Windows/GCC/Shared/no test: UTF_MAX=3"
os: linux
dist: xenial
compiler: x86_64-w64-mingw32-gcc
addons: *mingw64
env:
- BUILD_DIR=win
- CFGOPT="--host=x86_64-w64-mingw32 --enable-64bit CFLAGS=-DTCL_UTF_MAX=3"
script: *crosstest
- name: "Linux-cross-Windows/GCC/Static/no test"
os: linux
dist: xenial
compiler: x86_64-w64-mingw32-gcc
addons: *mingw64
env:
- BUILD_DIR=win
- CFGOPT="--host=x86_64-w64-mingw32 --enable-64bit --disable-shared"
script: *crosstest
- name: "Linux-cross-Windows/GCC/Debug/no test"
os: linux
dist: xenial
compiler: x86_64-w64-mingw32-gcc
addons: *mingw64
env:
- BUILD_DIR=win
- CFGOPT="--host=x86_64-w64-mingw32 --enable-64bit --enable-symbols"
script: *crosstest
# 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: xenial
compiler: i686-w64-mingw32-gcc
addons: &mingw32
apt:
packages:
- gcc-mingw-w64-base
- binutils-mingw-w64-i686
- gcc-mingw-w64-i686
- gcc-mingw-w64
- gcc-multilib
- wine
env:
- BUILD_DIR=win
- CFGOPT=--host=i686-w64-mingw32
script: *crosstest
- name: "Linux-cross-Windows-32/GCC/Shared/no test: UTF_MAX=6"
os: linux
dist: xenial
compiler: i686-w64-mingw32-gcc
addons: *mingw32
env:
- BUILD_DIR=win
- CFGOPT="--host=i686-w64-mingw32 CFLAGS=-DTCL_UTF_MAX=6"
script: *crosstest
- name: "Linux-cross-Windows-32/GCC/Shared/no test: UTF_MAX=3"
os: linux
dist: xenial
compiler: i686-w64-mingw32-gcc
addons: *mingw32
env:
- BUILD_DIR=win
- CFGOPT="--host=i686-w64-mingw32 CFLAGS=-DTCL_UTF_MAX=3"
script: *crosstest
- name: "Linux-cross-Windows-32/GCC/Static/no test"
os: linux
dist: xenial
compiler: i686-w64-mingw32-gcc
addons: *mingw32
env:
- BUILD_DIR=win
- CFGOPT="--host=i686-w64-mingw32 --disable-shared"
script: *crosstest
- name: "Linux-cross-Windows-32/GCC/Debug/no test"
os: linux
dist: xenial
compiler: i686-w64-mingw32-gcc
addons: *mingw32
env:
- BUILD_DIR=win
- CFGOPT="--host=i686-w64-mingw32 --enable-symbols"
script: *crosstest
# Test on Windows with MSVC native
- name: "Windows/MSVC/Shared"
os: windows
compiler: cl
env: &vcenv
- BUILD_DIR=win
- VCDIR="/C/Program Files (x86)/Microsoft Visual Studio/2017/BuildTools/VC/Auxiliary/Build"
|
| ︙ | ︙ | |||
301 302 303 304 305 306 307 308 309 310 |
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'
before_install:
- cd ${BUILD_DIR}
install:
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | 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 |
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: []
script:
- cmd.exe /C 'vcvarsall.bat x86 && nmake -f makefile.vc all tcltest'
- cmd.exe /C 'vcvarsall.bat x86 && nmake -f makefile.vc test'
- name: "Windows/MSVC-x86/Shared: UTF_MAX=6"
os: windows
compiler: cl
env: *vcenv
before_install: *vcpreinst
install: []
script:
- cmd.exe /C 'vcvarsall.bat x86 && nmake OPTS=utfmax -f makefile.vc all tcltest'
- cmd.exe /C 'vcvarsall.bat x86 && nmake OPTS=utfmax -f makefile.vc test'
- name: "Windows/MSVC-x86/Static"
os: windows
compiler: cl
env: *vcenv
before_install: *vcpreinst
install: []
script:
- cmd.exe /C 'vcvarsall.bat x86 && nmake OPTS=static -f makefile.vc all tcltest'
- cmd.exe /C 'vcvarsall.bat x86 && nmake OPTS=static -f makefile.vc test'
- name: "Windows/MSVC-x86/Debug"
os: windows
compiler: cl
env: *vcenv
before_install: *vcpreinst
install: []
script:
- cmd.exe /C 'vcvarsall.bat x86 && nmake OPTS=symbols -f makefile.vc all tcltest'
- cmd.exe /C 'vcvarsall.bat x86 && nmake OPTS=symbols -f makefile.vc test'
# Test on Windows with GCC native
- name: "Windows/GCC/Shared"
os: windows
compiler: gcc
env:
- BUILD_DIR=win
- CFGOPT="--enable-64bit"
before_install: &makepreinst
- choco install make
- cd ${BUILD_DIR}
- name: "Windows/GCC/Shared: UTF_MAX=6"
os: windows
compiler: gcc
env:
- BUILD_DIR=win
- CFGOPT="--enable-64bit CFLAGS=-DTCL_UTF_MAX=6"
before_install: *makepreinst
- name: "Windows/GCC/Shared: UTF_MAX=3"
os: windows
compiler: gcc
env:
- BUILD_DIR=win
- CFGOPT="--enable-64bit CFLAGS=-DTCL_UTF_MAX=3"
before_install: *makepreinst
- name: "Windows/GCC/Static"
os: windows
compiler: gcc
env:
- BUILD_DIR=win
- CFGOPT="--enable-64bit --disable-shared"
before_install: *makepreinst
- name: "Windows/GCC/Debug"
os: windows
compiler: gcc
env:
- BUILD_DIR=win
- CFGOPT="--enable-64bit --enable-symbols"
before_install: *makepreinst
# Test on Windows with GCC native (32-bit)
- name: "Windows/GCC-x86/Shared"
os: windows
compiler: gcc
env:
- BUILD_DIR=win
before_install: *makepreinst
- name: "Windows/GCC-x86/Shared: UTF_MAX=6"
os: windows
compiler: gcc
env:
- BUILD_DIR=win
- CFGOPT="CFLAGS=-DTCL_UTF_MAX=6"
before_install: *makepreinst
- name: "Windows/GCC-x86/Shared: UTF_MAX=3"
os: windows
compiler: gcc
env:
- BUILD_DIR=win
- CFGOPT="CFLAGS=-DTCL_UTF_MAX=3"
before_install: *makepreinst
- name: "Windows/GCC-x86/Static"
os: windows
compiler: gcc
env:
- BUILD_DIR=win
- CFGOPT="--disable-shared"
before_install: *makepreinst
- name: "Windows/GCC-x86/Debug"
os: windows
compiler: gcc
env:
- BUILD_DIR=win
- CFGOPT="--enable-symbols"
before_install: *makepreinst
before_install:
- cd ${BUILD_DIR}
install:
- ./configure ${CFGOPT} --prefix=$HOME || (cat config.log && exit 1)
before_script:
- export ERROR_ON_FAILURES=1
script:
- make all tcltest
- make test
|
Changes to compat/zlib/contrib/minizip/crypt.h.
| ︙ | ︙ | |||
53 54 55 56 57 58 59 |
*/
static int update_keys(unsigned long* pkeys,const z_crc_t* pcrc_32_tab,int c)
{
(*(pkeys+0)) = CRC32((*(pkeys+0)), c);
(*(pkeys+1)) += (*(pkeys+0)) & 0xff;
(*(pkeys+1)) = (*(pkeys+1)) * 134775813L + 1;
{
| | | 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 |
*/
static int update_keys(unsigned long* pkeys,const z_crc_t* pcrc_32_tab,int c)
{
(*(pkeys+0)) = CRC32((*(pkeys+0)), c);
(*(pkeys+1)) += (*(pkeys+0)) & 0xff;
(*(pkeys+1)) = (*(pkeys+1)) * 134775813L + 1;
{
int keyshift = (int)((*(pkeys+1)) >> 24);
(*(pkeys+2)) = CRC32((*(pkeys+2)), keyshift);
}
return c;
}
/***********************************************************************
|
| ︙ | ︙ |
Changes to doc/Encoding.3.
1 2 3 4 5 6 7 8 9 10 | '\" '\" Copyright (c) 1997-1998 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH Tcl_GetEncoding 3 "8.1" Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | '\" '\" Copyright (c) 1997-1998 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH Tcl_GetEncoding 3 "8.1" Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_GetEncoding, Tcl_FreeEncoding, Tcl_GetEncodingFromObj, Tcl_ExternalToUtfDString, Tcl_ExternalToUtf, Tcl_UtfToExternalDString, Tcl_UtfToExternal, Tcl_GetEncodingName, Tcl_SetSystemEncoding, Tcl_GetEncodingNameFromEnvironment, Tcl_GetEncodingNames, Tcl_CreateEncoding, Tcl_GetEncodingSearchPath, Tcl_SetEncodingSearchPath \- procedures for creating and using encodings .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp Tcl_Encoding \fBTcl_GetEncoding\fR(\fIinterp, name\fR) .sp |
| ︙ | ︙ | |||
32 33 34 35 36 37 38 |
\fBTcl_ExternalToUtf\fR(\fIinterp, encoding, src, srcLen, flags, statePtr,
dst, dstLen, srcReadPtr, dstWrotePtr, dstCharsPtr\fR)
.sp
int
\fBTcl_UtfToExternal\fR(\fIinterp, encoding, src, srcLen, flags, statePtr,
dst, dstLen, srcReadPtr, dstWrotePtr, dstCharsPtr\fR)
.sp
| < < < < < < | 32 33 34 35 36 37 38 39 40 41 42 43 44 45 |
\fBTcl_ExternalToUtf\fR(\fIinterp, encoding, src, srcLen, flags, statePtr,
dst, dstLen, srcReadPtr, dstWrotePtr, dstCharsPtr\fR)
.sp
int
\fBTcl_UtfToExternal\fR(\fIinterp, encoding, src, srcLen, flags, statePtr,
dst, dstLen, srcReadPtr, dstWrotePtr, dstCharsPtr\fR)
.sp
const char *
\fBTcl_GetEncodingName\fR(\fIencoding\fR)
.sp
int
\fBTcl_SetSystemEncoding\fR(\fIinterp, name\fR)
.sp
const char *
|
| ︙ | ︙ | |||
75 76 77 78 79 80 81 | .AP Tcl_Obj *objPtr in Name of encoding to get token for. .AP Tcl_Encoding *encodingPtr out Points to storage where encoding token is to be written. .AP "const char" *src in For the \fBTcl_ExternalToUtf\fR functions, an array of bytes in the specified encoding that are to be converted to UTF-8. For the | | | 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 | .AP Tcl_Obj *objPtr in Name of encoding to get token for. .AP Tcl_Encoding *encodingPtr out Points to storage where encoding token is to be written. .AP "const char" *src in For the \fBTcl_ExternalToUtf\fR functions, an array of bytes in the specified encoding that are to be converted to UTF-8. For the \fBTcl_UtfToExternal\fR function, an array of UTF-8 characters to be converted to the specified encoding. .AP "const TCHAR" *tsrc in An array of Windows TCHAR characters to convert to UTF-8. .AP size_t srcLen in Length of \fIsrc\fR or \fItsrc\fR in bytes. If the length is negative, the encoding-specific length of the string is used. .AP Tcl_DString *dstPtr out |
| ︙ | ︙ | |||
245 246 247 248 249 250 251 | the source buffer and up to \fIdstLen\fR converted bytes are stored in \fIdst\fR. In all cases, \fI*srcReadPtr\fR is filled with the number of bytes that were successfully converted from \fIsrc\fR and \fI*dstWrotePtr\fR is filled with the corresponding number of bytes that were stored in \fIdst\fR. The return values are the same as the return values for \fBTcl_ExternalToUtf\fR. .PP | < < < < < < | 239 240 241 242 243 244 245 246 247 248 249 250 251 252 | the source buffer and up to \fIdstLen\fR converted bytes are stored in \fIdst\fR. In all cases, \fI*srcReadPtr\fR is filled with the number of bytes that were successfully converted from \fIsrc\fR and \fI*dstWrotePtr\fR is filled with the corresponding number of bytes that were stored in \fIdst\fR. The return values are the same as the return values for \fBTcl_ExternalToUtf\fR. .PP \fBTcl_GetEncodingName\fR is roughly the inverse of \fBTcl_GetEncoding\fR. Given an \fIencoding\fR, the return value is the \fIname\fR argument that was used to create the encoding. The string returned by \fBTcl_GetEncodingName\fR is only guaranteed to persist until the \fIencoding\fR is deleted. The caller must not modify this string. .PP \fBTcl_SetSystemEncoding\fR sets the default encoding that should be used |
| ︙ | ︙ |
Added doc/InitSubSyst.3.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 | '\" '\" Copyright (c) 2018 Tcl Core Team '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .so man.macros .TH Tcl_InitSubsystems 3 8.7 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_InitSubsystems \- initialize the Tcl library. .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp const char * \fBTcl_InitSubsystems\fR(\fIvoid\fR) .SH DESCRIPTION .PP The \fBTcl_InitSubsystems\fR procedure initializes the Tcl library. This procedure is typically invoked as the very first thing in the application's main program. .PP \fBTcl_InitSubsystems\fR is very similar in use to \fBTcl_FindExecutable\fR. It can be used when Tcl is used as utility library, no other encodings than utf8, iso8859-1 or unicode are used, and no interest exists in the value of \fBinfo nameofexecutable\fR. The system encoding will not be extracted from the environment, but falls back to iso8859-1. .SH KEYWORDS binary, executable file |
Changes to doc/StringObj.3.
| ︙ | ︙ | |||
84 85 86 87 88 89 90 | .SH ARGUMENTS .AS "const Tcl_UniChar" *appendObjPtr in/out .AP "const char" *bytes in Points to the first byte of an array of UTF-8-encoded bytes used to set or append to a string value. This byte array may contain embedded null characters unless \fInumChars\fR is TCL_AUTO_LENGTH. (Applications needing null bytes | | | 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 | .SH ARGUMENTS .AS "const Tcl_UniChar" *appendObjPtr in/out .AP "const char" *bytes in Points to the first byte of an array of UTF-8-encoded bytes used to set or append to a string value. This byte array may contain embedded null characters unless \fInumChars\fR is TCL_AUTO_LENGTH. (Applications needing null bytes should represent them as the two-byte sequence \fI\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_AUTO_LENGTH, all bytes up to the first null are used. .AP "const Tcl_UniChar" *unicode in |
| ︙ | ︙ |
Changes to doc/Utf.3.
1 2 3 4 5 6 7 8 9 10 | '\" '\" Copyright (c) 1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH Utf 3 "8.1" Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME | | > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 | '\" '\" Copyright (c) 1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH Utf 3 "8.1" Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_UniChar, Tcl_UniCharToUtf, Tcl_UtfToUniChar, Tcl_UtfToChar16, Tcl_UtfToWChar, Tcl_UniCharToUtfDString, Tcl_UtfToUniCharDString, Tcl_WCharToUtfDString, Tcl_UtfToWCharDString, Tcl_Char16ToUtfDString, Tcl_UtfToChar16DString, Tcl_UniCharLen, Tcl_UniCharNcmp, Tcl_UniCharNcasecmp, Tcl_UniCharCaseMatch, Tcl_UtfNcmp, Tcl_UtfNcasecmp, Tcl_UtfCharComplete, Tcl_NumUtfChars, Tcl_UtfFindFirst, Tcl_UtfFindLast, Tcl_UtfNext, Tcl_UtfPrev, Tcl_UniCharAtIndex, Tcl_UtfAtIndex, Tcl_UtfBackslash \- routines for manipulating UTF-8 strings .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp typedef ... \fBTcl_UniChar\fR; .sp int \fBTcl_UniCharToUtf\fR(\fIch, buf\fR) .sp int \fBTcl_UtfToUniChar\fR(\fIsrc, chPtr\fR) .sp int \fBTcl_UtfToChar16\fR(\fIsrc, uPtr\fR) .sp int \fBTcl_UtfToWChar\fR(\fIsrc, wPtr\fR) .sp char * \fBTcl_UniCharToUtfDString\fR(\fIuniStr, uniLength, dsPtr\fR) .sp char * \fBTcl_Char16ToUtfDString\fR(\fIuStr, uniLength, dsPtr\fR) .sp char * \fBTcl_WCharToUtfDString\fR(\fIwStr, uniLength, dsPtr\fR) .sp Tcl_UniChar * \fBTcl_UtfToUniCharDString\fR(\fIsrc, length, dsPtr\fR) .sp unsigned short * \fBTcl_UtfToChar16DString\fR(\fIsrc, length, dsPtr\fR) .sp wchar_t * \fBTcl_UtfToWCharDString\fR(\fIsrc, length, dsPtr\fR) .sp int \fBTcl_UniCharLen\fR(\fIuniStr\fR) .sp int \fBTcl_UniCharNcmp\fR(\fIucs, uct, uniLength\fR) .sp int |
| ︙ | ︙ | |||
76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 | .AP char *buf out Buffer in which the UTF-8 representation of the Tcl_UniChar is stored. At most 4 bytes are stored in the buffer. .AP int ch in The Unicode character to be converted or examined. .AP Tcl_UniChar *chPtr out Filled with the Tcl_UniChar represented by the head of the UTF-8 string. .AP "const char" *src in Pointer to a UTF-8 string. .AP "const char" *cs in Pointer to a UTF-8 string. .AP "const char" *ct in Pointer to a UTF-8 string. .AP "const Tcl_UniChar" *uniStr in A null-terminated Unicode string. .AP "const Tcl_UniChar" *ucs in A null-terminated Unicode string. .AP "const Tcl_UniChar" *uct in A null-terminated Unicode string. .AP "const Tcl_UniChar" *uniPattern in A null-terminated Unicode string. .AP size_t length in The length of the UTF-8 string in bytes (not UTF-8 characters). If | > > > > > > > > | | 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 | .AP char *buf out Buffer in which the UTF-8 representation of the Tcl_UniChar is stored. At most 4 bytes are stored in the buffer. .AP int ch in The Unicode character to be converted or examined. .AP Tcl_UniChar *chPtr out Filled with the Tcl_UniChar represented by the head of the UTF-8 string. .AP unsigned short *uPtr out Filled with the utf-16 represented by the head of the UTF-8 string. .AP wchar_t *wPtr out Filled with the wchar_t represented by the head of the UTF-8 string. .AP "const char" *src in Pointer to a UTF-8 string. .AP "const char" *cs in Pointer to a UTF-8 string. .AP "const char" *ct in Pointer to a UTF-8 string. .AP "const Tcl_UniChar" *uniStr in A null-terminated Unicode string. .AP "const Tcl_UniChar" *ucs in A null-terminated Unicode string. .AP "const Tcl_UniChar" *uct in A null-terminated Unicode string. .AP "const Tcl_UniChar" *uniPattern in A null-terminated Unicode string. .AP "const unsigned short" *uStr in A null-terminated UTF-16 string. .AP "const wchar_t" *wStr in A null-terminated wchar_t string. .AP size_t length in The length of the UTF-8 string in bytes (not UTF-8 characters). If negative, all bytes up to the first null byte are used. .AP size_t uniLength in The length of the Unicode string in characters. .AP "Tcl_DString" *dsPtr in/out A pointer to a previously initialized \fBTcl_DString\fR. .AP "const char" *start in Pointer to the beginning of a UTF-8 string. .AP size_t index in |
| ︙ | ︙ | |||
114 115 116 117 118 119 120 | .AP int nocase in Specifies whether the match should be done case-sensitive (0) or case-insensitive (1). .BE .SH DESCRIPTION .PP | | < | | | | 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 | .AP int nocase in Specifies whether the match should be done case-sensitive (0) or case-insensitive (1). .BE .SH DESCRIPTION .PP These routines convert between UTF-8 strings and Unicode/Utf-16 characters. A UTF-8 character is a Unicode character represented as a varying-length sequence of up to \fBTCL_UTF_MAX\fR bytes. A multibyte UTF-8 sequence consists of a lead byte followed by some number of trail bytes. .PP \fBTCL_UTF_MAX\fR is the maximum number of bytes that it takes to represent one Unicode character in the UTF-8 representation. .PP \fBTcl_UniCharToUtf\fR stores the character \fIch\fR as a UTF-8 string in starting at \fIbuf\fR. The return value is the number of bytes stored in \fIbuf\fR. If ch is a high surrogate (range U+D800 - U+DBFF), then |
| ︙ | ︙ | |||
146 147 148 149 150 151 152 | and returns 1. If the input is otherwise not in proper UTF-8 format, \fBTcl_UtfToUniChar\fR will store the first byte of \fIsrc\fR in \fI*chPtr\fR as a Tcl_UniChar between 0x00A0 and 0x00FF and return 1. .PP \fBTcl_UniCharToUtfDString\fR converts the given Unicode string to UTF-8, storing the result in a previously initialized \fBTcl_DString\fR. | < | 171 172 173 174 175 176 177 178 179 180 181 182 183 184 | and returns 1. If the input is otherwise not in proper UTF-8 format, \fBTcl_UtfToUniChar\fR will store the first byte of \fIsrc\fR in \fI*chPtr\fR as a Tcl_UniChar between 0x00A0 and 0x00FF and return 1. .PP \fBTcl_UniCharToUtfDString\fR converts the given Unicode string to UTF-8, storing the result in a previously initialized \fBTcl_DString\fR. The return value is a pointer to the UTF-8 representation of the Unicode string. Storage for the return value is appended to the end of the \fBTcl_DString\fR. .PP \fBTcl_UtfToUniCharDString\fR converts the given UTF-8 string to Unicode, storing the result in the previously initialized \fBTcl_DString\fR. In the argument \fIlength\fR, you may either specify the length of |
| ︙ | ︙ |
Changes to doc/string.n.
| ︙ | ︙ | |||
358 359 360 361 362 363 364 | specified using the forms described in \fBSTRING INDICES\fR. .TP \fBstring trim \fIstring\fR ?\fIchars\fR? . Returns a value equal to \fIstring\fR except that any leading or trailing characters present in the string given by \fIchars\fR are removed. If \fIchars\fR is not specified then white space is removed (any character | | | | | 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 | specified using the forms described in \fBSTRING INDICES\fR. .TP \fBstring trim \fIstring\fR ?\fIchars\fR? . Returns a value equal to \fIstring\fR except that any leading or trailing characters present in the string given by \fIchars\fR are removed. If \fIchars\fR is not specified then white space is removed (any character for which \fBstring is space\fR returns 1, and "\e0"). .TP \fBstring trimleft \fIstring\fR ?\fIchars\fR? . Returns a value equal to \fIstring\fR except that any leading characters present in the string given by \fIchars\fR are removed. If \fIchars\fR is not specified then white space is removed (any character for which \fBstring is space\fR returns 1, and "\e0"). .TP \fBstring trimright \fIstring\fR ?\fIchars\fR? . Returns a value equal to \fIstring\fR except that any trailing characters present in the string given by \fIchars\fR are removed. If \fIchars\fR is not specified then white space is removed (any character for which \fBstring is space\fR returns 1, and "\e0"). .SS "OBSOLETE SUBCOMMANDS" .PP These subcommands are currently supported, but are likely to go away in a future release as their functionality is either virtually never used or highly misleading. .TP \fBstring bytelength \fIstring\fR |
| ︙ | ︙ |
Changes to generic/regc_lex.c.
| ︙ | ︙ | |||
901 902 903 904 905 906 907 | /* * Oops, doesn't look like it's a backref after all... */ v->now = save; | | < < | 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 |
/*
* Oops, doesn't look like it's a backref after all...
*/
v->now = save;
/* FALLTHRU */
case CHR('0'):
NOTE(REG_UUNPORT);
v->now--; /* put first digit back */
c = (uchr) lexdigits(v, 8, 1, 3);
if (ISERR()) {
FAILW(REG_EESCAPE);
|
| ︙ | ︙ |
Changes to generic/regc_nfa.c.
| ︙ | ︙ | |||
2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 |
narcs += s->nouts;
}
fprintf(f, "total of %d states, %d arcs\n", nstates, narcs);
if (nfa->parent == NULL) {
dumpcolors(nfa->cm, f);
}
fflush(f);
#endif
}
#ifdef REG_DEBUG /* subordinates of dumpnfa */
/*
^ #ifdef REG_DEBUG
*/
| > > > | 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 |
narcs += s->nouts;
}
fprintf(f, "total of %d states, %d arcs\n", nstates, narcs);
if (nfa->parent == NULL) {
dumpcolors(nfa->cm, f);
}
fflush(f);
#else
(void)nfa;
(void)f;
#endif
}
#ifdef REG_DEBUG /* subordinates of dumpnfa */
/*
^ #ifdef REG_DEBUG
*/
|
| ︙ | ︙ | |||
3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 |
fprintf(f, ", haslacons");
}
fprintf(f, "\n");
for (st = 0; st < cnfa->nstates; st++) {
dumpcstate(st, cnfa, f);
}
fflush(f);
#endif
}
#ifdef REG_DEBUG /* subordinates of dumpcnfa */
/*
^ #ifdef REG_DEBUG
*/
| > > > | 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 |
fprintf(f, ", haslacons");
}
fprintf(f, "\n");
for (st = 0; st < cnfa->nstates; st++) {
dumpcstate(st, cnfa, f);
}
fflush(f);
#else
(void)cnfa;
(void)f;
#endif
}
#ifdef REG_DEBUG /* subordinates of dumpcnfa */
/*
^ #ifdef REG_DEBUG
*/
|
| ︙ | ︙ |
Changes to generic/regcomp.c.
| ︙ | ︙ | |||
55 56 57 58 59 60 61 | static const chr *scanplain(struct vars *); static void onechr(struct vars *, pchr, struct state *, struct state *); static void dovec(struct vars *, struct cvec *, struct state *, struct state *); static void wordchrs(struct vars *); static struct subre *subre(struct vars *, int, int, struct state *, struct state *); static void freesubre(struct vars *, struct subre *); static void freesrnode(struct vars *, struct subre *); | < | 55 56 57 58 59 60 61 62 63 64 65 66 67 68 | static const chr *scanplain(struct vars *); static void onechr(struct vars *, pchr, struct state *, struct state *); static void dovec(struct vars *, struct cvec *, struct state *, struct state *); static void wordchrs(struct vars *); static struct subre *subre(struct vars *, int, int, struct state *, struct state *); static void freesubre(struct vars *, struct subre *); static void freesrnode(struct vars *, struct subre *); static int numst(struct subre *, int); static void markst(struct subre *); static void cleanst(struct vars *); static long nfatree(struct vars *, struct subre *, FILE *); static long nfanode(struct vars *, struct subre *, FILE *); static int newlacon(struct vars *, struct state *, struct state *, int); static void freelacons(struct subre *, int); |
| ︙ | ︙ | |||
389 390 391 392 393 394 395 |
specialcolors(v->nfa);
CNOERR();
if (debug != NULL) {
fprintf(debug, "\n\n\n========= RAW ==========\n");
dumpnfa(v->nfa, debug);
dumpst(v->tree, debug, 1);
}
| < | 388 389 390 391 392 393 394 395 396 397 398 399 400 401 |
specialcolors(v->nfa);
CNOERR();
if (debug != NULL) {
fprintf(debug, "\n\n\n========= RAW ==========\n");
dumpnfa(v->nfa, debug);
dumpst(v->tree, debug, 1);
}
v->ntree = numst(v->tree, 1);
markst(v->tree);
cleanst(v);
if (debug != NULL) {
fprintf(debug, "\n\n\n========= TREE FIXED ==========\n");
dumpst(v->tree, debug, 1);
}
|
| ︙ | ︙ | |||
917 918 919 920 921 922 923 | } /* * Legal in EREs due to specification botch. */ NOTE(REG_UPBOTCH); | | | 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 |
}
/*
* Legal in EREs due to specification botch.
*/
NOTE(REG_UPBOTCH);
/* FALLTHRU */
case PLAIN:
onechr(v, v->nextvalue, lp, rp);
okcolors(v->nfa, v->cm);
NOERR();
NEXT();
break;
case '[':
|
| ︙ | ︙ | |||
1804 1805 1806 1807 1808 1809 1810 |
/* we're still parsing, maybe we can reuse the subre */
sr->left = v->treefree;
v->treefree = sr;
} else {
FREE(sr);
}
}
| < < < < < < < < < < < < < < < < < < < | 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 |
/* we're still parsing, maybe we can reuse the subre */
sr->left = v->treefree;
v->treefree = sr;
} else {
FREE(sr);
}
}
/*
- numst - number tree nodes (assigning "id" indexes)
^ static int numst(struct subre *, int);
*/
static int /* next number */
numst(
|
| ︙ | ︙ | |||
2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 |
for (i = 1; i < g->nlacons; i++) {
fprintf(f, "\nla%d (%s):\n", i,
(g->lacons[i].subno) ? "positive" : "negative");
dumpcnfa(&g->lacons[i].cnfa, f);
}
fprintf(f, "\n");
dumpst(g->tree, f, 0);
#endif
}
/*
- dumpst - dump a subRE tree
^ static void dumpst(struct subre *, FILE *, int);
*/
| > > > | 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 |
for (i = 1; i < g->nlacons; i++) {
fprintf(f, "\nla%d (%s):\n", i,
(g->lacons[i].subno) ? "positive" : "negative");
dumpcnfa(&g->lacons[i].cnfa, f);
}
fprintf(f, "\n");
dumpst(g->tree, f, 0);
#else
(void)re;
(void)f;
#endif
}
/*
- dumpst - dump a subRE tree
^ static void dumpst(struct subre *, FILE *, int);
*/
|
| ︙ | ︙ |
Changes to generic/regerror.c.
| ︙ | ︙ | |||
54 55 56 57 58 59 60 |
/*
- regerror - the interface to error numbers
*/
/* ARGSUSED */
size_t /* Actual space needed (including NUL) */
regerror(
int code, /* Error code, or REG_ATOI or REG_ITOA */
| < | 54 55 56 57 58 59 60 61 62 63 64 65 66 67 |
/*
- regerror - the interface to error numbers
*/
/* ARGSUSED */
size_t /* Actual space needed (including NUL) */
regerror(
int code, /* Error code, or REG_ATOI or REG_ITOA */
char *errbuf, /* Result buffer (unless errbuf_size==0) */
size_t errbuf_size) /* Available space in errbuf, can be 0 */
{
const struct rerr *r;
const char *msg;
char convbuf[sizeof(unk)+50]; /* 50 = plenty for int */
size_t len;
|
| ︙ | ︙ |
Changes to generic/regex.h.
| ︙ | ︙ | |||
212 213 214 215 216 217 218 | * Be careful if modifying the list of error codes -- the table used by * regerror() is generated automatically from this file! * * Note that there is no wide-char variant of regerror at this time; what kind * of character is used for error reports is independent of what kind is used * in matching. * | | | 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 | * Be careful if modifying the list of error codes -- the table used by * regerror() is generated automatically from this file! * * Note that there is no wide-char variant of regerror at this time; what kind * of character is used for error reports is independent of what kind is used * in matching. * ^ extern size_t regerror(int, char *, size_t); */ #define REG_OKAY 0 /* no errors detected */ #define REG_NOMATCH 1 /* failed to match */ #define REG_BADPAT 2 /* invalid regexp */ #define REG_ECOLLATE 3 /* invalid collating element */ #define REG_ECTYPE 4 /* invalid character class */ #define REG_EESCAPE 5 /* invalid escape \ sequence */ |
| ︙ | ︙ | |||
263 264 265 266 267 268 269 | #ifndef __REG_NOFRONT int regexec(regex_t *, const char *, size_t, regmatch_t [], int); #endif #ifdef __REG_WIDE_T MODULE_SCOPE int __REG_WIDE_EXEC(regex_t *, const __REG_WIDE_T *, size_t, rm_detail_t *, size_t, regmatch_t [], int); #endif MODULE_SCOPE void regfree(regex_t *); | | | 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 | #ifndef __REG_NOFRONT int regexec(regex_t *, const char *, size_t, regmatch_t [], int); #endif #ifdef __REG_WIDE_T MODULE_SCOPE int __REG_WIDE_EXEC(regex_t *, const __REG_WIDE_T *, size_t, rm_detail_t *, size_t, regmatch_t [], int); #endif MODULE_SCOPE void regfree(regex_t *); MODULE_SCOPE size_t regerror(int, char *, size_t); /* automatically gathered by fwd; do not hand-edit */ /* =====^!^===== end forwards =====^!^===== */ /* * more C++ voodoo */ #ifdef __cplusplus |
| ︙ | ︙ |
Changes to generic/regexec.c.
| ︙ | ︙ | |||
124 125 126 127 128 129 130 | /* =====^!^===== begin forwards =====^!^===== */ /* automatically gathered by fwd; do not hand-edit */ /* === regexec.c === */ int exec(regex_t *, const chr *, size_t, rm_detail_t *, size_t, regmatch_t [], int); static struct dfa *getsubdfa(struct vars *, struct subre *); static int simpleFind(struct vars *const, struct cnfa *const, struct colormap *const); static int complicatedFind(struct vars *const, struct cnfa *const, struct colormap *const); | | | 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 | /* =====^!^===== begin forwards =====^!^===== */ /* automatically gathered by fwd; do not hand-edit */ /* === regexec.c === */ int exec(regex_t *, const chr *, size_t, rm_detail_t *, size_t, regmatch_t [], int); static struct dfa *getsubdfa(struct vars *, struct subre *); static int simpleFind(struct vars *const, struct cnfa *const, struct colormap *const); static int complicatedFind(struct vars *const, struct cnfa *const, struct colormap *const); static int complicatedFindLoop(struct vars *const, struct dfa *const, struct dfa *const, chr **const); static void zapallsubs(regmatch_t *const, const size_t); static void zaptreesubs(struct vars *const, struct subre *const); static void subset(struct vars *const, struct subre *const, chr *const, chr *const); static int cdissect(struct vars *, struct subre *, chr *, chr *); static int ccondissect(struct vars *, struct subre *, chr *, chr *); static int crevcondissect(struct vars *, struct subre *, chr *, chr *); static int cbrdissect(struct vars *, struct subre *, chr *, chr *); |
| ︙ | ︙ | |||
425 426 427 428 429 430 431 |
d = newDFA(v, cnfa, cm, &v->dfa2);
if (ISERR()) {
assert(d == NULL);
freeDFA(s);
return v->err;
}
| | | < < | 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 |
d = newDFA(v, cnfa, cm, &v->dfa2);
if (ISERR()) {
assert(d == NULL);
freeDFA(s);
return v->err;
}
ret = complicatedFindLoop(v, d, s, &cold);
freeDFA(d);
freeDFA(s);
NOERR();
if (v->g->cflags®_EXPECT) {
assert(v->details != NULL);
if (cold != NULL) {
v->details->rm_extend.rm_so = OFF(cold);
} else {
v->details->rm_extend.rm_so = OFF(v->stop);
}
v->details->rm_extend.rm_eo = OFF(v->stop); /* unknown */
}
return ret;
}
/*
- complicatedFindLoop - the heart of complicatedFind
^ static int complicatedFindLoop(struct vars *,
^ struct dfa *, struct dfa *, chr **);
*/
static int
complicatedFindLoop(
struct vars *const v,
struct dfa *const d,
struct dfa *const s,
chr **const coldp) /* where to put coldstart pointer */
{
chr *begin, *end;
chr *cold;
chr *open, *close; /* Open and close of range of possible
|
| ︙ | ︙ |
Changes to generic/tcl.decls.
| ︙ | ︙ | |||
1238 1239 1240 1241 1242 1243 1244 |
declare 334 {
int Tcl_UtfToLower(char *src)
}
declare 335 {
int Tcl_UtfToTitle(char *src)
}
declare 336 {
| | | 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 |
declare 334 {
int Tcl_UtfToLower(char *src)
}
declare 335 {
int Tcl_UtfToTitle(char *src)
}
declare 336 {
int Tcl_UtfToChar16(const char *src, unsigned short *chPtr)
}
declare 337 {
int Tcl_UtfToUpper(char *src)
}
declare 338 {
size_t Tcl_WriteChars(Tcl_Channel chan, const char *src, size_t srcLen)
}
|
| ︙ | ︙ | |||
1295 1296 1297 1298 1299 1300 1301 |
size_t Tcl_UniCharLen(const Tcl_UniChar *uniStr)
}
declare 353 {
int Tcl_UniCharNcmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct,
size_t numChars)
}
declare 354 {
| | | | 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 |
size_t Tcl_UniCharLen(const Tcl_UniChar *uniStr)
}
declare 353 {
int Tcl_UniCharNcmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct,
size_t numChars)
}
declare 354 {
char *Tcl_Char16ToUtfDString(const unsigned short *uniStr,
size_t uniLength, Tcl_DString *dsPtr)
}
declare 355 {
unsigned short *Tcl_UtfToChar16DString(const char *src,
size_t length, Tcl_DString *dsPtr)
}
declare 356 {
Tcl_RegExp Tcl_GetRegExpFromObj(Tcl_Interp *interp, Tcl_Obj *patObj,
int flags)
}
# Removed in 9.0:
|
| ︙ | ︙ | |||
2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 |
int type, size_t size)
}
declare 645 {
int Tcl_GetIntForIndex(Tcl_Interp *interp, Tcl_Obj *objPtr,
size_t endValue, size_t *indexPtr)
}
# ----- BASELINE -- FOR -- 8.7.0 ----- #
##############################################################################
# Define the platform specific public Tcl interface. These functions are only
# available on the designated platform.
interface tclPlat
################################
# Unix specific functions
# (none)
################################
# Windows specific functions
| > > > > > > > > > > > > > | | | < > | | < > | 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 |
int type, size_t size)
}
declare 645 {
int Tcl_GetIntForIndex(Tcl_Interp *interp, Tcl_Obj *objPtr,
size_t endValue, size_t *indexPtr)
}
# TIP #548
declare 646 {
int Tcl_UtfToUniChar(const char *src, int *chPtr)
}
declare 647 {
char *Tcl_UniCharToUtfDString(const int *uniStr,
size_t uniLength, Tcl_DString *dsPtr)
}
declare 648 {
int *Tcl_UtfToUniCharDString(const char *src,
size_t length, Tcl_DString *dsPtr)
}
# ----- BASELINE -- FOR -- 8.7.0 ----- #
##############################################################################
# Define the platform specific public Tcl interface. These functions are only
# available on the designated platform.
interface tclPlat
################################
# Unix specific functions
# (none)
################################
# Windows specific functions
# Added in Tcl 8.1, Removed in Tcl 9.0 (converted to macro)
#declare 0 win {
# TCHAR *Tcl_WinUtfToTChar(const char *str, size_t len, Tcl_DString *dsPtr)
#}
#declare 1 win {
# char *Tcl_WinTCharToUtf(const TCHAR *str, size_t len, Tcl_DString *dsPtr)
#}
################################
# Mac OS X specific functions
declare 0 macosx {
int Tcl_MacOSXOpenBundleResources(Tcl_Interp *interp,
const char *bundleName, int hasResourceFile,
|
| ︙ | ︙ | |||
2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 |
export {
const char *Tcl_PkgInitStubsCheck(Tcl_Interp *interp, const char *version,
int exact)
}
export {
void Tcl_GetMemoryInfo(Tcl_DString *dsPtr)
}
# Local Variables:
# mode: tcl
# End:
| > > > | 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 |
export {
const char *Tcl_PkgInitStubsCheck(Tcl_Interp *interp, const char *version,
int exact)
}
export {
void Tcl_GetMemoryInfo(Tcl_DString *dsPtr)
}
export {
void Tcl_InitSubsystems(void)
}
# Local Variables:
# mode: tcl
# End:
|
Changes to generic/tcl.h.
| ︙ | ︙ | |||
1980 1981 1982 1983 1984 1985 1986 |
/*
* This represents a Unicode character. Any changes to this should also be
* reflected in regcustom.h.
*/
#if TCL_UTF_MAX > 4
/*
| | | | 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 |
/*
* This represents a Unicode character. Any changes to this should also be
* reflected in regcustom.h.
*/
#if TCL_UTF_MAX > 4
/*
* int isn't 100% accurate as it should be a strict 4-byte value
* (perhaps wchar_t). 64-bit systems may have troubles. The size of this
* value must be reflected correctly in regcustom.h and
* in tclEncoding.c.
* XXX: Tcl is currently UCS-2 and planning UTF-16 for the Unicode
* XXX: string rep that Tcl_UniChar represents. Changing the size
* XXX: of Tcl_UniChar is /not/ supported.
*/
typedef int Tcl_UniChar;
#else
typedef unsigned short Tcl_UniChar;
#endif
/*
*----------------------------------------------------------------------------
* TIP #59: The following structure is used in calls 'Tcl_RegisterConfig' to
|
| ︙ | ︙ | |||
2236 2237 2238 2239 2240 2241 2242 | EXTERN const char * Tcl_SetPanicProc( TCL_NORETURN1 Tcl_PanicProc *panicProc); EXTERN void Tcl_StaticPackage(Tcl_Interp *interp, const char *pkgName, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc); EXTERN Tcl_ExitProc *Tcl_SetExitProc(TCL_NORETURN1 Tcl_ExitProc *proc); | | > > | | > | > > > | < > | | < > > > > > > | > > | > > > > > > > | 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 |
EXTERN const char * Tcl_SetPanicProc(
TCL_NORETURN1 Tcl_PanicProc *panicProc);
EXTERN void Tcl_StaticPackage(Tcl_Interp *interp,
const char *pkgName,
Tcl_PackageInitProc *initProc,
Tcl_PackageInitProc *safeInitProc);
EXTERN Tcl_ExitProc *Tcl_SetExitProc(TCL_NORETURN1 Tcl_ExitProc *proc);
#ifdef _WIN32
EXTERN const char *TclZipfs_AppHook(int *argc, wchar_t ***argv);
#else
EXTERN const char *TclZipfs_AppHook(int *argc, char ***argv);
#endif
extern void TclStubMainEx(int index, int argc, const void *argv,
Tcl_AppInitProc *appInitProc, Tcl_Interp *interp);
extern const char *TclStubStaticPackage(Tcl_Interp *interp,
const char *pkgName,
Tcl_PackageInitProc *initProc,
Tcl_PackageInitProc *safeInitProc);
extern const char *TclStubCall(int flags, void *arg1, void *arg2);
#if defined(_WIN32) && defined(UNICODE)
#ifndef USE_TCL_STUBS
# define Tcl_FindExecutable(arg) ((Tcl_FindExecutable)((const char *)(arg)))
#endif
# define Tcl_MainEx Tcl_MainExW
EXTERN TCL_NORETURN void Tcl_MainExW(int argc, wchar_t **argv,
Tcl_AppInitProc *appInitProc, Tcl_Interp *interp);
#endif
#ifdef USE_TCL_STUBS
#define Tcl_InitSubsystems() \
TclInitStubTable(TclStubCall(0, NULL, NULL))
#define Tcl_FindExecutable(argv0) \
TclInitStubTable(TclStubCall(1, (void *)argv0, NULL))
#define Tcl_SetPanicProc(panicProc) \
TclInitStubTable(TclStubCall(2, (void *)panicProc, NULL))
#define TclZipfs_AppHook(argcp, argvp) \
TclInitStubTable(TclStubCall(3, (void *)argcp, (void *)argvp))
#if !defined(_WIN32) || !defined(UNICODE)
#define Tcl_MainEx(argc, argv, appInitProc, interp) TclStubMainEx(0, argc, argv, appInitProc, interp)
#endif
#define Tcl_MainExW(argc, argv, appInitProc, interp) TclStubMainEx(1, argc, argv, appInitProc, interp)
#define Tcl_StaticPackage TclStubStaticPackage
#endif
/*
*----------------------------------------------------------------------------
* Include the public function declarations that are accessible via the stubs
* table.
*/
|
| ︙ | ︙ |
Changes to generic/tclAssembly.c.
| ︙ | ︙ | |||
283 284 285 286 287 288 289 | static void FreeAssemblyEnv(AssemblyEnv*); static int GetBooleanOperand(AssemblyEnv*, Tcl_Token**, int*); static int GetListIndexOperand(AssemblyEnv*, Tcl_Token**, int*); static int GetIntegerOperand(AssemblyEnv*, Tcl_Token**, int*); static int GetNextOperand(AssemblyEnv*, Tcl_Token**, Tcl_Obj**); static void LookForFreshCatches(BasicBlock*, BasicBlock**); static void MoveCodeForJumps(AssemblyEnv*, int); | | < | 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 | static void FreeAssemblyEnv(AssemblyEnv*); static int GetBooleanOperand(AssemblyEnv*, Tcl_Token**, int*); static int GetListIndexOperand(AssemblyEnv*, Tcl_Token**, int*); static int GetIntegerOperand(AssemblyEnv*, Tcl_Token**, int*); static int GetNextOperand(AssemblyEnv*, Tcl_Token**, Tcl_Obj**); static void LookForFreshCatches(BasicBlock*, BasicBlock**); static void MoveCodeForJumps(AssemblyEnv*, int); static void MoveExceptionRangesToBasicBlock(AssemblyEnv*, int); static AssemblyEnv* NewAssemblyEnv(CompileEnv*, int); static int ProcessCatches(AssemblyEnv*); static int ProcessCatchesInBasicBlock(AssemblyEnv*, BasicBlock*, BasicBlock*, enum BasicBlockCatchState, int); static void ResetVisitedBasicBlocks(AssemblyEnv*); static void ResolveJumpTableTargets(AssemblyEnv*, BasicBlock*); static void ReportUndefinedLabel(AssemblyEnv*, BasicBlock*, |
| ︙ | ︙ | |||
791 792 793 794 795 796 797 798 799 800 801 802 803 804 |
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
ByteCode *codePtr; /* Pointer to the bytecode to execute */
Tcl_Obj* backtrace; /* Object where extra error information is
* constructed. */
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "bytecodeList");
return TCL_ERROR;
}
/*
* Assemble the source to bytecode.
| > | 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 |
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
ByteCode *codePtr; /* Pointer to the bytecode to execute */
Tcl_Obj* backtrace; /* Object where extra error information is
* constructed. */
(void)dummy;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "bytecodeList");
return TCL_ERROR;
}
/*
* Assemble the source to bytecode.
|
| ︙ | ︙ | |||
964 965 966 967 968 969 970 |
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *tokenPtr; /* Token in the input script */
int numCommands = envPtr->numCommands;
int offset = envPtr->codeNext - envPtr->codeStart;
int depth = envPtr->currStackDepth;
| | | 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 |
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *tokenPtr; /* Token in the input script */
int numCommands = envPtr->numCommands;
int offset = envPtr->codeNext - envPtr->codeStart;
int depth = envPtr->currStackDepth;
(void)cmdPtr;
/*
* Make sure that the command has a single arg that is a simple word.
*/
if (parsePtr->numWords != 2) {
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
1814 1815 1816 1817 1818 1819 1820 |
* We'll record the stack usage of the script in the BasicBlock, and
* accumulate it together with the stack usage of the enclosing assembly
* code.
*/
int savedStackDepth = envPtr->currStackDepth;
int savedMaxStackDepth = envPtr->maxStackDepth;
| < | 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 |
* We'll record the stack usage of the script in the BasicBlock, and
* accumulate it together with the stack usage of the enclosing assembly
* code.
*/
int savedStackDepth = envPtr->currStackDepth;
int savedMaxStackDepth = envPtr->maxStackDepth;
int savedExceptArrayNext = envPtr->exceptArrayNext;
envPtr->currStackDepth = 0;
envPtr->maxStackDepth = 0;
StartBasicBlock(assemEnvPtr, BB_FALLTHRU, NULL);
switch(instPtr->tclInstCode) {
|
| ︙ | ︙ | |||
1847 1848 1849 1850 1851 1852 1853 |
envPtr->maxStackDepth = savedMaxStackDepth;
/*
* Save any exception ranges that were pushed by the compiler; they will
* need to be fixed up once the stack depth is known.
*/
| | < | 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 |
envPtr->maxStackDepth = savedMaxStackDepth;
/*
* Save any exception ranges that were pushed by the compiler; they will
* need to be fixed up once the stack depth is known.
*/
MoveExceptionRangesToBasicBlock(assemEnvPtr, savedExceptArrayNext);
/*
* Flush the current basic block.
*/
StartBasicBlock(assemEnvPtr, BB_FALLTHRU, NULL);
}
|
| ︙ | ︙ | |||
1907 1908 1909 1910 1911 1912 1913 |
*
*-----------------------------------------------------------------------------
*/
static void
MoveExceptionRangesToBasicBlock(
AssemblyEnv* assemEnvPtr, /* Assembly environment */
| < | 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 |
*
*-----------------------------------------------------------------------------
*/
static void
MoveExceptionRangesToBasicBlock(
AssemblyEnv* assemEnvPtr, /* Assembly environment */
int savedExceptArrayNext) /* Saved index of the end of the exception
* range array */
{
CompileEnv* envPtr = assemEnvPtr->envPtr;
/* Compilation environment */
BasicBlock* curr_bb = assemEnvPtr->curr_bb;
/* Current basic block */
|
| ︙ | ︙ | |||
4316 4317 4318 4319 4320 4321 4322 4323 4324 4325 4326 4327 4328 4329 |
*/
static void
DupAssembleCodeInternalRep(
Tcl_Obj *srcPtr,
Tcl_Obj *copyPtr)
{
return;
}
/*
*-----------------------------------------------------------------------------
*
* FreeAssembleCodeInternalRep --
| > > | 4313 4314 4315 4316 4317 4318 4319 4320 4321 4322 4323 4324 4325 4326 4327 4328 |
*/
static void
DupAssembleCodeInternalRep(
Tcl_Obj *srcPtr,
Tcl_Obj *copyPtr)
{
(void)srcPtr;
(void)copyPtr;
return;
}
/*
*-----------------------------------------------------------------------------
*
* FreeAssembleCodeInternalRep --
|
| ︙ | ︙ |
Changes to generic/tclBasic.c.
| ︙ | ︙ | |||
622 623 624 625 626 627 628 |
} order;
#ifdef TCL_COMPILE_STATS
ByteCodeStats *statsPtr;
#endif /* TCL_COMPILE_STATS */
char mathFuncName[32];
CallFrame *framePtr;
| | | 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 |
} order;
#ifdef TCL_COMPILE_STATS
ByteCodeStats *statsPtr;
#endif /* TCL_COMPILE_STATS */
char mathFuncName[32];
CallFrame *framePtr;
Tcl_InitSubsystems();
/*
* Panic if someone updated the CallFrame structure without also updating
* the Tcl_CallFrame structure (or vice versa).
*/
if (sizeof(Tcl_CallFrame) < sizeof(CallFrame)) {
|
| ︙ | ︙ | |||
6262 6263 6264 6265 6266 6267 6268 |
d = *((const double *) internalPtr);
Tcl_DecrRefCount(resultPtr);
if (Tcl_InitBignumFromDouble(interp, d, &big) != TCL_OK) {
return TCL_ERROR;
}
resultPtr = Tcl_NewBignumObj(&big);
| < > | 6262 6263 6264 6265 6266 6267 6268 6269 6270 6271 6272 6273 6274 6275 6276 6277 |
d = *((const double *) internalPtr);
Tcl_DecrRefCount(resultPtr);
if (Tcl_InitBignumFromDouble(interp, d, &big) != TCL_OK) {
return TCL_ERROR;
}
resultPtr = Tcl_NewBignumObj(&big);
}
/* FALLTHRU */
case TCL_NUMBER_INT:
case TCL_NUMBER_BIG:
result = TclGetLongFromObj(interp, resultPtr, ptr);
break;
case TCL_NUMBER_NAN:
Tcl_GetDoubleFromObj(interp, resultPtr, &d);
|
| ︙ | ︙ |
Changes to generic/tclCkalloc.c.
| ︙ | ︙ | |||
125 126 127 128 129 130 131 | static Tcl_Mutex *ckallocMutexPtr; static int ckallocInit = 0; /* * Prototypes for procedures defined in this file: */ | | > | | > | | | 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 |
static Tcl_Mutex *ckallocMutexPtr;
static int ckallocInit = 0;
/*
* Prototypes for procedures defined in this file:
*/
static int CheckmemCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
static int MemoryCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
static void ValidateMemory(struct mem_header *memHeaderP,
const char *file, int line, int nukeGuards);
/*
*----------------------------------------------------------------------
*
* TclInitDbCkalloc --
*
* Initialize the locks used by the allocator. This is only appropriate
* to call in a single threaded environment, such as during
* Tcl_InitSubsystems.
*
*----------------------------------------------------------------------
*/
void
TclInitDbCkalloc(void)
{
|
| ︙ | ︙ | |||
752 753 754 755 756 757 758 |
*----------------------------------------------------------------------
*/
/* ARGSUSED */
static int
MemoryCmd(
ClientData clientData,
Tcl_Interp *interp,
| | | | | < | | | < < | | | | | | | | | | | | < | | | | < | | | | < | | | | | | | | | | | | | < | < > > > | | | | < | | 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 |
*----------------------------------------------------------------------
*/
/* ARGSUSED */
static int
MemoryCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Obj values of arguments. */
{
const char *fileName;
FILE *fileP;
Tcl_DString buffer;
int result;
size_t len;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "option [args..]");
return TCL_ERROR;
}
if (strcmp(TclGetString(objv[1]), "active") == 0 || strcmp(TclGetString(objv[1]), "display") == 0) {
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "file");
return TCL_ERROR;
}
fileName = Tcl_TranslateFileName(interp, TclGetString(objv[2]), &buffer);
if (fileName == NULL) {
return TCL_ERROR;
}
result = Tcl_DumpActiveMemory(fileName);
Tcl_DStringFree(&buffer);
if (result != TCL_OK) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf("error accessing %s: %s",
TclGetString(objv[2]), Tcl_PosixError(interp)));
return TCL_ERROR;
}
return TCL_OK;
}
if (strcmp(TclGetString(objv[1]),"break_on_malloc") == 0) {
int value;
if (objc != 3) {
goto argError;
}
if (Tcl_GetIntFromObj(interp, objv[2], &value) != TCL_OK) {
return TCL_ERROR;
}
break_on_malloc = (unsigned int) value;
return TCL_OK;
}
if (strcmp(TclGetString(objv[1]),"info") == 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%-25s %10u\n%-25s %10u\n%-25s %10u\n%-25s %10" TCL_Z_MODIFIER"u\n%-25s %10u\n%-25s %10" TCL_Z_MODIFIER "u\n",
"total mallocs", total_mallocs, "total frees", total_frees,
"current packets allocated", current_malloc_packets,
"current bytes allocated", current_bytes_malloced,
"maximum packets allocated", maximum_malloc_packets,
"maximum bytes allocated", maximum_bytes_malloced));
return TCL_OK;
}
if (strcmp(TclGetString(objv[1]), "init") == 0) {
if (objc != 3) {
goto bad_suboption;
}
init_malloced_bodies = (strcmp(TclGetString(objv[2]),"on") == 0);
return TCL_OK;
}
if (strcmp(TclGetString(objv[1]), "objs") == 0) {
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "file");
return TCL_ERROR;
}
fileName = Tcl_TranslateFileName(interp, TclGetString(objv[2]), &buffer);
if (fileName == NULL) {
return TCL_ERROR;
}
fileP = fopen(fileName, "w");
if (fileP == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"cannot open output file: %s",
Tcl_PosixError(interp)));
return TCL_ERROR;
}
TclDbDumpActiveObjects(fileP);
fclose(fileP);
Tcl_DStringFree(&buffer);
return TCL_OK;
}
if (strcmp(TclGetString(objv[1]),"onexit") == 0) {
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "file");
return TCL_ERROR;
}
fileName = Tcl_TranslateFileName(interp, TclGetString(objv[2]), &buffer);
if (fileName == NULL) {
return TCL_ERROR;
}
onExitMemDumpFileName = dumpFile;
strcpy(onExitMemDumpFileName,fileName);
Tcl_DStringFree(&buffer);
return TCL_OK;
}
if (strcmp(TclGetString(objv[1]),"tag") == 0) {
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "file");
return TCL_ERROR;
}
if ((curTagPtr != NULL) && (curTagPtr->refCount == 0)) {
TclpFree((char *) curTagPtr);
}
len = strlen(TclGetString(objv[2]));
curTagPtr = (MemTag *) TclpAlloc(TAG_SIZE(len));
curTagPtr->refCount = 0;
memcpy(curTagPtr->string, TclGetString(objv[2]), len + 1);
return TCL_OK;
}
if (strcmp(TclGetString(objv[1]),"trace") == 0) {
if (objc != 3) {
goto bad_suboption;
}
alloc_tracing = (strcmp(TclGetString(objv[2]),"on") == 0);
return TCL_OK;
}
if (strcmp(TclGetString(objv[1]),"trace_on_at_malloc") == 0) {
int value;
if (objc != 3) {
goto argError;
}
if (Tcl_GetIntFromObj(interp, objv[2], &value) != TCL_OK) {
return TCL_ERROR;
}
trace_on_at_malloc = value;
return TCL_OK;
}
if (strcmp(TclGetString(objv[1]),"validate") == 0) {
if (objc != 3) {
goto bad_suboption;
}
validate_memory = (strcmp(TclGetString(objv[2]),"on") == 0);
return TCL_OK;
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad option \"%s\": should be active, break_on_malloc, info, "
"init, objs, onexit, tag, trace, trace_on_at_malloc, or validate",
TclGetString(objv[1])));
return TCL_ERROR;
argError:
Tcl_WrongNumArgs(interp, 2, objv, "count");
return TCL_ERROR;
bad_suboption:
Tcl_WrongNumArgs(interp, 2, objv, "on|off");
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* CheckmemCmd --
*
* This is the command procedure for the "checkmem" command, which causes
* the application to exit after printing information about memory usage
* to the file passed to this command as its first argument.
*
* Results:
* Returns a standard Tcl completion code.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int CheckmemCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
static int
CheckmemCmd(
ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Interpreter for evaluation. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Obj values of arguments. */
{
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "fileName");
return TCL_ERROR;
}
tclMemDumpFileName = dumpFile;
strcpy(tclMemDumpFileName, TclGetString(objv[1]));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_InitMemory --
|
| ︙ | ︙ | |||
968 969 970 971 972 973 974 |
void
Tcl_InitMemory(
Tcl_Interp *interp) /* Interpreter in which commands should be
* added */
{
TclInitDbCkalloc();
| | | | 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 |
void
Tcl_InitMemory(
Tcl_Interp *interp) /* Interpreter in which commands should be
* added */
{
TclInitDbCkalloc();
Tcl_CreateObjCommand(interp, "memory", MemoryCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "checkmem", CheckmemCmd, NULL, NULL);
}
#else /* TCL_MEM_DEBUG */
/* This is the !TCL_MEM_DEBUG case */
|
| ︙ | ︙ | |||
1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 |
void *
Tcl_AttemptDbCkalloc(
size_t size,
const char *file,
int line)
{
void *result;
result = TclpAlloc(size);
return result;
}
/*
*----------------------------------------------------------------------
| > > | 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 |
void *
Tcl_AttemptDbCkalloc(
size_t size,
const char *file,
int line)
{
void *result;
(void)file;
(void)line;
result = TclpAlloc(size);
return result;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 |
Tcl_AttemptDbCkrealloc(
void *ptr,
size_t size,
const char *file,
int line)
{
void *result;
result = TclpRealloc(ptr, size);
return result;
}
/*
*----------------------------------------------------------------------
| > > | 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 |
Tcl_AttemptDbCkrealloc(
void *ptr,
size_t size,
const char *file,
int line)
{
void *result;
(void)file;
(void)line;
result = TclpRealloc(ptr, size);
return result;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
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 |
void
Tcl_DbCkfree(
void *ptr,
const char *file,
int line)
{
TclpFree(ptr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_InitMemory --
*
* Dummy initialization for memory command, which is only available if
* TCL_MEM_DEBUG is on.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
void
Tcl_InitMemory(
Tcl_Interp *interp)
{
}
int
Tcl_DumpActiveMemory(
const char *fileName)
{
return TCL_OK;
}
void
Tcl_ValidateAllMemory(
const char *file,
int line)
{
}
int
TclDumpMemoryInfo(
ClientData clientData,
int flags)
{
return 1;
}
#endif /* TCL_MEM_DEBUG */
/*
*---------------------------------------------------------------------------
| > > > > > > > > | 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 |
void
Tcl_DbCkfree(
void *ptr,
const char *file,
int line)
{
(void)file;
(void)line;
TclpFree(ptr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_InitMemory --
*
* Dummy initialization for memory command, which is only available if
* TCL_MEM_DEBUG is on.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
void
Tcl_InitMemory(
Tcl_Interp *interp)
{
(void)interp;
}
int
Tcl_DumpActiveMemory(
const char *fileName)
{
(void)fileName;
return TCL_OK;
}
void
Tcl_ValidateAllMemory(
const char *file,
int line)
{
(void)file;
(void)line;
}
int
TclDumpMemoryInfo(
ClientData clientData,
int flags)
{
(void)clientData;
(void)flags;
return 1;
}
#endif /* TCL_MEM_DEBUG */
/*
*---------------------------------------------------------------------------
|
| ︙ | ︙ |
Changes to generic/tclClock.c.
| ︙ | ︙ | |||
1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 |
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
const char *varName;
const char *varValue;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "name");
return TCL_ERROR;
}
varName = TclGetString(objv[1]);
varValue = getenv(varName);
| > | 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 |
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
const char *varName;
const char *varValue;
(void)clientData;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "name");
return TCL_ERROR;
}
varName = TclGetString(objv[1]);
varValue = getenv(varName);
|
| ︙ | ︙ | |||
1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 |
};
enum ClicksSwitch {
CLICKS_MILLIS, CLICKS_MICROS, CLICKS_NATIVE
};
int index = CLICKS_NATIVE;
Tcl_Time now;
Tcl_WideInt clicks = 0;
switch (objc) {
case 1:
break;
case 2:
if (Tcl_GetIndexFromObj(interp, objv[1], clicksSwitches, "option", 0,
&index) != TCL_OK) {
| > | 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 |
};
enum ClicksSwitch {
CLICKS_MILLIS, CLICKS_MICROS, CLICKS_NATIVE
};
int index = CLICKS_NATIVE;
Tcl_Time now;
Tcl_WideInt clicks = 0;
(void)clientData;
switch (objc) {
case 1:
break;
case 2:
if (Tcl_GetIndexFromObj(interp, objv[1], clicksSwitches, "option", 0,
&index) != TCL_OK) {
|
| ︙ | ︙ | |||
1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 |
ClockMillisecondsObjCmd(
ClientData clientData, /* Client data is unused */
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const *objv) /* Parameter values */
{
Tcl_Time now;
if (objc != 1) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return TCL_ERROR;
}
Tcl_GetTime(&now);
Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt)
| > | 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 |
ClockMillisecondsObjCmd(
ClientData clientData, /* Client data is unused */
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const *objv) /* Parameter values */
{
Tcl_Time now;
(void)clientData;
if (objc != 1) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return TCL_ERROR;
}
Tcl_GetTime(&now);
Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt)
|
| ︙ | ︙ | |||
1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 |
int
ClockMicrosecondsObjCmd(
ClientData clientData, /* Client data is unused */
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const *objv) /* Parameter values */
{
if (objc != 1) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(TclpGetMicroseconds()));
return TCL_OK;
}
| > | 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 |
int
ClockMicrosecondsObjCmd(
ClientData clientData, /* Client data is unused */
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const *objv) /* Parameter values */
{
(void)clientData;
if (objc != 1) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(TclpGetMicroseconds()));
return TCL_OK;
}
|
| ︙ | ︙ | |||
1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 |
ClockSecondsObjCmd(
ClientData clientData, /* Client data is unused */
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const *objv) /* Parameter values */
{
Tcl_Time now;
if (objc != 1) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return TCL_ERROR;
}
Tcl_GetTime(&now);
Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt) now.sec));
| > | 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 |
ClockSecondsObjCmd(
ClientData clientData, /* Client data is unused */
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const *objv) /* Parameter values */
{
Tcl_Time now;
(void)clientData;
if (objc != 1) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return TCL_ERROR;
}
Tcl_GetTime(&now);
Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt) now.sec));
|
| ︙ | ︙ |
Changes to generic/tclCmdMZ.c.
| ︙ | ︙ | |||
4445 4446 4447 4448 4449 4450 4451 4452 4453 4454 4455 4456 4457 4458 | break; case TCL_BREAK: /* * Force stop immediately. */ threshold = 1; maxcnt = 0; case TCL_CONTINUE: result = TCL_OK; break; default: goto done; } | > | 4445 4446 4447 4448 4449 4450 4451 4452 4453 4454 4455 4456 4457 4458 4459 | break; case TCL_BREAK: /* * Force stop immediately. */ threshold = 1; maxcnt = 0; /* FALLTHRU */ case TCL_CONTINUE: result = TCL_OK; break; default: goto done; } |
| ︙ | ︙ |
Changes to generic/tclCompile.c.
| ︙ | ︙ | |||
2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 |
{
int lastCmdIdx = -1; /* Index into envPtr->cmdMapPtr of the last
* command this routine compiles into bytecode.
* Initial value of -1 indicates this routine
* has not yet generated any bytecode. */
const char *p = script; /* Where we are in our compile. */
int depth = TclGetStackDepth(envPtr);
if (envPtr->iPtr == NULL) {
Tcl_Panic("TclCompileScript() called on uninitialized CompileEnv");
}
| > > > > > > > > > > > > > > | > | > > > > > | > > | | | | > | | | | | | | | | > > > > > > | > > | | > > > | 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 |
{
int lastCmdIdx = -1; /* Index into envPtr->cmdMapPtr of the last
* command this routine compiles into bytecode.
* Initial value of -1 indicates this routine
* has not yet generated any bytecode. */
const char *p = script; /* Where we are in our compile. */
int depth = TclGetStackDepth(envPtr);
Interp *iPtr = (Interp *) interp;
if (envPtr->iPtr == NULL) {
Tcl_Panic("TclCompileScript() called on uninitialized CompileEnv");
}
/*
* Check depth to avoid overflow of the C execution stack by too many
* nested calls of TclCompileScript (considering interp recursionlimit).
* Factor 5/4 (1.25) is used to avoid too mistaken limit recognition
* during "mixed" evaluation and compilation process (nested eval+compile)
* and is good enough for default recursionlimit (1000).
*/
if (iPtr->numLevels / 5 > iPtr->maxNestingDepth / 4) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"too many nested compilations (infinite loop?)", -1));
Tcl_SetErrorCode(interp, "TCL", "LIMIT", "STACK", NULL);
TclCompileSyntaxError(interp, envPtr);
return;
}
/* Each iteration compiles one command from the script. */
if (numBytes + 1 > 1) {
/*
* Don't use system stack (size of Tcl_Parse is ca. 400 bytes), so
* many nested compilations (body enclosed in body) can cause abnormal
* program termination with a stack overflow exception, bug [fec0c17d39].
*/
Tcl_Parse *parsePtr = ckalloc(sizeof(Tcl_Parse));
do {
const char *next;
if (TCL_OK != Tcl_ParseCommand(interp, p, numBytes, 0, parsePtr)) {
/*
* Compile bytecodes to report the parsePtr error at runtime.
*/
Tcl_LogCommandInfo(interp, script, parsePtr->commandStart,
parsePtr->term + 1 - parsePtr->commandStart);
TclCompileSyntaxError(interp, envPtr);
ckfree(parsePtr);
return;
}
#ifdef TCL_COMPILE_DEBUG
/*
* If tracing, print a line for each top level command compiled.
* TODO: Suppress when numWords == 0 ?
*/
if ((tclTraceCompile >= 1) && (envPtr->procPtr == NULL)) {
int commandLength = parsePtr->term - parsePtr->commandStart;
fprintf(stdout, " Compiling: ");
TclPrintSource(stdout, parsePtr->commandStart,
TclMin(commandLength, 55));
fprintf(stdout, "\n");
}
#endif
/*
* TIP #280: Count newlines before the command start.
* (See test info-30.33).
*/
TclAdvanceLines(&envPtr->line, p, parsePtr->commandStart);
TclAdvanceContinuations(&envPtr->line, &envPtr->clNext,
parsePtr->commandStart - envPtr->source);
/*
* Advance parser to the next command in the script.
*/
next = parsePtr->commandStart + parsePtr->commandSize;
numBytes -= next - p;
p = next;
if (parsePtr->numWords == 0) {
/*
* The "command" parsed has no words. In this case we can skip
* the rest of the loop body. With no words, clearly
* CompileCommandTokens() has nothing to do. Since the parser
* aggressively sucks up leading comment and white space,
* including newlines, parsePtr->commandStart must be pointing at
* either the end of script, or a command-terminating semi-colon.
* In either case, the TclAdvance*() calls have nothing to do.
* Finally, when no words are parsed, no tokens have been
* allocated at parsePtr->tokenPtr so there's also nothing for
* Tcl_FreeParse() to do.
*
* The advantage of this shortcut is that CompileCommandTokens()
* can be written with an assumption that parsePtr->numWords > 0, with
* the implication the CCT() always generates bytecode.
*/
continue;
}
/*
* Avoid stack exhaustion by too many nested calls of TclCompileScript
* (considering interp recursionlimit).
*/
iPtr->numLevels++;
lastCmdIdx = CompileCommandTokens(interp, parsePtr, envPtr);
iPtr->numLevels--;
/*
* TIP #280: Track lines in the just compiled command.
*/
TclAdvanceLines(&envPtr->line, parsePtr->commandStart, p);
TclAdvanceContinuations(&envPtr->line, &envPtr->clNext,
p - envPtr->source);
Tcl_FreeParse(parsePtr);
} while (numBytes > 0);
ckfree(parsePtr);
}
if (lastCmdIdx == -1) {
/*
* Compiling the script yielded no bytecode. The script must be all
* whitespace, comments, and empty commands. Such scripts are defined
* to successfully produce the empty string result, so we emit the
|
| ︙ | ︙ |
Changes to generic/tclDecls.h.
| ︙ | ︙ | |||
906 907 908 909 910 911 912 | const char *src, size_t srcLen, Tcl_DString *dsPtr); /* 334 */ EXTERN int Tcl_UtfToLower(char *src); /* 335 */ EXTERN int Tcl_UtfToTitle(char *src); /* 336 */ | | > | 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 | const char *src, size_t srcLen, Tcl_DString *dsPtr); /* 334 */ EXTERN int Tcl_UtfToLower(char *src); /* 335 */ EXTERN int Tcl_UtfToTitle(char *src); /* 336 */ EXTERN int Tcl_UtfToChar16(const char *src, unsigned short *chPtr); /* 337 */ EXTERN int Tcl_UtfToUpper(char *src); /* 338 */ EXTERN size_t Tcl_WriteChars(Tcl_Channel chan, const char *src, size_t srcLen); /* 339 */ EXTERN size_t Tcl_WriteObj(Tcl_Channel chan, Tcl_Obj *objPtr); |
| ︙ | ︙ | |||
942 943 944 945 946 947 948 | EXTERN int Tcl_UniCharIsWordChar(int ch); /* 352 */ EXTERN size_t Tcl_UniCharLen(const Tcl_UniChar *uniStr); /* 353 */ EXTERN int Tcl_UniCharNcmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, size_t numChars); /* 354 */ | | | | 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 | EXTERN int Tcl_UniCharIsWordChar(int ch); /* 352 */ EXTERN size_t Tcl_UniCharLen(const Tcl_UniChar *uniStr); /* 353 */ EXTERN int Tcl_UniCharNcmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, size_t numChars); /* 354 */ EXTERN char * Tcl_Char16ToUtfDString(const unsigned short *uniStr, size_t uniLength, Tcl_DString *dsPtr); /* 355 */ EXTERN unsigned short * Tcl_UtfToChar16DString(const char *src, size_t length, Tcl_DString *dsPtr); /* 356 */ EXTERN Tcl_RegExp Tcl_GetRegExpFromObj(Tcl_Interp *interp, Tcl_Obj *patObj, int flags); /* Slot 357 is reserved */ /* 358 */ EXTERN void Tcl_FreeParse(Tcl_Parse *parsePtr); |
| ︙ | ︙ | |||
1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 |
EXTERN int Tcl_LinkArray(Tcl_Interp *interp,
const char *varName, void *addr, int type,
size_t size);
/* 645 */
EXTERN int Tcl_GetIntForIndex(Tcl_Interp *interp,
Tcl_Obj *objPtr, size_t endValue,
size_t *indexPtr);
typedef struct {
const struct TclPlatStubs *tclPlatStubs;
const struct TclIntStubs *tclIntStubs;
const struct TclIntPlatStubs *tclIntPlatStubs;
} TclStubHooks;
| > > > > > > > > | 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 |
EXTERN int Tcl_LinkArray(Tcl_Interp *interp,
const char *varName, void *addr, int type,
size_t size);
/* 645 */
EXTERN int Tcl_GetIntForIndex(Tcl_Interp *interp,
Tcl_Obj *objPtr, size_t endValue,
size_t *indexPtr);
/* 646 */
EXTERN int Tcl_UtfToUniChar(const char *src, int *chPtr);
/* 647 */
EXTERN char * Tcl_UniCharToUtfDString(const int *uniStr,
size_t uniLength, Tcl_DString *dsPtr);
/* 648 */
EXTERN int * Tcl_UtfToUniCharDString(const char *src,
size_t length, Tcl_DString *dsPtr);
typedef struct {
const struct TclPlatStubs *tclPlatStubs;
const struct TclIntStubs *tclIntStubs;
const struct TclIntPlatStubs *tclIntPlatStubs;
} TclStubHooks;
|
| ︙ | ︙ | |||
2124 2125 2126 2127 2128 2129 2130 |
const char * (*tcl_UtfFindLast) (const char *src, int ch); /* 329 */
const char * (*tcl_UtfNext) (const char *src); /* 330 */
const char * (*tcl_UtfPrev) (const char *src, const char *start); /* 331 */
int (*tcl_UtfToExternal) (Tcl_Interp *interp, Tcl_Encoding encoding, const char *src, size_t srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, size_t dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); /* 332 */
char * (*tcl_UtfToExternalDString) (Tcl_Encoding encoding, const char *src, size_t srcLen, Tcl_DString *dsPtr); /* 333 */
int (*tcl_UtfToLower) (char *src); /* 334 */
int (*tcl_UtfToTitle) (char *src); /* 335 */
| | | | | 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 |
const char * (*tcl_UtfFindLast) (const char *src, int ch); /* 329 */
const char * (*tcl_UtfNext) (const char *src); /* 330 */
const char * (*tcl_UtfPrev) (const char *src, const char *start); /* 331 */
int (*tcl_UtfToExternal) (Tcl_Interp *interp, Tcl_Encoding encoding, const char *src, size_t srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, size_t dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); /* 332 */
char * (*tcl_UtfToExternalDString) (Tcl_Encoding encoding, const char *src, size_t srcLen, Tcl_DString *dsPtr); /* 333 */
int (*tcl_UtfToLower) (char *src); /* 334 */
int (*tcl_UtfToTitle) (char *src); /* 335 */
int (*tcl_UtfToChar16) (const char *src, unsigned short *chPtr); /* 336 */
int (*tcl_UtfToUpper) (char *src); /* 337 */
size_t (*tcl_WriteChars) (Tcl_Channel chan, const char *src, size_t srcLen); /* 338 */
size_t (*tcl_WriteObj) (Tcl_Channel chan, Tcl_Obj *objPtr); /* 339 */
char * (*tcl_GetString) (Tcl_Obj *objPtr); /* 340 */
void (*reserved341)(void);
void (*reserved342)(void);
void (*tcl_AlertNotifier) (void *clientData); /* 343 */
void (*tcl_ServiceModeHook) (int mode); /* 344 */
int (*tcl_UniCharIsAlnum) (int ch); /* 345 */
int (*tcl_UniCharIsAlpha) (int ch); /* 346 */
int (*tcl_UniCharIsDigit) (int ch); /* 347 */
int (*tcl_UniCharIsLower) (int ch); /* 348 */
int (*tcl_UniCharIsSpace) (int ch); /* 349 */
int (*tcl_UniCharIsUpper) (int ch); /* 350 */
int (*tcl_UniCharIsWordChar) (int ch); /* 351 */
size_t (*tcl_UniCharLen) (const Tcl_UniChar *uniStr); /* 352 */
int (*tcl_UniCharNcmp) (const Tcl_UniChar *ucs, const Tcl_UniChar *uct, size_t numChars); /* 353 */
char * (*tcl_Char16ToUtfDString) (const unsigned short *uniStr, size_t uniLength, Tcl_DString *dsPtr); /* 354 */
unsigned short * (*tcl_UtfToChar16DString) (const char *src, size_t length, Tcl_DString *dsPtr); /* 355 */
Tcl_RegExp (*tcl_GetRegExpFromObj) (Tcl_Interp *interp, Tcl_Obj *patObj, int flags); /* 356 */
void (*reserved357)(void);
void (*tcl_FreeParse) (Tcl_Parse *parsePtr); /* 358 */
void (*tcl_LogCommandInfo) (Tcl_Interp *interp, const char *script, const char *command, size_t length); /* 359 */
int (*tcl_ParseBraces) (Tcl_Interp *interp, const char *start, size_t numBytes, Tcl_Parse *parsePtr, int append, const char **termPtr); /* 360 */
int (*tcl_ParseCommand) (Tcl_Interp *interp, const char *start, size_t numBytes, int nested, Tcl_Parse *parsePtr); /* 361 */
int (*tcl_ParseExpr) (Tcl_Interp *interp, const char *start, size_t numBytes, Tcl_Parse *parsePtr); /* 362 */
|
| ︙ | ︙ | |||
2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 |
void (*tcl_StoreIntRep) (Tcl_Obj *objPtr, const Tcl_ObjType *typePtr, const Tcl_ObjIntRep *irPtr); /* 639 */
int (*tcl_HasStringRep) (Tcl_Obj *objPtr); /* 640 */
void (*tcl_IncrRefCount) (Tcl_Obj *objPtr); /* 641 */
void (*tcl_DecrRefCount) (Tcl_Obj *objPtr); /* 642 */
int (*tcl_IsShared) (Tcl_Obj *objPtr); /* 643 */
int (*tcl_LinkArray) (Tcl_Interp *interp, const char *varName, void *addr, int type, size_t size); /* 644 */
int (*tcl_GetIntForIndex) (Tcl_Interp *interp, Tcl_Obj *objPtr, size_t endValue, size_t *indexPtr); /* 645 */
} TclStubs;
extern const TclStubs *tclStubsPtr;
#ifdef __cplusplus
}
#endif
| > > > | 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 |
void (*tcl_StoreIntRep) (Tcl_Obj *objPtr, const Tcl_ObjType *typePtr, const Tcl_ObjIntRep *irPtr); /* 639 */
int (*tcl_HasStringRep) (Tcl_Obj *objPtr); /* 640 */
void (*tcl_IncrRefCount) (Tcl_Obj *objPtr); /* 641 */
void (*tcl_DecrRefCount) (Tcl_Obj *objPtr); /* 642 */
int (*tcl_IsShared) (Tcl_Obj *objPtr); /* 643 */
int (*tcl_LinkArray) (Tcl_Interp *interp, const char *varName, void *addr, int type, size_t size); /* 644 */
int (*tcl_GetIntForIndex) (Tcl_Interp *interp, Tcl_Obj *objPtr, size_t endValue, size_t *indexPtr); /* 645 */
int (*tcl_UtfToUniChar) (const char *src, int *chPtr); /* 646 */
char * (*tcl_UniCharToUtfDString) (const int *uniStr, size_t uniLength, Tcl_DString *dsPtr); /* 647 */
int * (*tcl_UtfToUniCharDString) (const char *src, size_t length, Tcl_DString *dsPtr); /* 648 */
} TclStubs;
extern const TclStubs *tclStubsPtr;
#ifdef __cplusplus
}
#endif
|
| ︙ | ︙ | |||
3091 3092 3093 3094 3095 3096 3097 | (tclStubsPtr->tcl_UtfToExternal) /* 332 */ #define Tcl_UtfToExternalDString \ (tclStubsPtr->tcl_UtfToExternalDString) /* 333 */ #define Tcl_UtfToLower \ (tclStubsPtr->tcl_UtfToLower) /* 334 */ #define Tcl_UtfToTitle \ (tclStubsPtr->tcl_UtfToTitle) /* 335 */ | | | | 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 | (tclStubsPtr->tcl_UtfToExternal) /* 332 */ #define Tcl_UtfToExternalDString \ (tclStubsPtr->tcl_UtfToExternalDString) /* 333 */ #define Tcl_UtfToLower \ (tclStubsPtr->tcl_UtfToLower) /* 334 */ #define Tcl_UtfToTitle \ (tclStubsPtr->tcl_UtfToTitle) /* 335 */ #define Tcl_UtfToChar16 \ (tclStubsPtr->tcl_UtfToChar16) /* 336 */ #define Tcl_UtfToUpper \ (tclStubsPtr->tcl_UtfToUpper) /* 337 */ #define Tcl_WriteChars \ (tclStubsPtr->tcl_WriteChars) /* 338 */ #define Tcl_WriteObj \ (tclStubsPtr->tcl_WriteObj) /* 339 */ #define Tcl_GetString \ |
| ︙ | ︙ | |||
3125 3126 3127 3128 3129 3130 3131 | (tclStubsPtr->tcl_UniCharIsUpper) /* 350 */ #define Tcl_UniCharIsWordChar \ (tclStubsPtr->tcl_UniCharIsWordChar) /* 351 */ #define Tcl_UniCharLen \ (tclStubsPtr->tcl_UniCharLen) /* 352 */ #define Tcl_UniCharNcmp \ (tclStubsPtr->tcl_UniCharNcmp) /* 353 */ | | | | | | 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 | (tclStubsPtr->tcl_UniCharIsUpper) /* 350 */ #define Tcl_UniCharIsWordChar \ (tclStubsPtr->tcl_UniCharIsWordChar) /* 351 */ #define Tcl_UniCharLen \ (tclStubsPtr->tcl_UniCharLen) /* 352 */ #define Tcl_UniCharNcmp \ (tclStubsPtr->tcl_UniCharNcmp) /* 353 */ #define Tcl_Char16ToUtfDString \ (tclStubsPtr->tcl_Char16ToUtfDString) /* 354 */ #define Tcl_UtfToChar16DString \ (tclStubsPtr->tcl_UtfToChar16DString) /* 355 */ #define Tcl_GetRegExpFromObj \ (tclStubsPtr->tcl_GetRegExpFromObj) /* 356 */ /* Slot 357 is reserved */ #define Tcl_FreeParse \ (tclStubsPtr->tcl_FreeParse) /* 358 */ #define Tcl_LogCommandInfo \ (tclStubsPtr->tcl_LogCommandInfo) /* 359 */ |
| ︙ | ︙ | |||
3702 3703 3704 3705 3706 3707 3708 3709 3710 3711 3712 3713 | (tclStubsPtr->tcl_DecrRefCount) /* 642 */ #define Tcl_IsShared \ (tclStubsPtr->tcl_IsShared) /* 643 */ #define Tcl_LinkArray \ (tclStubsPtr->tcl_LinkArray) /* 644 */ #define Tcl_GetIntForIndex \ (tclStubsPtr->tcl_GetIntForIndex) /* 645 */ #endif /* defined(USE_TCL_STUBS) */ /* !END!: Do not edit above this line. */ | > > > > > > < < < < < < < < < < | 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 3729 3730 3731 3732 3733 3734 3735 3736 3737 3738 | (tclStubsPtr->tcl_DecrRefCount) /* 642 */ #define Tcl_IsShared \ (tclStubsPtr->tcl_IsShared) /* 643 */ #define Tcl_LinkArray \ (tclStubsPtr->tcl_LinkArray) /* 644 */ #define Tcl_GetIntForIndex \ (tclStubsPtr->tcl_GetIntForIndex) /* 645 */ #define Tcl_UtfToUniChar \ (tclStubsPtr->tcl_UtfToUniChar) /* 646 */ #define Tcl_UniCharToUtfDString \ (tclStubsPtr->tcl_UniCharToUtfDString) /* 647 */ #define Tcl_UtfToUniCharDString \ (tclStubsPtr->tcl_UtfToUniCharDString) /* 648 */ #endif /* defined(USE_TCL_STUBS) */ /* !END!: Do not edit above this line. */ #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLIMPORT #define Tcl_PkgPresent(interp, name, version, exact) \ Tcl_PkgPresentEx(interp, name, version, exact, NULL) #define Tcl_PkgProvide(interp, name, version) \ Tcl_PkgProvideEx(interp, name, version, NULL) |
| ︙ | ︙ | |||
3842 3843 3844 3845 3846 3847 3848 3849 3850 3851 3852 3853 3854 3855 |
#define Tcl_NewIntObj(value) Tcl_NewWideIntObj((int)(value))
#define Tcl_DbNewLongObj(value, file, line) Tcl_DbNewWideIntObj((long)(value), file, line)
#define Tcl_SetIntObj(objPtr, value) Tcl_SetWideIntObj((objPtr), (int)(value))
#define Tcl_SetLongObj(objPtr, value) Tcl_SetWideIntObj((objPtr), (long)(value))
#define Tcl_GetUnicode(objPtr) Tcl_GetUnicodeFromObj((objPtr), NULL)
#define Tcl_BackgroundError(interp) Tcl_BackgroundException((interp), TCL_ERROR)
#define Tcl_StringMatch(str, pattern) Tcl_StringCaseMatch((str), (pattern), 0)
/*
* Deprecated Tcl procedures:
*/
#define Tcl_EvalObj(interp, objPtr) \
Tcl_EvalObjEx(interp, objPtr, 0)
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
#define Tcl_NewIntObj(value) Tcl_NewWideIntObj((int)(value))
#define Tcl_DbNewLongObj(value, file, line) Tcl_DbNewWideIntObj((long)(value), file, line)
#define Tcl_SetIntObj(objPtr, value) Tcl_SetWideIntObj((objPtr), (int)(value))
#define Tcl_SetLongObj(objPtr, value) Tcl_SetWideIntObj((objPtr), (long)(value))
#define Tcl_GetUnicode(objPtr) Tcl_GetUnicodeFromObj((objPtr), NULL)
#define Tcl_BackgroundError(interp) Tcl_BackgroundException((interp), TCL_ERROR)
#define Tcl_StringMatch(str, pattern) Tcl_StringCaseMatch((str), (pattern), 0)
#if TCL_UTF_MAX <= 4
# undef Tcl_UniCharToUtfDString
# define Tcl_UniCharToUtfDString Tcl_Char16ToUtfDString
# undef Tcl_UtfToUniCharDString
# define Tcl_UtfToUniCharDString Tcl_UtfToChar16DString
# undef Tcl_UtfToUniChar
# define Tcl_UtfToUniChar Tcl_UtfToChar16
#endif
#if defined(USE_TCL_STUBS)
# define Tcl_WCharToUtfDString (sizeof(wchar_t) != sizeof(short) \
? (char *(*)(const wchar_t *, size_t, Tcl_DString *))tclStubsPtr->tcl_UniCharToUtfDString \
: (char *(*)(const wchar_t *, size_t, Tcl_DString *))Tcl_Char16ToUtfDString)
# define Tcl_UtfToWCharDString (sizeof(wchar_t) != sizeof(short) \
? (wchar_t *(*)(const char *, size_t, Tcl_DString *))tclStubsPtr->tcl_UtfToUniCharDString \
: (wchar_t *(*)(const char *, size_t, Tcl_DString *))Tcl_UtfToChar16DString)
# define Tcl_UtfToWChar (sizeof(wchar_t) != sizeof(short) \
? (int (*)(const char *, wchar_t *))tclStubsPtr->tcl_UtfToChar16 \
: (int (*)(const char *, wchar_t *))Tcl_UtfToUniChar)
#else
# define Tcl_WCharToUtfDString (sizeof(wchar_t) != sizeof(short) \
? (char *(*)(const wchar_t *, size_t, Tcl_DString *))Tcl_UniCharToUtfDString \
: (char *(*)(const wchar_t *, size_t, Tcl_DString *))Tcl_Char16ToUtfDString)
# define Tcl_UtfToWCharDString (sizeof(wchar_t) != sizeof(short) \
? (wchar_t *(*)(const char *, size_t, Tcl_DString *))Tcl_UtfToUniCharDString \
: (wchar_t *(*)(const char *, size_t, Tcl_DString *))Tcl_UtfToChar16DString)
# define Tcl_UtfToWChar (sizeof(wchar_t) != sizeof(short) \
? (int (*)(const char *, wchar_t *))Tcl_UtfToChar16 \
: (int (*)(const char *, wchar_t *))Tcl_UtfToUniChar)
#endif
/*
* Deprecated Tcl procedures:
*/
#define Tcl_EvalObj(interp, objPtr) \
Tcl_EvalObjEx(interp, objPtr, 0)
|
| ︙ | ︙ |
Changes to generic/tclDictObj.c.
| ︙ | ︙ | |||
3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 | * Force loop termination by calling Tcl_DictObjDone; this * makes the next Tcl_DictObjNext say there is nothing more to * do. */ Tcl_ResetResult(interp); Tcl_DictObjDone(&search); case TCL_CONTINUE: result = TCL_OK; break; case TCL_ERROR: Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (\"dict filter\" script line %d)", Tcl_GetErrorLine(interp))); | > | 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 | * Force loop termination by calling Tcl_DictObjDone; this * makes the next Tcl_DictObjNext say there is nothing more to * do. */ Tcl_ResetResult(interp); Tcl_DictObjDone(&search); /* FALLTHRU */ case TCL_CONTINUE: result = TCL_OK; break; case TCL_ERROR: Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (\"dict filter\" script line %d)", Tcl_GetErrorLine(interp))); |
| ︙ | ︙ | |||
3296 3297 3298 3299 3300 3301 3302 |
for (i=2 ; i+2<objc ; i+=2) {
if (Tcl_DictObjGet(interp, dictPtr, objv[i], &objPtr) != TCL_OK) {
TclDecrRefCount(dictPtr);
return TCL_ERROR;
}
if (objPtr == NULL) {
/* ??? */
| | | 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 |
for (i=2 ; i+2<objc ; i+=2) {
if (Tcl_DictObjGet(interp, dictPtr, objv[i], &objPtr) != TCL_OK) {
TclDecrRefCount(dictPtr);
return TCL_ERROR;
}
if (objPtr == NULL) {
/* ??? */
Tcl_UnsetVar2(interp, TclGetString(objv[i+1]), NULL, 0);
} else if (Tcl_ObjSetVar2(interp, objv[i+1], NULL, objPtr,
TCL_LEAVE_ERR_MSG) == NULL) {
TclDecrRefCount(dictPtr);
return TCL_ERROR;
}
}
TclDecrRefCount(dictPtr);
|
| ︙ | ︙ |
Changes to generic/tclEncoding.c.
| ︙ | ︙ | |||
1449 1450 1451 1452 1453 1454 1455 |
*/
#undef Tcl_FindExecutable
const char *
Tcl_FindExecutable(
const char *argv0) /* The value of the application's argv[0]
* (native). */
{
| | | 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 |
*/
#undef Tcl_FindExecutable
const char *
Tcl_FindExecutable(
const char *argv0) /* The value of the application's argv[0]
* (native). */
{
const char *version = Tcl_InitSubsystems();
TclpSetInitialEncodings();
TclpFindExecutable(argv0);
return version;
}
/*
*---------------------------------------------------------------------------
|
| ︙ | ︙ | |||
2420 2421 2422 2423 2424 2425 2426 |
int result, numChars, charLimit = INT_MAX;
unsigned short ch;
if (flags & TCL_ENCODING_CHAR_LIMIT) {
charLimit = *dstCharsPtr;
}
result = TCL_OK;
| > > | | > > > > | | 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 |
int result, numChars, charLimit = INT_MAX;
unsigned short ch;
if (flags & TCL_ENCODING_CHAR_LIMIT) {
charLimit = *dstCharsPtr;
}
result = TCL_OK;
/* check alignment with utf-16 (2 == sizeof(UTF-16)) */
if ((srcLen % 2) != 0) {
result = TCL_CONVERT_MULTIBYTE;
srcLen--;
}
/* If last code point is a high surrogate, we cannot handle that yet */
if ((srcLen >= 2) && ((src[srcLen - (clientData?1:2)] & 0xFC) == 0xD8)) {
result = TCL_CONVERT_MULTIBYTE;
srcLen-= 2;
}
srcStart = src;
srcEnd = src + srcLen;
dstStart = dst;
dstEnd = dst + dstLen - TCL_UTF_MAX;
|
| ︙ | ︙ | |||
3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 |
int *dstCharsPtr) /* Filled with the number of characters that
* correspond to the bytes stored in the
* output buffer. */
{
const char *srcStart, *srcEnd, *srcClose;
const char *dstStart, *dstEnd;
int result, numChars;
result = TCL_OK;
srcStart = src;
srcEnd = src + srcLen;
srcClose = srcEnd;
if ((flags & TCL_ENCODING_END) == 0) {
srcClose -= TCL_UTF_MAX;
}
dstStart = dst;
dstEnd = dst + dstLen - 1;
for (numChars = 0; src < srcEnd; numChars++) {
| > < | 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 |
int *dstCharsPtr) /* Filled with the number of characters that
* correspond to the bytes stored in the
* output buffer. */
{
const char *srcStart, *srcEnd, *srcClose;
const char *dstStart, *dstEnd;
int result, numChars;
Tcl_UniChar ch = 0;
result = TCL_OK;
srcStart = src;
srcEnd = src + srcLen;
srcClose = srcEnd;
if ((flags & TCL_ENCODING_END) == 0) {
srcClose -= TCL_UTF_MAX;
}
dstStart = dst;
dstEnd = dst + dstLen - 1;
for (numChars = 0; src < srcEnd; numChars++) {
int len;
if ((src > srcClose) && (!Tcl_UtfCharComplete(src, srcEnd - src))) {
/*
* If there is more string to follow, this will ensure that the
* last UTF-8 character in the source buffer hasn't been cut off.
*/
|
| ︙ | ︙ | |||
3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 |
const Encoding *encodingPtr;
const char *srcStart, *srcEnd, *srcClose;
const char *dstStart, *dstEnd;
int state, result, numChars;
const TableEncodingData *tableDataPtr;
const char *tablePrefixBytes;
const unsigned short *const *tableFromUnicode;
result = TCL_OK;
srcStart = src;
srcEnd = src + srcLen;
srcClose = srcEnd;
if ((flags & TCL_ENCODING_END) == 0) {
| > | 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 |
const Encoding *encodingPtr;
const char *srcStart, *srcEnd, *srcClose;
const char *dstStart, *dstEnd;
int state, result, numChars;
const TableEncodingData *tableDataPtr;
const char *tablePrefixBytes;
const unsigned short *const *tableFromUnicode;
Tcl_UniChar ch = 0;
result = TCL_OK;
srcStart = src;
srcEnd = src + srcLen;
srcClose = srcEnd;
if ((flags & TCL_ENCODING_END) == 0) {
|
| ︙ | ︙ | |||
3465 3466 3467 3468 3469 3470 3471 |
tablePrefixBytes = tableDataPtr->prefixBytes;
tableFromUnicode = (const unsigned short *const *)
tableDataPtr->fromUnicode;
for (numChars = 0; src < srcEnd; numChars++) {
unsigned len;
int word;
| < | 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 |
tablePrefixBytes = tableDataPtr->prefixBytes;
tableFromUnicode = (const unsigned short *const *)
tableDataPtr->fromUnicode;
for (numChars = 0; src < srcEnd; numChars++) {
unsigned len;
int word;
if ((src > srcClose) && (!Tcl_UtfCharComplete(src, srcEnd - src))) {
/*
* If there is more string to follow, this will ensure that the
* last UTF-8 character in the source buffer hasn't been cut off.
*/
|
| ︙ | ︙ |
Changes to generic/tclEvent.c.
| ︙ | ︙ | |||
987 988 989 990 991 992 993 |
TclpExit(status);
Tcl_Panic("OS exit failed!");
}
/*
*-------------------------------------------------------------------------
*
| | | 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 |
TclpExit(status);
Tcl_Panic("OS exit failed!");
}
/*
*-------------------------------------------------------------------------
*
* Tcl_InitSubsystems --
*
* Initialize various subsytems in Tcl. This should be called the first
* time an interp is created, or before any of the subsystems are used.
* This function ensures an order for the initialization of subsystems:
*
* 1. that cannot be initialized in lazy order because they are mutually
* dependent.
|
| ︙ | ︙ | |||
1019 1020 1021 1022 1023 1024 1025 |
const TclStubs *stubs;
const char version[12];
} stubInfo = {
&tclStubs, TCL_PATCH_LEVEL
};
const char *
| | | | 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 |
const TclStubs *stubs;
const char version[12];
} stubInfo = {
&tclStubs, TCL_PATCH_LEVEL
};
const char *
Tcl_InitSubsystems(void)
{
if (inExit != 0) {
Tcl_Panic("Tcl_InitSubsystems called while exiting");
}
if (subsystemsInitialized == 0) {
/*
* Double check inside the mutex. There are definitly calls back into
* this routine from some of the functions below.
*/
|
| ︙ | ︙ |
Changes to generic/tclExecute.c.
| ︙ | ︙ | |||
2008 2009 2010 2011 2012 2013 2014 |
/*
* Transfer variables - needed only between opcodes, but not while
* executing an instruction.
*/
int cleanup = PTR2INT(data[2]);
Tcl_Obj *objResultPtr;
| | | | 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 |
/*
* Transfer variables - needed only between opcodes, but not while
* executing an instruction.
*/
int cleanup = PTR2INT(data[2]);
Tcl_Obj *objResultPtr;
int checkInterp = 0; /* Indicates when a check of interp readyness
* is necessary. Set by CACHE_STACK_INFO() */
/*
* Locals - variables that are used within opcodes or bounded sections of
* the file (jumps between opcodes within a family).
* NOTE: These are now mostly defined locally where needed.
*/
Tcl_Obj *objPtr, *valuePtr, *value2Ptr, *part1Ptr, *part2Ptr, *tmpPtr;
Tcl_Obj **objv = NULL;
int objc = 0;
int opnd, length, pcAdjustment;
Var *varPtr, *arrayPtr;
#ifdef TCL_COMPILE_DEBUG
char cmdNameBuf[21];
#endif
|
| ︙ | ︙ | |||
2043 2044 2045 2046 2047 2048 2049 |
fprintf(stdout, " Starting stack top=%d\n", (int) CURR_DEPTH);
fflush(stdout);
}
#endif
if (!pc) {
/* bytecode is starting from scratch */
| < | 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 |
fprintf(stdout, " Starting stack top=%d\n", (int) CURR_DEPTH);
fflush(stdout);
}
#endif
if (!pc) {
/* bytecode is starting from scratch */
pc = codePtr->codeStart;
goto cleanup0;
} else {
/* resume from invocation */
CACHE_STACK_INFO();
NRE_ASSERT(iPtr->cmdFramePtr == bcFramePtr);
|
| ︙ | ︙ | |||
2065 2066 2067 2068 2069 2070 2071 |
TclArgumentBCRelease(interp, bcFramePtr);
}
if (iPtr->execEnvPtr->rewind) {
result = TCL_ERROR;
goto abnormalReturn;
}
if (codePtr->flags & TCL_BYTECODE_RECOMPILE) {
| < > > | 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 |
TclArgumentBCRelease(interp, bcFramePtr);
}
if (iPtr->execEnvPtr->rewind) {
result = TCL_ERROR;
goto abnormalReturn;
}
if (codePtr->flags & TCL_BYTECODE_RECOMPILE) {
codePtr->flags &= ~TCL_BYTECODE_RECOMPILE;
checkInterp = 1;
iPtr->flags |= ERR_ALREADY_LOGGED;
}
if (result != TCL_OK) {
pc--;
goto processExceptionReturn;
}
|
| ︙ | ︙ | |||
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 |
goto cleanup0;
default:
cleanup -= 2;
while (cleanup--) {
objPtr = POP_OBJECT();
TclDecrRefCount(objPtr);
}
case 2:
cleanup2_pushObjResultPtr:
objPtr = POP_OBJECT();
TclDecrRefCount(objPtr);
case 1:
cleanup1_pushObjResultPtr:
objPtr = OBJ_AT_TOS;
TclDecrRefCount(objPtr);
}
OBJ_AT_TOS = objResultPtr;
goto cleanup0;
cleanupV:
switch (cleanup) {
default:
cleanup -= 2;
while (cleanup--) {
objPtr = POP_OBJECT();
TclDecrRefCount(objPtr);
}
case 2:
cleanup2:
objPtr = POP_OBJECT();
TclDecrRefCount(objPtr);
case 1:
cleanup1:
objPtr = POP_OBJECT();
TclDecrRefCount(objPtr);
case 0:
/*
* We really want to do nothing now, but this is needed for some
* compilers (SunPro CC).
*/
break;
| > > > > > | 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 |
goto cleanup0;
default:
cleanup -= 2;
while (cleanup--) {
objPtr = POP_OBJECT();
TclDecrRefCount(objPtr);
}
/* FALLTHRU */
case 2:
cleanup2_pushObjResultPtr:
objPtr = POP_OBJECT();
TclDecrRefCount(objPtr);
/* FALLTHRU */
case 1:
cleanup1_pushObjResultPtr:
objPtr = OBJ_AT_TOS;
TclDecrRefCount(objPtr);
}
OBJ_AT_TOS = objResultPtr;
goto cleanup0;
cleanupV:
switch (cleanup) {
default:
cleanup -= 2;
while (cleanup--) {
objPtr = POP_OBJECT();
TclDecrRefCount(objPtr);
}
/* FALLTHRU */
case 2:
cleanup2:
objPtr = POP_OBJECT();
TclDecrRefCount(objPtr);
/* FALLTHRU */
case 1:
cleanup1:
objPtr = POP_OBJECT();
TclDecrRefCount(objPtr);
/* FALLTHRU */
case 0:
/*
* We really want to do nothing now, but this is needed for some
* compilers (SunPro CC).
*/
break;
|
| ︙ | ︙ | |||
2241 2242 2243 2244 2245 2246 2247 |
} else if (inst == INST_START_CMD) {
/*
* Peephole: do not run INST_START_CMD, just skip it
*/
iPtr->cmdCount += TclGetUInt4AtPtr(pc+5);
if (checkInterp) {
| < > | 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 |
} else if (inst == INST_START_CMD) {
/*
* Peephole: do not run INST_START_CMD, just skip it
*/
iPtr->cmdCount += TclGetUInt4AtPtr(pc+5);
if (checkInterp) {
if (((codePtr->compileEpoch != iPtr->compileEpoch) ||
(codePtr->nsEpoch != iPtr->varFramePtr->nsPtr->resolverEpoch)) &&
!(codePtr->flags & TCL_BYTECODE_PRECOMPILED)) {
goto instStartCmdFailed;
}
checkInterp = 0;
}
inst = *(pc += 9);
goto peepholeStart;
} else if (inst == INST_NOP) {
#ifndef TCL_COMPILE_DEBUG
while (inst == INST_NOP)
#endif
|
| ︙ | ︙ | |||
2680 2681 2682 2683 2684 2685 2686 |
return TclNRExecuteByteCode(interp, newCodePtr);
}
/*
* INVOCATION BLOCK
*/
| < > > > > | | 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 |
return TclNRExecuteByteCode(interp, newCodePtr);
}
/*
* INVOCATION BLOCK
*/
case INST_EVAL_STK:
instEvalStk:
bcFramePtr->data.tebc.pc = (char *) pc;
iPtr->cmdFramePtr = bcFramePtr;
cleanup = 1;
pc += 1;
/* yield next instruction */
TEBC_YIELD();
/* add TEBCResume for object at top of stack */
return TclNRExecuteByteCode(interp,
TclCompileObj(interp, OBJ_AT_TOS, NULL, 0));
case INST_INVOKE_EXPANDED:
CLANG_ASSERT(auxObjList);
objc = CURR_DEPTH - PTR2INT(auxObjList->internalRep.twoPtrValue.ptr2);
POP_TAUX_OBJ();
if (objc) {
pcAdjustment = 1;
|
| ︙ | ︙ | |||
7392 7393 7394 7395 7396 7397 7398 |
*/
instStartCmdFailed:
{
const char *bytes;
size_t xxx1length;
| < > > > > | < | > | | > | < | 7400 7401 7402 7403 7404 7405 7406 7407 7408 7409 7410 7411 7412 7413 7414 7415 7416 7417 7418 7419 7420 7421 7422 7423 7424 7425 7426 7427 7428 7429 |
*/
instStartCmdFailed:
{
const char *bytes;
size_t xxx1length;
xxx1length = 0;
if (TclInterpReady(interp) == TCL_ERROR) {
goto gotError;
}
/*
* We used to switch to direct eval; for NRE-awareness we now
* compile and eval the command so that this evaluation does not
* add a new TEBC instance. Bug [2910748], bug [fa6bf38d07]
*
* TODO: recompile, search this command and eval a code starting from,
* so that this evaluation does not add a new TEBC instance without
* NRE-trampoline.
*/
codePtr->flags |= TCL_BYTECODE_RECOMPILE;
bytes = GetSrcInfoForPc(pc, codePtr, &xxx1length, NULL, NULL);
opnd = TclGetUInt4AtPtr(pc+1);
pc += (opnd-1);
assert(bytes);
PUSH_OBJECT(Tcl_NewStringObj(bytes, xxx1length));
goto instEvalStk;
|
| ︙ | ︙ |
Changes to generic/tclIOSock.c.
| ︙ | ︙ | |||
26 27 28 29 30 31 32 |
static const char *
gai_strerror(
int code)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (tsdPtr->initialized) {
| | > | | 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 |
static const char *
gai_strerror(
int code)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (tsdPtr->initialized) {
Tcl_DStringSetLength(&tsdPtr->errorMsg, 0);
} else {
Tcl_DStringInit(&tsdPtr->errorMsg);
tsdPtr->initialized = 1;
}
Tcl_WCharToUtfDString(gai_strerrorW(code), -1, &tsdPtr->errorMsg);
return Tcl_DStringValue(&tsdPtr->errorMsg);
}
#endif
/*
*---------------------------------------------------------------------------
*
|
| ︙ | ︙ |
Changes to generic/tclInt.h.
| ︙ | ︙ | |||
2999 3000 3001 3002 3003 3004 3005 | Tcl_Interp *interp); MODULE_SCOPE void TclInitEncodingSubsystem(void); MODULE_SCOPE void TclInitIOSubsystem(void); MODULE_SCOPE void TclInitLimitSupport(Tcl_Interp *interp); MODULE_SCOPE void TclInitNamespaceSubsystem(void); MODULE_SCOPE void TclInitNotifier(void); MODULE_SCOPE void TclInitObjSubsystem(void); | < | 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 | Tcl_Interp *interp); MODULE_SCOPE void TclInitEncodingSubsystem(void); MODULE_SCOPE void TclInitIOSubsystem(void); MODULE_SCOPE void TclInitLimitSupport(Tcl_Interp *interp); MODULE_SCOPE void TclInitNamespaceSubsystem(void); MODULE_SCOPE void TclInitNotifier(void); MODULE_SCOPE void TclInitObjSubsystem(void); MODULE_SCOPE int TclInterpReady(Tcl_Interp *interp); MODULE_SCOPE int TclIsSpaceProc(int byte); 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); |
| ︙ | ︙ | |||
3169 3170 3171 3172 3173 3174 3175 | const char *trim, size_t numTrim); MODULE_SCOPE size_t TclTrimRight(const char *bytes, size_t numBytes, const char *trim, size_t numTrim); MODULE_SCOPE const char*TclGetCommandTypeName(Tcl_Command command); MODULE_SCOPE void TclRegisterCommandTypeName( Tcl_ObjCmdProc *implementationProc, const char *nameStr); | < < < < < < < < < < < | 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 | const char *trim, size_t numTrim); MODULE_SCOPE size_t TclTrimRight(const char *bytes, size_t numBytes, const char *trim, size_t numTrim); MODULE_SCOPE const char*TclGetCommandTypeName(Tcl_Command command); MODULE_SCOPE void TclRegisterCommandTypeName( Tcl_ObjCmdProc *implementationProc, const char *nameStr); MODULE_SCOPE int TclUtfCmp(const char *cs, const char *ct); MODULE_SCOPE int TclUtfCasecmp(const char *cs, const char *ct); MODULE_SCOPE size_t TclUtfCount(int ch); 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, |
| ︙ | ︙ | |||
4573 4574 4575 4576 4577 4578 4579 4580 4581 4582 4583 4584 4585 4586 4587 4588 4589 4590 | * string handling. The macro's expression result is 1 for the 1-byte case or * the result of Tcl_UtfToUniChar. The ANSI C "prototype" for this macro is: * * MODULE_SCOPE int TclUtfToUniChar(const char *string, Tcl_UniChar *ch); *---------------------------------------------------------------- */ #define TclUtfToUniChar(str, chPtr) \ ((((unsigned char) *(str)) < 0x80) ? \ ((*(chPtr) = (unsigned char) *(str)), 1) \ : Tcl_UtfToUniChar(str, chPtr)) /* *---------------------------------------------------------------- * Macro counterpart of the Tcl_NumUtfChars() function. To be used in speed- * -sensitive points where it pays to avoid a function call in the common case * of counting along a string of all one-byte characters. The ANSI C * "prototype" for this macro is: | > > > > > > > | 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 | * string handling. The macro's expression result is 1 for the 1-byte case or * the result of Tcl_UtfToUniChar. The ANSI C "prototype" for this macro is: * * MODULE_SCOPE int TclUtfToUniChar(const char *string, Tcl_UniChar *ch); *---------------------------------------------------------------- */ #if TCL_UTF_MAX > 4 #define TclUtfToUniChar(str, chPtr) \ ((((unsigned char) *(str)) < 0x80) ? \ ((*(chPtr) = (unsigned char) *(str)), 1) \ : Tcl_UtfToUniChar(str, chPtr)) #else #define TclUtfToUniChar(str, chPtr) \ ((((unsigned char) *(str)) < 0x80) ? \ ((*(chPtr) = (unsigned char) *(str)), 1) \ : Tcl_UtfToChar16(str, chPtr)) #endif /* *---------------------------------------------------------------- * Macro counterpart of the Tcl_NumUtfChars() function. To be used in speed- * -sensitive points where it pays to avoid a function call in the common case * of counting along a string of all one-byte characters. The ANSI C * "prototype" for this macro is: |
| ︙ | ︙ |
Changes to generic/tclInterp.c.
| ︙ | ︙ | |||
3287 3288 3289 3290 3291 3292 3293 |
* place, but...)
*/
/*
* No env array in a safe slave.
*/
| | | | | | 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 |
* place, but...)
*/
/*
* No env array in a safe slave.
*/
Tcl_UnsetVar2(interp, "env", NULL, TCL_GLOBAL_ONLY);
/*
* Remove unsafe parts of tcl_platform
*/
Tcl_UnsetVar2(interp, "tcl_platform", "os", TCL_GLOBAL_ONLY);
Tcl_UnsetVar2(interp, "tcl_platform", "osVersion", TCL_GLOBAL_ONLY);
Tcl_UnsetVar2(interp, "tcl_platform", "machine", TCL_GLOBAL_ONLY);
Tcl_UnsetVar2(interp, "tcl_platform", "user", TCL_GLOBAL_ONLY);
/*
* Unset path informations variables (the only one remaining is [info
* nameofexecutable])
*/
Tcl_UnsetVar2(interp, "tclDefaultLibrary", NULL, TCL_GLOBAL_ONLY);
Tcl_UnsetVar2(interp, "tcl_library", NULL, TCL_GLOBAL_ONLY);
Tcl_UnsetVar2(interp, "tcl_pkgPath", NULL, TCL_GLOBAL_ONLY);
/*
* Remove the standard channels from the interpreter; safe interpreters do
* not ordinarily have access to stdin, stdout and stderr.
*
* NOTE: These channels are not added to the interpreter by the
* Tcl_CreateInterp call, but may be added later, by another I/O
|
| ︙ | ︙ |
Changes to generic/tclMain.c.
| ︙ | ︙ | |||
13 14 15 16 17 18 19 | * Copyright (c) 2000 Ajuba Solutions. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* | | | | < < < < < < < < < < | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 | * Copyright (c) 2000 Ajuba Solutions. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * On Windows, this file needs to be compiled twice, once with UNICODE and * _UNICODE defined. This way both Tcl_Main and Tcl_MainExW can be * implemented, sharing the same source code. */ #include "tclInt.h" /* * The default prompt used when the user has not overridden it. */ #define DEFAULT_PRIMARY_PROMPT "% " |
| ︙ | ︙ | |||
49 50 51 52 53 54 55 | #ifndef _WIN32 # define TCHAR char # define TEXT(arg) arg # define _tcscmp strcmp #endif | < < < < < < < < < | < | < < | | < | 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 |
#ifndef _WIN32
# define TCHAR char
# define TEXT(arg) arg
# define _tcscmp strcmp
#endif
static inline Tcl_Obj *
NewNativeObj(
TCHAR *string)
{
Tcl_DString ds;
#ifdef UNICODE
Tcl_DStringInit(&ds);
Tcl_WCharToUtfDString(string, -1, &ds);
#else
Tcl_ExternalToUtfDString(NULL, (char *) string, -1, &ds);
#endif
return TclDStringToObj(&ds);
}
/*
* Declarations for various library functions and variables (don't want to
* include tclPort.h here, because people might copy this file out of the Tcl
* source directory to make their own modified versions).
*/
|
| ︙ | ︙ | |||
137 138 139 140 141 142 143 | */ MODULE_SCOPE Tcl_MainLoopProc *TclGetMainLoop(void); static void Prompt(Tcl_Interp *interp, InteractiveState *isPtr); static void StdinProc(ClientData clientData, int mask); static void FreeMainInterp(ClientData clientData); | | | 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 | */ MODULE_SCOPE Tcl_MainLoopProc *TclGetMainLoop(void); static void Prompt(Tcl_Interp *interp, InteractiveState *isPtr); static void StdinProc(ClientData clientData, int mask); static void FreeMainInterp(ClientData clientData); #if !defined(_WIN32) || defined(UNICODE) static Tcl_ThreadDataKey dataKey; /* *---------------------------------------------------------------------- * * Tcl_SetStartupScript -- * |
| ︙ | ︙ | |||
282 283 284 285 286 287 288 |
}
}
}
}
Tcl_DStringFree(&temp);
}
}
| | | 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 |
}
}
}
}
Tcl_DStringFree(&temp);
}
}
#endif /* !UNICODE */
/*----------------------------------------------------------------------
*
* Tcl_MainEx --
*
* Main program for tclsh and most other Tcl-based applications.
*
|
| ︙ | ︙ | |||
344 345 346 347 348 349 350 |
* -encoding ENCODING FILENAME
* or like
* FILENAME
*/
if ((argc > 3) && (0 == _tcscmp(TEXT("-encoding"), argv[1]))
&& ('-' != argv[3][0])) {
| | | | | | | 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 |
* -encoding ENCODING FILENAME
* or like
* FILENAME
*/
if ((argc > 3) && (0 == _tcscmp(TEXT("-encoding"), argv[1]))
&& ('-' != argv[3][0])) {
Tcl_Obj *value = NewNativeObj(argv[2]);
Tcl_SetStartupScript(NewNativeObj(argv[3]),
TclGetString(value));
Tcl_DecrRefCount(value);
argc -= 3;
argv += 3;
} else if ((argc > 1) && ('-' != argv[1][0])) {
Tcl_SetStartupScript(NewNativeObj(argv[1]), NULL);
argc--;
argv++;
}
}
path = Tcl_GetStartupScript(&encodingName);
if (path == NULL) {
appName = NewNativeObj(argv[0]);
} else {
appName = path;
}
Tcl_SetVar2Ex(interp, "argv0", NULL, appName, TCL_GLOBAL_ONLY);
argc--;
argv++;
Tcl_SetVar2Ex(interp, "argc", NULL, Tcl_NewIntObj(argc), TCL_GLOBAL_ONLY);
argvPtr = Tcl_NewListObj(0, NULL);
while (argc--) {
Tcl_ListObjAppendElement(NULL, argvPtr, NewNativeObj(*argv++));
}
Tcl_SetVar2Ex(interp, "argv", NULL, argvPtr, TCL_GLOBAL_ONLY);
/*
* Set the "tcl_interactive" variable.
*/
|
| ︙ | ︙ | |||
638 639 640 641 642 643 644 |
* maybe we've blown up because of an exceeded limit. We still want to
* cleanup and exit.
*/
Tcl_Exit(exitCode);
}
| | | 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 |
* maybe we've blown up because of an exceeded limit. We still want to
* cleanup and exit.
*/
Tcl_Exit(exitCode);
}
#if !defined(_WIN32) || defined(UNICODE)
/*
*---------------------------------------------------------------
*
* Tcl_SetMainLoop --
*
* Sets an alternative main loop function.
|
| ︙ | ︙ | |||
729 730 731 732 733 734 735 |
finalize = ((fin != NULL) && strcmp(fin, "0"));
if (fin != NULL) {
Tcl_DStringFree(&ds);
}
return finalize;
#endif /* PURIFY */
}
| | | 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 |
finalize = ((fin != NULL) && strcmp(fin, "0"));
if (fin != NULL) {
Tcl_DStringFree(&ds);
}
return finalize;
#endif /* PURIFY */
}
#endif /* UNICODE */
/*
*----------------------------------------------------------------------
*
* StdinProc --
*
* This function is invoked by the event dispatcher whenever standard
|
| ︙ | ︙ |
Changes to generic/tclObj.c.
| ︙ | ︙ | |||
2496 2497 2498 2499 2500 2501 2502 |
char *dst = Tcl_InitStringRep( objPtr, NULL, TCL_INTEGER_SPACE);
TclOOM(dst, TCL_INTEGER_SPACE + 1);
(void) Tcl_InitStringRep(objPtr, NULL,
TclFormatInt(dst, objPtr->internalRep.wideValue));
}
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 |
char *dst = Tcl_InitStringRep( objPtr, NULL, TCL_INTEGER_SPACE);
TclOOM(dst, TCL_INTEGER_SPACE + 1);
(void) Tcl_InitStringRep(objPtr, NULL,
TclFormatInt(dst, objPtr->internalRep.wideValue));
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetLongFromObj --
*
* Attempt to return an long integer from the Tcl object "objPtr". If the
* object is not already an int object, an attempt will be made to
|
| ︙ | ︙ |
Changes to generic/tclPanic.c.
| ︙ | ︙ | |||
42 43 44 45 46 47 48 |
*/
const char *
Tcl_SetPanicProc(
TCL_NORETURN1 Tcl_PanicProc *proc)
{
panicProc = proc;
| | | 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 |
*/
const char *
Tcl_SetPanicProc(
TCL_NORETURN1 Tcl_PanicProc *proc)
{
panicProc = proc;
return Tcl_InitSubsystems();
}
/*
*----------------------------------------------------------------------
*
* Tcl_Panic --
*
|
| ︙ | ︙ |
Changes to generic/tclPipe.c.
| ︙ | ︙ | |||
409 410 411 412 413 414 415 |
TclFile *inPipePtr, /* If non-NULL, input to the pipeline comes
* from a pipe (unless overridden by
* redirection in the command). The file id
* with which to write to this pipe is stored
* at *inPipePtr. NULL means command specified
* its own input source. */
TclFile *outPipePtr, /* If non-NULL, output to the pipeline goes to
| | | 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 |
TclFile *inPipePtr, /* If non-NULL, input to the pipeline comes
* from a pipe (unless overridden by
* redirection in the command). The file id
* with which to write to this pipe is stored
* at *inPipePtr. NULL means command specified
* its own input source. */
TclFile *outPipePtr, /* If non-NULL, output to the pipeline goes to
* a pipe, unless overridden by redirection in
* the command. The file id with which to read
* frome this pipe is stored at *outPipePtr.
* NULL means command specified its own output
* sink. */
TclFile *errFilePtr) /* If non-NULL, all stderr output from the
* pipeline will go to a temporary file
* created here, and a descriptor to read the
|
| ︙ | ︙ |
Changes to generic/tclPlatDecls.h.
| ︙ | ︙ | |||
46 47 48 49 50 51 52 |
extern "C" {
#endif
/*
* Exported function declarations:
*/
| < < < < < < < < < < < < < < < < < < > > > > > | | | 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 |
extern "C" {
#endif
/*
* Exported function declarations:
*/
#ifdef MAC_OSX_TCL /* MACOSX */
/* 0 */
EXTERN int Tcl_MacOSXOpenBundleResources(Tcl_Interp *interp,
const char *bundleName, int hasResourceFile,
size_t maxPathLen, char *libraryPath);
/* 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 */
int (*tcl_MacOSXOpenBundleResources) (Tcl_Interp *interp, const char *bundleName, int hasResourceFile, size_t maxPathLen, char *libraryPath); /* 0 */
int (*tcl_MacOSXOpenVersionedBundleResources) (Tcl_Interp *interp, const char *bundleName, const char *bundleVersion, int hasResourceFile, size_t maxPathLen, char *libraryPath); /* 1 */
#endif /* MACOSX */
} TclPlatStubs;
extern const TclPlatStubs *tclPlatStubsPtr;
#ifdef __cplusplus
}
#endif
#if defined(USE_TCL_STUBS)
/*
* Inline function declarations:
*/
#ifdef MAC_OSX_TCL /* MACOSX */
#define Tcl_MacOSXOpenBundleResources \
(tclPlatStubsPtr->tcl_MacOSXOpenBundleResources) /* 0 */
#define Tcl_MacOSXOpenVersionedBundleResources \
(tclPlatStubsPtr->tcl_MacOSXOpenVersionedBundleResources) /* 1 */
#endif /* MACOSX */
#endif /* defined(USE_TCL_STUBS) */
/* !END!: Do not edit above this line. */
#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS DLLIMPORT
#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.
| ︙ | ︙ | |||
804 805 806 807 808 809 810 |
ir.wideValue = level;
Tcl_StoreIntRep(objPtr, &levelReferenceType, &ir);
result = 1;
}
} else {
result = -1;
}
| | > > | > > > > > | | < | | | 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 |
ir.wideValue = level;
Tcl_StoreIntRep(objPtr, &levelReferenceType, &ir);
result = 1;
}
} else {
result = -1;
}
} else if (TclGetWideBitsFromObj(NULL, objPtr, &w) == TCL_OK) {
/*
* If this were an integer, we'd have succeeded already.
* Docs say we have to treat this as a 'bad level' error.
*/
result = -1;
}
}
if (result != -1) {
/* if relative current level */
if (result == 0) {
if (!curLevel) {
/* we are in top-level, so simply generate bad level */
name = "1";
goto badLevel;
}
level = curLevel - 1;
}
if (level >= 0) {
CallFrame *framePtr;
for (framePtr = iPtr->varFramePtr; framePtr != NULL;
framePtr = framePtr->callerVarPtr) {
if (framePtr->level == level) {
*framePtrPtr = framePtr;
return result;
}
}
}
}
badLevel:
if (name == NULL) {
name = objPtr ? TclGetString(objPtr) : "1" ;
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf("bad level \"%s\"", name));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LEVEL", name, NULL);
return -1;
}
/*
|
| ︙ | ︙ | |||
1839 1840 1841 1842 1843 1844 1845 | Tcl_SetObjResult(interp, Tcl_ObjPrintf( "invoked \"%s\" outside of a loop", ((result == TCL_BREAK) ? "break" : "continue"))); Tcl_SetErrorCode(interp, "TCL", "RESULT", "UNEXPECTED", NULL); result = TCL_ERROR; | | < < | 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 |
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"invoked \"%s\" outside of a loop",
((result == TCL_BREAK) ? "break" : "continue")));
Tcl_SetErrorCode(interp, "TCL", "RESULT", "UNEXPECTED", NULL);
result = TCL_ERROR;
/* FALLTHRU */
case TCL_ERROR:
/*
* Now it _must_ be an error, so we need to log it as such. This means
* filling out the error trace. Luckily, we just hand this off to the
* function handed to us as an argument.
*/
|
| ︙ | ︙ |
Changes to generic/tclRegexp.c.
| ︙ | ︙ | |||
720 721 722 723 724 725 726 |
{
char buf[100]; /* ample in practice */
char cbuf[TCL_INTEGER_SPACE];
size_t n;
const char *p;
Tcl_ResetResult(interp);
| | | | 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 |
{
char buf[100]; /* ample in practice */
char cbuf[TCL_INTEGER_SPACE];
size_t n;
const char *p;
Tcl_ResetResult(interp);
n = TclReError(status, buf, sizeof(buf));
p = (n > sizeof(buf)) ? "..." : "";
Tcl_SetObjResult(interp, Tcl_ObjPrintf("%s%s%s", msg, buf, p));
sprintf(cbuf, "%d", status);
(void) TclReError(REG_ITOA, cbuf, sizeof(cbuf));
Tcl_SetErrorCode(interp, "REGEXP", cbuf, buf, NULL);
}
/*
*----------------------------------------------------------------------
*
* FreeRegexpInternalRep --
|
| ︙ | ︙ |
Changes to generic/tclScan.c.
| ︙ | ︙ | |||
359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 |
case 'l':
if (*format == 'l') {
flags |= SCAN_BIG;
format += 1;
format += TclUtfToUniChar(format, &ch);
break;
}
case 'L':
flags |= SCAN_LONGER;
case 'h':
format += TclUtfToUniChar(format, &ch);
}
if (!(flags & SCAN_SUPPRESS) && numVars && (objIndex >= numVars)) {
goto badIndex;
}
| > > | 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 |
case 'l':
if (*format == 'l') {
flags |= SCAN_BIG;
format += 1;
format += TclUtfToUniChar(format, &ch);
break;
}
/* FALLTHRU */
case 'L':
flags |= SCAN_LONGER;
/* FALLTHRU */
case 'h':
format += TclUtfToUniChar(format, &ch);
}
if (!(flags & SCAN_SUPPRESS) && numVars && (objIndex >= numVars)) {
goto badIndex;
}
|
| ︙ | ︙ | |||
382 383 384 385 386 387 388 |
if (flags & SCAN_WIDTH) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"field width may not be specified in %c conversion",
-1));
Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADWIDTH", NULL);
goto error;
}
| | < < | 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 |
if (flags & SCAN_WIDTH) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"field width may not be specified in %c conversion",
-1));
Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADWIDTH", NULL);
goto error;
}
/* FALLTHRU */
case 'n':
case 's':
if (flags & (SCAN_LONGER|SCAN_BIG)) {
invalidFieldSize:
buf[Tcl_UniCharToUtf(ch, buf)] = '\0';
errorMsg = Tcl_NewStringObj(
"field size modifier may not be specified in %", -1);
|
| ︙ | ︙ | |||
699 700 701 702 703 704 705 706 707 |
case 'l':
if (*format == 'l') {
flags |= SCAN_BIG;
format += 1;
format += TclUtfToUniChar(format, &ch);
break;
}
case 'L':
flags |= SCAN_LONGER;
| > | < < | 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 |
case 'l':
if (*format == 'l') {
flags |= SCAN_BIG;
format += 1;
format += TclUtfToUniChar(format, &ch);
break;
}
/* FALLTHRU */
case 'L':
flags |= SCAN_LONGER;
/* FALLTHRU */
case 'h':
format += TclUtfToUniChar(format, &ch);
}
/*
* Handle the various field types.
*/
|
| ︙ | ︙ |
Changes to generic/tclStringObj.c.
| ︙ | ︙ | |||
1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 |
segment = Tcl_NewStringObj(buf, length);
Tcl_IncrRefCount(segment);
allocSegment = 1;
break;
}
case 'u':
case 'd':
case 'o':
case 'p':
case 'x':
case 'X':
case 'b': {
short s = 0; /* Silence compiler warning; only defined and
| > | 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 |
segment = Tcl_NewStringObj(buf, length);
Tcl_IncrRefCount(segment);
allocSegment = 1;
break;
}
case 'u':
/* FALLTHRU */
case 'd':
case 'o':
case 'p':
case 'x':
case 'X':
case 'b': {
short s = 0; /* Silence compiler warning; only defined and
|
| ︙ | ︙ | |||
2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 |
break;
case 'L':
size = 3;
p++;
break;
case 'h':
size = -1;
default:
p++;
}
} while (seekingConversion);
}
TclListObjGetElements(NULL, list, &objc, &objv);
code = Tcl_AppendFormatToObj(NULL, objPtr, format, objc, objv);
| > | 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 |
break;
case 'L':
size = 3;
p++;
break;
case 'h':
size = -1;
/* FALLTHRU */
default:
p++;
}
} while (seekingConversion);
}
TclListObjGetElements(NULL, list, &objc, &objv);
code = Tcl_AppendFormatToObj(NULL, objPtr, format, objc, objv);
|
| ︙ | ︙ |
Name change from generic/tclStubInitSubsystems.c to generic/tclStubCall.c.
1 | /* | | < < < < < < > > | > > > > > | | > > > > > > > > | > | | > > > | | | > > | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 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 |
/*
* tclStubCall.c --
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
#ifndef _WIN32
# include <dlfcn.h>
#else
# define dlopen(a,b) (void *)LoadLibrary(TEXT(a))
# define dlsym(a,b) (void *)GetProcAddress((HANDLE)(a),b)
# define dlerror() ""
#endif
MODULE_SCOPE void *tclStubsHandle;
/*
*----------------------------------------------------------------------
*
* Tcl_InitSubsystems --
*
* Load the Tcl core dynamically, version "9.0" (or higher, in future versions)
*
* Results:
* Outputs the value of the "version" argument.
*
* Side effects:
* Sets the stub table pointers.
*
*----------------------------------------------------------------------
*/
static const char PROCNAME[][24] = {
"_Tcl_InitSubsystems",
"_Tcl_FindExecutable",
"_Tcl_SetPanicProc",
"_TclZipfs_AppHook"
};
MODULE_SCOPE const char *
TclStubCall(int index, void *arg1, void *arg2)
{
static const char *(*stubFn[])(void *,void *) = {NULL,NULL,NULL,NULL};
static const char *version = NULL;
if (tclStubsHandle == (void *)-1) {
if (index == 2 && arg1 != NULL) {
((Tcl_PanicProc *)arg1)("Cannot call %s from stubbed extension\n", PROCNAME[index] + 1);
} else {
fprintf(stderr, "Cannot call %s from stubbed extension\n", PROCNAME[index] + 1);
abort();
}
}
if (!stubFn[index]) {
if (!tclStubsHandle) {
tclStubsHandle = dlopen(TCL_DLL_FILE, RTLD_NOW|RTLD_LOCAL);
if (!tclStubsHandle) {
if (index == 2 && arg1 != NULL) {
((Tcl_PanicProc *)arg1)("Cannot find " TCL_DLL_FILE ": %s\n", dlerror());
} else {
fprintf(stderr, "Cannot find " TCL_DLL_FILE ": %s\n", dlerror());
abort();
}
}
}
stubFn[index] = dlsym(tclStubsHandle, PROCNAME[index] + 1);
if (!stubFn[index]) {
stubFn[index] = dlsym(tclStubsHandle, PROCNAME[index]);
}
if (stubFn[index]) {
version = stubFn[index](arg1, arg2);
}
}
return version;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Deleted generic/tclStubFindExecutable.c.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Changes to generic/tclStubInit.c.
| ︙ | ︙ | |||
40 41 42 43 44 45 46 47 48 49 50 51 52 53 | #undef Tcl_DumpActiveMemory #undef Tcl_ValidateAllMemory #undef Tcl_SetExitProc #undef Tcl_SetPanicProc #undef TclpGetPid #undef TclStaticPackage #undef Tcl_BackgroundError #define TclStaticPackage Tcl_StaticPackage #ifdef TCL_MEM_DEBUG # define Tcl_Alloc TclpAlloc # define Tcl_Free TclpFree # define Tcl_Realloc TclpRealloc # undef Tcl_AttemptAlloc | > > > | 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 | #undef Tcl_DumpActiveMemory #undef Tcl_ValidateAllMemory #undef Tcl_SetExitProc #undef Tcl_SetPanicProc #undef TclpGetPid #undef TclStaticPackage #undef Tcl_BackgroundError #undef Tcl_UtfToUniChar #undef Tcl_UtfToUniCharDString #undef Tcl_UniCharToUtfDString #define TclStaticPackage Tcl_StaticPackage #ifdef TCL_MEM_DEBUG # define Tcl_Alloc TclpAlloc # define Tcl_Free TclpFree # define Tcl_Realloc TclpRealloc # undef Tcl_AttemptAlloc |
| ︙ | ︙ | |||
100 101 102 103 104 105 106 |
size_t
TclpGetPid(Tcl_Pid pid)
{
return (size_t) pid;
}
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 103 104 105 106 107 108 109 110 111 112 113 114 115 116 |
size_t
TclpGetPid(Tcl_Pid pid)
{
return (size_t) pid;
}
#if defined(TCL_WIDE_INT_IS_LONG)
/* On Cygwin64, long is 64-bit while on Win64 long is 32-bit. Therefore
* we have to make sure that all stub entries on Cygwin64 follow the Win64
* signature. Tcl 9 must find a better solution, but that cannot be done
* without introducing a binary incompatibility.
*/
static int exprInt(Tcl_Interp *interp, const char *expr, int *ptr){
|
| ︙ | ︙ | |||
564 565 566 567 568 569 570 |
TclUnixOpenTemporaryFile, /* 30 */
#endif /* MACOSX */
};
static const TclPlatStubs tclPlatStubs = {
TCL_STUB_MAGIC,
0,
| < < < < | 536 537 538 539 540 541 542 543 544 545 546 547 548 549 |
TclUnixOpenTemporaryFile, /* 30 */
#endif /* MACOSX */
};
static const TclPlatStubs tclPlatStubs = {
TCL_STUB_MAGIC,
0,
#ifdef MAC_OSX_TCL /* MACOSX */
Tcl_MacOSXOpenBundleResources, /* 0 */
Tcl_MacOSXOpenVersionedBundleResources, /* 1 */
#endif /* MACOSX */
};
const TclTomMathStubs tclTomMathStubs = {
|
| ︙ | ︙ | |||
1026 1027 1028 1029 1030 1031 1032 |
Tcl_UtfFindLast, /* 329 */
Tcl_UtfNext, /* 330 */
Tcl_UtfPrev, /* 331 */
Tcl_UtfToExternal, /* 332 */
Tcl_UtfToExternalDString, /* 333 */
Tcl_UtfToLower, /* 334 */
Tcl_UtfToTitle, /* 335 */
| | | | | 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 |
Tcl_UtfFindLast, /* 329 */
Tcl_UtfNext, /* 330 */
Tcl_UtfPrev, /* 331 */
Tcl_UtfToExternal, /* 332 */
Tcl_UtfToExternalDString, /* 333 */
Tcl_UtfToLower, /* 334 */
Tcl_UtfToTitle, /* 335 */
Tcl_UtfToChar16, /* 336 */
Tcl_UtfToUpper, /* 337 */
Tcl_WriteChars, /* 338 */
Tcl_WriteObj, /* 339 */
Tcl_GetString, /* 340 */
0, /* 341 */
0, /* 342 */
Tcl_AlertNotifier, /* 343 */
Tcl_ServiceModeHook, /* 344 */
Tcl_UniCharIsAlnum, /* 345 */
Tcl_UniCharIsAlpha, /* 346 */
Tcl_UniCharIsDigit, /* 347 */
Tcl_UniCharIsLower, /* 348 */
Tcl_UniCharIsSpace, /* 349 */
Tcl_UniCharIsUpper, /* 350 */
Tcl_UniCharIsWordChar, /* 351 */
Tcl_UniCharLen, /* 352 */
Tcl_UniCharNcmp, /* 353 */
Tcl_Char16ToUtfDString, /* 354 */
Tcl_UtfToChar16DString, /* 355 */
Tcl_GetRegExpFromObj, /* 356 */
0, /* 357 */
Tcl_FreeParse, /* 358 */
Tcl_LogCommandInfo, /* 359 */
Tcl_ParseBraces, /* 360 */
Tcl_ParseCommand, /* 361 */
Tcl_ParseExpr, /* 362 */
|
| ︙ | ︙ | |||
1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 |
Tcl_StoreIntRep, /* 639 */
Tcl_HasStringRep, /* 640 */
Tcl_IncrRefCount, /* 641 */
Tcl_DecrRefCount, /* 642 */
Tcl_IsShared, /* 643 */
Tcl_LinkArray, /* 644 */
Tcl_GetIntForIndex, /* 645 */
};
/* !END!: Do not edit above this line. */
| > > > | 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 |
Tcl_StoreIntRep, /* 639 */
Tcl_HasStringRep, /* 640 */
Tcl_IncrRefCount, /* 641 */
Tcl_DecrRefCount, /* 642 */
Tcl_IsShared, /* 643 */
Tcl_LinkArray, /* 644 */
Tcl_GetIntForIndex, /* 645 */
Tcl_UtfToUniChar, /* 646 */
Tcl_UniCharToUtfDString, /* 647 */
Tcl_UtfToUniCharDString, /* 648 */
};
/* !END!: Do not edit above this line. */
|
Changes to generic/tclStubLib.c.
| ︙ | ︙ | |||
13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 | #include "tclInt.h" MODULE_SCOPE const TclStubs *tclStubsPtr; MODULE_SCOPE const TclPlatStubs *tclPlatStubsPtr; MODULE_SCOPE const TclIntStubs *tclIntStubsPtr; MODULE_SCOPE const TclIntPlatStubs *tclIntPlatStubsPtr; const TclStubs *tclStubsPtr = NULL; const TclPlatStubs *tclPlatStubsPtr = NULL; const TclIntStubs *tclIntStubsPtr = NULL; const TclIntPlatStubs *tclIntPlatStubsPtr = NULL; /* * Use our own ISDIGIT to avoid linking to libc on windows */ #define ISDIGIT(c) (((unsigned)((c)-'0')) <= 9) | > > | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 | #include "tclInt.h" MODULE_SCOPE const TclStubs *tclStubsPtr; MODULE_SCOPE const TclPlatStubs *tclPlatStubsPtr; MODULE_SCOPE const TclIntStubs *tclIntStubsPtr; MODULE_SCOPE const TclIntPlatStubs *tclIntPlatStubsPtr; MODULE_SCOPE void *tclStubsHandle; const TclStubs *tclStubsPtr = NULL; const TclPlatStubs *tclPlatStubsPtr = NULL; const TclIntStubs *tclIntStubsPtr = NULL; const TclIntPlatStubs *tclIntPlatStubsPtr = NULL; void *tclStubsHandle = NULL; /* * Use our own ISDIGIT to avoid linking to libc on windows */ #define ISDIGIT(c) (((unsigned)((c)-'0')) <= 9) |
| ︙ | ︙ | |||
100 101 102 103 104 105 106 107 108 109 110 111 112 113 |
return NULL;
}
}
}
if (((exact&0xff00) < 0x900)) {
/* We are running Tcl 8.x */
stubsPtr = (TclStubs *)pkgData;
}
tclStubsPtr = stubsPtr;
if (stubsPtr->hooks) {
tclPlatStubsPtr = stubsPtr->hooks->tclPlatStubs;
tclIntStubsPtr = stubsPtr->hooks->tclIntStubs;
tclIntPlatStubsPtr = stubsPtr->hooks->tclIntPlatStubs;
| > > > | 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 |
return NULL;
}
}
}
if (((exact&0xff00) < 0x900)) {
/* We are running Tcl 8.x */
stubsPtr = (TclStubs *)pkgData;
}
if (tclStubsHandle == NULL) {
tclStubsHandle = (void *) -1;
}
tclStubsPtr = stubsPtr;
if (stubsPtr->hooks) {
tclPlatStubsPtr = stubsPtr->hooks->tclPlatStubs;
tclIntStubsPtr = stubsPtr->hooks->tclIntStubs;
tclIntPlatStubsPtr = stubsPtr->hooks->tclIntPlatStubs;
|
| ︙ | ︙ |
Changes to generic/tclStubLibTbl.c.
| ︙ | ︙ | |||
30 31 32 33 34 35 36 |
*----------------------------------------------------------------------
*/
MODULE_SCOPE const char *
TclInitStubTable(
const char *version) /* points to the version field of a
structure variable. */
{
| > | | | | | | | | | > | 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 |
*----------------------------------------------------------------------
*/
MODULE_SCOPE const char *
TclInitStubTable(
const char *version) /* points to the version field of a
structure variable. */
{
if (version) {
tclStubsPtr = ((const TclStubs **) version)[-1];
if (tclStubsPtr->hooks) {
tclPlatStubsPtr = tclStubsPtr->hooks->tclPlatStubs;
tclIntStubsPtr = tclStubsPtr->hooks->tclIntStubs;
tclIntPlatStubsPtr = tclStubsPtr->hooks->tclIntPlatStubs;
} else {
tclPlatStubsPtr = NULL;
tclIntStubsPtr = NULL;
tclIntPlatStubsPtr = NULL;
}
}
return version;
}
/*
* Local Variables:
|
| ︙ | ︙ |
Added generic/tclStubMainEx.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 |
/*
* tclStubMainEx.c --
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
#ifndef _WIN32
# include <dlfcn.h>
#else
# define dlopen(a,b) (void *)LoadLibrary(TEXT(a))
# define dlsym(a,b) (void *)GetProcAddress((HANDLE)(a),b)
# define dlerror() ""
#endif
MODULE_SCOPE void *tclStubsHandle;
/*
*----------------------------------------------------------------------
*
* Tcl_InitSubsystems --
*
* Load the Tcl core dynamically, version "9.0" (or higher, in future versions)
*
* Results:
* Outputs the value of the "version" argument.
*
* Side effects:
* Sets the stub table pointers.
*
*----------------------------------------------------------------------
*/
static const char PROCNAME[][24] = {
"_Tcl_MainEx",
"_Tcl_MainExW"
};
MODULE_SCOPE void
TclStubMainEx(int index, int argc, const void *argv,
Tcl_AppInitProc *appInitProc, Tcl_Interp *interp)
{
static void(*stubFn[])(int, const void *, Tcl_AppInitProc *, Tcl_Interp *) = {NULL,NULL};
if (!stubFn[index]) {
if (tclStubsHandle == (void *)-1) {
fprintf(stderr, "Cannot call %s from stubbed extension\n", PROCNAME[index] + 1);
abort();
}
if (!tclStubsHandle) {
tclStubsHandle = dlopen(TCL_DLL_FILE, RTLD_NOW|RTLD_LOCAL);
if (!tclStubsHandle) {
tclStubsPtr->tcl_Panic("Cannot find " TCL_DLL_FILE ": %s\n", dlerror());
}
}
stubFn[index] = dlsym(tclStubsHandle, PROCNAME[index] + 1);
if (!stubFn[index]) {
stubFn[index] = dlsym(tclStubsHandle, PROCNAME[index]);
}
if (stubFn[index]) {
stubFn[index](argc, argv, appInitProc, interp);
}
}
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Deleted generic/tclStubSetPanicProc.c.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Added generic/tclStubStaticPackage.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 |
/*
* tclStubStaticPackage.c --
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
#ifndef _WIN32
# include <dlfcn.h>
#else
# define dlopen(a,b) (void *)LoadLibrary(TEXT(a))
# define dlsym(a,b) (void *)GetProcAddress((HANDLE)(a),b)
# define dlerror() ""
#endif
MODULE_SCOPE void *tclStubsHandle;
/*
*----------------------------------------------------------------------
*
* Tcl_InitSubsystems --
*
* Load the Tcl core dynamically, version "9.0" (or higher, in future versions)
*
* Results:
* Outputs the value of the "version" argument.
*
* Side effects:
* Sets the stub table pointers.
*
*----------------------------------------------------------------------
*/
static const char PROCNAME[] = "_Tcl_StaticPackage";
MODULE_SCOPE const char *
TclStubStaticPackage(Tcl_Interp *interp,
const char *pkgName,
Tcl_PackageInitProc *initProc,
Tcl_PackageInitProc *safeInitProc)
{
static const char *(*stubFn)(Tcl_Interp *, const char *, Tcl_PackageInitProc *, Tcl_PackageInitProc *) = NULL;
static const char *version = NULL;
if (tclStubsHandle == (void *)-1) {
fprintf(stderr, "Cannot call %s from stubbed extension\n", PROCNAME + 1);
abort();
}
if (!stubFn) {
if (!tclStubsHandle) {
tclStubsHandle = dlopen(TCL_DLL_FILE, RTLD_NOW|RTLD_LOCAL);
if (!tclStubsHandle) {
tclStubsPtr->tcl_Panic("Cannot find " TCL_DLL_FILE ": %s\n", dlerror());
}
}
stubFn = dlsym(tclStubsHandle, PROCNAME + 1);
if (!stubFn) {
stubFn = dlsym(tclStubsHandle, PROCNAME);
}
if (stubFn) {
version = stubFn(interp, pkgName, initProc, safeInitProc);
}
}
return version;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclTest.c.
| ︙ | ︙ | |||
216 217 218 219 220 221 222 223 224 225 226 227 228 229 | Tcl_Obj *const objv[]); static void ObjTraceDeleteProc(void *clientData); static void PrintParse(Tcl_Interp *interp, Tcl_Parse *parsePtr); static void SpecialFree(void *blockPtr); static int StaticInitProc(Tcl_Interp *interp); static int TestasyncCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); static int TestbytestringObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int TestpurebytesobjObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int TeststringbytesObjCmd(void *clientData, | > > > | 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 | Tcl_Obj *const objv[]); static void ObjTraceDeleteProc(void *clientData); static void PrintParse(Tcl_Interp *interp, Tcl_Parse *parsePtr); static void SpecialFree(void *blockPtr); static int StaticInitProc(Tcl_Interp *interp); static int TestasyncCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); static int TestbumpinterpepochObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int TestbytestringObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int TestpurebytesobjObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int TeststringbytesObjCmd(void *clientData, |
| ︙ | ︙ | |||
380 381 382 383 384 385 386 387 388 389 390 391 392 393 | Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int TestSimpleFilesystemObjCmd( void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static void TestReport(const char *cmd, Tcl_Obj *arg1, Tcl_Obj *arg2); static Tcl_Obj * TestReportGetNativePath(Tcl_Obj *pathPtr); static Tcl_FSStatProc TestReportStat; static Tcl_FSAccessProc TestReportAccess; static Tcl_FSOpenFileChannelProc TestReportOpenFileChannel; static Tcl_FSMatchInDirectoryProc TestReportMatchInDirectory; static Tcl_FSChdirProc TestReportChdir; static Tcl_FSLstatProc TestReportLstat; | > > > > > > | 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 | Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int TestSimpleFilesystemObjCmd( void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static void TestReport(const char *cmd, Tcl_Obj *arg1, Tcl_Obj *arg2); static int TestgetencpathObjCmd(void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int TestsetencpathObjCmd(void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static Tcl_Obj * TestReportGetNativePath(Tcl_Obj *pathPtr); static Tcl_FSStatProc TestReportStat; static Tcl_FSAccessProc TestReportAccess; static Tcl_FSOpenFileChannelProc TestReportOpenFileChannel; static Tcl_FSMatchInDirectoryProc TestReportMatchInDirectory; static Tcl_FSChdirProc TestReportChdir; static Tcl_FSLstatProc TestReportLstat; |
| ︙ | ︙ | |||
592 593 594 595 596 597 598 599 600 601 602 603 604 605 |
Tcl_CreateObjCommand(interp, "testfilesystem", TestFilesystemObjCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testsimplefilesystem", TestSimpleFilesystemObjCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testgetindexfromobjstruct",
TestGetIndexFromObjStructObjCmd, NULL, NULL);
Tcl_CreateCommand(interp, "testasync", TestasyncCmd, NULL, NULL);
Tcl_CreateCommand(interp, "testchannel", TestChannelCmd,
NULL, NULL);
Tcl_CreateCommand(interp, "testchannelevent", TestChannelEventCmd,
NULL, NULL);
Tcl_CreateCommand(interp, "testcmdtoken", TestcmdtokenCmd, NULL,
NULL);
Tcl_CreateCommand(interp, "testcmdinfo", TestcmdinfoCmd, NULL,
| > > | 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 |
Tcl_CreateObjCommand(interp, "testfilesystem", TestFilesystemObjCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testsimplefilesystem", TestSimpleFilesystemObjCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testgetindexfromobjstruct",
TestGetIndexFromObjStructObjCmd, NULL, NULL);
Tcl_CreateCommand(interp, "testasync", TestasyncCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testbumpinterpepoch",
TestbumpinterpepochObjCmd, NULL, NULL);
Tcl_CreateCommand(interp, "testchannel", TestChannelCmd,
NULL, NULL);
Tcl_CreateCommand(interp, "testchannelevent", TestChannelEventCmd,
NULL, NULL);
Tcl_CreateCommand(interp, "testcmdtoken", TestcmdtokenCmd, NULL,
NULL);
Tcl_CreateCommand(interp, "testcmdinfo", TestcmdinfoCmd, NULL,
|
| ︙ | ︙ | |||
721 722 723 724 725 726 727 728 729 730 731 732 733 734 |
NULL, NULL);
#endif
Tcl_CreateObjCommand(interp, "testnreunwind", TestNREUnwind,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testnrelevels", TestNRELevels,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testinterpresolver", TestInterpResolverCmd,
NULL, NULL);
if (TclObjTest_Init(interp) != TCL_OK) {
return TCL_ERROR;
}
if (Procbodytest_Init(interp) != TCL_OK) {
return TCL_ERROR;
| > > > > | 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 |
NULL, NULL);
#endif
Tcl_CreateObjCommand(interp, "testnreunwind", TestNREUnwind,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testnrelevels", TestNRELevels,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testinterpresolver", TestInterpResolverCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testgetencpath", TestgetencpathObjCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testsetencpath", TestsetencpathObjCmd,
NULL, NULL);
if (TclObjTest_Init(interp) != TCL_OK) {
return TCL_ERROR;
}
if (Procbodytest_Init(interp) != TCL_OK) {
return TCL_ERROR;
|
| ︙ | ︙ | |||
1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 |
}
}
Tcl_MutexUnlock(&asyncTestMutex);
Tcl_ExitThread(TCL_OK);
TCL_THREAD_CREATE_RETURN;
}
#endif
/*
*----------------------------------------------------------------------
*
* TestcmdinfoCmd --
*
* This procedure implements the "testcmdinfo" command. It is used to
| > > > > > > > > > > > > > > > > | 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 |
}
}
Tcl_MutexUnlock(&asyncTestMutex);
Tcl_ExitThread(TCL_OK);
TCL_THREAD_CREATE_RETURN;
}
#endif
static int
TestbumpinterpepochObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Interp *iPtr = (Interp *)interp;
if (objc != 1) {
Tcl_WrongNumArgs(interp, 1, objv, "");
return TCL_ERROR;
}
iPtr->compileEpoch++;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestcmdinfoCmd --
*
* This procedure implements the "testcmdinfo" command. It is used to
|
| ︙ | ︙ | |||
7512 7513 7514 7515 7516 7517 7518 7519 7520 7521 7522 7523 7524 7525 |
if (result == TCL_OK) {
Tcl_ResetResult(interp);
}
return result;
}
/*
*----------------------------------------------------------------------
*
* TestparseargsCmd --
*
* This procedure implements the "testparseargs" command. It is used to
* test that Tcl_ParseArgsObjv does indeed return the right number of
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 7543 7544 7545 7546 7547 7548 7549 7550 7551 7552 7553 7554 7555 7556 7557 7558 7559 7560 7561 7562 7563 7564 7565 7566 7567 7568 7569 7570 7571 7572 7573 7574 7575 7576 7577 7578 7579 7580 7581 7582 7583 7584 7585 7586 7587 7588 7589 7590 7591 7592 7593 7594 7595 7596 7597 7598 7599 7600 7601 7602 7603 7604 7605 7606 7607 7608 7609 7610 7611 7612 7613 7614 7615 7616 7617 7618 7619 7620 7621 7622 |
if (result == TCL_OK) {
Tcl_ResetResult(interp);
}
return result;
}
/*
*----------------------------------------------------------------------
*
* TestgetencpathObjCmd --
*
* This function implements the "testgetencpath" command. It is used to
* test Tcl_GetEncodingSearchPath().
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
TestgetencpathObjCmd(
ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Argument strings. */
{
if (objc != 1) {
Tcl_WrongNumArgs(interp, 1, objv, "");
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_GetEncodingSearchPath());
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestsetencpathCmd --
*
* This function implements the "testsetencpath" command. It is used to
* test Tcl_SetDefaultEncodingDir().
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
TestsetencpathObjCmd(
ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Argument strings. */
{
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "defaultDir");
return TCL_ERROR;
}
Tcl_SetEncodingSearchPath(objv[1]);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestparseargsCmd --
*
* This procedure implements the "testparseargs" command. It is used to
* test that Tcl_ParseArgsObjv does indeed return the right number of
|
| ︙ | ︙ |
Changes to generic/tclThreadAlloc.c.
| ︙ | ︙ | |||
1032 1033 1034 1035 1036 1037 1038 | /* *---------------------------------------------------------------------- * * TclInitThreadAlloc -- * * Initializes the allocator cache-maintenance structures. | | | 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 | /* *---------------------------------------------------------------------- * * TclInitThreadAlloc -- * * Initializes the allocator cache-maintenance structures. * It is done early and protected during the Tcl_InitSubsystems(). * * Results: * None. * * Side effects: * None. * |
| ︙ | ︙ |
Changes to generic/tclUtf.c.
| ︙ | ︙ | |||
217 218 219 220 221 222 223 224 225 | * * Side effects: * None. * *--------------------------------------------------------------------------- */ char * Tcl_UniCharToUtfDString( | > | | < | < > > > > > > > > > > > < < | < < < < < < < < < < < | | | < | | > > > > > > > > > > > > | | 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 |
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
#undef Tcl_UniCharToUtfDString
char *
Tcl_UniCharToUtfDString(
const int *uniStr, /* Unicode string to convert to UTF-8. */
size_t uniLength, /* Length of Unicode string. */
Tcl_DString *dsPtr) /* UTF-8 representation of string is appended
* to this previously initialized DString. */
{
const int *w, *wEnd;
char *p, *string;
size_t oldLength;
/*
* UTF-8 string length in bytes will be <= Unicode string length * 4.
*/
if (uniStr == NULL) {
return NULL;
}
if (uniLength == TCL_AUTO_LENGTH) {
uniLength = 0;
w = uniStr;
while (*w != '\0') {
uniLength++;
w++;
}
}
oldLength = Tcl_DStringLength(dsPtr);
Tcl_DStringSetLength(dsPtr, oldLength + (uniLength + 1) * 4);
string = Tcl_DStringValue(dsPtr) + oldLength;
p = string;
wEnd = uniStr + uniLength;
for (w = uniStr; w < wEnd; ) {
p += Tcl_UniCharToUtf(*w, p);
w++;
}
Tcl_DStringSetLength(dsPtr, oldLength + (p - string));
return string;
}
char *
Tcl_Char16ToUtfDString(
const unsigned short *uniStr,/* Utf-16 string to convert to UTF-8. */
size_t uniLength, /* Length of Utf-16 string. */
Tcl_DString *dsPtr) /* UTF-8 representation of string is appended
* to this previously initialized DString. */
{
const unsigned short *w, *wEnd;
char *p, *string;
size_t oldLength;
int len = 1;
/*
* UTF-8 string length in bytes will be <= Utf16 string length * 3.
*/
if (uniStr == NULL) {
return NULL;
}
if (uniLength == TCL_AUTO_LENGTH) {
uniLength = 0;
w = uniStr;
while (*w != '\0') {
uniLength++;
w++;
}
}
oldLength = Tcl_DStringLength(dsPtr);
Tcl_DStringSetLength(dsPtr, oldLength + (uniLength + 1) * 3);
string = Tcl_DStringValue(dsPtr) + oldLength;
p = string;
wEnd = uniStr + uniLength;
for (w = uniStr; w < wEnd; ) {
if (!len && ((*w & 0xFC00) != 0xDC00)) {
/* Special case for handling high surrogates. */
|
| ︙ | ︙ | |||
305 306 307 308 309 310 311 |
/* Special case for handling high surrogates. */
p += Tcl_UniCharToUtf(-1, p);
}
Tcl_DStringSetLength(dsPtr, oldLength + (p - string));
return string;
}
| < | | 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 |
/* Special case for handling high surrogates. */
p += Tcl_UniCharToUtf(-1, p);
}
Tcl_DStringSetLength(dsPtr, oldLength + (p - string));
return string;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_UtfToUniChar --
*
* Extract the Tcl_UniChar represented by the UTF-8 string. Bad UTF-8
* sequences are converted to valid Tcl_UniChars and processing
* continues. Equivalent to Plan 9 chartorune().
*
* The caller must ensure that the source buffer is long enough that this
* routine does not run off the end and dereference non-existent memory
* looking for trail bytes. If the source buffer is known to be '\0'
* terminated, this cannot happen. Otherwise, the caller should call
* Tcl_UtfCharComplete() before calling this routine to ensure that
* enough bytes remain in the string.
*
* If TCL_UTF_MAX <= 4, special handling of Surrogate pairs is done:
* For any UTF-8 string containing a character outside of the BMP, the
* first call to this function will fill *chPtr with the high surrogate
* and generate a return value of 1. Calling Tcl_UtfToUniChar again
* will produce the low surrogate and a return value of 3. Because *chPtr
* is used to remember whether the high surrogate is already produced, it
* is recommended to initialize the variable it points to as 0 before
* the first call to Tcl_UtfToUniChar is done.
|
| ︙ | ︙ | |||
348 349 350 351 352 353 354 355 356 357 |
static const unsigned short cp1252[32] = {
0x20ac, 0x81, 0x201A, 0x0192, 0x201E, 0x2026, 0x2020, 0x2021,
0x02C6, 0x2030, 0x0160, 0x2039, 0x0152, 0x8D, 0x017D, 0x8F,
0x90, 0x2018, 0x2019, 0x201C, 0x201D, 0x2022, 0x2013, 0x2014,
0x2DC, 0x2122, 0x0161, 0x203A, 0x0153, 0x9D, 0x017E, 0x0178
};
int
Tcl_UtfToUniChar(
const char *src, /* The UTF-8 string. */
| > | | < < < < < < < < < < < < < < | 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 |
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 unsigned int represented by
* the UTF-8 string. */
{
int byte;
/*
* Unroll 1 to 4 byte UTF-8 sequences.
*/
byte = *((unsigned char *) src);
if (byte < 0xC0) {
/*
* Handles properly formed UTF-8 characters between 0x01 and 0x7F.
* Treats naked trail bytes 0x80 to 0x9F as valid characters from
* the cp1252 table. See: <https://en.wikipedia.org/wiki/UTF-8>
* Also treats \0 and other naked trail bytes 0xA0 to 0xBF as valid
* characters representing themselves.
*/
if ((unsigned)(byte-0x80) < (unsigned)0x20) {
*chPtr = cp1252[byte-0x80];
} else {
*chPtr = byte;
}
return 1;
} else if (byte < 0xE0) {
|
| ︙ | ︙ | |||
429 430 431 432 433 434 435 |
*/
}
else if (byte < 0xF8) {
if (((src[1] & 0xC0) == 0x80) && ((src[2] & 0xC0) == 0x80) && ((src[3] & 0xC0) == 0x80)) {
/*
* Four-byte-character lead byte followed by three trail bytes.
*/
| < < < < < < < < < < < < < | | | | 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 |
*/
}
else if (byte < 0xF8) {
if (((src[1] & 0xC0) == 0x80) && ((src[2] & 0xC0) == 0x80) && ((src[3] & 0xC0) == 0x80)) {
/*
* Four-byte-character lead byte followed by three trail bytes.
*/
*chPtr = (((byte & 0x07) << 18) | ((src[1] & 0x3F) << 12)
| ((src[2] & 0x3F) << 6) | (src[3] & 0x3F));
if ((unsigned)(*chPtr - 0x10000) <= 0xFFFFF) {
return 4;
}
}
/*
* A four-byte-character lead-byte not followed by three trail-bytes
* represents itself.
*/
}
*chPtr = byte;
return 1;
}
int
Tcl_UtfToChar16(
const char *src, /* The UTF-8 string. */
unsigned short *chPtr)/* Filled with the unsigned short represented by
* the UTF-8 string. */
{
unsigned short byte;
/*
* Unroll 1 to 4 byte UTF-8 sequences.
*/
byte = *((unsigned char *) src);
if (byte < 0xC0) {
|
| ︙ | ︙ | |||
538 539 540 541 542 543 544 |
*/
}
else if (byte < 0xF8) {
if (((src[1] & 0xC0) == 0x80) && ((src[2] & 0xC0) == 0x80) && ((src[3] & 0xC0) == 0x80)) {
/*
* Four-byte-character lead byte followed by three trail bytes.
*/
| | < | > | > > > | | | | | < | > | > > > | | | | < | 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 |
*/
}
else if (byte < 0xF8) {
if (((src[1] & 0xC0) == 0x80) && ((src[2] & 0xC0) == 0x80) && ((src[3] & 0xC0) == 0x80)) {
/*
* Four-byte-character lead byte followed by three trail bytes.
*/
unsigned short high = (((byte & 0x07) << 8) | ((src[1] & 0x3F) << 2)
| ((src[2] & 0x3F) >> 4)) - 0x40;
if (high >= 0x400) {
/* out of range, < 0x10000 or > 0x10ffff */
} else {
/* produce high surrogate, advance source pointer */
*chPtr = 0xD800 + high;
return 1;
}
}
/*
* A four-byte-character lead-byte not followed by three trail-bytes
* represents itself.
*/
}
*chPtr = byte;
return 1;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_UtfToUniCharDString --
*
* Convert the UTF-8 string to Unicode.
*
* Results:
* The return value is a pointer to the Unicode representation of the
* UTF-8 string. Storage for the return value is appended to the end of
* dsPtr. The Unicode string is terminated with a Unicode NULL character.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
#undef Tcl_UtfToUniCharDString
int *
Tcl_UtfToUniCharDString(
const char *src, /* UTF-8 string to convert to Unicode. */
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, *end;
size_t oldLength;
if (src == NULL) {
return NULL;
}
if (length == TCL_AUTO_LENGTH) {
length = strlen(src);
}
/*
* Unicode string length in Tcl_UniChars will be <= UTF-8 string length in
* bytes.
*/
oldLength = Tcl_DStringLength(dsPtr);
Tcl_DStringSetLength(dsPtr,
oldLength + ((length + 1) * sizeof(int)));
wString = (int *) (Tcl_DStringValue(dsPtr) + oldLength);
w = wString;
p = src;
end = src + length - 4;
while (p < end) {
p += Tcl_UtfToUniChar(p, &ch);
*w++ = ch;
}
end += 4;
while (p < end) {
if (Tcl_UtfCharComplete(p, end-p)) {
p += Tcl_UtfToUniChar(p, &ch);
} else {
ch = UCHAR(*p++);
}
*w++ = ch;
}
*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;
unsigned short *w, *wString;
const char *p, *end;
size_t oldLength;
if (src == NULL) {
return NULL;
}
if (length == TCL_AUTO_LENGTH) {
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;
end = src + length - 4;
while (p < end) {
p += Tcl_UtfToChar16(p, &ch);
*w++ = ch;
}
end += 4;
while (p < end) {
if (Tcl_UtfCharComplete(p, end-p)) {
p += Tcl_UtfToChar16(p, &ch);
} else {
ch = UCHAR(*p++);
}
*w++ = ch;
}
*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
|
| ︙ | ︙ | |||
799 800 801 802 803 804 805 |
int fullchar;
Tcl_UniChar find = 0;
while (1) {
len = TclUtfToUniChar(src, &find);
fullchar = find;
#if TCL_UTF_MAX <= 4
| | | 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 |
int fullchar;
Tcl_UniChar find = 0;
while (1) {
len = TclUtfToUniChar(src, &find);
fullchar = find;
#if TCL_UTF_MAX <= 4
if ((fullchar != ch) && (find >= 0xD800) && (len < 3)) {
len += TclUtfToUniChar(src + len, &find);
fullchar = (((fullchar & 0x3ff) << 10) | (find & 0x3ff)) + 0x10000;
}
#endif
if (fullchar == ch) {
return src;
}
|
| ︙ | ︙ | |||
848 849 850 851 852 853 854 |
const char *last;
last = NULL;
while (1) {
len = TclUtfToUniChar(src, &find);
fullchar = find;
#if TCL_UTF_MAX <= 4
| | | 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 |
const char *last;
last = NULL;
while (1) {
len = TclUtfToUniChar(src, &find);
fullchar = find;
#if TCL_UTF_MAX <= 4
if ((fullchar != ch) && (find >= 0xD800) && (len < 3)) {
len += TclUtfToUniChar(src + len, &find);
fullchar = (((fullchar & 0x3ff) << 10) | (find & 0x3ff)) + 0x10000;
}
#endif
if (fullchar == ch) {
last = src;
}
|
| ︙ | ︙ | |||
2157 2158 2159 2160 2161 2162 2163 |
* quickly if the next char in the pattern isn't a special
* character
*/
if ((p != '[') && (p != '?') && (p != '\\')) {
if (nocase) {
while (*uniStr && (p != *uniStr)
| | | 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 |
* quickly if the next char in the pattern isn't a special
* character
*/
if ((p != '[') && (p != '?') && (p != '\\')) {
if (nocase) {
while (*uniStr && (p != *uniStr)
&& (p != Tcl_UniCharToLower(*uniStr))) {
uniStr++;
}
} else {
while (*uniStr && (p != *uniStr)) {
uniStr++;
}
}
|
| ︙ | ︙ | |||
2197 2198 2199 2200 2201 2202 2203 |
* characters separated by "-").
*/
if (p == '[') {
Tcl_UniChar startChar, endChar;
uniPattern++;
| | | | | 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 |
* characters separated by "-").
*/
if (p == '[') {
Tcl_UniChar startChar, endChar;
uniPattern++;
ch1 = (nocase ? Tcl_UniCharToLower(*uniStr) : *uniStr);
uniStr++;
while (1) {
if ((*uniPattern == ']') || (*uniPattern == 0)) {
return 0;
}
startChar = (nocase ? Tcl_UniCharToLower(*uniPattern)
: *uniPattern);
uniPattern++;
if (*uniPattern == '-') {
uniPattern++;
if (*uniPattern == 0) {
return 0;
}
endChar = (nocase ? Tcl_UniCharToLower(*uniPattern)
: *uniPattern);
uniPattern++;
if (((startChar <= ch1) && (ch1 <= endChar))
|| ((endChar <= ch1) && (ch1 <= startChar))) {
/*
* Matches ranges of form [a-z] or [z-a].
*/
|
| ︙ | ︙ | |||
2349 2350 2351 2352 2353 2354 2355 |
* quickly if the next char in the pattern isn't a special
* character.
*/
if ((p != '[') && (p != '?') && (p != '\\')) {
if (nocase) {
while ((string < stringEnd) && (p != *string)
| | | 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 |
* quickly if the next char in the pattern isn't a special
* character.
*/
if ((p != '[') && (p != '?') && (p != '\\')) {
if (nocase) {
while ((string < stringEnd) && (p != *string)
&& (p != Tcl_UniCharToLower(*string))) {
string++;
}
} else {
while ((string < stringEnd) && (p != *string)) {
string++;
}
}
|
| ︙ | ︙ | |||
2390 2391 2392 2393 2394 2395 2396 |
* characters separated by "-").
*/
if (p == '[') {
Tcl_UniChar ch1, startChar, endChar;
pattern++;
| | | | | 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 |
* characters separated by "-").
*/
if (p == '[') {
Tcl_UniChar ch1, startChar, endChar;
pattern++;
ch1 = (nocase ? Tcl_UniCharToLower(*string) : *string);
string++;
while (1) {
if ((*pattern == ']') || (pattern == patternEnd)) {
return 0;
}
startChar = (nocase ? Tcl_UniCharToLower(*pattern) : *pattern);
pattern++;
if (*pattern == '-') {
pattern++;
if (pattern == patternEnd) {
return 0;
}
endChar = (nocase ? Tcl_UniCharToLower(*pattern)
: *pattern);
pattern++;
if (((startChar <= ch1) && (ch1 <= endChar))
|| ((endChar <= ch1) && (ch1 <= startChar))) {
/*
* Matches ranges of form [a-z] or [z-a].
*/
|
| ︙ | ︙ |
Changes to generic/tclUtil.c.
| ︙ | ︙ | |||
2207 2208 2209 2210 2211 2212 2213 |
* character
*/
if ((p != '[') && (p != '?') && (p != '\\')) {
if (nocase) {
while (*str) {
charLen = TclUtfToUniChar(str, &ch1);
| | | 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 |
* character
*/
if ((p != '[') && (p != '?') && (p != '\\')) {
if (nocase) {
while (*str) {
charLen = TclUtfToUniChar(str, &ch1);
if (ch2==ch1 || ch2==Tcl_UniCharToLower(ch1)) {
break;
}
str += charLen;
}
} else {
/*
* There's no point in trying to make this code
|
| ︙ | ︙ | |||
4024 4025 4026 4027 4028 4029 4030 |
* loss of the intrep. Increment newValue refCount early to handle case
* where we set a PGV to itself.
*/
Tcl_IncrRefCount(newValue);
cacheMap = GetThreadHash(&pgvPtr->key);
ClearHash(cacheMap);
| | | 4024 4025 4026 4027 4028 4029 4030 4031 4032 4033 4034 4035 4036 4037 4038 |
* loss of the intrep. Increment newValue refCount early to handle case
* where we set a PGV to itself.
*/
Tcl_IncrRefCount(newValue);
cacheMap = GetThreadHash(&pgvPtr->key);
ClearHash(cacheMap);
hPtr = Tcl_CreateHashEntry(cacheMap, INT2PTR(pgvPtr->epoch), &dummy);
Tcl_SetHashValue(hPtr, newValue);
Tcl_MutexUnlock(&pgvPtr->mutex);
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
4084 4085 4086 4087 4088 4089 4090 |
pgvPtr->encoding = current;
Tcl_MutexUnlock(&pgvPtr->mutex);
} else {
Tcl_FreeEncoding(current);
}
}
cacheMap = GetThreadHash(&pgvPtr->key);
| | | 4084 4085 4086 4087 4088 4089 4090 4091 4092 4093 4094 4095 4096 4097 4098 |
pgvPtr->encoding = current;
Tcl_MutexUnlock(&pgvPtr->mutex);
} else {
Tcl_FreeEncoding(current);
}
}
cacheMap = GetThreadHash(&pgvPtr->key);
hPtr = Tcl_FindHashEntry(cacheMap, INT2PTR(epoch));
if (NULL == hPtr) {
int dummy;
/*
* No cache for the current epoch - must be a new one.
*
* First, clear the cacheMap, as anything in it must refer to some
|
| ︙ | ︙ | |||
4117 4118 4119 4120 4121 4122 4123 | /* * Store a copy of the shared value in our epoch-indexed cache. */ value = Tcl_NewStringObj(pgvPtr->value, pgvPtr->numBytes); hPtr = Tcl_CreateHashEntry(cacheMap, | | | 4117 4118 4119 4120 4121 4122 4123 4124 4125 4126 4127 4128 4129 4130 4131 |
/*
* Store a copy of the shared value in our epoch-indexed cache.
*/
value = Tcl_NewStringObj(pgvPtr->value, pgvPtr->numBytes);
hPtr = Tcl_CreateHashEntry(cacheMap,
INT2PTR(pgvPtr->epoch), &dummy);
Tcl_MutexUnlock(&pgvPtr->mutex);
Tcl_SetHashValue(hPtr, value);
Tcl_IncrRefCount(value);
}
return Tcl_GetHashValue(hPtr);
}
|
| ︙ | ︙ |
Changes to generic/tclZipfs.c.
| ︙ | ︙ | |||
4847 4848 4849 4850 4851 4852 4853 | * TclZipfs_AppHook -- * * Performs the argument munging for the shell * *------------------------------------------------------------------------- */ | | > > > > | > | 4847 4848 4849 4850 4851 4852 4853 4854 4855 4856 4857 4858 4859 4860 4861 4862 4863 4864 4865 4866 4867 4868 4869 4870 4871 4872 4873 4874 4875 4876 4877 4878 |
* TclZipfs_AppHook --
*
* Performs the argument munging for the shell
*
*-------------------------------------------------------------------------
*/
const char *
TclZipfs_AppHook(
int *argcPtr, /* Pointer to argc */
#ifdef _WIN32
WCHAR
#else /* !_WIN32 */
char
#endif /* _WIN32 */
***argvPtr) /* Pointer to argv */
{
char *archive;
const char *result;
#ifdef _WIN32
result = Tcl_FindExecutable(NULL);
#else /* !_WIN32 */
result = Tcl_FindExecutable((*argvPtr)[0]);
#endif /* _WIN32 */
archive = (char *) Tcl_GetNameOfExecutable();
TclZipfs_Init(NULL);
/*
* Look for init.tcl in one of the locations mounted later in this
* function.
*/
|
| ︙ | ︙ | |||
4896 4897 4898 4899 4900 4901 4902 |
TclNewLiteralStringObj(vfsInitScript,
ZIPFS_APP_MOUNT "/tcl_library/init.tcl");
Tcl_IncrRefCount(vfsInitScript);
found = Tcl_FSAccess(vfsInitScript, F_OK);
Tcl_DecrRefCount(vfsInitScript);
if (found == TCL_OK) {
zipfs_literal_tcl_library = ZIPFS_APP_MOUNT "/tcl_library";
| | > | | | 4901 4902 4903 4904 4905 4906 4907 4908 4909 4910 4911 4912 4913 4914 4915 4916 4917 4918 4919 4920 4921 4922 4923 4924 4925 4926 4927 4928 4929 4930 4931 4932 4933 4934 4935 4936 4937 4938 4939 4940 4941 4942 4943 4944 4945 4946 4947 4948 |
TclNewLiteralStringObj(vfsInitScript,
ZIPFS_APP_MOUNT "/tcl_library/init.tcl");
Tcl_IncrRefCount(vfsInitScript);
found = Tcl_FSAccess(vfsInitScript, F_OK);
Tcl_DecrRefCount(vfsInitScript);
if (found == TCL_OK) {
zipfs_literal_tcl_library = ZIPFS_APP_MOUNT "/tcl_library";
return result;
}
}
#ifdef SUPPORT_BUILTIN_ZIP_INSTALL
} else if (*argcPtr > 1) {
/*
* If the first argument is "install", run the supplied installer
* script.
*/
#ifdef _WIN32
Tcl_DString ds;
Tcl_DStringInit(&ds);
archive = Tcl_WCharToUtfDString((*argvPtr)[1], -1, &ds);
#else /* !_WIN32 */
archive = (*argvPtr)[1];
#endif /* _WIN32 */
if (strcmp(archive, "install") == 0) {
Tcl_Obj *vfsInitScript;
/*
* Run this now to ensure the file is present by the time Tcl_Main
* wants it.
*/
TclZipfs_TclLibrary();
TclNewLiteralStringObj(vfsInitScript,
ZIPFS_ZIP_MOUNT "/tcl_library/install.tcl");
Tcl_IncrRefCount(vfsInitScript);
if (Tcl_FSAccess(vfsInitScript, F_OK) == 0) {
Tcl_SetStartupScript(vfsInitScript, NULL);
}
return result;
} else if (!TclZipfs_Mount(NULL, ZIPFS_APP_MOUNT, archive, NULL)) {
int found;
Tcl_Obj *vfsInitScript;
TclNewLiteralStringObj(vfsInitScript, ZIPFS_APP_MOUNT "/main.tcl");
Tcl_IncrRefCount(vfsInitScript);
if (Tcl_FSAccess(vfsInitScript, F_OK) == 0) {
|
| ︙ | ︙ | |||
4952 4953 4954 4955 4956 4957 4958 |
TclNewLiteralStringObj(vfsInitScript,
ZIPFS_APP_MOUNT "/tcl_library/init.tcl");
Tcl_IncrRefCount(vfsInitScript);
found = Tcl_FSAccess(vfsInitScript, F_OK);
Tcl_DecrRefCount(vfsInitScript);
if (found == TCL_OK) {
zipfs_literal_tcl_library = ZIPFS_APP_MOUNT "/tcl_library";
| | | | 4958 4959 4960 4961 4962 4963 4964 4965 4966 4967 4968 4969 4970 4971 4972 4973 4974 4975 4976 4977 4978 4979 4980 |
TclNewLiteralStringObj(vfsInitScript,
ZIPFS_APP_MOUNT "/tcl_library/init.tcl");
Tcl_IncrRefCount(vfsInitScript);
found = Tcl_FSAccess(vfsInitScript, F_OK);
Tcl_DecrRefCount(vfsInitScript);
if (found == TCL_OK) {
zipfs_literal_tcl_library = ZIPFS_APP_MOUNT "/tcl_library";
return result;
}
}
#ifdef _WIN32
Tcl_DStringFree(&ds);
#endif /* _WIN32 */
#endif /* SUPPORT_BUILTIN_ZIP_INSTALL */
}
return result;
}
#ifndef HAVE_ZLIB
/*
*-------------------------------------------------------------------------
*
|
| ︙ | ︙ |
Changes to library/dde/pkgIndex.tcl.
|
| | | | 1 2 3 4 5 6 7 |
if {![package vsatisfies [package provide Tcl] 8.5-]} return
if {[info sharedlibextension] != ".dll"} return
if {[::tcl::pkgconfig get debug]} {
package ifneeded dde 1.4.1 [list load [file join $dir tcldde14g.dll] dde]
} else {
package ifneeded dde 1.4.1 [list load [file join $dir tcldde14.dll] dde]
}
|
Changes to library/http/effective_tld_names.txt.gz.
cannot compute difference between binary files
Changes to library/init.tcl.
| ︙ | ︙ | |||
612 613 614 615 616 617 618 |
return [set auto_execs($name) [list $file]]
}
}
return ""
}
set path "[file dirname [info nameof]];.;"
| | > > | 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 |
return [set auto_execs($name) [list $file]]
}
}
return ""
}
set path "[file dirname [info nameof]];.;"
if {[info exists env(SystemRoot)]} {
set windir $env(SystemRoot)
} elseif {[info exists env(WINDIR)]} {
set windir $env(WINDIR)
}
if {[info exists windir]} {
append path "$windir/system32;$windir/system;$windir;"
}
foreach var {PATH Path path} {
|
| ︙ | ︙ |
Changes to library/manifest.txt.
1 2 3 4 5 6 7 8 9 10 11 12 |
###
# Package manifest for all Tcl packages included in the /library file system
###
apply {{dir} {
set ::test [info script]
set isafe [interp issafe]
foreach {safe package version file} {
0 http 2.9.0 {http http.tcl}
1 msgcat 1.7.0 {msgcat msgcat.tcl}
1 opt 0.4.7 {opt optparse.tcl}
0 platform 1.0.14 {platform platform.tcl}
0 platform::shell 1.1.4 {platform shell.tcl}
| | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 |
###
# Package manifest for all Tcl packages included in the /library file system
###
apply {{dir} {
set ::test [info script]
set isafe [interp issafe]
foreach {safe package version file} {
0 http 2.9.0 {http http.tcl}
1 msgcat 1.7.0 {msgcat msgcat.tcl}
1 opt 0.4.7 {opt optparse.tcl}
0 platform 1.0.14 {platform platform.tcl}
0 platform::shell 1.1.4 {platform shell.tcl}
1 tcltest 2.5.1 {tcltest tcltest.tcl}
} {
if {$isafe && !$safe} continue
package ifneeded $package $version [list source [file join $dir {*}$file]]
}
}} $dir
|
Changes to library/reg/pkgIndex.tcl.
|
| | | | 1 2 3 4 5 6 7 8 9 |
if {![package vsatisfies [package provide Tcl] 8.5-]} return
if {[info sharedlibextension] != ".dll"} return
if {[::tcl::pkgconfig get debug]} {
package ifneeded registry 1.3.3 \
[list load [file join $dir tclreg13g.dll] registry]
} else {
package ifneeded registry 1.3.3 \
[list load [file join $dir tclreg13.dll] registry]
}
|
Changes to library/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.1 [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.1
# 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]
|
| ︙ | ︙ | |||
3068 3069 3070 3071 3072 3073 3074 |
}
}
if {![file isfile $fullName]} {
DebugDo 1 {
Warn "removeFile removing \"$fullName\":\n not a file"
}
}
| | > > > > > | 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 |
}
}
if {![file isfile $fullName]} {
DebugDo 1 {
Warn "removeFile removing \"$fullName\":\n not a file"
}
}
if {[catch {file delete -- $fullName} msg ]} {
DebugDo 1 {
Warn "removeFile removing \"$fullName\":\n failed: $msg"
}
}
return
}
# tcltest::makeDirectory --
#
# Create a new dir with the name <name>.
#
# If this dir hasn't been created via makeDirectory since the last time
|
| ︙ | ︙ |
Changes to library/tm.tcl.
| ︙ | ︙ | |||
307 308 309 310 311 312 313 |
#
# Sideeffects
# May add paths to the list of defaults.
proc ::tcl::tm::Defaults {} {
global env tcl_platform
| | | 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 |
#
# Sideeffects
# May add paths to the list of defaults.
proc ::tcl::tm::Defaults {} {
global env tcl_platform
regexp {^(\d+)\.(\d+)} [package provide Tcl] - major minor
set exe [file normalize [info nameofexecutable]]
# Note that we're using [::list], not [list] because [list] means
# something other than [::list] in this namespace.
roots [::list \
[file dirname [info library]] \
[file join [file dirname [file dirname $exe]] lib] \
|
| ︙ | ︙ | |||
350 351 352 353 354 355 356 |
# Results
# No result.
#
# Sideeffects
# Calls 'path add' to paths to the list of module search paths.
proc ::tcl::tm::roots {paths} {
| | | 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 |
# Results
# No result.
#
# Sideeffects
# Calls 'path add' to paths to the list of module search paths.
proc ::tcl::tm::roots {paths} {
regexp {^(\d+)\.(\d+)} [package provide Tcl] - major minor
foreach pa $paths {
set p [file join $pa tcl$major]
for {set n $minor} {$n >= 0} {incr n -1} {
set px [file join $p ${major}.${n}]
if {![interp issafe]} {set px [file normalize $px]}
path add $px
}
|
| ︙ | ︙ |
Changes to library/tzdata/America/Detroit.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Detroit) {
{-9223372036854775808 -19931 0 LMT}
{-2051202469 -21600 0 CST}
{-1724083200 -18000 0 EST}
{-883594800 -18000 0 EST}
{-880218000 -14400 1 EWT}
{-769395600 -14400 1 EPT}
{-765396000 -18000 0 EST}
{-757364400 -18000 0 EST}
{-684349200 -14400 1 EDT}
{-671047200 -18000 0 EST}
{94712400 -18000 0 EST}
{104914800 -14400 1 EDT}
{120636000 -18000 0 EST}
{126687600 -14400 1 EDT}
{152085600 -18000 0 EST}
{157784400 -18000 0 EST}
{167814000 -14400 0 EDT}
| > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Detroit) {
{-9223372036854775808 -19931 0 LMT}
{-2051202469 -21600 0 CST}
{-1724083200 -18000 0 EST}
{-883594800 -18000 0 EST}
{-880218000 -14400 1 EWT}
{-769395600 -14400 1 EPT}
{-765396000 -18000 0 EST}
{-757364400 -18000 0 EST}
{-684349200 -14400 1 EDT}
{-671047200 -18000 0 EST}
{-80506740 -14400 0 EDT}
{-68666400 -18000 0 EST}
{-52938000 -14400 1 EDT}
{-37216800 -18000 0 EST}
{-31518000 -18000 0 EST}
{94712400 -18000 0 EST}
{104914800 -14400 1 EDT}
{120636000 -18000 0 EST}
{126687600 -14400 1 EDT}
{152085600 -18000 0 EST}
{157784400 -18000 0 EST}
{167814000 -14400 0 EDT}
|
| ︙ | ︙ |
Changes to library/tzdata/America/Edmonton.
| ︙ | ︙ | |||
16 17 18 19 20 21 22 |
{-1473001200 -21600 1 MDT}
{-1459699200 -25200 0 MST}
{-880210800 -21600 1 MWT}
{-769395600 -21600 1 MPT}
{-765388800 -25200 0 MST}
{-715791600 -21600 1 MDT}
{-702489600 -25200 0 MST}
| < < < < | 16 17 18 19 20 21 22 23 24 25 26 27 28 29 |
{-1473001200 -21600 1 MDT}
{-1459699200 -25200 0 MST}
{-880210800 -21600 1 MWT}
{-769395600 -21600 1 MPT}
{-765388800 -25200 0 MST}
{-715791600 -21600 1 MDT}
{-702489600 -25200 0 MST}
{73472400 -21600 1 MDT}
{89193600 -25200 0 MST}
{104922000 -21600 1 MDT}
{120643200 -25200 0 MST}
{136371600 -21600 1 MDT}
{152092800 -25200 0 MST}
{167821200 -21600 1 MDT}
|
| ︙ | ︙ |
Changes to library/tzdata/America/Indiana/Tell_City.
1 2 3 4 5 6 7 8 9 10 11 12 13 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Indiana/Tell_City) {
{-9223372036854775808 -20823 0 LMT}
{-2717647200 -21600 0 CST}
{-1633276800 -18000 1 CDT}
{-1615136400 -21600 0 CST}
{-1601827200 -18000 1 CDT}
{-1583686800 -21600 0 CST}
{-880214400 -18000 1 CWT}
{-769395600 -18000 1 CPT}
{-765392400 -21600 0 CST}
{-757360800 -21600 0 CST}
| < < < < < < | | > | > | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Indiana/Tell_City) {
{-9223372036854775808 -20823 0 LMT}
{-2717647200 -21600 0 CST}
{-1633276800 -18000 1 CDT}
{-1615136400 -21600 0 CST}
{-1601827200 -18000 1 CDT}
{-1583686800 -21600 0 CST}
{-880214400 -18000 1 CWT}
{-769395600 -18000 1 CPT}
{-765392400 -21600 0 CST}
{-757360800 -21600 0 CST}
{-462996000 -18000 1 CDT}
{-450291600 -21600 0 CST}
{-431539200 -18000 1 CDT}
{-418237200 -21600 0 CST}
{-400089600 -18000 1 CDT}
{-386787600 -21600 0 CST}
{-368640000 -18000 1 CDT}
{-355338000 -21600 0 CST}
{-337190400 -18000 1 CDT}
{-323888400 -21600 0 CST}
{-305740800 -18000 1 CDT}
{-292438800 -21600 0 CST}
{-273686400 -18000 1 CDT}
{-257965200 -21600 0 CST}
{-242236800 -18000 1 CDT}
{-226515600 -21600 0 CST}
{-210787200 -18000 1 CDT}
{-195066000 -21600 0 CST}
{-179337600 -18000 0 EST}
{-68662800 -21600 0 CST}
{-52934400 -18000 1 CDT}
{-37213200 -21600 0 CST}
{-21484800 -14400 0 EDT}
{-5767200 -18000 0 EST}
{9961200 -14400 1 EDT}
{25682400 -18000 0 EST}
{31554000 -18000 0 EST}
{1143961200 -21600 0 CST}
{1143964800 -18000 1 CDT}
{1162105200 -21600 0 CST}
|
| ︙ | ︙ |
Changes to library/tzdata/America/Kentucky/Louisville.
| ︙ | ︙ | |||
13 14 15 16 17 18 19 |
{-905097600 -18000 1 CDT}
{-891795600 -21600 0 CST}
{-883591200 -21600 0 CST}
{-880214400 -18000 1 CWT}
{-769395600 -18000 1 CPT}
{-765392400 -21600 0 CST}
{-757360800 -21600 0 CST}
| | | < < < | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 |
{-905097600 -18000 1 CDT}
{-891795600 -21600 0 CST}
{-883591200 -21600 0 CST}
{-880214400 -18000 1 CWT}
{-769395600 -18000 1 CPT}
{-765392400 -21600 0 CST}
{-757360800 -21600 0 CST}
{-747251940 -18000 1 CDT}
{-744224400 -21600 0 CST}
{-620841600 -18000 1 CDT}
{-608144400 -21600 0 CST}
{-589392000 -18000 1 CDT}
{-576090000 -21600 0 CST}
{-557942400 -18000 1 CDT}
{-544640400 -21600 0 CST}
{-526492800 -18000 1 CDT}
{-513190800 -21600 0 CST}
|
| ︙ | ︙ | |||
41 42 43 44 45 46 47 |
{-368640000 -18000 1 CDT}
{-352918800 -21600 0 CST}
{-337190400 -18000 1 CDT}
{-321469200 -21600 0 CST}
{-305740800 -18000 1 CDT}
{-289414800 -21600 0 CST}
{-273686400 -18000 1 CDT}
| | | 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 |
{-368640000 -18000 1 CDT}
{-352918800 -21600 0 CST}
{-337190400 -18000 1 CDT}
{-321469200 -21600 0 CST}
{-305740800 -18000 1 CDT}
{-289414800 -21600 0 CST}
{-273686400 -18000 1 CDT}
{-266428800 -18000 0 EST}
{-63140400 -18000 0 EST}
{-52938000 -14400 1 EDT}
{-37216800 -18000 0 EST}
{-21488400 -14400 1 EDT}
{-5767200 -18000 0 EST}
{9961200 -14400 1 EDT}
{25682400 -18000 0 EST}
|
| ︙ | ︙ |
Changes to library/tzdata/America/Vancouver.
1 2 3 4 5 6 7 8 9 10 11 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Vancouver) {
{-9223372036854775808 -29548 0 LMT}
{-2713880852 -28800 0 PST}
{-1632060000 -25200 1 PDT}
{-1615129200 -28800 0 PST}
{-880207200 -25200 1 PWT}
{-769395600 -25200 1 PPT}
{-765385200 -28800 0 PST}
{-747237600 -25200 1 PDT}
| | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Vancouver) {
{-9223372036854775808 -29548 0 LMT}
{-2713880852 -28800 0 PST}
{-1632060000 -25200 1 PDT}
{-1615129200 -28800 0 PST}
{-880207200 -25200 1 PWT}
{-769395600 -25200 1 PPT}
{-765385200 -28800 0 PST}
{-747237600 -25200 1 PDT}
{-733935600 -28800 0 PST}
{-715788000 -25200 1 PDT}
{-702486000 -28800 0 PST}
{-684338400 -25200 1 PDT}
{-671036400 -28800 0 PST}
{-652888800 -25200 1 PDT}
{-639586800 -28800 0 PST}
{-620834400 -25200 1 PDT}
|
| ︙ | ︙ |
Changes to library/tzdata/Asia/Hong_Kong.
1 2 3 4 5 6 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Hong_Kong) {
{-9223372036854775808 27402 0 LMT}
{-2056690800 28800 0 HKT}
{-900910800 32400 1 HKST}
| | | 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/Hong_Kong) {
{-9223372036854775808 27402 0 LMT}
{-2056690800 28800 0 HKT}
{-900910800 32400 1 HKST}
{-891579600 30600 1 HKWT}
{-884248200 32400 0 JST}
{-761209200 28800 0 HKT}
{-747907200 32400 1 HKST}
{-728541000 28800 0 HKT}
{-717049800 32400 1 HKST}
{-697091400 28800 0 HKT}
{-683785800 32400 1 HKST}
|
| ︙ | ︙ |
Changes to library/tzdata/Asia/Seoul.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Seoul) {
{-9223372036854775808 30472 0 LMT}
{-1948782472 30600 0 KST}
{-1830414600 32400 0 JST}
{-767350800 32400 0 KST}
{-498128400 30600 0 KST}
{-462702600 34200 1 KDT}
{-451733400 30600 0 KST}
{-429784200 34200 1 KDT}
{-418296600 30600 0 KST}
{-399544200 34200 1 KDT}
{-387451800 30600 0 KST}
| > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Seoul) {
{-9223372036854775808 30472 0 LMT}
{-1948782472 30600 0 KST}
{-1830414600 32400 0 JST}
{-767350800 32400 0 KST}
{-681210000 36000 1 KDT}
{-672228000 32400 0 KST}
{-654771600 36000 1 KDT}
{-640864800 32400 0 KST}
{-623408400 36000 1 KDT}
{-609415200 32400 0 KST}
{-588848400 36000 1 KDT}
{-577965600 32400 0 KST}
{-498128400 30600 0 KST}
{-462702600 34200 1 KDT}
{-451733400 30600 0 KST}
{-429784200 34200 1 KDT}
{-418296600 30600 0 KST}
{-399544200 34200 1 KDT}
{-387451800 30600 0 KST}
|
| ︙ | ︙ |
Changes to library/tzdata/Europe/Brussels.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Europe/Brussels) {
{-9223372036854775808 1050 0 LMT}
{-2840141850 1050 0 BMT}
| | | 1 2 3 4 5 6 7 8 9 10 11 12 13 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Europe/Brussels) {
{-9223372036854775808 1050 0 LMT}
{-2840141850 1050 0 BMT}
{-2450995200 0 0 WET}
{-1740355200 3600 0 CET}
{-1693702800 7200 0 CEST}
{-1680483600 3600 0 CET}
{-1663455600 7200 1 CEST}
{-1650150000 3600 0 CET}
{-1632006000 7200 1 CEST}
{-1618700400 3600 0 CET}
|
| ︙ | ︙ |
Changes to library/tzdata/Europe/Istanbul.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 |
{-1522551600 7200 0 EET}
{-1507514400 10800 1 EEST}
{-1490583600 7200 0 EET}
{-1440208800 10800 1 EEST}
{-1428030000 7200 0 EET}
{-1409709600 10800 1 EEST}
{-1396494000 7200 0 EET}
| | | < < | | | < < < < < < | | | | | | | | | < < | < | | | < < < < | | | | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 |
{-1522551600 7200 0 EET}
{-1507514400 10800 1 EEST}
{-1490583600 7200 0 EET}
{-1440208800 10800 1 EEST}
{-1428030000 7200 0 EET}
{-1409709600 10800 1 EEST}
{-1396494000 7200 0 EET}
{-931053600 10800 1 EEST}
{-922676400 7200 0 EET}
{-917834400 10800 1 EEST}
{-892436400 7200 0 EET}
{-875844000 10800 1 EEST}
{-764737200 7200 0 EET}
{-744343200 10800 1 EEST}
{-733806000 7200 0 EET}
{-716436000 10800 1 EEST}
{-701924400 7200 0 EET}
{-684986400 10800 1 EEST}
{-670474800 7200 0 EET}
{-654141600 10800 1 EEST}
{-639025200 7200 0 EET}
{-622087200 10800 1 EEST}
{-606970800 7200 0 EET}
{-590032800 10800 1 EEST}
{-575521200 7200 0 EET}
{-235620000 10800 1 EEST}
{-194842800 7200 0 EET}
{-177732000 10800 1 EEST}
{-165726000 7200 0 EET}
{107910000 10800 1 EEST}
{121215600 7200 0 EET}
{133920000 10800 1 EEST}
{152665200 7200 0 EET}
{164678400 10800 1 EEST}
{184114800 7200 0 EET}
{196214400 10800 1 EEST}
{215564400 7200 0 EET}
{228873600 10800 1 EEST}
{245804400 7200 0 EET}
{260323200 10800 1 EEST}
{267919200 10800 0 +03}
{277254000 10800 0 +03}
{428454000 14400 1 +04}
{433893600 10800 0 +03}
{468111600 7200 0 EET}
{482799600 10800 1 EEST}
{496710000 7200 0 EET}
{512521200 10800 1 EEST}
{528246000 7200 0 EET}
{543970800 10800 1 EEST}
{559695600 7200 0 EET}
{575420400 10800 1 EEST}
{591145200 7200 0 EET}
{606870000 10800 1 EEST}
|
| ︙ | ︙ |
Changes to library/tzdata/Europe/Kaliningrad.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 |
{-1618700400 3600 0 CET}
{-938905200 7200 1 CEST}
{-857257200 3600 0 CET}
{-844556400 7200 1 CEST}
{-828226800 3600 0 CET}
{-812502000 7200 1 CEST}
{-796777200 3600 0 CET}
| > | | | | | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 |
{-1618700400 3600 0 CET}
{-938905200 7200 1 CEST}
{-857257200 3600 0 CET}
{-844556400 7200 1 CEST}
{-828226800 3600 0 CET}
{-812502000 7200 1 CEST}
{-796777200 3600 0 CET}
{-781052400 7200 1 CEST}
{-780368400 7200 0 EET}
{-778730400 10800 1 EEST}
{-762663600 7200 0 EET}
{-749095200 10800 0 MSD}
{354920400 14400 1 MSD}
{370728000 10800 0 MSK}
{386456400 14400 1 MSD}
{402264000 10800 0 MSK}
{417992400 14400 1 MSD}
{433800000 10800 0 MSK}
{449614800 14400 1 MSD}
|
| ︙ | ︙ |
Changes to library/tzdata/Europe/Vienna.
| ︙ | ︙ | |||
18 19 20 21 22 23 24 |
{-828226800 3600 0 CET}
{-812502000 7200 1 CEST}
{-796777200 3600 0 CET}
{-781052400 7200 1 CEST}
{-780188400 3600 0 CET}
{-757386000 3600 0 CET}
{-748479600 7200 1 CEST}
| | | 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 |
{-828226800 3600 0 CET}
{-812502000 7200 1 CEST}
{-796777200 3600 0 CET}
{-781052400 7200 1 CEST}
{-780188400 3600 0 CET}
{-757386000 3600 0 CET}
{-748479600 7200 1 CEST}
{-733273200 3600 0 CET}
{-717634800 7200 1 CEST}
{-701910000 3600 0 CET}
{-684975600 7200 1 CEST}
{-670460400 3600 0 CET}
{323823600 7200 1 CEST}
{338940000 3600 0 CET}
{347151600 3600 0 CET}
|
| ︙ | ︙ |
Changes to library/tzdata/Pacific/Fiji.
| ︙ | ︙ | |||
23 24 25 26 27 28 29 |
{1452952800 43200 0 +12}
{1478354400 46800 1 +12}
{1484402400 43200 0 +12}
{1509804000 46800 1 +12}
{1515852000 43200 0 +12}
{1541253600 46800 1 +12}
{1547301600 43200 0 +12}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 |
{1452952800 43200 0 +12}
{1478354400 46800 1 +12}
{1484402400 43200 0 +12}
{1509804000 46800 1 +12}
{1515852000 43200 0 +12}
{1541253600 46800 1 +12}
{1547301600 43200 0 +12}
{1573308000 46800 1 +12}
{1578751200 43200 0 +12}
{1604757600 46800 1 +12}
{1610805600 43200 0 +12}
{1636812000 46800 1 +12}
{1642255200 43200 0 +12}
{1668261600 46800 1 +12}
{1673704800 43200 0 +12}
{1699711200 46800 1 +12}
{1705154400 43200 0 +12}
{1731160800 46800 1 +12}
{1736604000 43200 0 +12}
{1762610400 46800 1 +12}
{1768658400 43200 0 +12}
{1794060000 46800 1 +12}
{1800108000 43200 0 +12}
{1826114400 46800 1 +12}
{1831557600 43200 0 +12}
{1857564000 46800 1 +12}
{1863007200 43200 0 +12}
{1889013600 46800 1 +12}
{1894456800 43200 0 +12}
{1920463200 46800 1 +12}
{1925906400 43200 0 +12}
{1951912800 46800 1 +12}
{1957960800 43200 0 +12}
{1983967200 46800 1 +12}
{1989410400 43200 0 +12}
{2015416800 46800 1 +12}
{2020860000 43200 0 +12}
{2046866400 46800 1 +12}
{2052309600 43200 0 +12}
{2078316000 46800 1 +12}
{2083759200 43200 0 +12}
{2109765600 46800 1 +12}
{2115813600 43200 0 +12}
{2141215200 46800 1 +12}
{2147263200 43200 0 +12}
{2173269600 46800 1 +12}
{2178712800 43200 0 +12}
{2204719200 46800 1 +12}
{2210162400 43200 0 +12}
{2236168800 46800 1 +12}
{2241612000 43200 0 +12}
{2267618400 46800 1 +12}
{2273061600 43200 0 +12}
{2299068000 46800 1 +12}
{2305116000 43200 0 +12}
{2330517600 46800 1 +12}
{2336565600 43200 0 +12}
{2362572000 46800 1 +12}
{2368015200 43200 0 +12}
{2394021600 46800 1 +12}
{2399464800 43200 0 +12}
{2425471200 46800 1 +12}
{2430914400 43200 0 +12}
{2456920800 46800 1 +12}
{2462364000 43200 0 +12}
{2488370400 46800 1 +12}
{2494418400 43200 0 +12}
{2520424800 46800 1 +12}
{2525868000 43200 0 +12}
{2551874400 46800 1 +12}
{2557317600 43200 0 +12}
{2583324000 46800 1 +12}
{2588767200 43200 0 +12}
{2614773600 46800 1 +12}
{2620216800 43200 0 +12}
{2646223200 46800 1 +12}
{2652271200 43200 0 +12}
{2677672800 46800 1 +12}
{2683720800 43200 0 +12}
{2709727200 46800 1 +12}
{2715170400 43200 0 +12}
{2741176800 46800 1 +12}
{2746620000 43200 0 +12}
{2772626400 46800 1 +12}
{2778069600 43200 0 +12}
{2804076000 46800 1 +12}
{2809519200 43200 0 +12}
{2835525600 46800 1 +12}
{2841573600 43200 0 +12}
{2867580000 46800 1 +12}
{2873023200 43200 0 +12}
{2899029600 46800 1 +12}
{2904472800 43200 0 +12}
{2930479200 46800 1 +12}
{2935922400 43200 0 +12}
{2961928800 46800 1 +12}
{2967372000 43200 0 +12}
{2993378400 46800 1 +12}
{2999426400 43200 0 +12}
{3024828000 46800 1 +12}
{3030876000 43200 0 +12}
{3056882400 46800 1 +12}
{3062325600 43200 0 +12}
{3088332000 46800 1 +12}
{3093775200 43200 0 +12}
{3119781600 46800 1 +12}
{3125224800 43200 0 +12}
{3151231200 46800 1 +12}
{3156674400 43200 0 +12}
{3182680800 46800 1 +12}
{3188728800 43200 0 +12}
{3214130400 46800 1 +12}
{3220178400 43200 0 +12}
{3246184800 46800 1 +12}
{3251628000 43200 0 +12}
{3277634400 46800 1 +12}
{3283077600 43200 0 +12}
{3309084000 46800 1 +12}
{3314527200 43200 0 +12}
{3340533600 46800 1 +12}
{3345976800 43200 0 +12}
{3371983200 46800 1 +12}
{3378031200 43200 0 +12}
{3404037600 46800 1 +12}
{3409480800 43200 0 +12}
{3435487200 46800 1 +12}
{3440930400 43200 0 +12}
{3466936800 46800 1 +12}
{3472380000 43200 0 +12}
{3498386400 46800 1 +12}
{3503829600 43200 0 +12}
{3529836000 46800 1 +12}
{3535884000 43200 0 +12}
{3561285600 46800 1 +12}
{3567333600 43200 0 +12}
{3593340000 46800 1 +12}
{3598783200 43200 0 +12}
{3624789600 46800 1 +12}
{3630232800 43200 0 +12}
{3656239200 46800 1 +12}
{3661682400 43200 0 +12}
{3687688800 46800 1 +12}
{3693132000 43200 0 +12}
{3719138400 46800 1 +12}
{3725186400 43200 0 +12}
{3751192800 46800 1 +12}
{3756636000 43200 0 +12}
{3782642400 46800 1 +12}
{3788085600 43200 0 +12}
{3814092000 46800 1 +12}
{3819535200 43200 0 +12}
{3845541600 46800 1 +12}
{3850984800 43200 0 +12}
{3876991200 46800 1 +12}
{3883039200 43200 0 +12}
{3908440800 46800 1 +12}
{3914488800 43200 0 +12}
{3940495200 46800 1 +12}
{3945938400 43200 0 +12}
{3971944800 46800 1 +12}
{3977388000 43200 0 +12}
{4003394400 46800 1 +12}
{4008837600 43200 0 +12}
{4034844000 46800 1 +12}
{4040287200 43200 0 +12}
{4066293600 46800 1 +12}
{4072341600 43200 0 +12}
{4097743200 46800 1 +12}
}
|
Changes to library/tzdata/Pacific/Norfolk.
1 2 3 4 5 6 7 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Norfolk) {
{-9223372036854775808 40312 0 LMT}
{-2177493112 40320 0 +1112}
{-599656320 41400 0 +1130}
{152029800 45000 1 +1230}
| | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Norfolk) {
{-9223372036854775808 40312 0 LMT}
{-2177493112 40320 0 +1112}
{-599656320 41400 0 +1130}
{152029800 45000 1 +1230}
{162916200 41400 0 +1130}
{1443882600 39600 0 +11}
{1561899600 39600 0 +12}
{1570287600 43200 1 +12}
{1586012400 39600 0 +12}
{1601737200 43200 1 +12}
{1617462000 39600 0 +12}
{1633186800 43200 1 +12}
{1648911600 39600 0 +12}
{1664636400 43200 1 +12}
{1680361200 39600 0 +12}
{1696086000 43200 1 +12}
{1712415600 39600 0 +12}
{1728140400 43200 1 +12}
{1743865200 39600 0 +12}
{1759590000 43200 1 +12}
{1775314800 39600 0 +12}
{1791039600 43200 1 +12}
{1806764400 39600 0 +12}
{1822489200 43200 1 +12}
{1838214000 39600 0 +12}
{1853938800 43200 1 +12}
{1869663600 39600 0 +12}
{1885993200 43200 1 +12}
{1901718000 39600 0 +12}
{1917442800 43200 1 +12}
{1933167600 39600 0 +12}
{1948892400 43200 1 +12}
{1964617200 39600 0 +12}
{1980342000 43200 1 +12}
{1996066800 39600 0 +12}
{2011791600 43200 1 +12}
{2027516400 39600 0 +12}
{2043241200 43200 1 +12}
{2058966000 39600 0 +12}
{2075295600 43200 1 +12}
{2091020400 39600 0 +12}
{2106745200 43200 1 +12}
{2122470000 39600 0 +12}
{2138194800 43200 1 +12}
{2153919600 39600 0 +12}
{2169644400 43200 1 +12}
{2185369200 39600 0 +12}
{2201094000 43200 1 +12}
{2216818800 39600 0 +12}
{2233148400 43200 1 +12}
{2248873200 39600 0 +12}
{2264598000 43200 1 +12}
{2280322800 39600 0 +12}
{2296047600 43200 1 +12}
{2311772400 39600 0 +12}
{2327497200 43200 1 +12}
{2343222000 39600 0 +12}
{2358946800 43200 1 +12}
{2374671600 39600 0 +12}
{2390396400 43200 1 +12}
{2406121200 39600 0 +12}
{2422450800 43200 1 +12}
{2438175600 39600 0 +12}
{2453900400 43200 1 +12}
{2469625200 39600 0 +12}
{2485350000 43200 1 +12}
{2501074800 39600 0 +12}
{2516799600 43200 1 +12}
{2532524400 39600 0 +12}
{2548249200 43200 1 +12}
{2563974000 39600 0 +12}
{2579698800 43200 1 +12}
{2596028400 39600 0 +12}
{2611753200 43200 1 +12}
{2627478000 39600 0 +12}
{2643202800 43200 1 +12}
{2658927600 39600 0 +12}
{2674652400 43200 1 +12}
{2690377200 39600 0 +12}
{2706102000 43200 1 +12}
{2721826800 39600 0 +12}
{2737551600 43200 1 +12}
{2753276400 39600 0 +12}
{2769606000 43200 1 +12}
{2785330800 39600 0 +12}
{2801055600 43200 1 +12}
{2816780400 39600 0 +12}
{2832505200 43200 1 +12}
{2848230000 39600 0 +12}
{2863954800 43200 1 +12}
{2879679600 39600 0 +12}
{2895404400 43200 1 +12}
{2911129200 39600 0 +12}
{2926854000 43200 1 +12}
{2942578800 39600 0 +12}
{2958908400 43200 1 +12}
{2974633200 39600 0 +12}
{2990358000 43200 1 +12}
{3006082800 39600 0 +12}
{3021807600 43200 1 +12}
{3037532400 39600 0 +12}
{3053257200 43200 1 +12}
{3068982000 39600 0 +12}
{3084706800 43200 1 +12}
{3100431600 39600 0 +12}
{3116761200 43200 1 +12}
{3132486000 39600 0 +12}
{3148210800 43200 1 +12}
{3163935600 39600 0 +12}
{3179660400 43200 1 +12}
{3195385200 39600 0 +12}
{3211110000 43200 1 +12}
{3226834800 39600 0 +12}
{3242559600 43200 1 +12}
{3258284400 39600 0 +12}
{3274009200 43200 1 +12}
{3289734000 39600 0 +12}
{3306063600 43200 1 +12}
{3321788400 39600 0 +12}
{3337513200 43200 1 +12}
{3353238000 39600 0 +12}
{3368962800 43200 1 +12}
{3384687600 39600 0 +12}
{3400412400 43200 1 +12}
{3416137200 39600 0 +12}
{3431862000 43200 1 +12}
{3447586800 39600 0 +12}
{3463311600 43200 1 +12}
{3479641200 39600 0 +12}
{3495366000 43200 1 +12}
{3511090800 39600 0 +12}
{3526815600 43200 1 +12}
{3542540400 39600 0 +12}
{3558265200 43200 1 +12}
{3573990000 39600 0 +12}
{3589714800 43200 1 +12}
{3605439600 39600 0 +12}
{3621164400 43200 1 +12}
{3636889200 39600 0 +12}
{3653218800 43200 1 +12}
{3668943600 39600 0 +12}
{3684668400 43200 1 +12}
{3700393200 39600 0 +12}
{3716118000 43200 1 +12}
{3731842800 39600 0 +12}
{3747567600 43200 1 +12}
{3763292400 39600 0 +12}
{3779017200 43200 1 +12}
{3794742000 39600 0 +12}
{3810466800 43200 1 +12}
{3826191600 39600 0 +12}
{3842521200 43200 1 +12}
{3858246000 39600 0 +12}
{3873970800 43200 1 +12}
{3889695600 39600 0 +12}
{3905420400 43200 1 +12}
{3921145200 39600 0 +12}
{3936870000 43200 1 +12}
{3952594800 39600 0 +12}
{3968319600 43200 1 +12}
{3984044400 39600 0 +12}
{4000374000 43200 1 +12}
{4016098800 39600 0 +12}
{4031823600 43200 1 +12}
{4047548400 39600 0 +12}
{4063273200 43200 1 +12}
{4078998000 39600 0 +12}
{4094722800 43200 1 +12}
}
|
Changes to tests/all.tcl.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 | # Copyright (c) 2000 by Ajuba Solutions # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. package prefer latest package require Tcl 8.5- | | > > > > | > | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 |
# Copyright (c) 2000 by Ajuba Solutions
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
package prefer latest
package require Tcl 8.5-
package require tcltest 2.5
namespace import ::tcltest::*
configure {*}$argv -testdir [file dirname [file dirname [file normalize [
info script]/...]]]
if {[singleProcess]} {
interp debug {} -frame 1
}
set ErrorOnFailures [info exists env(ERROR_ON_FAILURES)]
unset -nocomplain env(ERROR_ON_FAILURES)
if {[runAllTests] && $ErrorOnFailures} {exit 1}
# if calling direct only (avoid rewrite exit if inlined or interactive):
if { [info exists ::argv0] && [file tail $::argv0] eq [file tail [info script]]
&& !([info exists ::tcl_interactive] && $::tcl_interactive)
} {
proc exit args {}
}
|
Changes to tests/basic.test.
| ︙ | ︙ | |||
960 961 962 963 964 965 966 |
test basic-48.24.$noComp {expansion: empty not canonical list, regression test, bug [cc1e91552c]} -constraints $constraints -setup {
unset -nocomplain a
} -body {
run {list [list {*}{ }] [list {*}[format %c 32]] [list {*}[set a { }]]}
} -result [lrepeat 3 {}] -cleanup {unset -nocomplain a}
| | | 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 |
test basic-48.24.$noComp {expansion: empty not canonical list, regression test, bug [cc1e91552c]} -constraints $constraints -setup {
unset -nocomplain a
} -body {
run {list [list {*}{ }] [list {*}[format %c 32]] [list {*}[set a { }]]}
} -result [lrepeat 3 {}] -cleanup {unset -nocomplain a}
test basic-48.25.$noComp {Bug cc191552c: expansion: empty non-canonical list} -constraints $constraints -setup {
unset -nocomplain ::CRLF
set ::CRLF "\r\n"
} -body {
# Force variant that turned up in Bug 2c154a40be as that's externally
# noticeable in an important downstream project.
run {scan [list {*}$::CRLF]x %c%c%c}
} -cleanup {
|
| ︙ | ︙ |
Changes to tests/chanio.test.
| ︙ | ︙ | |||
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]
| | | 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 |
set f [open $path(test1) w+]
list [chan configure $f -eofchar] [chan configure $f -translation]
} -cleanup {
chan close $f
} -result {{{} {}} {auto lf}}
test chan-io-20.5 {Tcl_CreateChannel: install channel in empty slot} -setup {
set path(stdout) [makeFile {} stdout]
} -constraints {stdio openpipe knownMsvcBug} -body {
set f [open $path(script) w]
chan puts -nonewline $f {
chan close stdout
set f1 [}
chan puts $f [list open $path(stdout) w]]
chan puts $f {
chan configure $f1 -buffersize 777
|
| ︙ | ︙ | |||
2021 2022 2023 2024 2025 2026 2027 |
lappend l [file size $path(test1)]
} -cleanup {
chan close $f
} -result {0 60 72}
test chan-io-27.5 {FlushChannel, implicit flush when buffer fills and on chan close} -setup {
file delete $path(test1)
set l ""
| | | 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 |
lappend l [file size $path(test1)]
} -cleanup {
chan close $f
} -result {0 60 72}
test chan-io-27.5 {FlushChannel, implicit flush when buffer fills and on chan close} -setup {
file delete $path(test1)
set l ""
} -constraints {unixOrWin} -body {
set f [open $path(test1) w]
chan configure $f -translation lf -buffersize 60 -eofchar {}
lappend l [file size $path(test1)]
for {set i 0} {$i < 12} {incr i} {
chan puts $f hello
}
lappend l [file size $path(test1)]
|
| ︙ | ︙ | |||
2813 2814 2815 2816 2817 2818 2819 |
set cs [socket 127.0.0.1 [lindex [chan configure $ss -sockname] 2]]
vwait [namespace which -variable x]
chan configure $cs -blocking off
writelots $cs $l
chan close $cs
chan close $ss
vwait [namespace which -variable x]
| | | 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 |
set cs [socket 127.0.0.1 [lindex [chan configure $ss -sockname] 2]]
vwait [namespace which -variable x]
chan configure $cs -blocking off
writelots $cs $l
chan close $cs
chan close $ss
vwait [namespace which -variable x]
set c
} -result 2000
test chan-io-29.35 {Tcl_Chan Close vs chan event vs multiple interpreters} -setup {
catch {interp delete x}
catch {interp delete y}
} -constraints {socket tempNotMac fileevent} -body {
# On Mac, this test screws up sockets such that subsequent tests using
# port 2828 either cause errors or panic().
|
| ︙ | ︙ | |||
7029 7030 7031 7032 7033 7034 7035 |
set token [after 1000 {
lappend ::RES {bgerror/FAIL timeout}
set ::forever has-been-reached
}]
vwait ::forever
catch {after cancel $token}
# Report
| | | 7029 7030 7031 7032 7033 7034 7035 7036 7037 7038 7039 7040 7041 7042 7043 |
set token [after 1000 {
lappend ::RES {bgerror/FAIL timeout}
set ::forever has-been-reached
}]
vwait ::forever
catch {after cancel $token}
# Report
set ::RES
} -cleanup {
chan close $f
chan close $g
catch {unset ::RES}
catch {unset ::forever}
rename ::bgerror {}
removeFile foo
|
| ︙ | ︙ | |||
7229 7230 7231 7232 7233 7234 7235 |
set ss [socket -server [namespace code accept] -myaddr 127.0.0.1 0]
# We need to delay on some systems until the creation of the server socket
# completes.
set done 0
for {set i 0} {$i < 10} {incr i} {
if {![catch {
set cs [socket 127.0.0.1 [lindex [chan configure $ss -sockname] 2]]
| | | 7229 7230 7231 7232 7233 7234 7235 7236 7237 7238 7239 7240 7241 7242 7243 |
set ss [socket -server [namespace code accept] -myaddr 127.0.0.1 0]
# We need to delay on some systems until the creation of the server socket
# completes.
set done 0
for {set i 0} {$i < 10} {incr i} {
if {![catch {
set cs [socket 127.0.0.1 [lindex [chan configure $ss -sockname] 2]]
}]} {
set done 1
break
}
after 100
}
if {$done == 0} {
chan close $ss
|
| ︙ | ︙ | |||
7301 7302 7303 7304 7305 7306 7307 |
chan flush $writer
}
producer
vwait [namespace which -variable done]
chan close $writer
chan close $s
after cancel $after
| | | 7301 7302 7303 7304 7305 7306 7307 7308 7309 7310 7311 7312 7313 7314 7315 |
chan flush $writer
}
producer
vwait [namespace which -variable done]
chan close $writer
chan close $s
after cancel $after
set counter
} -cleanup {
if {$accept ne {}} {chan close $accept}
} -result 1
set path(fooBar) [makeFile {} fooBar]
test chan-io-55.1 {ChannelEventScriptInvoker: deletion} -constraints {
|
| ︙ | ︙ | |||
7328 7329 7330 7331 7332 7333 7334 |
set handler [interp bgerror {}]
interp bgerror {} [namespace which myHandler]
} -body {
set f [open $path(fooBar) w]
chan event $f writable [namespace code [list eventScript $f]]
variable x not_done
vwait [namespace which -variable x]
| | | 7328 7329 7330 7331 7332 7333 7334 7335 7336 7337 7338 7339 7340 7341 7342 |
set handler [interp bgerror {}]
interp bgerror {} [namespace which myHandler]
} -body {
set f [open $path(fooBar) w]
chan event $f writable [namespace code [list eventScript $f]]
variable x not_done
vwait [namespace which -variable x]
set x
} -cleanup {
interp bgerror {} $handler
} -result {got_error}
test chan-io-56.1 {ChannelTimerProc} {testchannelevent} {
set f [open $path(fooBar) w]
chan puts $f "this is a test"
|
| ︙ | ︙ | |||
7373 7374 7375 7376 7377 7378 7379 |
chan puts $s "12\n34567890"
chan flush $s
variable result [chan gets $s2]
after 1000 [namespace code {lappend result timer}]
vwait [namespace which -variable result]
lappend result [chan gets $s2]
vwait [namespace which -variable result]
| | | 7373 7374 7375 7376 7377 7378 7379 7380 7381 7382 7383 7384 7385 7386 7387 |
chan puts $s "12\n34567890"
chan flush $s
variable result [chan gets $s2]
after 1000 [namespace code {lappend result timer}]
vwait [namespace which -variable result]
lappend result [chan gets $s2]
vwait [namespace which -variable result]
set result
} -cleanup {
chan close $s
chan close $s2
chan close $server
} -result {12 readable 34567890 timer}
test chan-io-57.2 {buffered data and file events, read} -setup {
variable s2
|
| ︙ | ︙ | |||
7398 7399 7400 7401 7402 7403 7404 |
chan puts -nonewline $s "1234567890"
chan flush $s
variable result [chan read $s2 1]
after 1000 [namespace code {lappend result timer}]
vwait [namespace which -variable result]
lappend result [chan read $s2 9]
vwait [namespace which -variable result]
| | | | 7398 7399 7400 7401 7402 7403 7404 7405 7406 7407 7408 7409 7410 7411 7412 7413 7414 7415 7416 7417 7418 7419 |
chan puts -nonewline $s "1234567890"
chan flush $s
variable result [chan read $s2 1]
after 1000 [namespace code {lappend result timer}]
vwait [namespace which -variable result]
lappend result [chan read $s2 9]
vwait [namespace which -variable result]
set result
} -cleanup {
chan close $s
chan close $s2
chan close $server
} -result {1 readable 234567890 timer}
test chan-io-58.1 {Tcl_NotifyChannel and error when closing} {stdio unixOrWin openpipe fileevent} {
set out [open $path(script) w]
chan puts $out {
chan puts "normal message from pipe"
chan puts stderr "error message from pipe"
exit 1
}
proc readit {pipe} {
|
| ︙ | ︙ |
Changes to tests/cmdAH.test.
| ︙ | ︙ | |||
22 23 24 25 26 27 28 |
testConstraint testsetplatform [llength [info commands testsetplatform]]
testConstraint testvolumetype [llength [info commands testvolumetype]]
testConstraint linkDirectory [expr {
![testConstraint win] ||
($::tcl_platform(osVersion) >= 5.0
&& [lindex [file system [temporaryDirectory]] 1] eq "NTFS")
}]
| < | 22 23 24 25 26 27 28 29 30 31 32 33 34 35 |
testConstraint testsetplatform [llength [info commands testsetplatform]]
testConstraint testvolumetype [llength [info commands testvolumetype]]
testConstraint linkDirectory [expr {
![testConstraint win] ||
($::tcl_platform(osVersion) >= 5.0
&& [lindex [file system [temporaryDirectory]] 1] eq "NTFS")
}]
global env
set cmdAHwd [pwd]
catch {set platform [testgetplatform]}
proc waitForEvenSecondForFAT {} {
# Windows 9x uses filesystems (the FAT* family of FSes) without enough
|
| ︙ | ︙ | |||
883 884 885 886 887 888 889 |
test cmdAH-18.3 {Tcl_FileObjCmd: executable} {unix testchmod} {
# Only on unix will setting the execute bit on a regular file cause that
# file to be executable.
testchmod 0o775 $gorpfile
file exe $gorpfile
} 1
test cmdAH-18.5 {Tcl_FileObjCmd: executable} -constraints {win} -body {
| | | 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 |
test cmdAH-18.3 {Tcl_FileObjCmd: executable} {unix testchmod} {
# Only on unix will setting the execute bit on a regular file cause that
# file to be executable.
testchmod 0o775 $gorpfile
file exe $gorpfile
} 1
test cmdAH-18.5 {Tcl_FileObjCmd: executable} -constraints {win} -body {
# On windows, must be a .exe, .com, etc.
set x {}
set gorpexes {}
foreach ext {exe com cmd bat} {
lappend x [file exe nosuchfile.$ext]
set gorpexe [makeFile foo gorp.$ext]
lappend gorpexes $gorpexe
lappend x [file exe $gorpexe] [file exe [string toupper $gorpexe]]
|
| ︙ | ︙ | |||
1305 1306 1307 1308 1309 1310 1311 |
file delete -force $filename
} -result {3155760000 3155760000}
# owned
test cmdAH-25.1 {Tcl_FileObjCmd: owned} -returnCodes error -body {
file owned a b
} -result {wrong # args: should be "file owned name"}
| | > > > > > > > > > > > > > > > > | > > > > | > > > | > | 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 |
file delete -force $filename
} -result {3155760000 3155760000}
# owned
test cmdAH-25.1 {Tcl_FileObjCmd: owned} -returnCodes error -body {
file owned a b
} -result {wrong # args: should be "file owned name"}
test cmdAH-25.2 {Tcl_FileObjCmd: owned} -constraints win -setup {
set fn $gorpfile
# prefer temp file to check owner (try to avoid bug [7de2d722bd]):
if {
[info exists ::env(TEMP)] && [file isdirectory $::env(TEMP)] &&
[file dirname $fn] ne [file normalize $::env(TEMP)]
} {
set fn [file join $::env(TEMP)/test-owner-from-tcl.txt]
set fn [makeFile "data" test-owner-from-tcl.txt $::env(TEMP)]
}
# be sure we have really owned this file before trying to check that
# (avoid dependency on admin with UAC and the setting "System objects:
# Default owner for objects created by members of the Administrators group"):
catch {
exec takeown /F [file nativename $fn]
}
} -body {
file owned $fn
} -cleanup {
if {$fn ne $gorpfile} {
removeFile $fn
}
} -result 1
test cmdAH-25.2.1 {Tcl_FileObjCmd: owned} -constraints unix -setup {
# Avoid problems with AFS
set tmpfile [makeFile "data" touch.me /tmp]
} -body {
file owned $tmpfile
} -cleanup {
removeFile touch.me /tmp
} -result 1
test cmdAH-25.3 {Tcl_FileObjCmd: owned} {unix notRoot} {
file owned /
} 0
test cmdAH-25.3.1 {Tcl_FileObjCmd: owned} -constraints win -body {
if {[info exists env(SystemRoot)]} {
file owned $env(SystemRoot)
} else {
file owned $env(windir)
}
} -result 0
test cmdAH-25.4 {Tcl_FileObjCmd: owned} -body {
file owned nosuchfile
} -result 0
# readlink
test cmdAH-26.1 {Tcl_FileObjCmd: readlink} -returnCodes error -body {
|
| ︙ | ︙ |
Changes to tests/cmdMZ.test.
| ︙ | ︙ | |||
22 23 24 25 26 27 28 |
namespace import ::tcltest::makeFile
namespace import ::tcltest::removeFile
namespace import ::tcltest::temporaryDirectory
namespace import ::tcltest::testConstraint
namespace import ::tcltest::test
testConstraint knownMsvcBug [expr {![info exists ::env(TRAVIS_OS_NAME)] || ![string match windows $::env(TRAVIS_OS_NAME)]}]
| | | 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 |
namespace import ::tcltest::makeFile
namespace import ::tcltest::removeFile
namespace import ::tcltest::temporaryDirectory
namespace import ::tcltest::testConstraint
namespace import ::tcltest::test
testConstraint knownMsvcBug [expr {![info exists ::env(TRAVIS_OS_NAME)] || ![string match windows $::env(TRAVIS_OS_NAME)]}]
proc ListGlobMatch {expected actual} {
if {[llength $expected] != [llength $actual]} {
return 0
}
foreach e $expected a $actual {
if {![string match $e $a]} {
return 0
|
| ︙ | ︙ | |||
226 227 228 229 230 231 232 |
# The tests for Tcl_ScanObjCmd are in scan.test
# Tcl_SourceObjCmd
# More tests of Tcl_SourceObjCmd are in source.test
test cmdMZ-3.3 {Tcl_SourceObjCmd: error conditions} -constraints {
| | | | 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 |
# The tests for Tcl_ScanObjCmd are in scan.test
# Tcl_SourceObjCmd
# More tests of Tcl_SourceObjCmd are in source.test
test cmdMZ-3.3 {Tcl_SourceObjCmd: error conditions} -constraints {
unixOrWin
} -returnCodes error -body {
source
} -match glob -result {wrong # args: should be "source*fileName"}
test cmdMZ-3.4 {Tcl_SourceObjCmd: error conditions} -constraints {
unixOrWin
} -returnCodes error -body {
source a b c d e f
} -match glob -result {wrong # args: should be "source*fileName"}
test cmdMZ-3.5 {Tcl_SourceObjCmd: error in script} -body {
set file [makeFile {
set x 146
error "error in sourced file"
|
| ︙ | ︙ |
Changes to tests/compile.test.
| ︙ | ︙ | |||
461 462 463 464 465 466 467 468 469 470 471 472 473 474 |
for {set i 0} {$i < 3000} {incr i} {
append body " $i"
}
append body {]; puts OK}
regsub BODY {proc crash {} {BODY}; crash} $body script
list [catch {exec [interpreter] << $script} msg] $msg
} {0 OK}
# Tests compile-14.* for [Bug 599788] [Bug 0c043a175a47da8c2342]
test compile-14.1 {testing errors in element name; segfault?} {} {
catch {set a([error])} msg1
catch {set bubba([join $abba $jubba]) $vol} msg2
list $msg1 $msg2
} {{wrong # args: should be "error message ?errorInfo? ?errorCode?"} {can't read "abba": no such variable}}
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 |
for {set i 0} {$i < 3000} {incr i} {
append body " $i"
}
append body {]; puts OK}
regsub BODY {proc crash {} {BODY}; crash} $body script
list [catch {exec [interpreter] << $script} msg] $msg
} {0 OK}
# Tests of nested compile (body in body compilation), should not generate stack overflow
# (with abnormal program termination), bug [fec0c17d39]:
proc _ti_gencode {} {
# creates test interpreter on demand with [gencode] generator:
if {[interp exists ti]} {
return
}
interp create ti
ti eval {proc gencode {nr {cmd eval} {nl 0}} {
set code ""
set e ""; if {$nl} {set e "\n"}
for {set i 0} {$i < $nr} {incr i} {
append code "$cmd \{$e"
}
append code "lappend result 1$e"
for {set i 0} {$i < $nr} {incr i} {
append code "\}$e"
}
#puts [format "%% %.40s ... %d bytes" $code [string length $code]]
return $code
}}
}
test compile-13.2 {TclCompileScript: testing expected nested scripts compilation} -setup {
_ti_gencode
interp recursionlimit ti [expr {10000+50}]
ti eval {set result {}}
} -body {
# Test different compilation variants (instructions evalStk, invokeStk, etc),
# with 1500 (1000 in debug) nested scripts (bodies). If you get SO/SF exceptions on some low-stack
# boxes or systems, please don't decrease it (either provide a constraint)
ti eval {foreach cmd {eval "if 1" try catch} {
set c [gencode [expr {![::tcl::pkgconfig get debug] ? 1500 : 1000}] $cmd]
if 1 $c
}}
ti eval {set result}
} -result {1 1 1 1}
test compile-13.3 {TclCompileScript: testing check of max depth by nested scripts compilation} -setup {
_ti_gencode
interp recursionlimit ti 100
ti eval {set result {}}
} -body {
# Test different compilation variants (instructions evalStk, invokeStk, etc),
# with 500 nested scripts (bodies). It must generate "too many nested compilations"
# error for any variant we're testing here:
ti eval {foreach cmd {eval "if 1" try catch} {
set c [gencode 500 $cmd]
lappend errors [catch $c e] $e
}}
#puts $errors
# all of nested calls exceed the limit, so must end with "too many nested compilations"
# (or evaluations, depending on compile method/instruction and "mixed" compile within
# evaliation), so no one succeeds, the result must be empty:
ti eval {set result}
} -result {}
#
# clean up:
if {[interp exists ti]} {
interp delete ti
}
rename _ti_gencode {}
# Tests compile-14.* for [Bug 599788] [Bug 0c043a175a47da8c2342]
test compile-14.1 {testing errors in element name; segfault?} {} {
catch {set a([error])} msg1
catch {set bubba([join $abba $jubba]) $vol} msg2
list $msg1 $msg2
} {{wrong # args: should be "error message ?errorInfo? ?errorCode?"} {can't read "abba": no such variable}}
|
| ︙ | ︙ |
Changes to tests/execute.test.
| ︙ | ︙ | |||
33 34 35 36 37 38 39 40 41 42 43 44 45 46 |
&& [llength [info commands testdoubleobj]]
&& [llength [info commands teststringobj]]
}]
testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}]
testConstraint testexprlongobj [llength [info commands testexprlongobj]]
# Tests for the omnibus TclExecuteByteCode function:
# INST_DONE not tested
# INST_PUSH1 not tested
# INST_PUSH4 not tested
# INST_POP not tested
# INST_DUP not tested
| > > > > > | 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 |
&& [llength [info commands testdoubleobj]]
&& [llength [info commands teststringobj]]
}]
testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}]
testConstraint testexprlongobj [llength [info commands testexprlongobj]]
if {[namespace which -command testbumpinterpepoch] eq ""} {
proc testbumpinterpepoch {} { rename ::set ::dummy; rename ::dummy ::set }
}
# Tests for the omnibus TclExecuteByteCode function:
# INST_DONE not tested
# INST_PUSH1 not tested
# INST_PUSH4 not tested
# INST_POP not tested
# INST_DUP not tested
|
| ︙ | ︙ | |||
925 926 927 928 929 930 931 |
# Test for [Bug #1055676], correct restoration of the stack top after the
# epoch is bumped and the stack is grown in a call from a nested
# evaluation
set arglst [string repeat "a " 1000]
proc f {args} "f $arglst"
proc run {} {
# bump the interp's epoch
| | < | < | 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 |
# Test for [Bug #1055676], correct restoration of the stack top after the
# epoch is bumped and the stack is grown in a call from a nested
# evaluation
set arglst [string repeat "a " 1000]
proc f {args} "f $arglst"
proc run {} {
# bump the interp's epoch
testbumpinterpepoch
catch f msg
set msg
}
run
} -cleanup {
interp recursionlimit {} $limit
} -result {too many nested evaluations (infinite loop?)}
test execute-8.4 {Compile epoch bump effect on stack trace} -setup {
proc foo {} {
error bar
}
proc FOO {} {
catch {error bar} m o
testbumpinterpepoch
return -options $o $m
}
} -body {
catch foo m o
set stack1 [dict get $o -errorinfo]
catch FOO m o
set stack2 [string map {FOO foo} [dict get $o -errorinfo]]
|
| ︙ | ︙ | |||
970 971 972 973 974 975 976 977 978 979 |
rename demo {}
} -match glob -result {-code 1 -level 0 -errorstack * -errorcode NONE -errorinfo {FOO
while executing
"error FOO"
invoked from within
"catch \[list error FOO\] m o"} -errorline 2}
test execute-9.1 {Interp result resetting [Bug 1522803]} {
set c 0
catch {
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | 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 |
rename demo {}
} -match glob -result {-code 1 -level 0 -errorstack * -errorcode NONE -errorinfo {FOO
while executing
"error FOO"
invoked from within
"catch \[list error FOO\] m o"} -errorline 2}
test execute-8.6 {Compile epoch bump in global level (bug [fa6bf38d07])} -setup {
interp create slave
slave eval {
package require tcltest
catch [list package require -exact Tcltest [info patchlevel]]
::tcltest::loadTestedCommands
if {[namespace which -command testbumpinterpepoch] eq ""} {
proc testbumpinterpepoch {} { rename ::set ::dummy; rename ::dummy ::set }
}
}
} -body {
slave eval {
lappend res A; testbumpinterpepoch; lappend res B; return; lappend res C;
}
slave eval {
set i 0; while {[incr i] < 3} {
lappend res A; testbumpinterpepoch; lappend res B; return; lappend res C;
}
}
slave eval {
set i 0; while {[incr i] < 3} {
lappend res A; testbumpinterpepoch; lappend res B; break; lappend res C;
}
}
slave eval {
catch {
lappend res A; testbumpinterpepoch; lappend res B; error test; lappend res C;
}
}
slave eval {set res}
} -cleanup {
interp delete slave
} -result [lrepeat 4 A B]
test execute-8.7 {Compile epoch bump in global level (bug [fa6bf38d07]), exception case} -setup {
interp create slave
slave eval {
package require tcltest
catch [list package require -exact Tcltest [info patchlevel]]
::tcltest::loadTestedCommands
if {[namespace which -command testbumpinterpepoch] eq ""} {
proc testbumpinterpepoch {} { rename ::set ::dummy; rename ::dummy ::set }
}
}
} -body {
set res {}
lappend res [catch {
slave eval {
lappend res A; testbumpinterpepoch; lappend res B; return -code error test; lappend res C;
}
} e] $e
lappend res [catch {
slave eval {
lappend res A; testbumpinterpepoch; lappend res B; error test; lappend res C;
}
} e] $e
lappend res [catch {
slave eval {
lappend res A; testbumpinterpepoch; lappend res B; return -code return test; lappend res C;
}
} e] $e
lappend res [catch {
slave eval {
lappend res A; testbumpinterpepoch; lappend res B; break; lappend res C;
}
} e] $e
list $res [slave eval {set res}]
} -cleanup {
interp delete slave
} -result [list {1 test 1 test 2 test 3 {}} [lrepeat 4 A B]]
test execute-9.1 {Interp result resetting [Bug 1522803]} {
set c 0
catch {
catch {error foo}
expr {1/$c}
}
if {[string match *foo* $::errorInfo]} {
set result "Bad errorInfo: $::errorInfo"
} else {
set result SUCCESS
}
|
| ︙ | ︙ | |||
1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 |
for {set i 0} {$i < $n} {incr i} {
yield $i
}
}
proc t {args} {
incr ::foo
}
trace add execution ::generate enterstep ::t
} -body {
coroutine coro generate 5
trace remove execution ::generate enterstep ::t
set ::foo
} -cleanup {
unset ::foo
| > | 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 |
for {set i 0} {$i < $n} {incr i} {
yield $i
}
}
proc t {args} {
incr ::foo
}
set ::foo 0
trace add execution ::generate enterstep ::t
} -body {
coroutine coro generate 5
trace remove execution ::generate enterstep ::t
set ::foo
} -cleanup {
unset ::foo
|
| ︙ | ︙ |
Changes to tests/fCmd.test.
| ︙ | ︙ | |||
272 273 274 275 276 277 278 |
cleanup
} -constraints {notRoot} -returnCodes error -body {
file mkdir td1
file rename ~_totally_bogus_user td1
} -result {user "_totally_bogus_user" doesn't exist}
test fCmd-3.15 {FileCopyRename: source[0] == '\0'} -setup {
cleanup
| | | 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 |
cleanup
} -constraints {notRoot} -returnCodes error -body {
file mkdir td1
file rename ~_totally_bogus_user td1
} -result {user "_totally_bogus_user" doesn't exist}
test fCmd-3.15 {FileCopyRename: source[0] == '\0'} -setup {
cleanup
} -constraints {notRoot unixOrWin} -returnCodes error -body {
file mkdir td1
file rename / td1
} -result {error renaming "/" to "td1": file already exists}
test fCmd-3.16 {FileCopyRename: break on first error} -setup {
cleanup
} -constraints {notRoot} -returnCodes error -body {
createfile tf1
|
| ︙ | ︙ | |||
412 413 414 415 416 417 418 |
file mkdir td1
set x [list [file exists tf1] [file exists tf2] [file exists td1]]
file delete tf1 td1 tf2
lappend x [file exists tf1] [file exists tf2] [file exists tf3]
} -cleanup {cleanup} -result {1 1 1 0 0 0}
test fCmd-5.5 {TclFileDeleteCmd: stop at first error} -setup {
cleanup
| | | 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 |
file mkdir td1
set x [list [file exists tf1] [file exists tf2] [file exists td1]]
file delete tf1 td1 tf2
lappend x [file exists tf1] [file exists tf2] [file exists tf3]
} -cleanup {cleanup} -result {1 1 1 0 0 0}
test fCmd-5.5 {TclFileDeleteCmd: stop at first error} -setup {
cleanup
} -constraints {notRoot unixOrWin} -body {
createfile tf1
createfile tf2
file mkdir td1
catch {file delete tf1 td1 $root tf2}
list [file exists tf1] [file exists tf2] [file exists td1]
} -cleanup {cleanup} -result {0 1 0}
test fCmd-5.6 {TclFileDeleteCmd: Tcl_TranslateFileName fails} -constraints {notRoot} -body {
|
| ︙ | ︙ | |||
1112 1113 1114 1115 1116 1117 1118 |
set a3 [catch {file copy -force tds2 tdd2}]
set a4 [catch {file copy -force tds3 tdd3}]
set a5 [catch {file copy -force tds4 tdd4}]
list [lsort [glob td*]] $a1 $a2 $a3 $a4 $a5
} -result [subst {{td1 td2 tdd1 tdd2 tdd3 tdd4 tds1 tds2 tds3 tds4} {1 {error copying "td1" to "[file join td2 td1]": file already exists}} {1 {error copying "tds1" to "[file join tdd1 tds1]": file already exists}} 1 1 1}]
test fCmd-10.6 {file copy: comprehensive: dir to non-empty dir} -setup {
cleanup
| | | 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 |
set a3 [catch {file copy -force tds2 tdd2}]
set a4 [catch {file copy -force tds3 tdd3}]
set a5 [catch {file copy -force tds4 tdd4}]
list [lsort [glob td*]] $a1 $a2 $a3 $a4 $a5
} -result [subst {{td1 td2 tdd1 tdd2 tdd3 tdd4 tds1 tds2 tds3 tds4} {1 {error copying "td1" to "[file join td2 td1]": file already exists}} {1 {error copying "tds1" to "[file join tdd1 tds1]": file already exists}} 1 1 1}]
test fCmd-10.6 {file copy: comprehensive: dir to non-empty dir} -setup {
cleanup
} -constraints {notRoot unixOrWin testchmod} -body {
file mkdir tds1
file mkdir tds2
file mkdir [file join tdd1 tds1 xxx]
file mkdir [file join tdd2 tds2 xxx]
testchmod 0o555 tds2
set a1 [list [catch {file copy -force tds1 tdd1} msg] $msg]
set a2 [list [catch {file copy -force tds2 tdd2} msg] $msg]
|
| ︙ | ︙ |
Changes to tests/fileName.test.
| ︙ | ︙ | |||
1085 1086 1087 1088 1089 1090 1091 |
} -result {bad argument to "-types": abcde}
file rename $horribleglobname globTest
file delete -force $tildeglobname
set globname globTest
unset horribleglobname tildeglobname
| | | | | | 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 |
} -result {bad argument to "-types": abcde}
file rename $horribleglobname globTest
file delete -force $tildeglobname
set globname globTest
unset horribleglobname tildeglobname
test filename-12.1 {simple globbing} {unixOrWin} {
glob {}
} {.}
test filename-12.1.1 {simple globbing} -constraints {unixOrWin} -body {
glob -types f {}
} -returnCodes error -result {no files matched glob pattern ""}
test filename-12.1.2 {simple globbing} {unixOrWin} {
glob -types d {}
} {.}
test filename-12.1.3 {simple globbing} {unix} {
glob -types hidden {}
} {.}
test filename-12.1.4 {simple globbing} -constraints {win} -body {
glob -types hidden {}
} -returnCodes error -result {no files matched glob pattern ""}
test filename-12.1.5 {simple globbing} -constraints {win} -body {
glob -types hidden c:/
} -returnCodes error -result {no files matched glob pattern "c:/"}
test filename-12.1.6 {simple globbing} {win} {
glob c:/
} {c:/}
test filename-12.3 {simple globbing} {
glob -nocomplain \{a1,a2\}
} {}
set globPreResult globTest/
set x1 x1.c
set y1 y1.c
test filename-12.4 {simple globbing} {unixOrWin} {
lsort [glob globTest/x1.c globTest/y1.c globTest/foo]
} "$globPreResult$x1 $globPreResult$y1"
test filename-12.5 {simple globbing} {
glob globTest\\/x1.c
} "$globPreResult$x1"
test filename-12.6 {simple globbing} {
glob globTest\\/\\x1.c
|
| ︙ | ︙ | |||
1174 1175 1176 1177 1178 1179 1180 |
} "$globPreResult$x1"
test filename-13.9 {globbing with brace substitution} {
lsort [glob globTest/\{x,y\}1.c]
} [list $globPreResult$x1 $globPreResult$y1]
test filename-13.10 {globbing with brace substitution} {
lsort [glob globTest/\{x,,y\}1.c]
} [list $globPreResult$x1 $globPreResult$y1]
| | | | | | | | | | | | | | | 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 |
} "$globPreResult$x1"
test filename-13.9 {globbing with brace substitution} {
lsort [glob globTest/\{x,y\}1.c]
} [list $globPreResult$x1 $globPreResult$y1]
test filename-13.10 {globbing with brace substitution} {
lsort [glob globTest/\{x,,y\}1.c]
} [list $globPreResult$x1 $globPreResult$y1]
test filename-13.11 {globbing with brace substitution} {unixOrWin} {
lsort [glob globTest/\{x,x\\,z,z\}1.c]
} [lsort {globTest/x1.c globTest/x,z1.c globTest/z1.c}]
test filename-13.13 {globbing with brace substitution} {
lsort [glob globTest/{a,b,x,y}1.c]
} [list $globPreResult$x1 $globPreResult$y1]
test filename-13.14 {globbing with brace substitution} {unixOrWin} {
lsort [glob {globTest/{x1,y2,weird name}.c}]
} {{globTest/weird name.c} globTest/x1.c}
test filename-13.16 {globbing with brace substitution} {unixOrWin} {
lsort [glob globTest/{x1.c,a1/*}]
} {globTest/a1/b1 globTest/a1/b2 globTest/x1.c}
test filename-13.18 {globbing with brace substitution} {unixOrWin} {
lsort [glob globTest/{x1.c,{a},a1/*}]
} {globTest/a1/b1 globTest/a1/b2 globTest/x1.c}
test filename-13.20 {globbing with brace substitution} {unixOrWin} {
lsort [glob globTest/{a,x}1/*/{x,y}*]
} {globTest/a1/b1/x2.c globTest/a1/b2/y2.c}
test filename-13.22 {globbing with brace substitution} -body {
glob globTest/\{a,x\}1/*/\{
} -returnCodes error -result {unmatched open-brace in file name}
test filename-14.1 {asterisks, question marks, and brackets} {unixOrWin} {
lsort [glob glo*/*.c]
} {{globTest/weird name.c} globTest/x,z1.c globTest/x1.c globTest/y1.c globTest/z1.c}
test filename-14.3 {asterisks, question marks, and brackets} {unixOrWin} {
lsort [glob globTest/?1.c]
} {globTest/x1.c globTest/y1.c globTest/z1.c}
test filename-14.5 {asterisks, question marks, and brackets} -setup {
# The current directory could be anywhere; do this to stop spurious
# matches
file mkdir globTestContext
file rename globTest [file join globTestContext globTest]
set savepwd [pwd]
cd globTestContext
} -constraints {unixOrWin} -body {
lsort [glob */*/*/*.c]
} -cleanup {
# Reset to where we were
cd $savepwd
file rename [file join globTestContext globTest] globTest
file delete globTestContext
} -result {globTest/a1/b1/x2.c globTest/a1/b2/y2.c}
test filename-14.7 {asterisks, question marks, and brackets} {unix} {
lsort [glob globTest/*]
} {globTest/a1 globTest/a2 globTest/a3 {globTest/weird name.c} globTest/x,z1.c globTest/x1.c globTest/y1.c globTest/z1.c}
test filename-14.7.1 {asterisks, question marks, and brackets} {win} {
lsort [glob globTest/*]
} {globTest/.1 globTest/a1 globTest/a2 globTest/a3 {globTest/weird name.c} globTest/x,z1.c globTest/x1.c globTest/y1.c globTest/z1.c}
test filename-14.9 {asterisks, question marks, and brackets} {unixOrWin} {
lsort [glob globTest/.*]
} {globTest/. globTest/.. globTest/.1}
test filename-14.11 {asterisks, question marks, and brackets} {unixOrWin} {
lsort [glob globTest/*/*]
} {globTest/a1/b1 globTest/a1/b2 globTest/a2/b3}
test filename-14.13 {asterisks, question marks, and brackets} {unixOrWin} {
lsort [glob {globTest/[xyab]1.*}]
} {globTest/x1.c globTest/y1.c}
test filename-14.15 {asterisks, question marks, and brackets} {unixOrWin} {
lsort [glob globTest/*/]
} {globTest/a1/ globTest/a2/ globTest/a3/}
test filename-14.17 {asterisks, question marks, and brackets} -setup {
global env
set temp $env(HOME)
} -body {
set env(HOME) [file join $env(HOME) globTest]
glob ~/z*
} -cleanup {
set env(HOME) $temp
} -result [list [file join $env(HOME) globTest z1.c]]
test filename-14.18 {asterisks, question marks, and brackets} {unixOrWin} {
lsort [glob globTest/*.c goo/*]
} {{globTest/weird name.c} globTest/x,z1.c globTest/x1.c globTest/y1.c globTest/z1.c}
test filename-14.20 {asterisks, question marks, and brackets} {
glob -nocomplain goo/*
} {}
test filename-14.21 {asterisks, question marks, and brackets} -body {
glob globTest/*/gorp
|
| ︙ | ︙ | |||
1283 1284 1285 1286 1287 1288 1289 |
[file join $globname "weird name.c"]\
[file join $globname x,z1.c]\
[file join $globname x1.c]\
[file join $globname y1.c] [file join $globname z1.c]]]
test filename-14.26 {type specific globbing} {
glob -nocomplain -dir globTest -types {readonly} *
} {}
| | | | | | 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 |
[file join $globname "weird name.c"]\
[file join $globname x,z1.c]\
[file join $globname x1.c]\
[file join $globname y1.c] [file join $globname z1.c]]]
test filename-14.26 {type specific globbing} {
glob -nocomplain -dir globTest -types {readonly} *
} {}
test filename-14.27 {Bug 2710920} {unixOrWin} {
file tail [lindex [lsort [glob globTest/*/]] 0]
} a1
test filename-14.28 {Bug 2710920} {unixOrWin} {
file dirname [lindex [lsort [glob globTest/*/]] 0]
} globTest
test filename-14.29 {Bug 2710920} {unixOrWin} {
file extension [lindex [lsort [glob globTest/*/]] 0]
} {}
test filename-14.30 {Bug 2710920} {unixOrWin} {
file rootname [lindex [lsort [glob globTest/*/]] 0]
} globTest/a1/
test filename-14.31 {Bug 2918610} -setup {
set d [makeDirectory foo]
makeFile {} bar.soom $d
} -body {
|
| ︙ | ︙ |
Changes to tests/interp.test.
| ︙ | ︙ | |||
1832 1833 1834 1835 1836 1837 1838 |
lappend l [interp aliases a] [interp hidden a]
} -cleanup {
interp delete a
} -result {{} bar {} bar bar {} {}}
test interp-23.2 {testing hiding vs aliases: safe interp} -setup {
catch {interp delete a}
set l ""
| | | 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 |
lappend l [interp aliases a] [interp hidden a]
} -cleanup {
interp delete a
} -result {{} bar {} bar bar {} {}}
test interp-23.2 {testing hiding vs aliases: safe interp} -setup {
catch {interp delete a}
set l ""
} -constraints {unixOrWin} -body {
interp create a -safe
lappend l [lsort [interp hidden a]]
a alias bar bar
lappend l [lsort [interp aliases a]] [lsort [interp hidden a]]
a hide bar
lappend l [lsort [interp aliases a]] [lsort [interp hidden a]]
a alias bar {}
|
| ︙ | ︙ |
Changes to tests/io.test.
| ︙ | ︙ | |||
2208 2209 2210 2211 2212 2213 2214 |
lappend l [file size $path(test1)]
flush $f
lappend l [file size $path(test1)]
close $f
set l
} {0 60 72}
test io-27.5 {FlushChannel, implicit flush when buffer fills and on close} \
| | | 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 |
lappend l [file size $path(test1)]
flush $f
lappend l [file size $path(test1)]
close $f
set l
} {0 60 72}
test io-27.5 {FlushChannel, implicit flush when buffer fills and on close} \
{unixOrWin} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf -buffersize 60 -eofchar {}
set l ""
lappend l [file size $path(test1)]
for {set i 0} {$i < 12} {incr i} {
puts $f hello
|
| ︙ | ︙ | |||
8080 8081 8082 8083 8084 8085 8086 |
list [gets $c] [chan copy $c $outChan -size 100] [gets $c]
} -cleanup {
close $outChan
close $c
removeFile out
} -result {line 100 line}
| | | 8080 8081 8082 8083 8084 8085 8086 8087 8088 8089 8090 8091 8092 8093 8094 |
list [gets $c] [chan copy $c $outChan -size 100] [gets $c]
} -cleanup {
close $outChan
close $c
removeFile out
} -result {line 100 line}
test io-54.1 {Recursive channel events} {socket fileevent knownMsvcBug} {
# This test checks to see if file events are delivered during recursive
# event loops when there is buffered data on the channel.
proc accept {s a p} {
variable as
fconfigure $s -translation lf
puts $s "line 1\nline2\nline3"
|
| ︙ | ︙ | |||
8289 8290 8291 8292 8293 8294 8295 |
vwait [namespace which -variable result]
close $s
close $s2
close $server
set result
} {1 readable 234567890 timer}
| | | 8289 8290 8291 8292 8293 8294 8295 8296 8297 8298 8299 8300 8301 8302 8303 |
vwait [namespace which -variable result]
close $s
close $s2
close $server
set result
} {1 readable 234567890 timer}
test io-58.1 {Tcl_NotifyChannel and error when closing} {stdio unixOrWin openpipe fileevent} {
set out [open $path(script) w]
puts $out {
puts "normal message from pipe"
puts stderr "error message from pipe"
exit 1
}
proc readit {pipe} {
|
| ︙ | ︙ |
Changes to tests/ioCmd.test.
| ︙ | ︙ | |||
21 22 23 24 25 26 27 | ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] package require tcltests # Custom constraints used in this file testConstraint testchannel [llength [info commands testchannel]] | < | 21 22 23 24 25 26 27 28 29 30 31 32 33 34 |
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
package require tcltests
# Custom constraints used in this file
testConstraint testchannel [llength [info commands testchannel]]
#----------------------------------------------------------------------
test iocmd-1.1 {puts command} {
list [catch {puts} msg] $msg
} {1 {wrong # args: should be "puts ?-nonewline? ?channelId? string"}}
test iocmd-1.2 {puts command} {
|
| ︙ | ︙ | |||
291 292 293 294 295 296 297 |
} -returnCodes error -cleanup {
catch {close $chan}
} -result [expectedOpts "-buffer" {}]
removeFile fconfigure.dummy
test iocmd-8.14 {fconfigure command} {
fconfigure stdin -buffers
} 4096
| | | 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 |
} -returnCodes error -cleanup {
catch {close $chan}
} -result [expectedOpts "-buffer" {}]
removeFile fconfigure.dummy
test iocmd-8.14 {fconfigure command} {
fconfigure stdin -buffers
} 4096
test iocmd-8.15.1 {fconfigure command / tcp channel} -constraints {socket unixOrWin} -setup {
set srv [socket -server iocmdSRV -myaddr 127.0.0.1 0]
set port [lindex [fconfigure $srv -sockname] 2]
proc iocmdSRV {sock ip port} {close $sock}
set cli [socket 127.0.0.1 $port]
} -body {
fconfigure $cli -blah
} -cleanup {
|
| ︙ | ︙ | |||
399 400 401 402 403 404 405 |
test iocmd-10.5 {fblocked command} {
fblocked stdin
} 0
set path(test4) [makeFile {} test4]
set path(test5) [makeFile {} test5]
| | | | | | 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 |
test iocmd-10.5 {fblocked command} {
fblocked stdin
} 0
set path(test4) [makeFile {} test4]
set path(test5) [makeFile {} test5]
test iocmd-11.1 {I/O to command pipelines} {unixOrWin unixExecs} {
set f [open $path(test4) w]
close $f
list [catch {open "| cat < \"$path(test4)\" > \"$path(test5)\"" w} msg] $msg $::errorCode
} {1 {can't write input to command: standard input was redirected} {TCL OPERATION EXEC BADREDIRECT}}
test iocmd-11.2 {I/O to command pipelines} {unixOrWin unixExecs} {
list [catch {open "| echo > \"$path(test5)\"" r} msg] $msg $::errorCode
} {1 {can't read output from command: standard output was redirected} {TCL OPERATION EXEC BADREDIRECT}}
test iocmd-11.3 {I/O to command pipelines} {unixOrWin unixExecs} {
list [catch {open "| echo > \"$path(test5)\"" r+} msg] $msg $::errorCode
} {1 {can't read output from command: standard output was redirected} {TCL OPERATION EXEC BADREDIRECT}}
test iocmd-11.4 {I/O to command pipelines} {notValgrind unixOrWin} {
list [catch {open "| no_such_command_exists" rb} msg] $msg $::errorCode
} {1 {couldn't execute "no_such_command_exists": no such file or directory} {POSIX ENOENT {no such file or directory}}}
test iocmd-12.1 {POSIX open access modes: RDONLY} {
file delete $path(test1)
set f [open $path(test1) w]
puts $f "Two lines: this one"
|
| ︙ | ︙ | |||
807 808 809 810 811 812 813 |
lappend res [file channel rc*]
lappend res [catch {chan create {r w} foo} msg]
lappend res $msg
lappend res [file channel rc*]
rename foo {}
set res
} -result {{} {initialize rc* {read write}} 1 {*all required methods*} {}}
| | | | | 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 |
lappend res [file channel rc*]
lappend res [catch {chan create {r w} foo} msg]
lappend res $msg
lappend res [file channel rc*]
rename foo {}
set res
} -result {{} {initialize rc* {read write}} 1 {*all required methods*} {}}
test iocmd-21.20 {Bug 88aef05cda} -setup {
proc foo {method chan args} {
switch -- $method blocking {
chan configure $chan -blocking [lindex $args 0]
return
} initialize {
return {initialize finalize watch blocking read write
configure cget cgetall}
} finalize {
return
}
}
set ch [chan create {read write} foo]
} -body {
chan configure $ch -blocking 0
} -cleanup {
close $ch
rename foo {}
} -match glob -returnCodes 1 -result {*(infinite loop?)*}
test iocmd-21.21 {[close] in [read] segfaults} -setup {
proc foo {method chan args} {
switch -- $method initialize {
return {initialize finalize watch read}
} finalize {} watch {} read {
close $chan
return a
|
| ︙ | ︙ |
Changes to tests/lrange.test.
| ︙ | ︙ | |||
129 130 131 132 133 134 135 |
[lrange {} 0-1 end+1] [lrange [lindex a -1] 0-1 end+1] [lrange $a 0-1 end+1]
} [lrepeat 6 {}]
test lrange-3.7b.2 {not compiled on empty not list object, 2nd regression test, bug [cc1e91552c]} {
set cmd lrange
list [$cmd {} 0 1] [$cmd [lindex a -1] 0 1] [$cmd [set a {}] 0 1] \
[$cmd {} 0-1 end+1] [$cmd [lindex a -1] 0-1 end+1] [$cmd $a 0-1 end+1]
} [lrepeat 6 {}]
| | > > | | > > | | 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 |
[lrange {} 0-1 end+1] [lrange [lindex a -1] 0-1 end+1] [lrange $a 0-1 end+1]
} [lrepeat 6 {}]
test lrange-3.7b.2 {not compiled on empty not list object, 2nd regression test, bug [cc1e91552c]} {
set cmd lrange
list [$cmd {} 0 1] [$cmd [lindex a -1] 0 1] [$cmd [set a {}] 0 1] \
[$cmd {} 0-1 end+1] [$cmd [lindex a -1] 0-1 end+1] [$cmd $a 0-1 end+1]
} [lrepeat 6 {}]
test lrange-3.7c.2 {compiled on empty pure bytes object, 2nd regression test, bug [cc1e91552c]} -constraints {
testpurebytesobj
} -body {
list [lrange [testpurebytesobj] 0 1] [lrange [testpurebytesobj { }] 0 1] [lrange [set a [testpurebytesobj {}]] 0 1] \
[lrange [testpurebytesobj] 0-1 end+1] [lrange [testpurebytesobj { }] 0-1 end+1] [lrange $a 0-1 end+1]
} -result [lrepeat 6 {}]
test lrange-3.7d.2 {not compiled on empty pure bytes object, 2nd regression test, bug [cc1e91552c]} -constraints {
testpurebytesobj
} -body {
set cmd lrange
list [$cmd [testpurebytesobj] 0 1] [$cmd [testpurebytesobj { }] 0 1] [$cmd [set a [testpurebytesobj {}]] 0 1] \
[$cmd [testpurebytesobj] 0-1 end+1] [$cmd [testpurebytesobj { }] 0-1 end+1] [$cmd $a 0-1 end+1]
} -result [lrepeat 6 {}]
test lrange-4.1 {lrange pure promise} -body {
set ll1 [list $tcl_version 2 3 4]
# Shared
set ll2 $ll1
# With string rep
string length $ll1
|
| ︙ | ︙ |
Changes to tests/namespace.test.
| ︙ | ︙ | |||
2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 |
return global
}
lappend result [::test_ns_1::test_ns_2::pathtestA]
} -result "1,2,1,::test_ns_1 {global,2,global,:: ::test_ns_1} {global,1,global,:: ::test_ns_1} {global,global,global,:: ::test_ns_1}" -cleanup {
namespace delete ::test_ns_1
catch {rename ::pathtestB {}}
catch {rename ::pathtestD {}}
}
test namespace-51.7 {name resolution path control} -body {
namespace eval ::test_ns_1 {
}
namespace eval ::test_ns_2 {
namespace path ::test_ns_1
proc getpath {} {namespace path}
| > | 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 |
return global
}
lappend result [::test_ns_1::test_ns_2::pathtestA]
} -result "1,2,1,::test_ns_1 {global,2,global,:: ::test_ns_1} {global,1,global,:: ::test_ns_1} {global,global,global,:: ::test_ns_1}" -cleanup {
namespace delete ::test_ns_1
catch {rename ::pathtestB {}}
catch {rename ::pathtestD {}}
catch {rename ::pathtestC {}}
}
test namespace-51.7 {name resolution path control} -body {
namespace eval ::test_ns_1 {
}
namespace eval ::test_ns_2 {
namespace path ::test_ns_1
proc getpath {} {namespace path}
|
| ︙ | ︙ |
Changes to tests/pid.test.
| ︙ | ︙ | |||
17 18 19 20 21 22 23 |
}
testConstraint pidDefined [llength [info commands pid]]
test pid-1.1 {pid command} pidDefined {
regexp {(^[0-9]+$)|(^0x[0-9a-fA-F]+$)} [pid]
} 1
| | | 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 |
}
testConstraint pidDefined [llength [info commands pid]]
test pid-1.1 {pid command} pidDefined {
regexp {(^[0-9]+$)|(^0x[0-9a-fA-F]+$)} [pid]
} 1
test pid-1.2 {pid command} -constraints {unixOrWin unixExecs pidDefined} -setup {
set path(test1) [makeFile {} test1]
file delete $path(test1)
} -body {
set f [open |[list echo foo | cat >$path(test1)] w]
set pids [pid $f]
close $f
list [llength $pids] [regexp {^[0-9]+$} [lindex $pids 0]] \
|
| ︙ | ︙ |
Changes to tests/socket.test.
| ︙ | ︙ | |||
1080 1081 1082 1083 1084 1085 1086 |
after cancel $timer
close $s
close $s1
} -result {1 3}
test socket_$af-7.5 {testing socket specific options} -setup {
set timer [after 10000 "set x timed_out"]
set l ""
| | | 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 |
after cancel $timer
close $s
close $s1
} -result {1 3}
test socket_$af-7.5 {testing socket specific options} -setup {
set timer [after 10000 "set x timed_out"]
set l ""
} -constraints [list socket supported_$af unixOrWin] -body {
set s [socket -server accept 0]
proc accept {s a p} {
global x
set x [fconfigure $s -sockname]
close $s
}
set listen [lindex [fconfigure $s -sockname] 2]
|
| ︙ | ︙ |
Changes to tests/tcltest.test.
| ︙ | ︙ | |||
94 95 96 97 98 99 100 |
removeFile error
if {[string length $err]} {
set code 1
append msg \n$err
}
return $code
}
| | | | | | | | | | | 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 |
removeFile error
if {[string length $err]} {
set code 1
append msg \n$err
}
return $code
}
test tcltest-2.0 {tcltest (verbose default - 'b')} {unixOrWin} {
set result [slave msg test.tcl]
list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
[regexp c-1.0 $msg] \
[regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
} {0 1 0 0 1}
test tcltest-2.1 {tcltest -verbose 'b'} {unixOrWin} {
set result [slave msg test.tcl -verbose 'b']
list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
[regexp c-1.0 $msg] \
[regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
} {0 1 0 0 1}
test tcltest-2.2 {tcltest -verbose 'p'} {unixOrWin} {
set result [slave msg test.tcl -verbose 'p']
list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
[regexp c-1.0 $msg] \
[regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
} {0 0 1 0 1}
test tcltest-2.3 {tcltest -verbose 's'} {unixOrWin} {
set result [slave msg test.tcl -verbose 's']
list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
[regexp c-1.0 $msg] \
[regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
} {0 0 0 1 1}
test tcltest-2.4 {tcltest -verbose 'ps'} {unixOrWin} {
set result [slave msg test.tcl -verbose 'ps']
list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
[regexp c-1.0 $msg] \
[regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
} {0 0 1 1 1}
test tcltest-2.5 {tcltest -verbose 'psb'} {unixOrWin} {
set result [slave msg test.tcl -verbose 'psb']
list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
[regexp c-1.0 $msg] \
[regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
} {0 1 1 1 1}
test tcltest-2.5a {tcltest -verbose 'pass skip body'} {unixOrWin} {
set result [slave msg test.tcl -verbose "pass skip body"]
list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
[regexp c-1.0 $msg] \
[regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
} {0 1 1 1 1}
test tcltest-2.6 {tcltest -verbose 't'} {
-constraints {unixOrWin}
-body {
set result [slave msg test.tcl -verbose 't']
list $result $msg
}
-result {^0 .*a-1.0 start.*b-1.0 start}
-match regexp
}
test tcltest-2.6a {tcltest -verbose 'start'} {
-constraints {unixOrWin}
-body {
set result [slave msg test.tcl -verbose start]
list $result $msg
}
-result {^0 .*a-1.0 start.*b-1.0 start}
-match regexp
}
|
| ︙ | ︙ | |||
172 173 174 175 176 177 178 |
verbose $oldVerbosity
list $currentVerbosity $newVerbosity
}
-result {body {}}
}
test tcltest-2.8 {tcltest -verbose 'error'} {
| | | | | | | | | | | | | | 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 |
verbose $oldVerbosity
list $currentVerbosity $newVerbosity
}
-result {body {}}
}
test tcltest-2.8 {tcltest -verbose 'error'} {
-constraints {unixOrWin}
-body {
set result [slave msg test.tcl -verbose error]
list $result $msg
}
-result {errorInfo: foo.*errorCode: 9}
-match regexp
}
# -match, [match]
test tcltest-3.1 {tcltest -match 'a*'} {unixOrWin} {
set result [slave msg test.tcl -match a* -verbose 'ps']
list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
[regexp "Total.+4.+Passed.+1.+Skipped.+3.+Failed.+0" $msg]
} {0 1 0 0 1}
test tcltest-3.2 {tcltest -match 'b*'} {unixOrWin} {
set result [slave msg test.tcl -match b* -verbose 'ps']
list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
[regexp "Total.+4.+Passed.+0.+Skipped.+3.+Failed.+1" $msg]
} {0 0 1 0 1}
test tcltest-3.3 {tcltest -match 'c*'} {unixOrWin} {
set result [slave msg test.tcl -match c* -verbose 'ps']
list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
[regexp "Total.+4.+Passed.+0.+Skipped.+4.+Failed.+0" $msg]
} {0 0 0 1 1}
test tcltest-3.4 {tcltest -match 'a* b*'} {unixOrWin} {
set result [slave msg test.tcl -match {a* b*} -verbose 'ps']
list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
[regexp "Total.+4.+Passed.+1.+Skipped.+2.+Failed.+1" $msg]
} {0 1 1 0 1}
test tcltest-3.5 {tcltest::match} {
-body {
set oldMatch [match]
match foo
set currentMatch [match]
match bar
set newMatch [match]
match $oldMatch
list $currentMatch $newMatch
}
-result {foo bar}
}
# -skip, [skip]
test tcltest-4.1 {tcltest -skip 'a*'} {unixOrWin} {
set result [slave msg test.tcl -skip a* -verbose 'ps']
list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
[regexp "Total.+4.+Passed.+0.+Skipped.+2.+Failed.+1" $msg]
} {0 0 1 1 1}
test tcltest-4.2 {tcltest -skip 'b*'} {unixOrWin} {
set result [slave msg test.tcl -skip b* -verbose 'ps']
list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
[regexp "Total.+4.+Passed.+1.+Skipped.+2.+Failed.+1" $msg]
} {0 1 0 1 1}
test tcltest-4.3 {tcltest -skip 'c*'} {unixOrWin} {
set result [slave msg test.tcl -skip c* -verbose 'ps']
list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
[regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
} {0 1 1 0 1}
test tcltest-4.4 {tcltest -skip 'a* b*'} {unixOrWin} {
set result [slave msg test.tcl -skip {a* b*} -verbose 'ps']
list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
[regexp "Total.+4.+Passed.+0.+Skipped.+3.+Failed.+1" $msg]
} {0 0 0 1 1}
test tcltest-4.5 {tcltest -match 'a* b*' -skip 'b*'} {unixOrWin} {
set result [slave msg test.tcl -match {a* b*} -skip b* -verbose 'ps']
list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
[regexp "Total.+4.+Passed.+1.+Skipped.+3.+Failed.+0" $msg]
} {0 1 0 0 1}
test tcltest-4.6 {tcltest::skip} {
-body {
set oldSkip [skip]
skip foo
set currentSkip [skip]
skip bar
set newSkip [skip]
skip $oldSkip
list $currentSkip $newSkip
}
-result {foo bar}
}
# -constraints, -limitconstraints, [testConstraint],
# $constraintsSpecified, [limitConstraints]
test tcltest-5.1 {tcltest -constraints 'knownBug'} {unixOrWin} {
set result [slave msg test.tcl -constraints knownBug -verbose 'ps']
list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
[regexp "Total.+4.+Passed.+2.+Skipped.+0.+Failed.+2" $msg]
} {0 1 1 1 1}
test tcltest-5.2 {tcltest -constraints 'knownBug' -limitconstraints 1} {unixOrWin} {
set result [slave msg test.tcl -constraints knownBug -verbose 'p' -limitconstraints 1]
list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
[regexp "Total.+4.+Passed.+1.+Skipped.+3.+Failed.+0" $msg]
} {0 0 0 1 1}
test tcltest-5.3 {testConstraint - constraint empty (tcltest::safeFetch)} {
-body {
|
| ︙ | ︙ | |||
351 352 353 354 355 356 357 |
::tcltest::PrintError "a really really long string containing a \
\"Really/Long/Path/that/contains/no/spaces/and/is/longer/than/eighty/characters/to/see/what/happens\""
::tcltest::PrintError "Problem renaming file: error renaming \"Z:/ws/tcl8.2/win32-ix86/tests/core\" to \"Z:/ws/tcl8.2/win32-ix86/tests/movecore-core\""
exit
} printerror.tcl]
test tcltest-6.1 {tcltest -outfile, -errfile defaults} {
| | | | | | 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 |
::tcltest::PrintError "a really really long string containing a \
\"Really/Long/Path/that/contains/no/spaces/and/is/longer/than/eighty/characters/to/see/what/happens\""
::tcltest::PrintError "Problem renaming file: error renaming \"Z:/ws/tcl8.2/win32-ix86/tests/core\" to \"Z:/ws/tcl8.2/win32-ix86/tests/movecore-core\""
exit
} printerror.tcl]
test tcltest-6.1 {tcltest -outfile, -errfile defaults} {
-constraints unixOrWin
-body {
slave msg $printerror
return $msg
}
-result {a test.*a really}
-match regexp
}
test tcltest-6.2 {tcltest -outfile a.tmp} {unixOrWin unixExecs} {
slave msg $printerror -outfile a.tmp
set result1 [catch {exec grep "a test" a.tmp}]
set result2 [catch {exec grep "a really" a.tmp}]
list [regexp "a test" $msg] [regexp "a really" $msg] \
$result1 $result2 [file exists a.tmp] [file delete a.tmp]
} {0 1 0 1 1 {}}
test tcltest-6.3 {tcltest -errfile a.tmp} {unixOrWin unixExecs} {
slave msg $printerror -errfile a.tmp
set result1 [catch {exec grep "a test" a.tmp}]
set result2 [catch {exec grep "a really" a.tmp}]
list [regexp "a test" $msg] [regexp "a really" $msg] \
$result1 $result2 [file exists a.tmp] [file delete a.tmp]
} {1 0 1 0 1 {}}
test tcltest-6.4 {tcltest -outfile a.tmp -errfile b.tmp} {unixOrWin unixExecs} {
slave msg $printerror -outfile a.tmp -errfile b.tmp
set result1 [catch {exec grep "a test" a.tmp}]
set result2 [catch {exec grep "a really" b.tmp}]
list [regexp "a test" $msg] [regexp "a really" $msg] \
$result1 $result2 \
[file exists a.tmp] [file delete a.tmp] \
[file exists b.tmp] [file delete b.tmp]
|
| ︙ | ︙ | |||
460 461 462 463 464 465 466 |
}
}
# -debug, [debug]
# Must use child processes to test -debug because it always writes
# messages to stdout, and we have no way to capture stdout of a
# slave interp
| | | | | | | 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 |
}
}
# -debug, [debug]
# Must use child processes to test -debug because it always writes
# messages to stdout, and we have no way to capture stdout of a
# slave interp
test tcltest-7.1 {tcltest test.tcl -debug 0} {unixOrWin} {
catch {exec [interpreter] test.tcl -debug 0} msg
regexp "Flags passed into tcltest" $msg
} {0}
test tcltest-7.2 {tcltest test.tcl -debug 1} {unixOrWin} {
catch {exec [interpreter] test.tcl -debug 1 -skip b*} msg
list [regexp userSpecifiedSkip $msg] \
[regexp "Flags passed into tcltest" $msg]
} {1 0}
test tcltest-7.3 {tcltest test.tcl -debug 1} {unixOrWin} {
catch {exec [interpreter] test.tcl -debug 1 -match b*} msg
list [regexp userSpecifiedNonMatch $msg] \
[regexp "Flags passed into tcltest" $msg]
} {1 0}
test tcltest-7.4 {tcltest test.tcl -debug 2} {unixOrWin} {
catch {exec [interpreter] test.tcl -debug 2} msg
list [regexp "Flags passed into tcltest" $msg] [regexp "Running" $msg]
} {1 0}
test tcltest-7.5 {tcltest test.tcl -debug 3} {unixOrWin} {
catch {exec [interpreter] test.tcl -debug 3} msg
list [regexp "Flags passed into tcltest" $msg] [regexp "Running" $msg]
} {1 1}
test tcltest-7.6 {tcltest::debug} {
-setup {
set old $::tcltest::debug
|
| ︙ | ︙ | |||
518 519 520 521 522 523 524 |
set tdiaf [makeFile {} thisdirectoryisafile]
set normaldirectory [makeDirectory normaldirectory]
normalizePath normaldirectory
# -tmpdir, [temporaryDirectory]
| | | | 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 |
set tdiaf [makeFile {} thisdirectoryisafile]
set normaldirectory [makeDirectory normaldirectory]
normalizePath normaldirectory
# -tmpdir, [temporaryDirectory]
test tcltest-8.1 {tcltest a.tcl -tmpdir a} -constraints unixOrWin -setup {
file delete -force thisdirectorydoesnotexist
} -body {
slave msg $a -tmpdir thisdirectorydoesnotexist
file exists [file join thisdirectorydoesnotexist a.tmp]
} -cleanup {
file delete -force thisdirectorydoesnotexist
} -result 1
test tcltest-8.2 {tcltest a.tcl -tmpdir thisdirectoryisafile} {
-constraints unixOrWin
-body {
slave msg $a -tmpdir $tdiaf
return $msg
}
-result {*not a directory*}
-match glob
}
|
| ︙ | ︙ | |||
569 570 571 572 573 574 575 |
# interfere with tcltest-5.5
testConstraint notFAT [expr {
![regexp {^(FAT\d*|NTFS)$} [lindex [file system $notWriteableDir] 1]]
|| $::tcl_platform(platform) eq "unix" || [llength [info commands testchmod]]
}]
# FAT/NTFS permissions are fairly hopeless; ignore this test if that FS is used
test tcltest-8.4 {tcltest a.tcl -tmpdir notWriteableDir} {
| | | | 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 |
# interfere with tcltest-5.5
testConstraint notFAT [expr {
![regexp {^(FAT\d*|NTFS)$} [lindex [file system $notWriteableDir] 1]]
|| $::tcl_platform(platform) eq "unix" || [llength [info commands testchmod]]
}]
# FAT/NTFS permissions are fairly hopeless; ignore this test if that FS is used
test tcltest-8.4 {tcltest a.tcl -tmpdir notWriteableDir} {
-constraints {unixOrWin notRoot notFAT}
-body {
slave msg $a -tmpdir $notWriteableDir
return $msg
}
-result {*not writeable*}
-match glob
}
test tcltest-8.5 {tcltest a.tcl -tmpdir normaldirectory} {
-constraints unixOrWin
-body {
slave msg $a -tmpdir $normaldirectory
# The join is necessary because the message can be split on multiple
# lines
file exists [file join $normaldirectory a.tmp]
}
-cleanup {
|
| ︙ | ︙ | |||
621 622 623 624 625 626 627 |
list $f1 $f2 $f3
} -cleanup {
set ::tcltest::temporaryDirectory $old
} -result [list $normaldirectory [workingDirectory] [workingDirectory]]
cd [temporaryDirectory]
# -testdir, [testsDirectory]
test tcltest-8.10 {tcltest a.tcl -testdir thisdirectorydoesnotexist} {
| | | | | 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 |
list $f1 $f2 $f3
} -cleanup {
set ::tcltest::temporaryDirectory $old
} -result [list $normaldirectory [workingDirectory] [workingDirectory]]
cd [temporaryDirectory]
# -testdir, [testsDirectory]
test tcltest-8.10 {tcltest a.tcl -testdir thisdirectorydoesnotexist} {
-constraints unixOrWin
-setup {
file delete -force thisdirectorydoesnotexist
}
-body {
slave msg $a -testdir thisdirectorydoesnotexist
return $msg
}
-match glob
-result {*does not exist*}
}
test tcltest-8.11 {tcltest a.tcl -testdir thisdirectoryisafile} {
-constraints unixOrWin
-body {
slave msg $a -testdir $tdiaf
return $msg
}
-match glob
-result {*not a directory*}
}
test tcltest-8.12 {tcltest a.tcl -testdir notReadableDir} {
-constraints {unix notRoot}
-body {
slave msg $a -testdir $notReadableDir
return $msg
}
-match glob
-result {*not readable*}
}
test tcltest-8.13 {tcltest a.tcl -testdir normaldirectory} {
-constraints unixOrWin
-body {
slave msg $a -testdir $normaldirectory
# The join is necessary because the message can be split on multiple
# lines
list [string first "testdir: $normaldirectory" [join $msg]] \
[file exists [file join [temporaryDirectory] a.tmp]]
}
|
| ︙ | ︙ | |||
728 729 730 731 732 733 734 | file delete -force -- $notReadableDir $notWriteableDir removeFile a.tcl removeFile thisdirectoryisafile removeDirectory normaldirectory # -file, -notfile, [matchFiles], [skipFiles] | | | | 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 |
file delete -force -- $notReadableDir $notWriteableDir
removeFile a.tcl
removeFile thisdirectoryisafile
removeDirectory normaldirectory
# -file, -notfile, [matchFiles], [skipFiles]
test tcltest-9.1 {-file d*.tcl} -constraints {unixOrWin} -setup {
set old [testsDirectory]
testsDirectory [file dirname [info script]]
} -body {
slave msg [file join [testsDirectory] all.tcl] -file d*.test
return $msg
} -cleanup {
testsDirectory $old
} -match regexp -result {dstring\.test}
test tcltest-9.2 {-file d*.tcl} -constraints {unixOrWin} -setup {
set old [testsDirectory]
testsDirectory [file dirname [info script]]
} -body {
slave msg [file join [testsDirectory] all.tcl] \
-file d*.test -notfile dstring*
regexp {dstring\.test} $msg
} -cleanup {
|
| ︙ | ︙ | |||
803 804 805 806 807 808 809 |
close $f
} {}
::tcltest::cleanupTests
return
} makecore.tcl]
cd [temporaryDirectory]
| | | | | | 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 |
close $f
} {}
::tcltest::cleanupTests
return
} makecore.tcl]
cd [temporaryDirectory]
test tcltest-10.1 {-preservecore 0} {unixOrWin} {
slave msg $mc -preservecore 0
file delete core
regexp "Core file produced" $msg
} {0}
test tcltest-10.2 {-preservecore 1} {unixOrWin} {
slave msg $mc -preservecore 1
file delete core
regexp "Core file produced" $msg
} {1}
test tcltest-10.3 {-preservecore 2} {unixOrWin} {
slave msg $mc -preservecore 2
file delete core
list [regexp "Core file produced" $msg] [regexp "Moving file to" $msg] \
[regexp "core-" $msg] [file delete core-makecore]
} {1 1 1 {}}
test tcltest-10.4 {-preservecore 3} {unixOrWin} {
slave msg $mc -preservecore 3
file delete core
list [regexp "Core file produced" $msg] [regexp "Moving file to" $msg] \
[regexp "core-" $msg] [file delete core-makecore]
} {1 1 1 {}}
# Removing this test. It makes no sense to test the ability of
|
| ︙ | ︙ | |||
850 851 852 853 854 855 856 |
package require tcltest
namespace import tcltest::*
puts [outputChannel] $::tcltest::loadScript
exit
}
set loadfile [makeFile $contents load.tcl]
| | | | 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 |
package require tcltest
namespace import tcltest::*
puts [outputChannel] $::tcltest::loadScript
exit
}
set loadfile [makeFile $contents load.tcl]
test tcltest-12.1 {-load xxx} {unixOrWin} {
slave msg $loadfile -load xxx
return $msg
} {xxx}
# Using child process because of -debug usage.
test tcltest-12.2 {-loadfile load.tcl} {unixOrWin} {
catch {exec [interpreter] $loadfile -debug 2 -loadfile $loadfile} msg
list \
[regexp {tcltest} [join [list $msg] [split $msg \n]]] \
[regexp {loadScript} [join [list $msg] [split $msg \n]]]
} {1 1}
test tcltest-12.3 {loadScript} {
|
| ︙ | ︙ | |||
947 948 949 950 951 952 953 |
namespace import tcltest::*
testsDirectory [file join [temporaryDirectory] singleprocdir]
runAllTests
} all-single.tcl $spd]
cd [workingDirectory]
test tcltest-14.1 {-singleproc - single process} {
| | | | 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 |
namespace import tcltest::*
testsDirectory [file join [temporaryDirectory] singleprocdir]
runAllTests
} all-single.tcl $spd]
cd [workingDirectory]
test tcltest-14.1 {-singleproc - single process} {
-constraints {unixOrWin}
-body {
slave msg $allfile -singleproc 0 -tmpdir [temporaryDirectory]
return $msg
}
-result {Test file error: can't unset .foo.: no such variable}
-match regexp
}
test tcltest-14.2 {-singleproc - multiple process} {
-constraints {unixOrWin}
-body {
slave msg $allfile -singleproc 1 -tmpdir [temporaryDirectory]
return $msg
}
-result {single1.test.*single2.test.*all\-single.tcl:.*Total.*0.*Passed.*0.*Skipped.*0.*Failed.*0}
-match regexp
}
|
| ︙ | ︙ | |||
1021 1022 1023 1024 1025 1026 1027 |
package require tcltest
namespace import -force tcltest::*
testsDirectory [file join [temporaryDirectory] dirtestdir dirtestdir2.3]
runAllTests
} all.tcl $dtd3
test tcltest-15.1 {basic directory walking} {
| | | | | | | 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 |
package require tcltest
namespace import -force tcltest::*
testsDirectory [file join [temporaryDirectory] dirtestdir dirtestdir2.3]
runAllTests
} all.tcl $dtd3
test tcltest-15.1 {basic directory walking} {
-constraints {unixOrWin}
-body {
if {[slave msg \
[file join $dtd all.tcl] \
-tmpdir [temporaryDirectory]] == 1} {
error $msg
}
}
-match regexp
-returnCodes 1
-result {Tests located in:.*dirtestdir.*Tests located in:.*dirtestdir2.[123].*Tests located in:.*dirtestdir2.[123].*Tests located in:.*dirtestdir2.[123]}
}
test tcltest-15.2 {-asidefromdir} {
-constraints {unixOrWin}
-body {
if {[slave msg \
[file join $dtd all.tcl] \
-asidefromdir dirtestdir2.3 \
-tmpdir [temporaryDirectory]] == 1} {
error $msg
}
}
-match regexp
-returnCodes 1
-result {Tests located in:.*dirtestdir.*Tests located in:.*dirtestdir2.[12].*Tests located in:.*dirtestdir2.[12].*dirtestdir2.[12] test ended at .*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Error: No test files remain after applying your match and skip patterns!
Error: No test files remain after applying your match and skip patterns!
Error: No test files remain after applying your match and skip patterns!$}
}
test tcltest-15.3 {-relateddir, non-existent dir} {
-constraints {unixOrWin}
-body {
if {[slave msg \
[file join $dtd all.tcl] \
-relateddir [file join [temporaryDirectory] dirtestdir0] \
-tmpdir [temporaryDirectory]] == 1} {
error $msg
}
}
-returnCodes 1
-match regexp
-result {[^~]|dirtestdir[^2]}
}
test tcltest-15.4 {-relateddir, subdir} {
-constraints {unixOrWin}
-body {
if {[slave msg \
[file join $dtd all.tcl] \
-relateddir dirtestdir2.1 -tmpdir [temporaryDirectory]] == 1} {
error $msg
}
}
-returnCodes 1
-match regexp
-result {Tests located in:.*dirtestdir2.[^23]}
}
test tcltest-15.5 {-relateddir, -asidefromdir} {
-constraints {unixOrWin}
-body {
if {[slave msg \
[file join $dtd all.tcl] \
-relateddir "dirtestdir2.1 dirtestdir2.2" \
-asidefromdir dirtestdir2.2 \
-tmpdir [temporaryDirectory]] == 1} {
error $msg
|
| ︙ | ︙ | |||
1170 1171 1172 1173 1174 1175 1176 |
} -result {^3$} -match regexp -output\
{tcltest::debug\s+= 2.*tcltest::debug\s+= 3}
# Begin testing of tcltest procs ...
cd [temporaryDirectory]
# PrintError
| | | 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 |
} -result {^3$} -match regexp -output\
{tcltest::debug\s+= 2.*tcltest::debug\s+= 3}
# Begin testing of tcltest procs ...
cd [temporaryDirectory]
# PrintError
test tcltest-20.1 {PrintError} {unixOrWin} {
set result [slave msg $printerror]
list $result [regexp "Error: a really short string" $msg] \
[regexp " \"quotes\"" $msg] [regexp " \"Path" $msg] \
[regexp " \"Really" $msg] [regexp Problem $msg]
} {1 1 1 1 1 1}
cd [workingDirectory]
removeFile printerror.tcl
|
| ︙ | ︙ | |||
1406 1407 1408 1409 1410 1411 1412 |
}
cleanupTests
} test.test $atd
# Must use a child process because stdout/stderr parsing can't be
# duplicated in slave interp.
test tcltest-22.1 {runAllTests} {
| | | 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 |
}
cleanupTests
} test.test $atd
# Must use a child process because stdout/stderr parsing can't be
# duplicated in slave interp.
test tcltest-22.1 {runAllTests} {
-constraints {unixOrWin}
-body {
exec [interpreter] \
[file join $atd all.tcl] \
-verbose t -tmpdir [temporaryDirectory]
}
-match regexp
-result "Test files exiting with errors:.*error.test.*exit.test"
|
| ︙ | ︙ |
Changes to tests/tm.test.
| ︙ | ︙ | |||
196 197 198 199 200 201 202 |
::tcl::tm::path list
} -result {geode snarf foo}
proc genpaths {base} {
# Normalizing picks up drive letters on windows [Bug 1053568]
set base [file normalize $base]
| | | 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 |
::tcl::tm::path list
} -result {geode snarf foo}
proc genpaths {base} {
# Normalizing picks up drive letters on windows [Bug 1053568]
set base [file normalize $base]
regexp {^(\d+)\.(\d+)} [package provide Tcl] - major minor
set results {}
set base [file join $base tcl$major]
lappend results [file join $base site-tcl]
for {set i 0} {$i <= $minor} {incr i} {
lappend results [file join $base ${major}.$i]
}
return $results
|
| ︙ | ︙ |
Changes to tests/uplevel.test.
| ︙ | ︙ | |||
79 80 81 82 83 84 85 86 87 88 89 90 91 92 |
} 66
test uplevel-3.4 {uplevel to same level} {
set y zzz
proc a1 {} {set y 55; uplevel #1 set y}
a1
} 55
test uplevel-4.1 {error: non-existent level} -returnCodes error -body {
apply {{} {
uplevel #2 {set y 222}
}}
} -result {bad level "#2"}
test uplevel-4.2 {error: non-existent level} -returnCodes error -body {
apply {{} {
| > > > > > > > > > > | 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 |
} 66
test uplevel-3.4 {uplevel to same level} {
set y zzz
proc a1 {} {set y 55; uplevel #1 set y}
a1
} 55
test uplevel-4.0.1 {error: non-existent level} -body {
uplevel #0 { uplevel { set y 222 } }
} -returnCodes error -result {bad level "1"}
test uplevel-4.0.2 {error: non-existent level} -setup {
interp create i
} -body {
i eval { uplevel { set y 222 } }
} -returnCodes error -result {bad level "1"} -cleanup {
interp delete i
}
test uplevel-4.1 {error: non-existent level} -returnCodes error -body {
apply {{} {
uplevel #2 {set y 222}
}}
} -result {bad level "#2"}
test uplevel-4.2 {error: non-existent level} -returnCodes error -body {
apply {{} {
|
| ︙ | ︙ |
Changes to tests/upvar.test.
| ︙ | ︙ | |||
300 301 302 303 304 305 306 307 308 309 310 311 312 313 |
test upvar-8.2.1 {upvar with numeric first argument} {
apply {{} {set 0 ok; apply {{} {upvar 0 x; return $x}}}}
} ok
test upvar-8.3 {errors in upvar command} -returnCodes error -body {
proc p1 {} {upvar a b c}
p1
} -result {bad level "a"}
test upvar-8.4 {errors in upvar command} -returnCodes error -body {
proc p1 {} {upvar 0 b b}
p1
} -result {can't upvar from variable to itself}
test upvar-8.5 {errors in upvar command} -returnCodes error -body {
proc p1 {} {upvar 0 a b; upvar 0 b a}
p1
| > > > > > > > > > > > | 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 |
test upvar-8.2.1 {upvar with numeric first argument} {
apply {{} {set 0 ok; apply {{} {upvar 0 x; return $x}}}}
} ok
test upvar-8.3 {errors in upvar command} -returnCodes error -body {
proc p1 {} {upvar a b c}
p1
} -result {bad level "a"}
test upvar-8.3.1 {bad level for upvar (upvar at top-level, bug [775ee88560])} -body {
proc p1 {} { uplevel { upvar b b; lappend b UNEXPECTED } }
uplevel #0 { p1 }
} -returnCodes error -result {bad level "1"}
test upvar-8.3.2 {bad level for upvar (upvar at top-level, bug [775ee88560])} -setup {
interp create i
} -body {
i eval { upvar b b; lappend b UNEXPECTED }
} -returnCodes error -result {bad level "1"} -cleanup {
interp delete i
}
test upvar-8.4 {errors in upvar command} -returnCodes error -body {
proc p1 {} {upvar 0 b b}
p1
} -result {can't upvar from variable to itself}
test upvar-8.5 {errors in upvar command} -returnCodes error -body {
proc p1 {} {upvar 0 a b; upvar 0 b a}
p1
|
| ︙ | ︙ | |||
351 352 353 354 355 356 357 |
} -body {
array set upvarArray {}
upvar 0 upvarArray(elem) upvarArrayElemAlias(elem)
} -returnCodes 1 -match glob -result *
test upvar-9.1 {Tcl_UpVar2 procedure} testupvar {
list [catch {testupvar xyz a {} x global} msg] $msg
| | | 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 |
} -body {
array set upvarArray {}
upvar 0 upvarArray(elem) upvarArrayElemAlias(elem)
} -returnCodes 1 -match glob -result *
test upvar-9.1 {Tcl_UpVar2 procedure} testupvar {
list [catch {testupvar xyz a {} x global} msg] $msg
} {1 {bad level "1"}}
test upvar-9.1.1 {TclGetFrame, via Tcl_UpVar2} testupvar {
apply {{} {testupvar xyz a {} x local; set x foo}}
set a
} foo
test upvar-9.2 {Tcl_UpVar2 procedure} testupvar {
catch {unset a}
catch {unset x}
|
| ︙ | ︙ |
Changes to tests/winTime.test.
| ︙ | ︙ | |||
15 16 17 18 19 20 21 22 23 24 25 26 27 28 |
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testwinclock [llength [info commands testwinclock]]
# The next two tests will crash on Windows if the check for negative
# clock values is not done properly.
test winTime-1.1 {TclpGetDate} {win} {
set ::env(TZ) JST-9
set result [clock format -1 -format %Y]
| > | 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 |
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testwinclock [llength [info commands testwinclock]]
testConstraint knownMsvcBug [expr {![info exists ::env(TRAVIS_OS_NAME)] || ![string match windows $::env(TRAVIS_OS_NAME)]}]
# The next two tests will crash on Windows if the check for negative
# clock values is not done properly.
test winTime-1.1 {TclpGetDate} {win} {
set ::env(TZ) JST-9
set result [clock format -1 -format %Y]
|
| ︙ | ︙ | |||
36 37 38 39 40 41 42 |
set result
} {1969}
# Next test tries to make sure that the Tcl clock stays in step
# with the Windows clock. 30 sec really isn't enough,
# but how much time does a tester have patience for?
| | | | 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 |
set result
} {1969}
# Next test tries to make sure that the Tcl clock stays in step
# with the Windows clock. 30 sec really isn't enough,
# but how much time does a tester have patience for?
test winTime-2.1 {Synchronization of Tcl and Windows clocks} {testwinclock knownMsvcBug} {
# May fail due to OS/hardware discrepancies. See:
# http://support.microsoft.com/default.aspx?scid=kb;en-us;274323
set failed {}
set ok 1
foreach start_sec [testwinclock] break
while { 1 } {
foreach { sys_sec sys_usec tcl_sec tcl_usec } [testwinclock] break
set diff [expr { $tcl_sec - $sys_sec
+ 1.0e-6 * ( $tcl_usec - $sys_usec ) }]
if { abs($diff) > 0.1 } {
set failed "Tcl clock differs from system clock by $diff sec"
break
} else {
testwinsleep 1
}
if { $sys_sec - $start_sec >= 30 } break
}
set failed
} {}
# cleanup
::tcltest::cleanupTests
return
|
Changes to tools/tcltk-man2html-utils.tcl.
| ︙ | ︙ | |||
872 873 874 875 876 877 878 |
url - end-bold {
append result \
[string range $text 0 [expr {$offset(bold)-1}]]
set body [string range $text [expr {$offset(bold)+3}] \
[expr {$offset(end-bold)-1}]]
set text [string range $text[set text ""] \
[expr {$offset(end-bold)+4}] end]
| | | 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 |
url - end-bold {
append result \
[string range $text 0 [expr {$offset(bold)-1}]]
set body [string range $text [expr {$offset(bold)+3}] \
[expr {$offset(end-bold)-1}]]
set text [string range $text[set text ""] \
[expr {$offset(end-bold)+4}] end]
regsub {http://[\w/.-]+} $body {<A HREF="&">&</A>} body
append result <B> [cross-reference $body] </B>
continue
}
anchor {
append result \
[string range $text 0 [expr {$offset(end-bold)+3}]]
set text [string range $text[set text ""] \
|
| ︙ | ︙ | |||
908 909 910 911 912 913 914 |
set text [string range $text[set text ""] [expr {$off+3}] end]
append result [cross-reference Tcl]
continue
}
url {
set off [lindex $offsets 0]
append result [string range $text 0 [expr {$off-1}]]
| | | 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 |
set text [string range $text[set text ""] [expr {$off+3}] end]
append result [cross-reference Tcl]
continue
}
url {
set off [lindex $offsets 0]
append result [string range $text 0 [expr {$off-1}]]
regexp -indices -start $off {http://[\w/.-]+} $text range
set url [string range $text {*}$range]
append result "<A HREF=\"[string trimright $url .]\">$url</A>"
set text [string range $text[set text ""] \
[expr {[lindex $range 1]+1}] end]
continue
}
end-anchor - end-bold - end-quote {
|
| ︙ | ︙ |
Changes to unix/Makefile.in.
| ︙ | ︙ | |||
24 25 26 27 28 29 30 31 32 33 34 35 36 37 | prefix = @prefix@ exec_prefix = @exec_prefix@ bindir = @bindir@ libdir = @libdir@ includedir = @includedir@ datarootdir = @datarootdir@ mandir = @mandir@ # The following definition can be set to non-null for special systems like AFS # with replication. It allows the pathnames used for installation to be # different than those used for actually reference files at run-time. # INSTALL_ROOT is prepended to $prefix and $exec_prefix when installing files. INSTALL_ROOT = $(DESTDIR) | > | 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 | prefix = @prefix@ exec_prefix = @exec_prefix@ bindir = @bindir@ libdir = @libdir@ includedir = @includedir@ datarootdir = @datarootdir@ runstatedir = @runstatedir@ mandir = @mandir@ # The following definition can be set to non-null for special systems like AFS # with replication. It allows the pathnames used for installation to be # different than those used for actually reference files at run-time. # INSTALL_ROOT is prepended to $prefix and $exec_prefix when installing files. INSTALL_ROOT = $(DESTDIR) |
| ︙ | ︙ | |||
341 342 343 344 345 346 347 | bn_mp_signed_rsh.o \ bn_mp_to_unsigned_bin.o bn_mp_to_unsigned_bin_n.o \ bn_mp_toom_mul.o bn_mp_toom_sqr.o bn_mp_toradix_n.o \ bn_mp_unsigned_bin_size.o bn_mp_xor.o bn_mp_zero.o bn_s_mp_add.o \ bn_s_mp_mul_digs.o bn_s_mp_sqr.o bn_s_mp_sub.o STUB_LIB_OBJS = tclStubLib.o \ | | | | | 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 |
bn_mp_signed_rsh.o \
bn_mp_to_unsigned_bin.o bn_mp_to_unsigned_bin_n.o \
bn_mp_toom_mul.o bn_mp_toom_sqr.o bn_mp_toradix_n.o \
bn_mp_unsigned_bin_size.o bn_mp_xor.o bn_mp_zero.o bn_s_mp_add.o \
bn_s_mp_mul_digs.o bn_s_mp_sqr.o bn_s_mp_sub.o
STUB_LIB_OBJS = tclStubLib.o \
tclStubCall.o \
tclStubStaticPackage.o \
tclStubMainEx.o \
tclStubLibTbl.o \
tclTomMathStubLib.o \
tclOOStubLib.o \
${COMPAT_OBJS}
UNIX_OBJS = tclUnixChan.o tclUnixEvent.o tclUnixFCmd.o \
tclUnixFile.o tclUnixPipe.o tclUnixSock.o \
|
| ︙ | ︙ | |||
487 488 489 490 491 492 493 | $(GENERIC_DIR)/tclOODefineCmds.c \ $(GENERIC_DIR)/tclOOInfo.c \ $(GENERIC_DIR)/tclOOMethod.c \ $(GENERIC_DIR)/tclOOStubInit.c STUB_SRCS = \ $(GENERIC_DIR)/tclStubLib.c \ | | | | | 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 | $(GENERIC_DIR)/tclOODefineCmds.c \ $(GENERIC_DIR)/tclOOInfo.c \ $(GENERIC_DIR)/tclOOMethod.c \ $(GENERIC_DIR)/tclOOStubInit.c STUB_SRCS = \ $(GENERIC_DIR)/tclStubLib.c \ $(GENERIC_DIR)/tclStubCall.c \ $(GENERIC_DIR)/tclStubStaticPackage.c \ $(GENERIC_DIR)/tclStubMainEx.c \ $(GENERIC_DIR)/tclStubLibTbl.c \ $(GENERIC_DIR)/tclTomMathStubLib.c \ $(GENERIC_DIR)/tclOOStubLib.c TOMMATH_SRCS = \ $(TOMMATH_DIR)/bn_reverse.c \ $(TOMMATH_DIR)/bn_fast_s_mp_mul_digs.c \ |
| ︙ | ︙ | |||
953 954 955 956 957 958 959 | $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/opt0.4; \ done @echo "Installing package msgcat 1.7.0 as a Tcl Module" @$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl \ "$(MODULE_INSTALL_DIR)"/tcl9/9.0/msgcat-1.7.0.tm @echo "Installing package tcltest 2.5.0 as a Tcl Module" @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl \ | | | 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 | $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/opt0.4; \ done @echo "Installing package msgcat 1.7.0 as a Tcl Module" @$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl \ "$(MODULE_INSTALL_DIR)"/tcl9/9.0/msgcat-1.7.0.tm @echo "Installing package tcltest 2.5.0 as a Tcl Module" @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl \ "$(MODULE_INSTALL_DIR)"/tcl9/9.0/tcltest-2.5.1.tm @echo "Installing package platform 1.0.14 as a Tcl Module" @$(INSTALL_DATA) $(TOP_DIR)/library/platform/platform.tcl \ "$(MODULE_INSTALL_DIR)"/tcl9/9.0/platform-1.0.14.tm @echo "Installing package platform::shell 1.1.4 as a Tcl Module" @$(INSTALL_DATA) $(TOP_DIR)/library/platform/shell.tcl \ "$(MODULE_INSTALL_DIR)"/tcl9/9.0/platform/shell-1.1.4.tm @echo "Installing encoding files to $(SCRIPT_INSTALL_DIR)/encoding/" |
| ︙ | ︙ | |||
1825 1826 1827 1828 1829 1830 1831 | # Stub library binaries, these must be compiled for use in a shared library # even though they will be placed in a static archive #-------------------------------------------------------------------------- tclStubLib.o: $(GENERIC_DIR)/tclStubLib.c $(CC) -c $(STUB_CC_SWITCHES) -DSTATIC_BUILD $(GENERIC_DIR)/tclStubLib.c | | | | | | | | 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 | # Stub library binaries, these must be compiled for use in a shared library # even though they will be placed in a static archive #-------------------------------------------------------------------------- tclStubLib.o: $(GENERIC_DIR)/tclStubLib.c $(CC) -c $(STUB_CC_SWITCHES) -DSTATIC_BUILD $(GENERIC_DIR)/tclStubLib.c tclStubCall.o: $(GENERIC_DIR)/tclStubCall.c $(CC) -c $(STUB_CC_SWITCHES) -DSTATIC_BUILD -DTCL_DLL_FILE="\"$(TCL_LIB_FILE)\"" $(GENERIC_DIR)/tclStubCall.c tclStubStaticPackage.o: $(GENERIC_DIR)/tclStubStaticPackage.c $(CC) -c $(STUB_CC_SWITCHES) -DSTATIC_BUILD -DTCL_DLL_FILE="\"$(TCL_LIB_FILE)\"" $(GENERIC_DIR)/tclStubStaticPackage.c tclStubMainEx.o: $(GENERIC_DIR)/tclStubMainEx.c $(CC) -c $(STUB_CC_SWITCHES) -DSTATIC_BUILD -DTCL_DLL_FILE="\"$(TCL_LIB_FILE)\"" $(GENERIC_DIR)/tclStubMainEx.c tclStubLibTbl.o: $(GENERIC_DIR)/tclStubLibTbl.c $(CC) -c $(STUB_CC_SWITCHES) -DSTATIC_BUILD $(GENERIC_DIR)/tclStubLibTbl.c tclTomMathStubLib.o: $(GENERIC_DIR)/tclTomMathStubLib.c $(CC) -c $(STUB_CC_SWITCHES) $(GENERIC_DIR)/tclTomMathStubLib.c |
| ︙ | ︙ |
Changes to unix/configure.
| ︙ | ︙ | |||
9832 9833 9834 9835 9836 9837 9838 |
fi
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_ok" >&5
$as_echo "$tcl_ok" >&6; }
#------------------------------------------------------------------------
# Check whether the timezone data is supplied by the OS or has
# to be installed by Tcl. The default is autodetection, but can
| | | 9832 9833 9834 9835 9836 9837 9838 9839 9840 9841 9842 9843 9844 9845 9846 |
fi
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_ok" >&5
$as_echo "$tcl_ok" >&6; }
#------------------------------------------------------------------------
# Check whether the timezone data is supplied by the OS or has
# to be installed by Tcl. The default is autodetection, but can
# be overridden on the configure command line either way.
#------------------------------------------------------------------------
{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for timezone data" >&5
$as_echo_n "checking for timezone data... " >&6; }
# Check whether --with-tzdata was given.
if test "${with_tzdata+set}" = set; then :
|
| ︙ | ︙ |
Changes to unix/configure.ac.
| ︙ | ︙ | |||
673 674 675 676 677 678 679 |
AC_DEFINE(TCL_UNLOAD_DLLS, 1, [Do we allow unloading of shared libraries?])
fi
AC_MSG_RESULT([$tcl_ok])
#------------------------------------------------------------------------
# Check whether the timezone data is supplied by the OS or has
# to be installed by Tcl. The default is autodetection, but can
| | | 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 |
AC_DEFINE(TCL_UNLOAD_DLLS, 1, [Do we allow unloading of shared libraries?])
fi
AC_MSG_RESULT([$tcl_ok])
#------------------------------------------------------------------------
# Check whether the timezone data is supplied by the OS or has
# to be installed by Tcl. The default is autodetection, but can
# be overridden on the configure command line either way.
#------------------------------------------------------------------------
AC_MSG_CHECKING([for timezone data])
AC_ARG_WITH(tzdata,
AC_HELP_STRING([--with-tzdata],
[install timezone data (default: autodetect)]),
[tcl_ok=$withval], [tcl_ok=auto])
|
| ︙ | ︙ |
Changes to unix/tclAppInit.c.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 | * Copyright (c) 1994-1997 Sun Microsystems, Inc. * Copyright (c) 1998-1999 Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ | < < | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | * Copyright (c) 1994-1997 Sun Microsystems, Inc. * Copyright (c) 1998-1999 Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tcl.h" #ifdef TCL_TEST extern Tcl_PackageInitProc Tcltest_Init; extern Tcl_PackageInitProc Tcltest_SafeInit; #endif /* TCL_TEST */ |
| ︙ | ︙ |
Changes to unix/tclSelectNotfy.c.
| ︙ | ︙ | |||
227 228 229 230 231 232 233 |
int cbWndExtra;
void *hInstance;
void *hIcon;
void *hCursor;
void *hbrBackground;
void *lpszMenuName;
const void *lpszClassName;
| | | | 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 |
int cbWndExtra;
void *hInstance;
void *hIcon;
void *hCursor;
void *hbrBackground;
void *lpszMenuName;
const void *lpszClassName;
} WNDCLASSW;
extern void __stdcall CloseHandle(void *);
extern void *__stdcall CreateEventW(void *, unsigned char, unsigned char,
void *);
extern void *__stdcall CreateWindowExW(void *, const void *, const void *,
DWORD, int, int, int, int, void *, void *, void *,
void *);
extern DWORD __stdcall DefWindowProcW(void *, int, void *, void *);
extern unsigned char __stdcall DestroyWindow(void *);
extern int __stdcall DispatchMessageW(const MSG *);
extern unsigned char __stdcall GetMessageW(MSG *, void *, int, int);
extern void __stdcall MsgWaitForMultipleObjects(DWORD, void *,
unsigned char, DWORD, DWORD);
extern unsigned char __stdcall PeekMessageW(MSG *, void *, int, int, int);
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:
*/
|
| ︙ | ︙ | |||
293 294 295 296 297 298 299 |
tsdPtr->eventReady = 0;
/*
* Initialize thread specific condition variable for this thread.
*/
if (tsdPtr->waitCVinitialized == 0) {
#ifdef __CYGWIN__
| | | 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 |
tsdPtr->eventReady = 0;
/*
* Initialize thread specific condition variable for this thread.
*/
if (tsdPtr->waitCVinitialized == 0) {
#ifdef __CYGWIN__
WNDCLASSW class;
class.style = 0;
class.cbClsExtra = 0;
class.cbWndExtra = 0;
class.hInstance = TclWinGetTclInstance();
class.hbrBackground = NULL;
class.lpszMenuName = NULL;
|
| ︙ | ︙ |
Changes to unix/tclUnixChan.c.
| ︙ | ︙ | |||
92 93 94 95 96 97 98 | #endif /* SUPPORTS_TTY */ } TtyState; #ifdef SUPPORTS_TTY /* * The following structure is used to set or get the serial port attributes in | | | 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 |
#endif /* SUPPORTS_TTY */
} TtyState;
#ifdef SUPPORTS_TTY
/*
* The following structure is used to set or get the serial port attributes in
* a platform-independent manner.
*/
typedef struct {
int baud;
int parity;
int data;
int stop;
|
| ︙ | ︙ |
Changes to unix/tclUnixInit.c.
| ︙ | ︙ | |||
329 330 331 332 333 334 335 | /* *--------------------------------------------------------------------------- * * TclpInitPlatform -- * | | | 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 | /* *--------------------------------------------------------------------------- * * TclpInitPlatform -- * * Initialize all the platform-dependent things like signals and * floating-point error handling. * * Called at process initialization time. * * Results: * None. * |
| ︙ | ︙ |
Changes to unix/tclUnixTest.c.
| ︙ | ︙ | |||
58 59 60 61 62 63 64 | static const char *gotsig = "0"; /* * Forward declarations of functions defined later in this file: */ | | | | < | | < < | | 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 | static const char *gotsig = "0"; /* * Forward declarations of functions defined later in this file: */ static Tcl_ObjCmdProc TestalarmCmd; static Tcl_ObjCmdProc TestchmodCmd; static Tcl_ObjCmdProc TestfilehandlerCmd; static Tcl_ObjCmdProc TestfilewaitCmd; static Tcl_ObjCmdProc TestfindexecutableCmd; static Tcl_ObjCmdProc TestforkCmd; static Tcl_ObjCmdProc TestgotsigCmd; static Tcl_FileProc TestFileHandlerProc; static void AlarmHandler(int signum); /* *---------------------------------------------------------------------- * * TclplatformtestInit -- |
| ︙ | ︙ | |||
94 95 96 97 98 99 100 |
int
TclplatformtestInit(
Tcl_Interp *interp) /* Interpreter to add commands to. */
{
Tcl_CreateObjCommand(interp, "testchmod", TestchmodCmd,
NULL, NULL);
| | | | | < < | | < < < < | 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 |
int
TclplatformtestInit(
Tcl_Interp *interp) /* Interpreter to add commands to. */
{
Tcl_CreateObjCommand(interp, "testchmod", TestchmodCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testfilehandler", TestfilehandlerCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testfilewait", TestfilewaitCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testfindexecutable", TestfindexecutableCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testfork", TestforkCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testalarm", TestalarmCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testgotsig", TestgotsigCmd,
NULL, NULL);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
136 137 138 139 140 141 142 |
*----------------------------------------------------------------------
*/
static int
TestfilehandlerCmd(
ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
| | | | | < | | | | | | | < | | | < | | < | | | | | | | | | | | | < | | | < | | | | | < | | | < | | | | | | | 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 |
*----------------------------------------------------------------------
*/
static int
TestfilehandlerCmd(
ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Argument strings. */
{
Pipe *pipePtr;
int i, mask, timeout;
static int initialized = 0;
char buffer[4000];
TclFile file;
/*
* NOTE: When we make this code work on Windows also, the following
* variable needs to be made Unix-only.
*/
if (!initialized) {
for (i = 0; i < MAX_PIPES; i++) {
testPipes[i].readFile = NULL;
}
initialized = 1;
}
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "option ...");
return TCL_ERROR;
}
pipePtr = NULL;
if (objc >= 3) {
if (Tcl_GetIntFromObj(interp, objv[2], &i) != TCL_OK) {
return TCL_ERROR;
}
if (i >= MAX_PIPES) {
Tcl_AppendResult(interp, "bad index ", objv[2], NULL);
return TCL_ERROR;
}
pipePtr = &testPipes[i];
}
if (strcmp(Tcl_GetString(objv[1]), "close") == 0) {
for (i = 0; i < MAX_PIPES; i++) {
if (testPipes[i].readFile != NULL) {
TclpCloseFile(testPipes[i].readFile);
testPipes[i].readFile = NULL;
TclpCloseFile(testPipes[i].writeFile);
testPipes[i].writeFile = NULL;
}
}
} else if (strcmp(Tcl_GetString(objv[1]), "clear") == 0) {
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "index");
return TCL_ERROR;
}
pipePtr->readCount = pipePtr->writeCount = 0;
} else if (strcmp(Tcl_GetString(objv[1]), "counts") == 0) {
char buf[TCL_INTEGER_SPACE * 2];
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "index");
return TCL_ERROR;
}
sprintf(buf, "%d %d", pipePtr->readCount, pipePtr->writeCount);
Tcl_AppendResult(interp, buf, NULL);
} else if (strcmp(Tcl_GetString(objv[1]), "create") == 0) {
if (objc != 5) {
Tcl_WrongNumArgs(interp, 2, objv, "index readMode writeMode");
return TCL_ERROR;
}
if (pipePtr->readFile == NULL) {
if (!TclpCreatePipe(&pipePtr->readFile, &pipePtr->writeFile)) {
Tcl_AppendResult(interp, "couldn't open pipe: ",
Tcl_PosixError(interp), NULL);
return TCL_ERROR;
}
#ifdef O_NONBLOCK
fcntl(GetFd(pipePtr->readFile), F_SETFL, O_NONBLOCK);
fcntl(GetFd(pipePtr->writeFile), F_SETFL, O_NONBLOCK);
#else
Tcl_AppendResult(interp, "can't make pipes non-blocking",
NULL);
return TCL_ERROR;
#endif
}
pipePtr->readCount = 0;
pipePtr->writeCount = 0;
if (strcmp(Tcl_GetString(objv[3]), "readable") == 0) {
Tcl_CreateFileHandler(GetFd(pipePtr->readFile), TCL_READABLE,
TestFileHandlerProc, pipePtr);
} else if (strcmp(Tcl_GetString(objv[3]), "off") == 0) {
Tcl_DeleteFileHandler(GetFd(pipePtr->readFile));
} else if (strcmp(Tcl_GetString(objv[3]), "disabled") == 0) {
Tcl_CreateFileHandler(GetFd(pipePtr->readFile), 0,
TestFileHandlerProc, pipePtr);
} else {
Tcl_AppendResult(interp, "bad read mode \"", Tcl_GetString(objv[3]), "\"", NULL);
return TCL_ERROR;
}
if (strcmp(Tcl_GetString(objv[4]), "writable") == 0) {
Tcl_CreateFileHandler(GetFd(pipePtr->writeFile), TCL_WRITABLE,
TestFileHandlerProc, pipePtr);
} else if (strcmp(Tcl_GetString(objv[4]), "off") == 0) {
Tcl_DeleteFileHandler(GetFd(pipePtr->writeFile));
} else if (strcmp(Tcl_GetString(objv[4]), "disabled") == 0) {
Tcl_CreateFileHandler(GetFd(pipePtr->writeFile), 0,
TestFileHandlerProc, pipePtr);
} else {
Tcl_AppendResult(interp, "bad read mode \"", Tcl_GetString(objv[4]), "\"", NULL);
return TCL_ERROR;
}
} else if (strcmp(Tcl_GetString(objv[1]), "empty") == 0) {
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "index");
return TCL_ERROR;
}
while (read(GetFd(pipePtr->readFile), buffer, 4000) > 0) {
/* Empty loop body. */
}
} else if (strcmp(Tcl_GetString(objv[1]), "fill") == 0) {
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "index");
return TCL_ERROR;
}
memset(buffer, 'a', 4000);
while (write(GetFd(pipePtr->writeFile), buffer, 4000) > 0) {
/* Empty loop body. */
}
} else if (strcmp(Tcl_GetString(objv[1]), "fillpartial") == 0) {
char buf[TCL_INTEGER_SPACE];
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "index");
return TCL_ERROR;
}
memset(buffer, 'b', 10);
TclFormatInt(buf, write(GetFd(pipePtr->writeFile), buffer, 10));
Tcl_AppendResult(interp, buf, NULL);
} else if (strcmp(Tcl_GetString(objv[1]), "oneevent") == 0) {
Tcl_DoOneEvent(TCL_FILE_EVENTS|TCL_DONT_WAIT);
} else if (strcmp(Tcl_GetString(objv[1]), "wait") == 0) {
if (objc != 5) {
Tcl_WrongNumArgs(interp, 2, objv, "index readable|writable timeout");
return TCL_ERROR;
}
if (pipePtr->readFile == NULL) {
Tcl_AppendResult(interp, "pipe ", Tcl_GetString(objv[2]), " doesn't exist", NULL);
return TCL_ERROR;
}
if (strcmp(Tcl_GetString(objv[3]), "readable") == 0) {
mask = TCL_READABLE;
file = pipePtr->readFile;
} else {
mask = TCL_WRITABLE;
file = pipePtr->writeFile;
}
if (Tcl_GetIntFromObj(interp, objv[4], &timeout) != TCL_OK) {
return TCL_ERROR;
}
i = TclUnixWaitForFile(GetFd(file), mask, timeout);
if (i & TCL_READABLE) {
Tcl_AppendElement(interp, "readable");
}
if (i & TCL_WRITABLE) {
Tcl_AppendElement(interp, "writable");
}
} else if (strcmp(Tcl_GetString(objv[1]), "windowevent") == 0) {
Tcl_DoOneEvent(TCL_WINDOW_EVENTS|TCL_DONT_WAIT);
} else {
Tcl_AppendResult(interp, "bad option \"", Tcl_GetString(objv[1]),
"\": must be close, clear, counts, create, empty, fill, "
"fillpartial, oneevent, wait, or windowevent", NULL);
return TCL_ERROR;
}
return TCL_OK;
}
|
| ︙ | ︙ | |||
358 359 360 361 362 363 364 |
*----------------------------------------------------------------------
*/
static int
TestfilewaitCmd(
ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
| | | | < | | | | | | | | 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 |
*----------------------------------------------------------------------
*/
static int
TestfilewaitCmd(
ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Argument strings. */
{
int mask, result, timeout;
Tcl_Channel channel;
int fd;
ClientData data;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 2, objv, "file readable|writable|both timeout");
return TCL_ERROR;
}
channel = Tcl_GetChannel(interp, Tcl_GetString(objv[1]), NULL);
if (channel == NULL) {
return TCL_ERROR;
}
if (strcmp(Tcl_GetString(objv[2]), "readable") == 0) {
mask = TCL_READABLE;
} else if (strcmp(Tcl_GetString(objv[2]), "writable") == 0){
mask = TCL_WRITABLE;
} else if (strcmp(Tcl_GetString(objv[2]), "both") == 0){
mask = TCL_WRITABLE|TCL_READABLE;
} else {
Tcl_AppendResult(interp, "bad argument \"", Tcl_GetString(objv[2]),
"\": must be readable, writable, or both", NULL);
return TCL_ERROR;
}
if (Tcl_GetChannelHandle(channel,
(mask & TCL_READABLE) ? TCL_READABLE : TCL_WRITABLE,
(ClientData*) &data) != TCL_OK) {
Tcl_AppendResult(interp, "couldn't get channel file", NULL);
return TCL_ERROR;
}
fd = PTR2INT(data);
if (Tcl_GetIntFromObj(interp, objv[3], &timeout) != TCL_OK) {
return TCL_ERROR;
}
result = TclUnixWaitForFile(fd, mask, timeout);
if (result & TCL_READABLE) {
Tcl_AppendElement(interp, "readable");
}
if (result & TCL_WRITABLE) {
|
| ︙ | ︙ | |||
427 428 429 430 431 432 433 |
*----------------------------------------------------------------------
*/
static int
TestfindexecutableCmd(
ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
| | | | | < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | 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 |
*----------------------------------------------------------------------
*/
static int
TestfindexecutableCmd(
ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Argument strings. */
{
Tcl_Obj *saveName;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "argv0");
return TCL_ERROR;
}
saveName = TclGetObjNameOfExecutable();
Tcl_IncrRefCount(saveName);
TclpFindExecutable(Tcl_GetString(objv[1]));
Tcl_SetObjResult(interp, TclGetObjNameOfExecutable());
TclSetObjNameOfExecutable(saveName, NULL);
Tcl_DecrRefCount(saveName);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestforkCmd --
*
* This function implements the "testfork" command. It is used to
* fork the Tcl process for specific test cases.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
TestforkCmd(
ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Argument strings. */
{
pid_t pid;
|
| ︙ | ︙ | |||
573 574 575 576 577 578 579 |
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(pid));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | | | < < | 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 |
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(pid));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestalarmCmd --
*
* Test that EINTR is handled correctly by generating and handling a
* signal. This requires using the SA_RESTART flag when registering the
* signal handler.
*
* Results:
* None.
*
* Side Effects:
* Sets up an signal and async handlers.
*
*----------------------------------------------------------------------
*/
static int
TestalarmCmd(
ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Argument strings. */
{
#ifdef SA_RESTART
unsigned int sec = 1;
struct sigaction action;
if (objc > 1) {
Tcl_GetIntFromObj(interp, objv[1], (int *)&sec);
}
/*
* Setup the signal handling that automatically retries any interrupted
* I/O system calls.
*/
|
| ︙ | ︙ | |||
704 705 706 707 708 709 710 |
*----------------------------------------------------------------------
*/
static int
TestgotsigCmd(
ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
| | | | 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 |
*----------------------------------------------------------------------
*/
static int
TestgotsigCmd(
ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Argument strings. */
{
Tcl_AppendResult(interp, gotsig, NULL);
gotsig = "0";
return TCL_OK;
}
/*
|
| ︙ | ︙ |
Changes to unix/tclUnixTime.c.
| ︙ | ︙ | |||
85 86 87 88 89 90 91 | *---------------------------------------------------------------------- * * TclpGetClicks -- * * This procedure returns a value that represents the highest resolution * clock available on the system. There are no garantees on what the * resolution will be. In Tcl we will call this value a "click". The | | | 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 | *---------------------------------------------------------------------- * * TclpGetClicks -- * * This procedure returns a value that represents the highest resolution * clock available on the system. There are no garantees on what the * resolution will be. In Tcl we will call this value a "click". The * start time is also system dependent. * * Results: * Number of clicks from some start time. * * Side effects: * None. * |
| ︙ | ︙ |
Changes to win/Makefile.in.
| ︙ | ︙ | |||
19 20 21 22 23 24 25 26 27 28 29 30 31 32 | prefix = @prefix@ exec_prefix = @exec_prefix@ bindir = @bindir@ libdir = @libdir@ includedir = @includedir@ datarootdir = @datarootdir@ mandir = @mandir@ # The following definition can be set to non-null for special systems like AFS # with replication. It allows the pathnames used for installation to be # different than those used for actually reference files at run-time. # INSTALL_ROOT is prepended to $prefix and $exec_prefix when installing files. INSTALL_ROOT = | > | 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 | prefix = @prefix@ exec_prefix = @exec_prefix@ bindir = @bindir@ libdir = @libdir@ includedir = @includedir@ datarootdir = @datarootdir@ runstatedir = @runstatedir@ mandir = @mandir@ # The following definition can be set to non-null for special systems like AFS # with replication. It allows the pathnames used for installation to be # different than those used for actually reference files at run-time. # INSTALL_ROOT is prepended to $prefix and $exec_prefix when installing files. INSTALL_ROOT = |
| ︙ | ︙ | |||
77 78 79 80 81 82 83 | CFLAGS_OPTIMIZE = @CFLAGS_OPTIMIZE@ # To change the compiler switches, for example to change from optimization to # debugging symbols, change the following line: #CFLAGS = $(CFLAGS_DEBUG) #CFLAGS = $(CFLAGS_OPTIMIZE) #CFLAGS = $(CFLAGS_DEBUG) $(CFLAGS_OPTIMIZE) | | | | | 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 | CFLAGS_OPTIMIZE = @CFLAGS_OPTIMIZE@ # To change the compiler switches, for example to change from optimization to # debugging symbols, change the following line: #CFLAGS = $(CFLAGS_DEBUG) #CFLAGS = $(CFLAGS_OPTIMIZE) #CFLAGS = $(CFLAGS_DEBUG) $(CFLAGS_OPTIMIZE) CFLAGS = @CFLAGS@ @CFLAGS_DEFAULT@ -D_ATL_XP_TARGETING # To compile without backward compatibility and deprecated code uncomment the # following NO_DEPRECATED_FLAGS = #NO_DEPRECATED_FLAGS = -DTCL_NO_DEPRECATED # To enable compilation debugging reverse the comment characters on one of the # following lines. COMPILE_DEBUG_FLAGS = #COMPILE_DEBUG_FLAGS = -DTCL_COMPILE_DEBUG #COMPILE_DEBUG_FLAGS = -DTCL_COMPILE_DEBUG -DTCL_COMPILE_STATS SRC_DIR = @srcdir@ ROOT_DIR = @srcdir@/.. TOP_DIR = $(shell cd @srcdir@/..; pwd -W 2>/dev/null || pwd -P) GENERIC_DIR = $(TOP_DIR)/generic TOMMATH_DIR = $(TOP_DIR)/libtommath WIN_DIR = $(TOP_DIR)/win COMPAT_DIR = $(TOP_DIR)/compat PKGS_DIR = $(TOP_DIR)/pkgs ZLIB_DIR = $(COMPAT_DIR)/zlib # Converts a POSIX path to a Windows native path. CYGPATH = @CYGPATH@ libdir_native = $(shell $(CYGPATH) '$(libdir)') bindir_native = $(shell $(CYGPATH) '$(bindir)') includedir_native = $(shell $(CYGPATH) '$(includedir)') mandir_native = $(shell $(CYGPATH) '$(mandir)') TCL_LIBRARY_NATIVE = $(shell $(CYGPATH) '$(TCL_LIBRARY)') GENERIC_DIR_NATIVE = $(shell $(CYGPATH) '$(GENERIC_DIR)') TOMMATH_DIR_NATIVE = $(shell $(CYGPATH) '$(TOMMATH_DIR)') WIN_DIR_NATIVE = $(shell $(CYGPATH) '$(WIN_DIR)') ROOT_DIR_NATIVE = $(shell $(CYGPATH) '$(ROOT_DIR)') ROOT_DIR_WIN_NATIVE = $(shell cd '$(ROOT_DIR)' ; pwd -W 2>/dev/null || pwd -P) ZLIB_DIR_NATIVE = $(shell $(CYGPATH) '$(ZLIB_DIR)') #GENERIC_DIR_NATIVE = $(GENERIC_DIR) #TOMMATH_DIR_NATIVE = $(TOMMATH_DIR) #WIN_DIR_NATIVE = $(WIN_DIR) #ROOT_DIR_NATIVE = $(ROOT_DIR) # Fully qualify library path so that `make test` |
| ︙ | ︙ | |||
312 313 314 315 316 317 318 | tclIORTrans.$(OBJEXT) \ tclIOSock.$(OBJEXT) \ tclIOUtil.$(OBJEXT) \ tclLink.$(OBJEXT) \ tclLiteral.$(OBJEXT) \ tclListObj.$(OBJEXT) \ tclLoad.$(OBJEXT) \ | | | | 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 | tclIORTrans.$(OBJEXT) \ tclIOSock.$(OBJEXT) \ tclIOUtil.$(OBJEXT) \ tclLink.$(OBJEXT) \ tclLiteral.$(OBJEXT) \ tclListObj.$(OBJEXT) \ tclLoad.$(OBJEXT) \ tclMainW.$(OBJEXT) \ tclMain.$(OBJEXT) \ tclNamesp.$(OBJEXT) \ tclNotify.$(OBJEXT) \ tclOO.$(OBJEXT) \ tclOOBasic.$(OBJEXT) \ tclOOCall.$(OBJEXT) \ tclOODefineCmds.$(OBJEXT) \ tclOOInfo.$(OBJEXT) \ |
| ︙ | ︙ | |||
451 452 453 454 455 456 457 | DDE_OBJS = tclWinDde.$(OBJEXT) REG_OBJS = tclWinReg.$(OBJEXT) STUB_OBJS = \ tclStubLib.$(OBJEXT) \ | | | | | 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 | DDE_OBJS = tclWinDde.$(OBJEXT) REG_OBJS = tclWinReg.$(OBJEXT) STUB_OBJS = \ tclStubLib.$(OBJEXT) \ tclStubCall.$(OBJEXT) \ tclStubStaticPackage.$(OBJEXT) \ tclStubMainEx.$(OBJEXT) \ tclStubLibTbl.$(OBJEXT) \ tclTomMathStubLib.$(OBJEXT) \ tclOOStubLib.$(OBJEXT) \ tclWinPanic.$(OBJEXT) TCLSH_OBJS = tclAppInit.$(OBJEXT) |
| ︙ | ︙ | |||
486 487 488 489 490 491 492 | # Test-suite helper (can be used to test Tcl from build directory with all expected modules). # To start from windows shell use: # > tcltest.cmd -verbose bps -file fileName.test # or from mingw/msys shell: # $ ./tcltest -verbose bps -file fileName.test | | > | < | | 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 |
# Test-suite helper (can be used to test Tcl from build directory with all expected modules).
# To start from windows shell use:
# > tcltest.cmd -verbose bps -file fileName.test
# or from mingw/msys shell:
# $ ./tcltest -verbose bps -file fileName.test
tcltest.cmd: Makefile
@echo 'Create tcltest.cmd helpers';
@(\
echo '@echo off'; \
echo 'rem set LANG=en_US'; \
echo 'set BDP=%~dp0'; \
echo 'set OWD=%CD%'; \
echo 'cd /d %TEMP%'; \
echo 'rem "%BDP%\$(TCLSH)" "$(ROOT_DIR_WIN_NATIVE)/tests/all.tcl" %TESTFLAGS% -load "$(TEST_LOAD_FACILITIES)" %*'; \
echo '"%BDP%\$(TEST_EXE_FILE)" "$(ROOT_DIR_WIN_NATIVE)/tests/all.tcl" %TESTFLAGS% -load "$(TEST_LOAD_PRMS)" %*'; \
echo 'cd /d %OWD%'; \
) > tcltest.cmd;
@(\
echo '#!/bin/sh'; \
echo '#LANG=en_US'; \
echo 'BDP=$$(dirname $$(readlink -f %0))'; \
echo 'cd /tmp'; \
echo '#"$$BDP/$(TCLSH)" "$(ROOT_DIR_WIN_NATIVE)/tests/all.tcl" $$TESTFLAGS -load "$(TEST_LOAD_FACILITIES)" "$$@"'; \
echo '"$$BDP/$(TEST_EXE_FILE)" "$(ROOT_DIR_WIN_NATIVE)/tests/all.tcl" $$TESTFLAGS -load "$(TEST_LOAD_PRMS)" "$$@"'; \
) > tcltest.sh;
tcltest.sh: tcltest.cmd
tcltest: binaries $(TEST_EXE_FILE) $(TEST_DLL_FILE) $(CAT32) tcltest.cmd
binaries: $(TCL_STUB_LIB_FILE) @LIBRARIES@ winextensions ${TCL_ZIP_FILE} $(TCLSH)
winextensions: ${DDE_DLL_FILE} ${REG_DLL_FILE}
libraries:
|
| ︙ | ︙ | |||
554 555 556 557 558 559 560 | $(TCLSH): $(TCLSH_OBJS) @LIBRARIES@ $(TCL_STUB_LIB_FILE) tclsh.$(RES) $(CC) $(CFLAGS) $(TCLSH_OBJS) $(TCL_LIB_FILE) $(TCL_STUB_LIB_FILE) $(LIBS) \ tclsh.$(RES) $(CC_EXENAME) $(LDFLAGS_CONSOLE) $(COPY) tclsh.exe.manifest $(TCLSH).manifest @VC_MANIFEST_EMBED_EXE@ cat32.$(OBJEXT): cat.c | | | 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 | $(TCLSH): $(TCLSH_OBJS) @LIBRARIES@ $(TCL_STUB_LIB_FILE) tclsh.$(RES) $(CC) $(CFLAGS) $(TCLSH_OBJS) $(TCL_LIB_FILE) $(TCL_STUB_LIB_FILE) $(LIBS) \ tclsh.$(RES) $(CC_EXENAME) $(LDFLAGS_CONSOLE) $(COPY) tclsh.exe.manifest $(TCLSH).manifest @VC_MANIFEST_EMBED_EXE@ cat32.$(OBJEXT): cat.c $(CC) -c $(CC_SWITCHES) -DUNICODE -D_UNICODE @DEPARG@ $(CC_OBJNAME) $(CAT32): cat32.$(OBJEXT) $(CC) $(CFLAGS) cat32.$(OBJEXT) $(CC_EXENAME) $(LIBS) $(LDFLAGS_CONSOLE) # The following targets are configured by autoconf to generate either a shared # library or static library |
| ︙ | ︙ | |||
620 621 622 623 624 625 626 |
.SUFFIXES: .${OBJEXT}
.SUFFIXES: .$(RES)
.SUFFIXES: .rc
# Special case object targets
tclTestMain.${OBJEXT}: tclAppInit.c
| | > > > > > > | | | | 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 |
.SUFFIXES: .${OBJEXT}
.SUFFIXES: .$(RES)
.SUFFIXES: .rc
# Special case object targets
tclTestMain.${OBJEXT}: tclAppInit.c
$(CC) -c $(CC_SWITCHES) -DTCL_TEST -DUNICODE -D_UNICODE $(EXTFLAGS) @DEPARG@ $(CC_OBJNAME)
tclWinInit.${OBJEXT}: tclWinInit.c
$(CC) -c $(CC_SWITCHES) -DBUILD_tcl $(EXTFLAGS) @DEPARG@ $(CC_OBJNAME)
tclWinPipe.${OBJEXT}: tclWinPipe.c
$(CC) -c $(CC_SWITCHES) -DBUILD_tcl $(EXTFLAGS) @DEPARG@ $(CC_OBJNAME)
tclWinReg.${OBJEXT}: tclWinReg.c
$(CC) -c $(CC_SWITCHES) $(EXTFLAGS) @DEPARG@ $(CC_OBJNAME)
tclWinDde.${OBJEXT}: tclWinDde.c
$(CC) -c $(CC_SWITCHES) $(EXTFLAGS) @DEPARG@ $(CC_OBJNAME)
tclAppInit.${OBJEXT}: tclAppInit.c
$(CC) -c $(CC_SWITCHES) $(EXTFLAGS) -DUNICODE -D_UNICODE @DEPARG@ $(CC_OBJNAME)
tclMainW.${OBJEXT}: tclMain.c
$(CC) -c $(CC_SWITCHES) -DBUILD_tcl -DUNICODE -D_UNICODE @DEPARG@ $(CC_OBJNAME)
# TIP #430, ZipFS Support
tclZipfs.${OBJEXT}: $(GENERIC_DIR)/tclZipfs.c
$(CC) -c $(CC_SWITCHES) -DBUILD_tcl \
-DCFG_RUNTIME_PATH=\"$(bindir_native)\" \
-DCFG_RUNTIME_DLLFILE="\"$(TCL_DLL_FILE)\"" \
-DCFG_RUNTIME_ZIPFILE="\"$(TCL_ZIP_FILE)\"" \
|
| ︙ | ︙ | |||
677 678 679 680 681 682 683 |
# The following objects are part of the stub library and should not be built
# as DLL objects but none of the symbols should be exported
tclStubLib.${OBJEXT}: tclStubLib.c
$(CC) -c $(CC_SWITCHES) -DSTATIC_BUILD @DEPARG@ $(CC_OBJNAME)
| | | | | 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 |
# The following objects are part of the stub library and should not be built
# as DLL objects but none of the symbols should be exported
tclStubLib.${OBJEXT}: tclStubLib.c
$(CC) -c $(CC_SWITCHES) -DSTATIC_BUILD @DEPARG@ $(CC_OBJNAME)
tclStubCall.${OBJEXT}: tclStubCall.c
$(CC) -c $(CC_SWITCHES) -DSTATIC_BUILD -DTCL_DLL_FILE="\"$(TCL_DLL_FILE)\"" @DEPARG@ $(CC_OBJNAME)
tclStubStaticPackage.${OBJEXT}: tclStubStaticPackage.c
$(CC) -c $(CC_SWITCHES) -DSTATIC_BUILD -DTCL_DLL_FILE="\"$(TCL_DLL_FILE)\"" @DEPARG@ $(CC_OBJNAME)
tclStubMainEx.${OBJEXT}: tclStubMainEx.c
$(CC) -c $(CC_SWITCHES) -DSTATIC_BUILD -DTCL_DLL_FILE="\"$(TCL_DLL_FILE)\"" @DEPARG@ $(CC_OBJNAME)
tclStubLibTbl.${OBJEXT}: tclStubLibTbl.c
$(CC) -c $(CC_SWITCHES) -DSTATIC_BUILD @DEPARG@ $(CC_OBJNAME)
tclTomMathStubLib.${OBJEXT}: tclTomMathStubLib.c
$(CC) -c $(CC_SWITCHES) -DSTATIC_BUILD @DEPARG@ $(CC_OBJNAME)
|
| ︙ | ︙ | |||
724 725 726 727 728 729 730 | crc32.$(HOST_OBJEXT): $(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/crc32.c deflate.$(HOST_OBJEXT): $(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/deflate.c ioapi.$(HOST_OBJEXT): | | | 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 | crc32.$(HOST_OBJEXT): $(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/crc32.c deflate.$(HOST_OBJEXT): $(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/deflate.c ioapi.$(HOST_OBJEXT): $(HOST_CC) -o $@ -I$(ZLIB_DIR) -I$(ZLIB_DIR)/contrib/minizip -c $(ZLIB_DIR)/contrib/minizip/ioapi.c iowin32.$(HOST_OBJEXT): $(HOST_CC) -o $@ -I$(ZLIB_DIR) -I$(ZLIB_DIR)/contrib/minizip -c $(ZLIB_DIR)/contrib/minizip/iowin32.c infback.$(HOST_OBJEXT): $(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/infback.c |
| ︙ | ︙ | |||
754 755 756 757 758 759 760 | zip.$(HOST_OBJEXT): $(HOST_CC) -o $@ -I$(ZLIB_DIR) -I$(ZLIB_DIR)/contrib/minizip -c $(ZLIB_DIR)/contrib/minizip/zip.c zutil.$(HOST_OBJEXT): $(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/zutil.c minizip.$(HOST_OBJEXT): | | | 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 |
zip.$(HOST_OBJEXT):
$(HOST_CC) -o $@ -I$(ZLIB_DIR) -I$(ZLIB_DIR)/contrib/minizip -c $(ZLIB_DIR)/contrib/minizip/zip.c
zutil.$(HOST_OBJEXT):
$(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/zutil.c
minizip.$(HOST_OBJEXT):
$(HOST_CC) -o $@ -I$(ZLIB_DIR) -I$(ZLIB_DIR)/contrib/minizip -c $(ZLIB_DIR)/contrib/minizip/minizip.c
minizip${HOST_EXEEXT}: $(MINIZIP_OBJS)
$(HOST_CC) -o $@ $(MINIZIP_OBJS)
# The following target generates the file generic/tclDate.c from the yacc
# grammar found in generic/tclGetDate.y. This is only run by hand as yacc is
# not available in all environments. The name of the .c file is different than
|
| ︙ | ︙ | |||
880 881 882 883 884 885 886 | @for j in $(ROOT_DIR)/library/opt/*.tcl; \ do \ $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/opt0.4"; \ done; @echo "Installing package msgcat 1.7.0 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl9/9.0/msgcat-1.7.0.tm; @echo "Installing package tcltest 2.4.0 as a Tcl Module"; | | | 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 | @for j in $(ROOT_DIR)/library/opt/*.tcl; \ do \ $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/opt0.4"; \ done; @echo "Installing package msgcat 1.7.0 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl9/9.0/msgcat-1.7.0.tm; @echo "Installing package tcltest 2.4.0 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl9/9.0/tcltest-2.5.1.tm; @echo "Installing package platform 1.0.14 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/platform/platform.tcl $(SCRIPT_INSTALL_DIR)/../tcl9/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 $(SCRIPT_INSTALL_DIR)/../tcl9/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"; \ |
| ︙ | ︙ | |||
947 948 949 950 951 952 953 | # Specifying TESTFLAGS on the command line is the standard way to pass args to # tcltest, i.e.: # % make test TESTFLAGS="-verbose bps -file fileName.test" test: test-tcl test-packages | | | | | 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 | # Specifying TESTFLAGS on the command line is the standard way to pass args to # tcltest, i.e.: # % make test TESTFLAGS="-verbose bps -file fileName.test" test: test-tcl test-packages test-tcl: tcltest TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \ $(WINE) ./$(TCLSH) "$(ROOT_DIR_NATIVE)/tests/all.tcl" $(TESTFLAGS) \ -load "$(TEST_LOAD_FACILITIES)" # Useful target to launch a built tclsh with the proper path,... runtest: tcltest @TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \ $(WINE) ./$(TCLSH) $(TESTFLAGS) -load "$(TEST_LOAD_FACILITIES)" $(SCRIPT) # This target can be used to run tclsh from the build directory via # `make shell SCRIPT=foo.tcl` shell: binaries @TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \ |
| ︙ | ︙ | |||
979 980 981 982 983 984 985 |
./config.status
cleanhelp:
$(RM) *.hlp *.cnt *.GID *.rtf man2tcl.exe
clean: cleanhelp clean-packages
$(RM) *.lib *.a *.exp *.dll *.$(RES) *.${OBJEXT} *~ \#* TAGS a.out
| | | 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 |
./config.status
cleanhelp:
$(RM) *.hlp *.cnt *.GID *.rtf man2tcl.exe
clean: cleanhelp clean-packages
$(RM) *.lib *.a *.exp *.dll *.$(RES) *.${OBJEXT} *~ \#* TAGS a.out
$(RM) $(TCLSH) $(CAT32) $(TEST_EXE_FILE) $(TEST_DLL_FILE) tcltest.cmd tcltest.sh
$(RM) *.pch *.ilk *.pdb
$(RM) minizip${HOST_EXEEXT} *.${HOST_OBJEXT}
$(RM) *.zip
$(RMDIR) *.vfs
distclean: distclean-packages clean
$(RM) Makefile config.status config.cache config.log tclConfig.sh \
|
| ︙ | ︙ |
Changes to win/makefile.vc.
| ︙ | ︙ | |||
254 255 256 257 258 259 260 | $(TMP_DIR)\tclIOUtil.obj \ $(TMP_DIR)\tclIORChan.obj \ $(TMP_DIR)\tclIORTrans.obj \ $(TMP_DIR)\tclLink.obj \ $(TMP_DIR)\tclListObj.obj \ $(TMP_DIR)\tclLiteral.obj \ $(TMP_DIR)\tclLoad.obj \ | | | | 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 | $(TMP_DIR)\tclIOUtil.obj \ $(TMP_DIR)\tclIORChan.obj \ $(TMP_DIR)\tclIORTrans.obj \ $(TMP_DIR)\tclLink.obj \ $(TMP_DIR)\tclListObj.obj \ $(TMP_DIR)\tclLiteral.obj \ $(TMP_DIR)\tclLoad.obj \ $(TMP_DIR)\tclMainW.obj \ $(TMP_DIR)\tclMain.obj \ $(TMP_DIR)\tclNamesp.obj \ $(TMP_DIR)\tclNotify.obj \ $(TMP_DIR)\tclOO.obj \ $(TMP_DIR)\tclOOBasic.obj \ $(TMP_DIR)\tclOOCall.obj \ $(TMP_DIR)\tclOODefineCmds.obj \ $(TMP_DIR)\tclOOInfo.obj \ |
| ︙ | ︙ | |||
409 410 411 412 413 414 415 | $(TMP_DIR)\tcl.res !endif TCLOBJS = $(COREOBJS) $(ZLIBOBJS) $(TOMMATHOBJS) $(PLATFORMOBJS) TCLSTUBOBJS = \ $(TMP_DIR)\tclStubLib.obj \ | | | | | | 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 | $(TMP_DIR)\tcl.res !endif TCLOBJS = $(COREOBJS) $(ZLIBOBJS) $(TOMMATHOBJS) $(PLATFORMOBJS) TCLSTUBOBJS = \ $(TMP_DIR)\tclStubLib.obj \ $(TMP_DIR)\tclStubCall.obj \ $(TMP_DIR)\tclStubStaticPackage.obj \ $(TMP_DIR)\tclStubMainEx.obj \ $(TMP_DIR)\tclStubLibTbl.obj \ $(TMP_DIR)\tclTomMathStubLib.obj \ $(TMP_DIR)\tclOOStubLib.obj \ $(TMP_DIR)\tclWinPanic.obj ### The following paths CANNOT have spaces in them as they appear on ### the left side of implicit rules. TOMMATHDIR = $(ROOT)\libtommath PKGSDIR = $(ROOT)\pkgs # Additional include and C macro definitions for the implicit rules # defined in rules.vc PRJ_INCLUDES = -I"$(TOMMATHDIR)" PRJ_DEFINES = /DTCL_TOMMATH /DMP_PREC=4 /Dinline=__inline /DHAVE_ZLIB=1 /D_CRT_SECURE_NO_DEPRECATE /D_CRT_NONSTDC_NO_DEPRECATE # Additional Link libraries needed beyond those in rules.vc PRJ_LIBS = netapi32.lib user32.lib userenv.lib ws2_32.lib #--------------------------------------------------------------------- # TclTest flags #--------------------------------------------------------------------- |
| ︙ | ︙ | |||
645 646 647 648 649 650 651 | #--------------------------------------------------------------------- tcl-nmake: $(OUT_DIR)\tcl.nmake $(OUT_DIR)\tcl.nmake: @type << >$@ CORE_MACHINE = $(MACHINE) CORE_DEBUG = $(DEBUG) CORE_USE_THREAD_ALLOC = $(USE_THREAD_ALLOC) | < | | 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 |
#---------------------------------------------------------------------
tcl-nmake: $(OUT_DIR)\tcl.nmake
$(OUT_DIR)\tcl.nmake:
@type << >$@
CORE_MACHINE = $(MACHINE)
CORE_DEBUG = $(DEBUG)
CORE_USE_THREAD_ALLOC = $(USE_THREAD_ALLOC)
<<
#---------------------------------------------------------------------
# Build tclConfig.sh for the TEA build system.
#---------------------------------------------------------------------
tclConfig: $(OUT_DIR)\tclConfig.sh
# TBD - is this tclConfig.sh file ever used? The values are incorrect!
$(OUT_DIR)\tclConfig.sh: $(WIN_DIR)\tclConfig.sh.in
@echo Creating tclConfig.sh
@nmakehlp -s << $** >$@
@TCL_DLL_FILE@ $(TCLLIBNAME)
@TCL_VERSION@ $(DOTVERSION)
@TCL_MAJOR_VERSION@ $(TCL_MAJOR_VERSION)
@TCL_MINOR_VERSION@ $(TCL_MINOR_VERSION)
@TCL_PATCH_LEVEL@ $(TCL_PATCH_LEVEL)
|
| ︙ | ︙ | |||
730 731 732 733 734 735 736 | --name-prefix=TclDate \ $(GENERICDIR)/tclGetDate.y #--------------------------------------------------------------------- # Special case object file targets #--------------------------------------------------------------------- | | | | | | | | | | | | | | | | | | | | | | | < < < | < | < < < | < | | | | | | | | 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 | --name-prefix=TclDate \ $(GENERICDIR)/tclGetDate.y #--------------------------------------------------------------------- # Special case object file targets #--------------------------------------------------------------------- $(TMP_DIR)\testMain.obj: $(WIN_DIR)\tclAppInit.c $(cc32) $(appcflags) /DTCL_TEST /DUNICODE /D_UNICODE \ /DTCL_USE_STATIC_PACKAGES=$(TCL_USE_STATIC_PACKAGES) \ -Fo$@ $? $(TMP_DIR)\tclMainW.obj: $(GENERICDIR)\tclMain.c $(cc32) $(pkgcflags) /DUNICODE /D_UNICODE \ -Fo$@ $? $(TMP_DIR)\tclTest.obj: $(GENERICDIR)\tclTest.c $(cc32) $(appcflags) -Fo$@ $? $(TMP_DIR)\tclTestObj.obj: $(GENERICDIR)\tclTestObj.c $(cc32) $(appcflags) -Fo$@ $? $(TMP_DIR)\tclWinTest.obj: $(WIN_DIR)\tclWinTest.c $(CCAPPCMD) $? $(TMP_DIR)\tclZipfs.obj: $(GENERICDIR)\tclZipfs.c $(cc32) $(pkgcflags) -I$(COMPATDIR)\zlib -I$(COMPATDIR)\zlib\contrib\minizip -Fo$@ $? $(TMP_DIR)\tclZlib.obj: $(GENERICDIR)\tclZlib.c $(cc32) $(pkgcflags) -I$(COMPATDIR)\zlib -Fo$@ $? $(TMP_DIR)\tclPkgConfig.obj: $(GENERICDIR)\tclPkgConfig.c $(cc32) $(pkgcflags) \ /DCFG_INSTALL_LIBDIR="\"$(LIB_INSTALL_DIR:\=\\)\"" \ /DCFG_INSTALL_BINDIR="\"$(BIN_INSTALL_DIR:\=\\)\"" \ /DCFG_INSTALL_SCRDIR="\"$(SCRIPT_INSTALL_DIR:\=\\)\"" \ /DCFG_INSTALL_INCDIR="\"$(INCLUDE_INSTALL_DIR:\=\\)\"" \ /DCFG_INSTALL_DOCDIR="\"$(DOC_INSTALL_DIR:\=\\)\"" \ /DCFG_RUNTIME_LIBDIR="\"$(LIB_INSTALL_DIR:\=\\)\"" \ /DCFG_RUNTIME_BINDIR="\"$(BIN_INSTALL_DIR:\=\\)\"" \ /DCFG_RUNTIME_SCRDIR="\"$(SCRIPT_INSTALL_DIR:\=\\)\"" \ /DCFG_RUNTIME_INCDIR="\"$(INCLUDE_INSTALL_DIR:\=\\)\"" \ /DCFG_RUNTIME_DOCDIR="\"$(DOC_INSTALL_DIR:\=\\)\"" \ /DCFG_RUNTIME_DLLFILE="\"$(CFG_RUNTIME_DLLFILE:\=\\)\"" \ /DCFG_RUNTIME_ZIPFILE="\"$(CFG_RUNTIME_ZIPFILE:\=\\)\"" \ -Fo$@ $? $(TMP_DIR)\tclAppInit.obj: $(WIN_DIR)\tclAppInit.c $(cc32) $(appcflags) /DUNICODE /D_UNICODE \ /DTCL_USE_STATIC_PACKAGES=$(TCL_USE_STATIC_PACKAGES) \ -Fo$@ $? ### The following objects should be built using the stub interfaces $(TMP_DIR)\tclWinReg.obj: $(WIN_DIR)\tclWinReg.c $(cc32) $(appcflags) /DUSE_TCL_STUBS -Fo$@ $? $(TMP_DIR)\tclWinDde.obj: $(WIN_DIR)\tclWinDde.c $(cc32) $(appcflags) /DUSE_TCL_STUBS -Fo$@ $? ### The following objects are part of the stub library and should not ### be built as DLL objects. -Zl is used to avoid a dependency on any ### specific C run-time. $(TMP_DIR)\tclStubLib.obj: $(GENERICDIR)\tclStubLib.c $(cc32) $(stubscflags) -Fo$@ $? $(TMP_DIR)\tclStubCall.obj: $(GENERICDIR)\tclStubCall.c $(cc32) $(stubscflags) -DTCL_DLL_FILE="\"tcl90.dll\"" $(TCL_INCLUDES) -Fo$@ $? $(TMP_DIR)\tclStubStaticPackage.obj: $(GENERICDIR)\tclStubStaticPackage.c $(cc32) $(stubscflags) -DTCL_DLL_FILE="\"tcl90.dll\"" $(TCL_INCLUDES) -Fo$@ $? $(TMP_DIR)\tclStubMainEx.obj: $(GENERICDIR)\tclStubMainEx.c $(cc32) $(stubscflags) -DTCL_DLL_FILE="\"tcl90.dll\"" $(TCL_INCLUDES) -Fo$@ $? $(TMP_DIR)\tclStubLibTbl.obj: $(GENERICDIR)\tclStubLibTbl.c $(cc32) $(stubscflags) $(TCL_INCLUDES) -Fo$@ $? $(TMP_DIR)\tclTomMathStubLib.obj: $(GENERICDIR)\tclTomMathStubLib.c $(cc32) $(stubscflags) -Fo$@ $? $(TMP_DIR)\tclOOStubLib.obj: $(GENERICDIR)\tclOOStubLib.c $(cc32) $(stubscflags) -Fo$@ $? $(TMP_DIR)\tclWinPanic.obj: $(WIN_DIR)\tclWinPanic.c $(cc32) $(stubscflags) -Fo$@ $? $(TMP_DIR)\tclsh.exe.manifest: $(WIN_DIR)\tclsh.exe.manifest.in @nmakehlp -s << $** >$@ @MACHINE@ $(MACHINE:IX86=X86) @TCL_WIN_VERSION@ $(DOTVERSION).0.0 << #--------------------------------------------------------------------- # Generate the source dependencies. Having dependency rules will # improve incremental build accuracy without having to resort to a # full rebuild just because some non-global header file like # tclCompile.h was changed. These rules aren't needed when building # from scratch. #--------------------------------------------------------------------- depend: !if !exist($(TCLSH)) @echo Build tclsh first! !else $(TCLSH) $(TOOLSDIR:\=/)/mkdepend.tcl -vc32 -out:"$(OUT_DIR)\depend.mk" \ -passthru:"/DBUILD_tcl $(TCL_INCLUDES) $(PRJ_INCLUDES)" $(GENERICDIR),$$(GENERICDIR) \ $(COMPATDIR),$$(COMPATDIR) $(TOMMATHDIR),$$(TOMMATHDIR) $(WIN_DIR),$$(WIN_DIR) @<< $(TCLOBJS) << !endif #--------------------------------------------------------------------- # Dependency rules #--------------------------------------------------------------------- |
| ︙ | ︙ | |||
878 879 880 881 882 883 884 |
<<
{$(COMPATDIR)\zlib}.c{$(TMP_DIR)}.obj::
$(cc32) $(pkgcflags) -Fo$(TMP_DIR)\ @<<
$<
<<
| | | 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 |
<<
{$(COMPATDIR)\zlib}.c{$(TMP_DIR)}.obj::
$(cc32) $(pkgcflags) -Fo$(TMP_DIR)\ @<<
$<
<<
$(TMP_DIR)\tclsh.res: $(TMP_DIR)\tclsh.exe.manifest $(WIN_DIR)\tclsh.rc
#---------------------------------------------------------------------
# Installation.
#---------------------------------------------------------------------
install-binaries:
|
| ︙ | ︙ | |||
930 931 932 933 934 935 936 | @$(CPY) "$(ROOT)\library\parray.tcl" "$(SCRIPT_INSTALL_DIR)\" @$(CPY) "$(ROOT)\library\safe.tcl" "$(SCRIPT_INSTALL_DIR)\" @$(CPY) "$(ROOT)\library\tclIndex" "$(SCRIPT_INSTALL_DIR)\" @$(CPY) "$(ROOT)\library\package.tcl" "$(SCRIPT_INSTALL_DIR)\" @$(CPY) "$(ROOT)\library\word.tcl" "$(SCRIPT_INSTALL_DIR)\" @$(CPY) "$(ROOT)\library\auto.tcl" "$(SCRIPT_INSTALL_DIR)\" @$(CPY) "$(OUT_DIR)\tclConfig.sh" "$(LIB_INSTALL_DIR)\" | | | | | | 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 | @$(CPY) "$(ROOT)\library\parray.tcl" "$(SCRIPT_INSTALL_DIR)\" @$(CPY) "$(ROOT)\library\safe.tcl" "$(SCRIPT_INSTALL_DIR)\" @$(CPY) "$(ROOT)\library\tclIndex" "$(SCRIPT_INSTALL_DIR)\" @$(CPY) "$(ROOT)\library\package.tcl" "$(SCRIPT_INSTALL_DIR)\" @$(CPY) "$(ROOT)\library\word.tcl" "$(SCRIPT_INSTALL_DIR)\" @$(CPY) "$(ROOT)\library\auto.tcl" "$(SCRIPT_INSTALL_DIR)\" @$(CPY) "$(OUT_DIR)\tclConfig.sh" "$(LIB_INSTALL_DIR)\" @$(CPY) "$(WIN_DIR)\tclooConfig.sh" "$(LIB_INSTALL_DIR)\" @$(CPY) "$(WIN_DIR)\rules.vc" "$(LIB_INSTALL_DIR)\nmake\" @$(CPY) "$(WIN_DIR)\targets.vc" "$(LIB_INSTALL_DIR)\nmake\" @$(CPY) "$(WIN_DIR)\nmakehlp.c" "$(LIB_INSTALL_DIR)\nmake\" @$(CPY) "$(OUT_DIR)\tcl.nmake" "$(LIB_INSTALL_DIR)\nmake\" @echo Installing library opt0.4 directory @$(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" \ "$(SCRIPT_INSTALL_DIR)\..\tcl9\9.0\http-$(PKG_HTTP_VER).tm" |
| ︙ | ︙ |
Changes to win/nmakehlp.c.
| ︙ | ︙ | |||
639 640 641 642 643 644 645 | *ke = 0, *ve = 0; list_insert(&substPtr, (char*)ks, (char*)vs); } fclose(sp); } /* debug: dump the list */ | | | 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 |
*ke = 0, *ve = 0;
list_insert(&substPtr, (char*)ks, (char*)vs);
}
fclose(sp);
}
/* debug: dump the list */
#ifndef NDEBUG
{
int n = 0;
list_item_t *p = NULL;
for (p = substPtr; p != NULL; p = p->nextPtr, ++n) {
fprintf(stderr, "% 3d '%s' => '%s'\n", n, p->key, p->value);
}
}
|
| ︙ | ︙ |
Changes to win/rules.vc.
| ︙ | ︙ | |||
20 21 22 23 24 25 26 | !ifndef _RULES_VC _RULES_VC = 1 # The following macros define the version of the rules.vc nmake build system # For modifications that are not backward-compatible, you *must* change # the major version. RULES_VERSION_MAJOR = 1 | | | 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 | !ifndef _RULES_VC _RULES_VC = 1 # The following macros define the version of the rules.vc nmake build system # For modifications that are not backward-compatible, you *must* change # the major version. RULES_VERSION_MAJOR = 1 RULES_VERSION_MINOR = 4 # The PROJECT macro must be defined by parent makefile. !if "$(PROJECT)" == "" !error *** Error: Macro PROJECT not defined! Please define it before including rules.vc !endif !if "$(PRJ_PACKAGE_TCLNAME)" == "" |
| ︙ | ︙ | |||
158 159 160 161 162 163 164 | # some Tcl interfaces that are not publicly exposed. # # The fragment will set the following macros: # ROOT - root of this module sources # COMPATDIR - source directory that holds compatibility sources # DOCDIR - source directory containing documentation files # GENERICDIR - platform-independent source directory | | | 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 | # some Tcl interfaces that are not publicly exposed. # # The fragment will set the following macros: # ROOT - root of this module sources # COMPATDIR - source directory that holds compatibility sources # DOCDIR - source directory containing documentation files # GENERICDIR - platform-independent source directory # WIN_DIR - Windows-specific source directory # TESTDIR - directory containing test files # TOOLSDIR - directory containing build tools # _TCLDIR - root of the Tcl installation OR the Tcl sources. Not set # when building Tcl itself. # _INSTALLDIR - native form of the installation path. For Tcl # this will be the root of the Tcl installation. For extensions # this will be the lib directory under the root. |
| ︙ | ︙ | |||
211 212 213 214 215 216 217 |
!ifndef DEMODIR
!if exist("$(LIBDIR)\demos")
DEMODIR = $(LIBDIR)\demos
!else
DEMODIR = $(ROOT)\demos
!endif
!endif # ifndef DEMODIR
| | | < < | | | | | 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 |
!ifndef DEMODIR
!if exist("$(LIBDIR)\demos")
DEMODIR = $(LIBDIR)\demos
!else
DEMODIR = $(ROOT)\demos
!endif
!endif # ifndef DEMODIR
# Do NOT use WINDIR because it is Windows internal environment
# variable to point to c:\windows!
WIN_DIR = $(ROOT)\win
!ifndef RCDIR
!if exist("$(WIN_DIR)\rc")
RCDIR = $(WIN_DIR)\rc
!else
RCDIR = $(WIN_DIR)
!endif
!endif
RCDIR = $(RCDIR:/=\)
# The target directory where the built packages and binaries will be installed.
# INSTALLDIR is the (optional) path specified by the user.
# _INSTALLDIR is INSTALLDIR using the backslash separator syntax
|
| ︙ | ︙ | |||
1073 1074 1075 1076 1077 1078 1079 | TCLSH = $(OUT_DIR)\$(TCLSHNAME) TCLIMPLIB = $(OUT_DIR)\$(PROJECT)$(VERSION)$(SUFX).lib TCLLIBNAME = $(PROJECT)$(VERSION)$(SUFX).$(EXT) TCLLIB = $(OUT_DIR)\$(TCLLIBNAME) TCLSTUBLIBNAME = $(STUBPREFIX)$(VERSION).lib TCLSTUBLIB = $(OUT_DIR)\$(TCLSTUBLIBNAME) | | | 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 | TCLSH = $(OUT_DIR)\$(TCLSHNAME) TCLIMPLIB = $(OUT_DIR)\$(PROJECT)$(VERSION)$(SUFX).lib TCLLIBNAME = $(PROJECT)$(VERSION)$(SUFX).$(EXT) TCLLIB = $(OUT_DIR)\$(TCLLIBNAME) TCLSTUBLIBNAME = $(STUBPREFIX)$(VERSION).lib TCLSTUBLIB = $(OUT_DIR)\$(TCLSTUBLIBNAME) TCL_INCLUDES = -I"$(WIN_DIR)" -I"$(GENERICDIR)" !else # ! $(DOING_TCL) !if $(TCLINSTALL) # Building against an installed Tcl # When building extensions, we need to locate tclsh. Depending on version # of Tcl we are building against, this may or may not have a "t" suffix. |
| ︙ | ︙ | |||
1148 1149 1150 1151 1152 1153 1154 | TKIMPLIBNAME = tk$(TK_VERSION)$(SUFX).lib !if $(DOING_TK) WISH = $(OUT_DIR)\$(WISHNAME) TKSTUBLIB = $(OUT_DIR)\$(TKSTUBLIBNAME) TKIMPLIB = $(OUT_DIR)\$(TKIMPLIBNAME) TKLIB = $(OUT_DIR)\$(TKLIBNAME) | | | 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 | TKIMPLIBNAME = tk$(TK_VERSION)$(SUFX).lib !if $(DOING_TK) WISH = $(OUT_DIR)\$(WISHNAME) TKSTUBLIB = $(OUT_DIR)\$(TKSTUBLIBNAME) TKIMPLIB = $(OUT_DIR)\$(TKIMPLIBNAME) TKLIB = $(OUT_DIR)\$(TKLIBNAME) TK_INCLUDES = -I"$(WIN_DIR)" -I"$(GENERICDIR)" !else # effectively NEED_TK !if $(TKINSTALL) # Building against installed Tk WISH = $(_TKDIR)\bin\$(WISHNAME) TKSTUBLIB = $(_TKDIR)\lib\$(TKSTUBLIBNAME) TKIMPLIB = $(_TKDIR)\lib\$(TKIMPLIBNAME) |
| ︙ | ︙ | |||
1259 1260 1261 1262 1263 1264 1265 | # lflags - complete linker switches (subsumes ldebug) except subsystem type # dlllflags - complete linker switches to build DLLs (subsumes lflags) # conlflags - complete linker switches for console program (subsumes lflags) # guilflags - complete linker switches for GUI program (subsumes lflags) # baselibs - minimum Windows libraries required. Parent makefile can # define PRJ_LIBS before including rules.rc if additional libs are needed | | | | | | | | | | | | | | | | | | < < < < < < < < < < < < < < < < < | | | | | 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 |
# lflags - complete linker switches (subsumes ldebug) except subsystem type
# dlllflags - complete linker switches to build DLLs (subsumes lflags)
# conlflags - complete linker switches for console program (subsumes lflags)
# guilflags - complete linker switches for GUI program (subsumes lflags)
# baselibs - minimum Windows libraries required. Parent makefile can
# define PRJ_LIBS before including rules.rc if additional libs are needed
OPTDEFINES = /DTCL_CFGVAL_ENCODING=$(CFG_ENCODING) /DSTDC_HEADERS
!if $(TCL_MEM_DEBUG)
OPTDEFINES = $(OPTDEFINES) /DTCL_MEM_DEBUG
!endif
!if $(TCL_COMPILE_DEBUG)
OPTDEFINES = $(OPTDEFINES) /DTCL_COMPILE_DEBUG /DTCL_COMPILE_STATS
!endif
!if $(TCL_THREADS) && $(TCL_VERSION) < 87
OPTDEFINES = $(OPTDEFINES) /DTCL_THREADS=1
!if $(USE_THREAD_ALLOC) && $(TCL_VERSION) < 87
OPTDEFINES = $(OPTDEFINES) /DUSE_THREAD_ALLOC=1
!endif
!endif
!if $(STATIC_BUILD)
OPTDEFINES = $(OPTDEFINES) /DSTATIC_BUILD
!endif
!if $(TCL_NO_DEPRECATED)
OPTDEFINES = $(OPTDEFINES) /DTCL_NO_DEPRECATED
!endif
!if $(USE_STUBS)
# Note we do not define USE_TCL_STUBS even when building tk since some
# test targets in tk do not use stubs
!if ! $(DOING_TCL)
USE_STUBS_DEFS = /DUSE_TCL_STUBS /DUSE_TCLOO_STUBS
!if $(NEED_TK)
USE_STUBS_DEFS = $(USE_STUBS_DEFS) /DUSE_TK_STUBS
!endif
!endif
!endif # USE_STUBS
!if !$(DEBUG)
OPTDEFINES = $(OPTDEFINES) /DNDEBUG
!if $(OPTIMIZING)
OPTDEFINES = $(OPTDEFINES) /DTCL_CFG_OPTIMIZED
!endif
!endif
!if $(PROFILE)
OPTDEFINES = $(OPTDEFINES) /DTCL_CFG_PROFILED
!endif
!if "$(MACHINE)" == "AMD64"
OPTDEFINES = $(OPTDEFINES) /DTCL_CFG_DO64BIT
!endif
!if $(VCVERSION) < 1300
OPTDEFINES = $(OPTDEFINES) /DNO_STRTOI64
!endif
!if "$(TCL_UTF_MAX)" == "6"
OPTDEFINES = $(OPTDEFINES) /DTCL_UTF_MAX=6
!endif
# _ATL_XP_TARGETING - Newer SDK's need this to build for XP
COMPILERFLAGS = /D_ATL_XP_TARGETING
# Like the TEA system only set this non empty for non-Tk extensions
# Note: some extensions use PACKAGE_NAME and others use PACKAGE_TCLNAME
# so we pass both
!if !$(DOING_TCL) && !$(DOING_TK)
PKGNAMEFLAGS = /DPACKAGE_NAME="\"$(PRJ_PACKAGE_TCLNAME)\"" \
/DPACKAGE_TCLNAME="\"$(PRJ_PACKAGE_TCLNAME)\"" \
/DPACKAGE_VERSION="\"$(DOTVERSION)\"" \
/DMODULE_SCOPE=extern
!endif
# crt picks the C run time based on selected OPTS
!if $(MSVCRT)
!if $(DEBUG) && !$(UNCHECKED)
crt = -MDd
!else
|
| ︙ | ︙ | |||
1385 1386 1387 1388 1389 1390 1391 | # output increasing chance of a real warning getting lost. So disable them. # Eventually some day, Tcl will be 64-bit clean. cwarn = $(cwarn) -wd4311 -wd4312 !endif ### Common compiler options that are architecture specific !if "$(MACHINE)" == "ARM" | | | < > | | | | | 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 | # output increasing chance of a real warning getting lost. So disable them. # Eventually some day, Tcl will be 64-bit clean. cwarn = $(cwarn) -wd4311 -wd4312 !endif ### Common compiler options that are architecture specific !if "$(MACHINE)" == "ARM" carch = /D_ARM_WINAPI_PARTITION_DESKTOP_SDK_AVAILABLE !else carch = !endif !if $(DEBUG) # Turn warnings into errors cwarn = $(cwarn) -WX !endif INCLUDES = $(TCL_INCLUDES) $(TK_INCLUDES) $(PRJ_INCLUDES) !if !$(DOING_TCL) && !$(DOING_TK) INCLUDES = $(INCLUDES) -I"$(GENERICDIR)" -I"$(WIN_DIR)" -I"$(COMPATDIR)" !endif # These flags are defined roughly in the order of the pre-reform # rules.vc/makefile.vc to help visually compare that the pre- and # post-reform build logs # cflags contains generic flags used for building practically all object files cflags = -nologo -c $(COMPILERFLAGS) $(carch) $(cwarn) -Fp$(TMP_DIR)^\ $(cdebug) # appcflags contains $(cflags) and flags for building the application # object files (e.g. tclsh, or wish) pkgcflags contains $(cflags) plus # flags used for building shared object files The two differ in the # BUILD_$(PROJECT) macro which should be defined only for the shared # library *implementation* and not for its caller interface appcflags_nostubs = $(cflags) $(crt) $(INCLUDES) $(TCL_DEFINES) $(PRJ_DEFINES) $(OPTDEFINES) appcflags = $(appcflags_nostubs) $(USE_STUBS_DEFS) pkgcflags = $(appcflags) $(PKGNAMEFLAGS) /DBUILD_$(PROJECT) pkgcflags_nostubs = $(appcflags_nostubs) $(PKGNAMEFLAGS) /DBUILD_$(PROJECT) # stubscflags contains $(cflags) plus flags used for building a stubs # library for the package. Note: /DSTATIC_BUILD is defined in # $(OPTDEFINES) only if the OPTS configuration indicates a static # library. However the stubs library is ALWAYS static hence included # here irrespective of the OPTS setting. # # TBD - tclvfs has a comment that stubs libs should not be compiled with -GL # without stating why. Tcl itself compiled stubs libs with this flag. # so we do not remove it from cflags. -GL may prevent extensions # compiled with one VC version to fail to link against stubs library # compiled with another VC version. Check for this and fix accordingly. stubscflags = $(cflags) $(PKGNAMEFLAGS) $(PRJ_DEFINES) $(OPTDEFINES) -Zl /DSTATIC_BUILD $(INCLUDES) $(USE_STUBS_DEFS) # Link flags !if $(DEBUG) ldebug = -debug -debugtype:cv !else ldebug = -release -opt:ref -opt:icf,3 |
| ︙ | ︙ | |||
1494 1495 1496 1497 1498 1499 1500 | LIBCMD = $(lib32) -nologo $(LINKERFLAGS) -out:$@ DLLCMD = $(link32) $(dlllflags) -out:$@ $(baselibs) $(tcllibs) $(tklibs) CONEXECMD = $(link32) $(conlflags) -out:$@ $(baselibs) $(tcllibs) $(tklibs) GUIEXECMD = $(link32) $(guilflags) -out:$@ $(baselibs) $(tcllibs) $(tklibs) RESCMD = $(rc32) -fo $@ -r -i "$(GENERICDIR)" -i "$(TMP_DIR)" \ $(TCL_INCLUDES) \ | | | | | | | | | 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 | LIBCMD = $(lib32) -nologo $(LINKERFLAGS) -out:$@ DLLCMD = $(link32) $(dlllflags) -out:$@ $(baselibs) $(tcllibs) $(tklibs) CONEXECMD = $(link32) $(conlflags) -out:$@ $(baselibs) $(tcllibs) $(tklibs) GUIEXECMD = $(link32) $(guilflags) -out:$@ $(baselibs) $(tcllibs) $(tklibs) RESCMD = $(rc32) -fo $@ -r -i "$(GENERICDIR)" -i "$(TMP_DIR)" \ $(TCL_INCLUDES) \ /DDEBUG=$(DEBUG) -d UNCHECKED=$(UNCHECKED) \ /DCOMMAVERSION=$(DOTVERSION:.=,),0 \ /DDOTVERSION=\"$(DOTVERSION)\" \ /DVERSION=\"$(VERSION)\" \ /DSUFX=\"$(SUFX:t=)\" \ /DPROJECT=\"$(PROJECT)\" \ /DPRJLIBNAME=\"$(PRJLIBNAME)\" !ifndef DEFAULT_BUILD_TARGET DEFAULT_BUILD_TARGET = $(PROJECT) !endif default-target: $(DEFAULT_BUILD_TARGET) |
| ︙ | ︙ | |||
1579 1580 1581 1582 1583 1584 1585 | @echo Installing demos to '$(DEMO_INSTALL_DIR)' @if not exist "$(DEMO_INSTALL_DIR)" mkdir "$(DEMO_INSTALL_DIR)" @if exist $(DEMODIR) $(CPYDIR) "$(DEMODIR)" "$(DEMO_INSTALL_DIR)" default-clean: @echo Cleaning $(TMP_DIR)\* ... @if exist $(TMP_DIR)\nul $(RMDIR) $(TMP_DIR) | | | | | | | | | | | | | | | | 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 | @echo Installing demos to '$(DEMO_INSTALL_DIR)' @if not exist "$(DEMO_INSTALL_DIR)" mkdir "$(DEMO_INSTALL_DIR)" @if exist $(DEMODIR) $(CPYDIR) "$(DEMODIR)" "$(DEMO_INSTALL_DIR)" default-clean: @echo Cleaning $(TMP_DIR)\* ... @if exist $(TMP_DIR)\nul $(RMDIR) $(TMP_DIR) @echo Cleaning $(WIN_DIR)\nmakehlp.obj, nmakehlp.exe ... @if exist $(WIN_DIR)\nmakehlp.obj del $(WIN_DIR)\nmakehlp.obj @if exist $(WIN_DIR)\nmakehlp.exe del $(WIN_DIR)\nmakehlp.exe @if exist $(WIN_DIR)\nmakehlp.out del $(WIN_DIR)\nmakehlp.out @echo Cleaning $(WIN_DIR)\nmhlp-out.txt ... @if exist $(WIN_DIR)\nmhlp-out.txt del $(WIN_DIR)\nmhlp-out.txt @echo Cleaning $(WIN_DIR)\_junk.pch ... @if exist $(WIN_DIR)\_junk.pch del $(WIN_DIR)\_junk.pch @echo Cleaning $(WIN_DIR)\vercl.x, vercl.i ... @if exist $(WIN_DIR)\vercl.x del $(WIN_DIR)\vercl.x @if exist $(WIN_DIR)\vercl.i del $(WIN_DIR)\vercl.i @echo Cleaning $(WIN_DIR)\versions.vc, version.vc ... @if exist $(WIN_DIR)\versions.vc del $(WIN_DIR)\versions.vc @if exist $(WIN_DIR)\version.vc del $(WIN_DIR)\version.vc default-hose: default-clean @echo Hosing $(OUT_DIR)\* ... @if exist $(OUT_DIR)\nul $(RMDIR) $(OUT_DIR) # Only for backward compatibility default-distclean: default-hose |
| ︙ | ︙ | |||
1684 1685 1686 1687 1688 1689 1690 |
# main application, the master makefile should define explicit rules.
{$(ROOT)}.c{$(TMP_DIR)}.obj::
$(CCPKGCMD) @<<
$<
<<
| | | | 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 |
# main application, the master makefile should define explicit rules.
{$(ROOT)}.c{$(TMP_DIR)}.obj::
$(CCPKGCMD) @<<
$<
<<
{$(WIN_DIR)}.c{$(TMP_DIR)}.obj::
$(CCPKGCMD) @<<
$<
<<
{$(GENERICDIR)}.c{$(TMP_DIR)}.obj::
$(CCPKGCMD) @<<
$<
<<
{$(COMPATDIR)}.c{$(TMP_DIR)}.obj::
$(CCPKGCMD) @<<
$<
<<
{$(RCDIR)}.rc{$(TMP_DIR)}.res:
$(RESCMD) $<
{$(WIN_DIR)}.rc{$(TMP_DIR)}.res:
$(RESCMD) $<
{$(TMP_DIR)}.rc{$(TMP_DIR)}.res:
$(RESCMD) $<
.SUFFIXES:
.SUFFIXES:.c .rc
|
| ︙ | ︙ | |||
1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 | !if $(CONFIG_CHECK) !ifdef TCLNMAKECONFIG !include $(TCLNMAKECONFIG) !if defined(CORE_MACHINE) && "$(CORE_MACHINE)" != "$(MACHINE)" !error ERROR: Build target ($(MACHINE)) does not match the Tcl library architecture ($(CORE_MACHINE)). !endif !if defined(CORE_DEBUG) && $(CORE_DEBUG) != $(DEBUG) !message WARNING: Value of DEBUG ($(DEBUG)) does not match its Tcl library configuration ($(DEBUG)). !endif !endif !endif # TCLNMAKECONFIG | > > > | 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 | !if $(CONFIG_CHECK) !ifdef TCLNMAKECONFIG !include $(TCLNMAKECONFIG) !if defined(CORE_MACHINE) && "$(CORE_MACHINE)" != "$(MACHINE)" !error ERROR: Build target ($(MACHINE)) does not match the Tcl library architecture ($(CORE_MACHINE)). !endif !if $(TCL_VERSION) < 87 && defined(CORE_USE_THREAD_ALLOC) && $(CORE_USE_THREAD_ALLOC) != $(USE_THREAD_ALLOC) !message WARNING: Value of USE_THREAD_ALLOC ($(USE_THREAD_ALLOC)) does not match its Tcl core value ($(CORE_USE_THREAD_ALLOC)). !endif !if defined(CORE_DEBUG) && $(CORE_DEBUG) != $(DEBUG) !message WARNING: Value of DEBUG ($(DEBUG)) does not match its Tcl library configuration ($(DEBUG)). !endif !endif !endif # TCLNMAKECONFIG |
| ︙ | ︙ |
Changes to win/tclAppInit.c.
| ︙ | ︙ | |||
10 11 12 13 14 15 16 17 18 19 20 21 22 23 | * Copyright (c) 1994-1997 Sun Microsystems, Inc. * Copyright (c) 1998-1999 Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tcl.h" #define WIN32_LEAN_AND_MEAN #define STRICT /* See MSDN Article Q83456 */ #include <windows.h> #undef STRICT #undef WIN32_LEAN_AND_MEAN #include <locale.h> | > | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | * Copyright (c) 1994-1997 Sun Microsystems, Inc. * Copyright (c) 1998-1999 Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #define USE_TCL_STUBS #include "tcl.h" #define WIN32_LEAN_AND_MEAN #define STRICT /* See MSDN Article Q83456 */ #include <windows.h> #undef STRICT #undef WIN32_LEAN_AND_MEAN #include <locale.h> |
| ︙ | ︙ |
Changes to win/tclWin32Dll.c.
| ︙ | ︙ | |||
310 311 312 313 314 315 316 | drive[0] = (WCHAR) dlIter->driveLetter; /* * Try to read the volume mount point and see where it points. */ | | | 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 |
drive[0] = (WCHAR) dlIter->driveLetter;
/*
* Try to read the volume mount point and see where it points.
*/
if (GetVolumeNameForVolumeMountPointW(drive,
Target, 55) != 0) {
if (wcscmp(dlIter->volumeName, Target) == 0) {
/*
* Nothing has changed.
*/
Tcl_MutexUnlock(&mountPointMap);
|
| ︙ | ︙ | |||
369 370 371 372 373 374 375 |
*/
for (drive[0] = 'A'; drive[0] <= 'Z'; drive[0]++) {
/*
* Try to read the volume mount point and see where it points.
*/
| | | 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 |
*/
for (drive[0] = 'A'; drive[0] <= 'Z'; drive[0]++) {
/*
* Try to read the volume mount point and see where it points.
*/
if (GetVolumeNameForVolumeMountPointW(drive,
Target, 55) != 0) {
int alreadyStored = 0;
for (dlIter = driveLetterLookup; dlIter != NULL;
dlIter = dlIter->nextPtr) {
if (wcscmp(dlIter->volumeName, Target) == 0) {
alreadyStored = 1;
|
| ︙ | ︙ | |||
415 416 417 418 419 420 421 |
dlPtr2->volumeName = TclNativeDupInternalRep((ClientData) mountPoint);
dlPtr2->driveLetter = -1;
dlPtr2->nextPtr = driveLetterLookup;
driveLetterLookup = dlPtr2;
Tcl_MutexUnlock(&mountPointMap);
return -1;
}
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 415 416 417 418 419 420 421 422 423 424 425 426 427 428 |
dlPtr2->volumeName = TclNativeDupInternalRep((ClientData) mountPoint);
dlPtr2->driveLetter = -1;
dlPtr2->nextPtr = driveLetterLookup;
driveLetterLookup = dlPtr2;
Tcl_MutexUnlock(&mountPointMap);
return -1;
}
/*
*------------------------------------------------------------------------
*
* TclWinCPUID --
*
* Get CPU ID information on an Intel box under Windows
|
| ︙ | ︙ |
Changes to win/tclWinChan.c.
| ︙ | ︙ | |||
942 943 944 945 946 947 948 |
if (TEST_FLAG(mode, O_CREAT)) {
if (TEST_FLAG(permissions, S_IWRITE)) {
flags = FILE_ATTRIBUTE_NORMAL;
} else {
flags = FILE_ATTRIBUTE_READONLY;
}
} else {
| | | | 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 |
if (TEST_FLAG(mode, O_CREAT)) {
if (TEST_FLAG(permissions, S_IWRITE)) {
flags = FILE_ATTRIBUTE_NORMAL;
} else {
flags = FILE_ATTRIBUTE_READONLY;
}
} else {
flags = GetFileAttributesW(nativeName);
if (flags == 0xFFFFFFFF) {
flags = 0;
}
}
/*
* Set up the file sharing mode. We want to allow simultaneous access.
*/
shareMode = FILE_SHARE_READ | FILE_SHARE_WRITE;
/*
* Now we get to create the file.
*/
handle = CreateFileW(nativeName, accessMode, shareMode,
NULL, createMode, flags, (HANDLE) NULL);
if (handle == INVALID_HANDLE_VALUE) {
DWORD err = GetLastError();
if ((err & 0xffffL) == ERROR_OPEN_FAILED) {
err = TEST_FLAG(mode, O_CREAT) ? ERROR_FILE_EXISTS
|
| ︙ | ︙ |
Changes to win/tclWinConsole.c.
| ︙ | ︙ | |||
225 226 227 228 229 230 231 |
* as EOF so we will loop around again. If no Ctrl signal handlers
* have been established, the default signal OS handler in a separate
* thread will terminate the program. If a Ctrl signal handler
* has been established (through an extension for example), it
* will run and take whatever action it deems appropriate.
*/
do {
| | | | 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 |
* as EOF so we will loop around again. If no Ctrl signal handlers
* have been established, the default signal OS handler in a separate
* thread will terminate the program. If a Ctrl signal handler
* has been established (through an extension for example), it
* will run and take whatever action it deems appropriate.
*/
do {
result = ReadConsoleW(hConsole, lpBuffer, nbytes / sizeof(WCHAR), &ntchars,
NULL);
} while (result && ntchars == 0 && GetLastError() == ERROR_OPERATION_ABORTED);
if (nbytesread != NULL) {
*nbytesread = ntchars * sizeof(WCHAR);
}
return result;
}
static BOOL
WriteConsoleBytes(
HANDLE hConsole,
const void *lpBuffer,
DWORD nbytes,
LPDWORD nbyteswritten)
{
DWORD ntchars;
BOOL result;
result = WriteConsoleW(hConsole, lpBuffer, nbytes / sizeof(WCHAR), &ntchars,
NULL);
if (nbyteswritten != NULL) {
*nbyteswritten = ntchars * sizeof(WCHAR);
}
return result;
}
|
| ︙ | ︙ | |||
1051 1052 1053 1054 1055 1056 1057 |
* If the console has hit EOF, it is always readable.
*/
if (infoPtr->readFlags & CONSOLE_EOF) {
return 1;
}
| | | 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 |
* If the console has hit EOF, it is always readable.
*/
if (infoPtr->readFlags & CONSOLE_EOF) {
return 1;
}
if (PeekConsoleInputW(handle, &input, 1, &count) == FALSE) {
/*
* Check to see if the peek failed because of EOF.
*/
TclWinConvertError(GetLastError());
if (errno == EOF) {
|
| ︙ | ︙ | |||
1353 1354 1355 1356 1357 1358 1359 | infoPtr->flags |= CONSOLE_READ_OPS; GetConsoleMode(infoPtr->handle, &infoPtr->initMode); modes = infoPtr->initMode; modes &= ~(ENABLE_WINDOW_INPUT | ENABLE_MOUSE_INPUT); modes |= ENABLE_LINE_INPUT; SetConsoleMode(infoPtr->handle, modes); | | | | 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 |
infoPtr->flags |= CONSOLE_READ_OPS;
GetConsoleMode(infoPtr->handle, &infoPtr->initMode);
modes = infoPtr->initMode;
modes &= ~(ENABLE_WINDOW_INPUT | ENABLE_MOUSE_INPUT);
modes |= ENABLE_LINE_INPUT;
SetConsoleMode(infoPtr->handle, modes);
infoPtr->reader.readyEvent = CreateEventW(NULL, TRUE, TRUE, NULL);
infoPtr->reader.thread = CreateThread(NULL, 256, ConsoleReaderThread,
TclPipeThreadCreateTI(&infoPtr->reader.TI, infoPtr,
infoPtr->reader.readyEvent), 0, NULL);
SetThreadPriority(infoPtr->reader.thread, THREAD_PRIORITY_HIGHEST);
}
if (permissions & TCL_WRITABLE) {
infoPtr->writer.readyEvent = CreateEventW(NULL, TRUE, TRUE, NULL);
infoPtr->writer.thread = CreateThread(NULL, 256, ConsoleWriterThread,
TclPipeThreadCreateTI(&infoPtr->writer.TI, infoPtr,
infoPtr->writer.readyEvent), 0, NULL);
SetThreadPriority(infoPtr->writer.thread, THREAD_PRIORITY_HIGHEST);
}
/*
|
| ︙ | ︙ |
Changes to win/tclWinDde.c.
| ︙ | ︙ | |||
30 31 32 33 34 35 36 |
* registered by this process.
*/
typedef struct RegisteredInterp {
struct RegisteredInterp *nextPtr;
/* The next interp this application knows
* about. */
| | | 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 |
* registered by this process.
*/
typedef struct RegisteredInterp {
struct RegisteredInterp *nextPtr;
/* The next interp this application knows
* about. */
WCHAR *name; /* Interpreter's name (malloc-ed). */
Tcl_Obj *handlerPtr; /* The server handler command */
Tcl_Interp *interp; /* The interpreter attached to this name. */
} RegisteredInterp;
/*
* Used to keep track of conversations.
*/
|
| ︙ | ︙ | |||
77 78 79 80 81 82 83 | static HSZ ddeServiceGlobal = 0; static DWORD ddeInstance; /* The application instance handle given to us * by DdeInitialize. */ static int ddeIsServer = 0; #define TCL_DDE_VERSION "1.4.1" #define TCL_DDE_PACKAGE_NAME "dde" | | | | | | | | > > > > > > > > > > > > > > > > | 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 |
static HSZ ddeServiceGlobal = 0;
static DWORD ddeInstance; /* The application instance handle given to us
* by DdeInitialize. */
static int ddeIsServer = 0;
#define TCL_DDE_VERSION "1.4.1"
#define TCL_DDE_PACKAGE_NAME "dde"
#define TCL_DDE_SERVICE_NAME L"TclEval"
#define TCL_DDE_EXECUTE_RESULT L"$TCLEVAL$EXECUTE$RESULT"
#define DDE_FLAG_ASYNC 1
#define DDE_FLAG_BINARY 2
#define DDE_FLAG_FORCE 4
TCL_DECLARE_MUTEX(ddeMutex)
/*
* Forward declarations for functions defined later in this file.
*/
static LRESULT CALLBACK DdeClientWindowProc(HWND hwnd, UINT uMsg,
WPARAM wParam, LPARAM lParam);
static int DdeCreateClient(DdeEnumServices *es);
static BOOL CALLBACK DdeEnumWindowsCallback(HWND hwndTarget,
LPARAM lParam);
static void DdeExitProc(void *clientData);
static int DdeGetServicesList(Tcl_Interp *interp,
const WCHAR *serviceName, const WCHAR *topicName);
static HDDEDATA CALLBACK DdeServerProc(UINT uType, UINT uFmt, HCONV hConv,
HSZ ddeTopic, HSZ ddeItem, HDDEDATA hData,
DWORD dwData1, DWORD dwData2);
static LRESULT DdeServicesOnAck(HWND hwnd, WPARAM wParam,
LPARAM lParam);
static void DeleteProc(void *clientData);
static Tcl_Obj * ExecuteRemoteObject(RegisteredInterp *riPtr,
Tcl_Obj *ddeObjectPtr);
static int MakeDdeConnection(Tcl_Interp *interp,
const WCHAR *name, HCONV *ddeConvPtr);
static void SetDdeError(Tcl_Interp *interp);
static int DdeObjCmd(void *clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
#if (TCL_MAJOR_VERSION < 9) && (TCL_MINOR_VERSION < 7)
# if TCL_UTF_MAX > 3
# define Tcl_WCharToUtfDString(a,b,c) Tcl_WinTCharToUtf(a,(b)*sizeof(WCHAR),c)
# define Tcl_UtfToWCharDString(a,b,c) Tcl_WinUtfToTChar(a,b,c)
# else
# define Tcl_WCharToUtfDString Tcl_UniCharToUtfDString
# define Tcl_UtfToWCharDString Tcl_UtfToUniCharDString
# endif
#endif
static unsigned char *
getByteArrayFromObj(
Tcl_Obj *objPtr,
size_t *lengthPtr
) {
int length;
unsigned char *result = Tcl_GetByteArrayFromObj(objPtr, &length);
#if TCL_MAJOR_VERSION > 8
if (sizeof(TCL_HASH_TYPE) > sizeof(int)) {
/* 64-bit and TIP #494 situation: */
*lengthPtr = *(TCL_HASH_TYPE *) objPtr->internalRep.twoPtrValue.ptr1;
} else
#endif
/* 32-bit or without TIP #494 */
*lengthPtr = (size_t) (unsigned) length;
return result;
}
#ifdef __cplusplus
extern "C" {
#endif
DLLEXPORT int Dde_Init(Tcl_Interp *interp);
DLLEXPORT int Dde_SafeInit(Tcl_Interp *interp);
#ifdef __cplusplus
}
#endif
/*
*----------------------------------------------------------------------
*
* Dde_Init --
*
* This function initializes the dde command.
|
| ︙ | ︙ | |||
155 156 157 158 159 160 161 |
*----------------------------------------------------------------------
*/
int
Dde_Init(
Tcl_Interp *interp)
{
| | | | 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 |
*----------------------------------------------------------------------
*/
int
Dde_Init(
Tcl_Interp *interp)
{
if (!Tcl_InitStubs(interp, "8.5-", 0)) {
return TCL_ERROR;
}
Tcl_CreateObjCommand(interp, "dde", DdeObjCmd, NULL, NULL);
Tcl_CreateExitHandler(DdeExitProc, NULL);
return Tcl_PkgProvideEx(interp, TCL_DDE_PACKAGE_NAME, TCL_DDE_VERSION, NULL);
}
/*
*----------------------------------------------------------------------
*
* Dde_SafeInit --
*
|
| ︙ | ︙ | |||
231 232 233 234 235 236 237 |
* Make sure that the DDE server is there. This is done only once, add an
* exit handler tear it down.
*/
if (ddeInstance == 0) {
Tcl_MutexLock(&ddeMutex);
if (ddeInstance == 0) {
| | | | 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 |
* Make sure that the DDE server is there. This is done only once, add an
* exit handler tear it down.
*/
if (ddeInstance == 0) {
Tcl_MutexLock(&ddeMutex);
if (ddeInstance == 0) {
if (DdeInitializeW(&ddeInstance, (PFNCALLBACK) DdeServerProc,
CBF_SKIP_REGISTRATIONS | CBF_SKIP_UNREGISTRATIONS
| CBF_FAIL_POKES, 0) != DMLERR_NO_ERROR) {
ddeInstance = 0;
}
}
Tcl_MutexUnlock(&ddeMutex);
}
if ((ddeServiceGlobal == 0) && (nameFound != 0)) {
Tcl_MutexLock(&ddeMutex);
if ((ddeServiceGlobal == 0) && (nameFound != 0)) {
ddeIsServer = 1;
Tcl_CreateExitHandler(DdeExitProc, NULL);
ddeServiceGlobal = DdeCreateStringHandleW(ddeInstance,
TCL_DDE_SERVICE_NAME, CP_WINUNICODE);
DdeNameService(ddeInstance, ddeServiceGlobal, 0L, DNS_REGISTER);
} else {
ddeIsServer = 0;
}
Tcl_MutexUnlock(&ddeMutex);
}
|
| ︙ | ︙ | |||
279 280 281 282 283 284 285 | * "send" command is created in the application's interpreter. The * registration will be removed automatically if the interpreter is * deleted or the "send" command is removed. * *---------------------------------------------------------------------- */ | | | | | 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 |
* "send" command is created in the application's interpreter. The
* registration will be removed automatically if the interpreter is
* deleted or the "send" command is removed.
*
*----------------------------------------------------------------------
*/
static const WCHAR *
DdeSetServerName(
Tcl_Interp *interp,
const WCHAR *name, /* The name that will be used to refer to the
* interpreter in later "send" commands. Must
* be globally unique. */
int flags, /* DDE_FLAG_FORCE or 0 */
Tcl_Obj *handlerPtr) /* Name of the optional proc/command to handle
* incoming Dde eval's */
{
int suffix, offset;
RegisteredInterp *riPtr, *prevPtr;
Tcl_DString dString;
const WCHAR *actualName;
Tcl_Obj *srvListPtr = NULL, **srvPtrPtr = NULL;
int n, srvCount = 0, lastSuffix, r = TCL_OK;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
/*
* See if the application is already registered; if so, remove its current
* name from the registry. The deletion of the command will take care of
|
| ︙ | ︙ | |||
330 331 332 333 334 335 336 |
if (name == NULL) {
/*
* The name was NULL, so the caller is asking for the name of the
* current interp, but it doesn't have a name.
*/
| | | | | | | | | | > | | | | | 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 |
if (name == NULL) {
/*
* The name was NULL, so the caller is asking for the name of the
* current interp, but it doesn't have a name.
*/
return L"";
}
/*
* Get the list of currently registered Tcl interpreters by calling the
* internal implementation of the 'dde services' command.
*/
Tcl_DStringInit(&dString);
actualName = name;
if (!(flags & DDE_FLAG_FORCE)) {
r = DdeGetServicesList(interp, TCL_DDE_SERVICE_NAME, NULL);
if (r == TCL_OK) {
srvListPtr = Tcl_GetObjResult(interp);
}
if (r == TCL_OK) {
r = Tcl_ListObjGetElements(interp, srvListPtr, &srvCount,
&srvPtrPtr);
}
if (r != TCL_OK) {
Tcl_DStringInit(&dString);
OutputDebugStringW(Tcl_UtfToWCharDString(Tcl_GetString(Tcl_GetObjResult(interp)), -1, &dString));
Tcl_DStringFree(&dString);
return NULL;
}
/*
* Pick a name to use for the application. Use "name" if it's not
* already in use. Otherwise add a suffix such as " #2", trying larger
* and larger numbers until we eventually find one that is unique.
*/
offset = lastSuffix = 0;
suffix = 1;
while (suffix != lastSuffix) {
lastSuffix = suffix;
if (suffix > 1) {
if (suffix == 2) {
Tcl_DStringAppend(&dString, (char *)name, wcslen(name) * sizeof(WCHAR));
Tcl_DStringAppend(&dString, (char *)L" #", 2 * sizeof(WCHAR));
offset = Tcl_DStringLength(&dString);
Tcl_DStringSetLength(&dString, offset + sizeof(WCHAR) * TCL_INTEGER_SPACE);
actualName = (WCHAR *) Tcl_DStringValue(&dString);
}
_snwprintf((WCHAR *) (Tcl_DStringValue(&dString) + offset),
TCL_INTEGER_SPACE, L"%d", suffix);
}
/*
* See if the name is already in use, if so increment suffix.
*/
for (n = 0; n < srvCount; ++n) {
Tcl_Obj* namePtr;
Tcl_DString ds;
Tcl_ListObjIndex(interp, srvPtrPtr[n], 1, &namePtr);
Tcl_DStringInit(&ds);
Tcl_UtfToWCharDString(Tcl_GetString(namePtr), -1, &ds);
if (wcscmp(actualName, (WCHAR *)Tcl_DStringValue(&ds)) == 0) {
suffix++;
Tcl_DStringFree(&ds);
break;
}
Tcl_DStringFree(&ds);
}
}
}
/*
* We have found a unique name. Now add it to the registry.
*/
riPtr = (RegisteredInterp *) Tcl_Alloc(sizeof(RegisteredInterp));
riPtr->interp = interp;
riPtr->name = (WCHAR *) Tcl_Alloc((wcslen(actualName) + 1) * sizeof(WCHAR));
riPtr->nextPtr = tsdPtr->interpListPtr;
riPtr->handlerPtr = handlerPtr;
if (riPtr->handlerPtr != NULL) {
Tcl_IncrRefCount(riPtr->handlerPtr);
}
tsdPtr->interpListPtr = riPtr;
wcscpy(riPtr->name, actualName);
if (Tcl_IsSafe(interp)) {
Tcl_ExposeCommand(interp, "dde", "dde");
}
Tcl_CreateObjCommand(interp, "dde", DdeObjCmd,
riPtr, DeleteProc);
|
| ︙ | ︙ | |||
485 486 487 488 489 490 491 | * The interpreter given by riPtr is unregistered. * *---------------------------------------------------------------------- */ static void DeleteProc( | | < | 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 |
* The interpreter given by riPtr is unregistered.
*
*----------------------------------------------------------------------
*/
static void
DeleteProc(
void *clientData) /* The interp we are deleting. */
{
RegisteredInterp *riPtr = (RegisteredInterp *) clientData;
RegisteredInterp *searchPtr, *prevPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
for (searchPtr = tsdPtr->interpListPtr, prevPtr = NULL;
(searchPtr != NULL) && (searchPtr != riPtr);
|
| ︙ | ︙ | |||
623 624 625 626 627 628 629 |
* performing. */
UINT uFmt, /* The format that data is sent or received */
HCONV hConv, /* The conversation associated with the
* current transaction. */
HSZ ddeTopic, HSZ ddeItem, /* String handles. Transaction-type
* dependent. */
HDDEDATA hData, /* DDE data. Transaction-type dependent. */
| | | > > | | | | | | | | | | | 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 |
* performing. */
UINT uFmt, /* The format that data is sent or received */
HCONV hConv, /* The conversation associated with the
* current transaction. */
HSZ ddeTopic, HSZ ddeItem, /* String handles. Transaction-type
* dependent. */
HDDEDATA hData, /* DDE data. Transaction-type dependent. */
DWORD unused1, DWORD unused2)
/* Transaction-dependent data. */
{
Tcl_DString dString;
size_t len;
DWORD dlen;
WCHAR *utilString;
Tcl_Obj *ddeObjectPtr;
HDDEDATA ddeReturn = NULL;
RegisteredInterp *riPtr;
Conversation *convPtr, *prevConvPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
(void)unused1;
(void)unused2;
switch(uType) {
case XTYP_CONNECT:
/*
* Dde is trying to initialize a conversation with us. Check and make
* sure we have a valid topic.
*/
len = DdeQueryStringW(ddeInstance, ddeTopic, NULL, 0, CP_WINUNICODE);
Tcl_DStringInit(&dString);
Tcl_DStringSetLength(&dString, (len + 1) * sizeof(WCHAR) - 1);
utilString = (WCHAR *) Tcl_DStringValue(&dString);
DdeQueryStringW(ddeInstance, ddeTopic, utilString, (DWORD) len + 1,
CP_WINUNICODE);
for (riPtr = tsdPtr->interpListPtr; riPtr != NULL;
riPtr = riPtr->nextPtr) {
if (_wcsicmp(utilString, riPtr->name) == 0) {
Tcl_DStringFree(&dString);
return (HDDEDATA) TRUE;
}
}
Tcl_DStringFree(&dString);
return (HDDEDATA) FALSE;
case XTYP_CONNECT_CONFIRM:
/*
* Dde has decided that we can connect, so it gives us a conversation
* handle. We need to keep track of it so we know which execution
* result to return in an XTYP_REQUEST.
*/
len = DdeQueryStringW(ddeInstance, ddeTopic, NULL, 0, CP_WINUNICODE);
Tcl_DStringInit(&dString);
Tcl_DStringSetLength(&dString, (len + 1) * sizeof(WCHAR) - 1);
utilString = (WCHAR *) Tcl_DStringValue(&dString);
DdeQueryStringW(ddeInstance, ddeTopic, utilString, (DWORD) len + 1,
CP_WINUNICODE);
for (riPtr = tsdPtr->interpListPtr; riPtr != NULL;
riPtr = riPtr->nextPtr) {
if (_wcsicmp(riPtr->name, utilString) == 0) {
convPtr = (Conversation *) Tcl_Alloc(sizeof(Conversation));
convPtr->nextPtr = tsdPtr->currentConversations;
convPtr->returnPackagePtr = NULL;
convPtr->hConv = hConv;
convPtr->riPtr = riPtr;
tsdPtr->currentConversations = convPtr;
break;
|
| ︙ | ︙ | |||
736 737 738 739 740 741 742 |
*/
}
if (convPtr != NULL) {
Tcl_DString dsBuf;
char *returnString;
| | | | | | > | | > | > | | | 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 |
*/
}
if (convPtr != NULL) {
Tcl_DString dsBuf;
char *returnString;
len = DdeQueryStringW(ddeInstance, ddeItem, NULL, 0, CP_WINUNICODE);
Tcl_DStringInit(&dString);
Tcl_DStringInit(&dsBuf);
Tcl_DStringSetLength(&dString, (len + 1) * sizeof(WCHAR) - 1);
utilString = (WCHAR *) Tcl_DStringValue(&dString);
DdeQueryStringW(ddeInstance, ddeItem, utilString, (DWORD) len + 1,
CP_WINUNICODE);
if (_wcsicmp(utilString, TCL_DDE_EXECUTE_RESULT) == 0) {
returnString =
Tcl_GetString(convPtr->returnPackagePtr);
len = convPtr->returnPackagePtr->length;
if (uFmt != CF_TEXT) {
Tcl_DStringInit(&dsBuf);
Tcl_UtfToWCharDString(returnString, len, &dsBuf);
returnString = Tcl_DStringValue(&dsBuf);
len = Tcl_DStringLength(&dsBuf) + sizeof(WCHAR) - 1;
}
ddeReturn = DdeCreateDataHandle(ddeInstance, (BYTE *)returnString,
(DWORD) len+1, 0, ddeItem, uFmt, 0);
} else {
if (Tcl_IsSafe(convPtr->riPtr->interp)) {
ddeReturn = NULL;
} else {
Tcl_DString ds;
Tcl_Obj *variableObjPtr;
Tcl_DStringInit(&ds);
Tcl_WCharToUtfDString(utilString, wcslen(utilString), &ds);
variableObjPtr = Tcl_GetVar2Ex(
convPtr->riPtr->interp, Tcl_DStringValue(&ds), NULL,
TCL_GLOBAL_ONLY);
if (variableObjPtr != NULL) {
returnString = Tcl_GetString(variableObjPtr);
len = variableObjPtr->length;
if (uFmt != CF_TEXT) {
Tcl_DStringInit(&dsBuf);
Tcl_UtfToWCharDString(returnString, len, &dsBuf);
returnString = Tcl_DStringValue(&dsBuf);
len = Tcl_DStringLength(&dsBuf) + sizeof(WCHAR) - 1;
}
ddeReturn = DdeCreateDataHandle(ddeInstance,
(BYTE *)returnString, (DWORD) len+1, 0, ddeItem,
uFmt, 0);
} else {
ddeReturn = NULL;
}
|
| ︙ | ︙ | |||
813 814 815 816 817 818 819 |
if (convPtr && !Tcl_IsSafe(convPtr->riPtr->interp)) {
Tcl_DString ds, ds2;
Tcl_Obj *variableObjPtr;
DWORD len2;
Tcl_DStringInit(&dString);
Tcl_DStringInit(&ds2);
| | | | | > | | > | | | 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 |
if (convPtr && !Tcl_IsSafe(convPtr->riPtr->interp)) {
Tcl_DString ds, ds2;
Tcl_Obj *variableObjPtr;
DWORD len2;
Tcl_DStringInit(&dString);
Tcl_DStringInit(&ds2);
len = DdeQueryStringW(ddeInstance, ddeItem, NULL, 0, CP_WINUNICODE);
Tcl_DStringSetLength(&dString, (len + 1) * sizeof(WCHAR) - 1);
utilString = (WCHAR *) Tcl_DStringValue(&dString);
DdeQueryStringW(ddeInstance, ddeItem, utilString, (DWORD) len + 1,
CP_WINUNICODE);
Tcl_DStringInit(&ds);
Tcl_WCharToUtfDString(utilString, wcslen(utilString), &ds);
utilString = (WCHAR *) DdeAccessData(hData, &len2);
len = len2;
if (uFmt != CF_TEXT) {
Tcl_DStringInit(&ds2);
Tcl_WCharToUtfDString(utilString, wcslen(utilString), &ds2);
utilString = (WCHAR *) Tcl_DStringValue(&ds2);
}
variableObjPtr = Tcl_NewStringObj((char *)utilString, -1);
Tcl_SetVar2Ex(convPtr->riPtr->interp, Tcl_DStringValue(&ds), NULL,
variableObjPtr, TCL_GLOBAL_ONLY);
Tcl_DStringFree(&ds2);
|
| ︙ | ︙ | |||
858 859 860 861 862 863 864 |
*/
}
if (convPtr == NULL) {
return (HDDEDATA) DDE_FNOTPROCESSED;
}
| | > | | 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 |
*/
}
if (convPtr == NULL) {
return (HDDEDATA) DDE_FNOTPROCESSED;
}
utilString = (WCHAR *) DdeAccessData(hData, &dlen);
string = (char *) utilString;
if (!dlen) {
/* Empty binary array. */
ddeObjectPtr = Tcl_NewObj();
} else if ((dlen & 1) || utilString[(dlen>>1)-1]) {
/* Cannot be unicode, so assume utf-8 */
if (!string[dlen-1]) {
dlen--;
}
ddeObjectPtr = Tcl_NewStringObj(string, dlen);
} else {
/* unicode */
Tcl_DString dsBuf;
Tcl_DStringInit(&dsBuf);
Tcl_WCharToUtfDString(utilString, (dlen>>1) - 1, &dsBuf);
ddeObjectPtr = Tcl_NewStringObj(Tcl_DStringValue(&dsBuf),
Tcl_DStringLength(&dsBuf));
Tcl_DStringFree(&dsBuf);
}
Tcl_IncrRefCount(ddeObjectPtr);
DdeUnaccessData(hData);
if (convPtr->returnPackagePtr != NULL) {
|
| ︙ | ︙ | |||
928 929 930 931 932 933 934 |
numItems = i;
ddeReturn = DdeCreateDataHandle(ddeInstance, NULL,
(numItems + 1) * sizeof(HSZPAIR), 0, 0, 0, 0);
returnPtr = (HSZPAIR *) DdeAccessData(ddeReturn, &dlen);
len = dlen;
for (i = 0, riPtr = tsdPtr->interpListPtr; i < numItems;
i++, riPtr = riPtr->nextPtr) {
| | | | 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 |
numItems = i;
ddeReturn = DdeCreateDataHandle(ddeInstance, NULL,
(numItems + 1) * sizeof(HSZPAIR), 0, 0, 0, 0);
returnPtr = (HSZPAIR *) DdeAccessData(ddeReturn, &dlen);
len = dlen;
for (i = 0, riPtr = tsdPtr->interpListPtr; i < numItems;
i++, riPtr = riPtr->nextPtr) {
returnPtr[i].hszSvc = DdeCreateStringHandleW(ddeInstance,
TCL_DDE_SERVICE_NAME, CP_WINUNICODE);
returnPtr[i].hszTopic = DdeCreateStringHandleW(ddeInstance,
riPtr->name, CP_WINUNICODE);
}
returnPtr[i].hszSvc = NULL;
returnPtr[i].hszTopic = NULL;
DdeUnaccessData(ddeReturn);
return ddeReturn;
}
|
| ︙ | ︙ | |||
962 963 964 965 966 967 968 | * The DDE server is deleted. * *---------------------------------------------------------------------- */ static void DdeExitProc( | | > | 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 |
* The DDE server is deleted.
*
*----------------------------------------------------------------------
*/
static void
DdeExitProc(
void *dummy) /* Not used. */
{
(void)dummy;
DdeNameService(ddeInstance, NULL, 0, DNS_UNREGISTER);
DdeUninitialize(ddeInstance);
ddeInstance = 0;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
989 990 991 992 993 994 995 |
*
*----------------------------------------------------------------------
*/
static int
MakeDdeConnection(
Tcl_Interp *interp, /* Used to report errors. */
| | | | | > | 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 |
*
*----------------------------------------------------------------------
*/
static int
MakeDdeConnection(
Tcl_Interp *interp, /* Used to report errors. */
const WCHAR *name, /* The connection to use. */
HCONV *ddeConvPtr)
{
HSZ ddeTopic, ddeService;
HCONV ddeConv;
ddeService = DdeCreateStringHandleW(ddeInstance, TCL_DDE_SERVICE_NAME, CP_WINUNICODE);
ddeTopic = DdeCreateStringHandleW(ddeInstance, name, CP_WINUNICODE);
ddeConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL);
DdeFreeStringHandle(ddeInstance, ddeService);
DdeFreeStringHandle(ddeInstance, ddeTopic);
if (ddeConv == (HCONV) NULL) {
if (interp != NULL) {
Tcl_DString dString;
Tcl_DStringInit(&dString);
Tcl_WCharToUtfDString(name, wcslen(name), &dString);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"no registered server named \"%s\"", Tcl_DStringValue(&dString)));
Tcl_DStringFree(&dString);
Tcl_SetErrorCode(interp, "TCL", "DDE", "NO_SERVER", NULL);
}
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
1043 1044 1045 1046 1047 1048 1049 |
*----------------------------------------------------------------------
*/
static int
DdeCreateClient(
DdeEnumServices *es)
{
| | | | | | | | | | | | | | > | | > | 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 |
*----------------------------------------------------------------------
*/
static int
DdeCreateClient(
DdeEnumServices *es)
{
WNDCLASSEXW wc;
static const WCHAR *szDdeClientClassName = L"TclEval client class";
static const WCHAR *szDdeClientWindowName = L"TclEval client window";
memset(&wc, 0, sizeof(wc));
wc.cbSize = sizeof(wc);
wc.lpfnWndProc = DdeClientWindowProc;
wc.lpszClassName = szDdeClientClassName;
wc.cbWndExtra = sizeof(DdeEnumServices *);
/*
* Register and create the callback window.
*/
RegisterClassExW(&wc);
es->hwnd = CreateWindowExW(0, szDdeClientClassName, szDdeClientWindowName,
WS_POPUP, 0, 0, 0, 0, NULL, NULL, NULL, (LPVOID)es);
return TCL_OK;
}
static LRESULT CALLBACK
DdeClientWindowProc(
HWND hwnd, /* What window is the message for */
UINT uMsg, /* The type of message received */
WPARAM wParam,
LPARAM lParam) /* (Potentially) our local handle */
{
switch (uMsg) {
case WM_CREATE: {
LPCREATESTRUCT lpcs = (LPCREATESTRUCT) lParam;
DdeEnumServices *es =
(DdeEnumServices *) lpcs->lpCreateParams;
#ifdef _WIN64
SetWindowLongPtrW(hwnd, GWLP_USERDATA, (LONG_PTR) es);
#else
SetWindowLongW(hwnd, GWL_USERDATA, (LONG) es);
#endif
return (LRESULT) 0L;
}
case WM_DDE_ACK:
return DdeServicesOnAck(hwnd, wParam, lParam);
default:
return DefWindowProcW(hwnd, uMsg, wParam, lParam);
}
}
static LRESULT
DdeServicesOnAck(
HWND hwnd,
WPARAM wParam,
LPARAM lParam)
{
HWND hwndRemote = (HWND)wParam;
ATOM service = (ATOM)LOWORD(lParam);
ATOM topic = (ATOM)HIWORD(lParam);
DdeEnumServices *es;
WCHAR sz[255];
Tcl_DString dString;
#ifdef _WIN64
es = (DdeEnumServices *) GetWindowLongPtrW(hwnd, GWLP_USERDATA);
#else
es = (DdeEnumServices *) GetWindowLongW(hwnd, GWL_USERDATA);
#endif
if (((es->service == (ATOM)0) || (es->service == service))
&& ((es->topic == (ATOM)0) || (es->topic == topic))) {
Tcl_Obj *matchPtr = Tcl_NewListObj(0, NULL);
Tcl_Obj *resultPtr = Tcl_GetObjResult(es->interp);
GlobalGetAtomNameW(service, sz, 255);
Tcl_DStringInit(&dString);
Tcl_WCharToUtfDString(sz, wcslen(sz), &dString);
Tcl_ListObjAppendElement(NULL, matchPtr, Tcl_NewStringObj(Tcl_DStringValue(&dString), -1));
Tcl_DStringFree(&dString);
GlobalGetAtomNameW(topic, sz, 255);
Tcl_DStringInit(&dString);
Tcl_WCharToUtfDString(sz, wcslen(sz), &dString);
Tcl_ListObjAppendElement(NULL, matchPtr, Tcl_NewStringObj(Tcl_DStringValue(&dString), -1));
Tcl_DStringFree(&dString);
/*
* Adding the hwnd as a third list element provides a unique
* identifier in the case of multiple servers with the name
* application and topic names.
|
| ︙ | ︙ | |||
1147 1148 1149 1150 1151 1152 1153 |
}
}
/*
* Tell the server we are no longer interested.
*/
| | | | | | | | 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 |
}
}
/*
* Tell the server we are no longer interested.
*/
PostMessageW(hwndRemote, WM_DDE_TERMINATE, (WPARAM)hwnd, 0L);
return 0L;
}
static BOOL CALLBACK
DdeEnumWindowsCallback(
HWND hwndTarget,
LPARAM lParam)
{
DWORD_PTR dwResult = 0;
DdeEnumServices *es = (DdeEnumServices *) lParam;
SendMessageTimeoutW(hwndTarget, WM_DDE_INITIATE, (WPARAM)es->hwnd,
MAKELONG(es->service, es->topic), SMTO_ABORTIFHUNG, 1000,
&dwResult);
return TRUE;
}
static int
DdeGetServicesList(
Tcl_Interp *interp,
const WCHAR *serviceName,
const WCHAR *topicName)
{
DdeEnumServices es;
es.interp = interp;
es.result = TCL_OK;
es.service = (serviceName == NULL)
? (ATOM)0 : GlobalAddAtomW(serviceName);
es.topic = (topicName == NULL) ? (ATOM)0 : GlobalAddAtomW(topicName);
Tcl_ResetResult(interp); /* our list is to be appended to result. */
DdeCreateClient(&es);
EnumWindows(DdeEnumWindowsCallback, (LPARAM)&es);
if (IsWindow(es.hwnd)) {
DestroyWindow(es.hwnd);
|
| ︙ | ︙ | |||
1261 1262 1263 1264 1265 1266 1267 | * See the user documentation. * *---------------------------------------------------------------------- */ static int DdeObjCmd( | | | 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
DdeObjCmd(
void *dummy, /* Not used. */
Tcl_Interp *interp, /* The interp we are sending from */
int objc, /* Number of arguments */
Tcl_Obj *const *objv) /* The arguments */
{
static const char *const ddeCommands[] = {
"servername", "execute", "poke", "request", "services", "eval",
(char *) NULL};
|
| ︙ | ︙ | |||
1298 1299 1300 1301 1302 1303 1304 |
int index, i, argIndex;
size_t length;
int flags = 0, result = TCL_OK, firstArg = 0;
HSZ ddeService = NULL, ddeTopic = NULL, ddeItem = NULL, ddeCookie = NULL;
HDDEDATA ddeData = NULL, ddeItemData = NULL, ddeReturn;
HCONV hConv = NULL;
| | > | 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 |
int index, i, argIndex;
size_t length;
int flags = 0, result = TCL_OK, firstArg = 0;
HSZ ddeService = NULL, ddeTopic = NULL, ddeItem = NULL, ddeCookie = NULL;
HDDEDATA ddeData = NULL, ddeItemData = NULL, ddeReturn;
HCONV hConv = NULL;
const WCHAR *serviceName = NULL, *topicName = NULL;
const char *string;
DWORD ddeResult;
Tcl_Obj *objPtr, *handlerPtr = NULL;
Tcl_DString serviceBuf, topicBuf, itemBuf;
(void)dummy;
/*
* Initialize DDE server/client
*/
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "command ?arg ...?");
|
| ︙ | ︙ | |||
1458 1459 1460 1461 1462 1463 1464 |
Initialize();
if (firstArg != 1) {
const char *src = Tcl_GetString(objv[firstArg]);
length = objv[firstArg]->length;
| > | | | | > | | | > | | 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 |
Initialize();
if (firstArg != 1) {
const char *src = Tcl_GetString(objv[firstArg]);
length = objv[firstArg]->length;
Tcl_DStringInit(&serviceBuf);
Tcl_UtfToWCharDString(src, length, &serviceBuf);
serviceName = (WCHAR *) Tcl_DStringValue(&serviceBuf);
length = Tcl_DStringLength(&serviceBuf) / sizeof(WCHAR);
} else {
length = 0;
}
if (length == 0) {
serviceName = NULL;
} else if ((index != DDE_SERVERNAME) && (index != DDE_EVAL)) {
ddeService = DdeCreateStringHandleW(ddeInstance, serviceName,
CP_WINUNICODE);
}
if ((index != DDE_SERVERNAME) && (index != DDE_EVAL)) {
const char *src = Tcl_GetString(objv[firstArg + 1]);
length = objv[firstArg + 1]->length;
Tcl_DStringInit(&topicBuf);
topicName = Tcl_UtfToWCharDString(src, length, &topicBuf);
length = Tcl_DStringLength(&topicBuf) / sizeof(WCHAR);
if (length == 0) {
topicName = NULL;
} else {
ddeTopic = DdeCreateStringHandleW(ddeInstance, topicName,
CP_WINUNICODE);
}
}
switch ((enum DdeSubcommands) index) {
case DDE_SERVERNAME:
serviceName = DdeSetServerName(interp, serviceName, flags,
handlerPtr);
if (serviceName != NULL) {
Tcl_DString dsBuf;
Tcl_DStringInit(&dsBuf);
Tcl_WCharToUtfDString(serviceName, wcslen(serviceName), &dsBuf);
Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_DStringValue(&dsBuf),
Tcl_DStringLength(&dsBuf)));
Tcl_DStringFree(&dsBuf);
} else {
Tcl_ResetResult(interp);
}
break;
|
| ︙ | ︙ | |||
1516 1517 1518 1519 1520 1521 1522 |
dataString =
getByteArrayFromObj(objv[firstArg + 2], &dataLength);
} else {
const char *src;
src = Tcl_GetString(objv[firstArg + 2]);
dataLength = objv[firstArg + 2]->length;
| > | | | | 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 |
dataString =
getByteArrayFromObj(objv[firstArg + 2], &dataLength);
} else {
const char *src;
src = Tcl_GetString(objv[firstArg + 2]);
dataLength = objv[firstArg + 2]->length;
Tcl_DStringInit(&dsBuf);
dataString =
Tcl_UtfToWCharDString(src, dataLength, &dsBuf);
dataLength = Tcl_DStringLength(&dsBuf) + sizeof(WCHAR);
}
if (dataLength + 1 < 2) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("cannot execute null data", -1));
Tcl_DStringFree(&dsBuf);
Tcl_SetErrorCode(interp, "TCL", "DDE", "NULL", NULL);
|
| ︙ | ︙ | |||
1564 1565 1566 1567 1568 1569 1570 |
SetDdeError(interp);
result = TCL_ERROR;
}
Tcl_DStringFree(&dsBuf);
break;
}
case DDE_REQUEST: {
| | > | | | | | | | > | | > | | > | | | | 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 |
SetDdeError(interp);
result = TCL_ERROR;
}
Tcl_DStringFree(&dsBuf);
break;
}
case DDE_REQUEST: {
const WCHAR *itemString;
const char *src;
src = Tcl_GetString(objv[firstArg + 2]);
length = objv[firstArg + 2]->length;
Tcl_DStringInit(&itemBuf);
itemString = Tcl_UtfToWCharDString(src, length, &itemBuf);
length = Tcl_DStringLength(&itemBuf) / sizeof(WCHAR);
if (length == 0) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("cannot request value of null data", -1));
Tcl_SetErrorCode(interp, "TCL", "DDE", "NULL", NULL);
result = TCL_ERROR;
goto cleanup;
}
hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL);
DdeFreeStringHandle(ddeInstance, ddeService);
DdeFreeStringHandle(ddeInstance, ddeTopic);
if (hConv == NULL) {
SetDdeError(interp);
result = TCL_ERROR;
} else {
Tcl_Obj *returnObjPtr;
ddeItem = DdeCreateStringHandleW(ddeInstance, itemString,
CP_WINUNICODE);
if (ddeItem != NULL) {
ddeData = DdeClientTransaction(NULL, 0, hConv, ddeItem,
(flags & DDE_FLAG_BINARY) ? CF_TEXT : CF_UNICODETEXT, XTYP_REQUEST, 5000, NULL);
if (ddeData == NULL) {
SetDdeError(interp);
result = TCL_ERROR;
} else {
DWORD tmp;
WCHAR *dataString = (WCHAR *) DdeAccessData(ddeData, &tmp);
if (flags & DDE_FLAG_BINARY) {
returnObjPtr =
Tcl_NewByteArrayObj((BYTE *) dataString, tmp);
} else {
Tcl_DString dsBuf;
if ((tmp >= sizeof(WCHAR))
&& !dataString[tmp / sizeof(WCHAR) - 1]) {
tmp -= sizeof(WCHAR);
}
Tcl_DStringInit(&dsBuf);
Tcl_WCharToUtfDString(dataString, tmp>>1, &dsBuf);
returnObjPtr =
Tcl_NewStringObj(Tcl_DStringValue(&dsBuf),
Tcl_DStringLength(&dsBuf));
Tcl_DStringFree(&dsBuf);
}
DdeUnaccessData(ddeData);
DdeFreeDataHandle(ddeData);
Tcl_SetObjResult(interp, returnObjPtr);
}
} else {
SetDdeError(interp);
result = TCL_ERROR;
}
}
break;
}
case DDE_POKE: {
Tcl_DString dsBuf;
const WCHAR *itemString;
BYTE *dataString;
const char *src;
src = Tcl_GetString(objv[firstArg + 2]);
length = objv[firstArg + 2]->length;
Tcl_DStringInit(&itemBuf);
itemString = Tcl_UtfToWCharDString(src, length, &itemBuf);
length = Tcl_DStringLength(&itemBuf) / sizeof(WCHAR);
if (length == 0) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("cannot have a null item", -1));
Tcl_SetErrorCode(interp, "TCL", "DDE", "NULL", NULL);
result = TCL_ERROR;
goto cleanup;
}
Tcl_DStringInit(&dsBuf);
if (flags & DDE_FLAG_BINARY) {
dataString = (BYTE *)
getByteArrayFromObj(objv[firstArg + 3], &length);
} else {
const char *data =
Tcl_GetString(objv[firstArg + 3]);
length = objv[firstArg + 3]->length;
Tcl_DStringInit(&dsBuf);
dataString = (BYTE *)
Tcl_UtfToWCharDString(data, length, &dsBuf);
length = Tcl_DStringLength(&dsBuf) + sizeof(WCHAR);
}
hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL);
DdeFreeStringHandle(ddeInstance, ddeService);
DdeFreeStringHandle(ddeInstance, ddeTopic);
if (hConv == NULL) {
SetDdeError(interp);
result = TCL_ERROR;
} else {
ddeItem = DdeCreateStringHandleW(ddeInstance, itemString,
CP_WINUNICODE);
if (ddeItem != NULL) {
ddeData = DdeClientTransaction(dataString, (DWORD) length,
hConv, ddeItem, (flags & DDE_FLAG_BINARY) ? CF_TEXT : CF_UNICODETEXT, XTYP_POKE, 5000, NULL);
if (ddeData == NULL) {
SetDdeError(interp);
result = TCL_ERROR;
|
| ︙ | ︙ | |||
1713 1714 1715 1716 1717 1718 1719 |
* producing a bytecode structure that refers to other objects owned
* by the target interp. If the target interp is then deleted, the
* bytecode structure would be referring to deallocated objects.
*/
for (riPtr = tsdPtr->interpListPtr; riPtr != NULL;
riPtr = riPtr->nextPtr) {
| | | 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 |
* producing a bytecode structure that refers to other objects owned
* by the target interp. If the target interp is then deleted, the
* bytecode structure would be referring to deallocated objects.
*/
for (riPtr = tsdPtr->interpListPtr; riPtr != NULL;
riPtr = riPtr->nextPtr) {
if (_wcsicmp(serviceName, riPtr->name) == 0) {
break;
}
}
if (riPtr != NULL) {
Tcl_Interp *sendInterp;
|
| ︙ | ︙ | |||
1816 1817 1818 1819 1820 1821 1822 | result = TCL_ERROR; goto cleanup; } objPtr = Tcl_ConcatObj(objc, objv); string = Tcl_GetString(objPtr); length = objPtr->length; | > | | | | | | | > | | 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 |
result = TCL_ERROR;
goto cleanup;
}
objPtr = Tcl_ConcatObj(objc, objv);
string = Tcl_GetString(objPtr);
length = objPtr->length;
Tcl_DStringInit(&dsBuf);
Tcl_UtfToWCharDString(string, length, &dsBuf);
string = Tcl_DStringValue(&dsBuf);
length = Tcl_DStringLength(&dsBuf) + sizeof(WCHAR);
ddeItemData = DdeCreateDataHandle(ddeInstance, (BYTE *) string,
(DWORD) length, 0, 0, CF_UNICODETEXT, 0);
Tcl_DStringFree(&dsBuf);
if (flags & DDE_FLAG_ASYNC) {
ddeData = DdeClientTransaction((LPBYTE) ddeItemData,
0xFFFFFFFF, hConv, 0,
CF_UNICODETEXT, XTYP_EXECUTE, TIMEOUT_ASYNC, &ddeResult);
DdeAbandonTransaction(ddeInstance, hConv, ddeResult);
} else {
ddeData = DdeClientTransaction((LPBYTE) ddeItemData,
0xFFFFFFFF, hConv, 0,
CF_UNICODETEXT, XTYP_EXECUTE, 30000, NULL);
if (ddeData != 0) {
ddeCookie = DdeCreateStringHandleW(ddeInstance,
TCL_DDE_EXECUTE_RESULT, CP_WINUNICODE);
ddeData = DdeClientTransaction(NULL, 0, hConv, ddeCookie,
CF_UNICODETEXT, XTYP_REQUEST, 30000, NULL);
}
}
Tcl_DecrRefCount(objPtr);
if (ddeData == 0) {
SetDdeError(interp);
result = TCL_ERROR;
goto cleanup;
}
if (!(flags & DDE_FLAG_ASYNC)) {
Tcl_Obj *resultPtr;
WCHAR *ddeDataString;
/*
* The return handle has a two or four element list in it. The
* first element is the return code (TCL_OK, TCL_ERROR, etc.).
* The second is the result of the script. If the return code
* is TCL_ERROR, then the third element is the value of the
* variable "errorCode", and the fourth is the value of the
* variable "errorInfo".
*/
length = DdeGetData(ddeData, NULL, 0, 0);
ddeDataString = (WCHAR *) Tcl_Alloc(length);
DdeGetData(ddeData, (BYTE *) ddeDataString, (DWORD) length, 0);
if (length > sizeof(WCHAR)) {
length -= sizeof(WCHAR);
}
Tcl_DStringInit(&dsBuf);
Tcl_WCharToUtfDString(ddeDataString, length>>1, &dsBuf);
resultPtr = Tcl_NewStringObj(Tcl_DStringValue(&dsBuf),
Tcl_DStringLength(&dsBuf));
Tcl_DStringFree(&dsBuf);
Tcl_Free((char *) ddeDataString);
if (Tcl_ListObjIndex(NULL, resultPtr, 0, &objPtr) != TCL_OK) {
Tcl_DecrRefCount(resultPtr);
|
| ︙ | ︙ |
Changes to win/tclWinFCmd.c.
| ︙ | ︙ | |||
210 211 212 213 214 215 216 | /* * Link the TCLEXCEPTION_REGISTRATION on the chain. */ "movl %%edx, %%fs:0" "\n\t" /* | | | | 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 | /* * Link the TCLEXCEPTION_REGISTRATION on the chain. */ "movl %%edx, %%fs:0" "\n\t" /* * Call MoveFileW(nativeSrc, nativeDst) */ "pushl %%ebx" "\n\t" "pushl %%ecx" "\n\t" "movl %[moveFileW], %%eax" "\n\t" "call *%%eax" "\n\t" /* * Come here on normal exit. Recover the TCLEXCEPTION_REGISTRATION and * put the status return from MoveFile into it. */ |
| ︙ | ︙ | |||
252 253 254 255 256 257 258 | : /* No outputs */ : [registration] "m" (registration), [nativeDst] "m" (nativeDst), [nativeSrc] "m" (nativeSrc), | | | | | | | | 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 |
:
/* No outputs */
:
[registration] "m" (registration),
[nativeDst] "m" (nativeDst),
[nativeSrc] "m" (nativeSrc),
[moveFileW] "r" (MoveFileW)
:
"%eax", "%ebx", "%ecx", "%edx", "memory"
);
if (registration.status != FALSE) {
retval = TCL_OK;
}
#else
#ifndef HAVE_NO_SEH
__try {
#endif
if ((*MoveFileW)(nativeSrc, nativeDst) != FALSE) {
retval = TCL_OK;
}
#ifndef HAVE_NO_SEH
} __except (EXCEPTION_EXECUTE_HANDLER) {}
#endif
#endif
if (retval != -1) {
return retval;
}
TclWinConvertError(GetLastError());
srcAttr = GetFileAttributesW(nativeSrc);
dstAttr = GetFileAttributesW(nativeDst);
if (srcAttr == 0xffffffff) {
if (GetFullPathNameW(nativeSrc, 0, NULL,
NULL) >= MAX_PATH) {
errno = ENAMETOOLONG;
return TCL_ERROR;
}
srcAttr = 0;
}
if (dstAttr == 0xffffffff) {
if (GetFullPathNameW(nativeDst, 0, NULL,
NULL) >= MAX_PATH) {
errno = ENAMETOOLONG;
return TCL_ERROR;
}
dstAttr = 0;
}
|
| ︙ | ︙ | |||
311 312 313 314 315 316 317 | const char **srcArgv, **dstArgv; int size, srcArgc, dstArgc; WCHAR nativeSrcPath[MAX_PATH]; WCHAR nativeDstPath[MAX_PATH]; Tcl_DString srcString, dstString; const char *src, *dst; | | | | | > > | | | 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 |
const char **srcArgv, **dstArgv;
int size, srcArgc, dstArgc;
WCHAR nativeSrcPath[MAX_PATH];
WCHAR nativeDstPath[MAX_PATH];
Tcl_DString srcString, dstString;
const char *src, *dst;
size = GetFullPathNameW(nativeSrc, MAX_PATH,
nativeSrcPath, &nativeSrcRest);
if ((size == 0) || (size > MAX_PATH)) {
return TCL_ERROR;
}
size = GetFullPathNameW(nativeDst, MAX_PATH,
nativeDstPath, &nativeDstRest);
if ((size == 0) || (size > MAX_PATH)) {
return TCL_ERROR;
}
CharLowerW(nativeSrcPath);
CharLowerW(nativeDstPath);
Tcl_DStringInit(&srcString);
Tcl_DStringInit(&dstString);
src = Tcl_WCharToUtfDString(nativeSrcPath, -1, &srcString);
dst = Tcl_WCharToUtfDString(nativeDstPath, -1, &dstString);
/*
* Check whether the destination path is actually inside the
* source path. This is true if the prefix matches, and the next
* character is either end-of-string or a directory separator
*/
|
| ︙ | ︙ | |||
404 405 406 407 408 409 410 |
if (DoRemoveJustDirectory(nativeDst, 0, NULL) == TCL_OK) {
/*
* Now that that empty directory is gone, we can try
* renaming again. If that fails, we'll put this empty
* directory back, for completeness.
*/
| | | | | 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 |
if (DoRemoveJustDirectory(nativeDst, 0, NULL) == TCL_OK) {
/*
* Now that that empty directory is gone, we can try
* renaming again. If that fails, we'll put this empty
* directory back, for completeness.
*/
if (MoveFileW(nativeSrc,
nativeDst) != FALSE) {
return TCL_OK;
}
/*
* Some new error has occurred. Don't know what it could
* be, but report this one.
*/
TclWinConvertError(GetLastError());
CreateDirectoryW(nativeDst, NULL);
SetFileAttributesW(nativeDst, dstAttr);
if (Tcl_GetErrno() == EACCES) {
/*
* Decode the EACCES to a more meaningful error.
*/
goto decode;
}
|
| ︙ | ︙ | |||
445 446 447 448 449 450 451 | * back to old name. */ WCHAR *nativeRest, *nativeTmp, *nativePrefix; int result, size; WCHAR tempBuf[MAX_PATH]; | | | | | | | | | | | | 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 |
* back to old name.
*/
WCHAR *nativeRest, *nativeTmp, *nativePrefix;
int result, size;
WCHAR tempBuf[MAX_PATH];
size = GetFullPathNameW(nativeDst, MAX_PATH,
tempBuf, &nativeRest);
if ((size == 0) || (size > MAX_PATH) || (nativeRest == NULL)) {
return TCL_ERROR;
}
nativeTmp = (WCHAR *) tempBuf;
nativeRest[0] = '\0';
result = TCL_ERROR;
nativePrefix = (WCHAR *)L"tclr";
if (GetTempFileNameW(nativeTmp, nativePrefix,
0, tempBuf) != 0) {
/*
* Strictly speaking, need the following DeleteFile and
* MoveFile to be joined as an atomic operation so no
* other app comes along in the meantime and creates the
* same temp file.
*/
nativeTmp = tempBuf;
DeleteFileW(nativeTmp);
if (MoveFileW(nativeDst, nativeTmp) != FALSE) {
if (MoveFileW(nativeSrc, nativeDst) != FALSE) {
SetFileAttributesW(nativeTmp, FILE_ATTRIBUTE_NORMAL);
DeleteFileW(nativeTmp);
return TCL_OK;
} else {
DeleteFileW(nativeDst);
MoveFileW(nativeTmp, nativeDst);
}
}
/*
* Can't backup dst file or move src file. Return that
* error. Could happen if an open file refers to dst.
*/
|
| ︙ | ︙ | |||
597 598 599 600 601 602 603 | /* * Link the TCLEXCEPTION_REGISTRATION on the chain. */ "movl %%edx, %%fs:0" "\n\t" /* | | | | 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 | /* * Link the TCLEXCEPTION_REGISTRATION on the chain. */ "movl %%edx, %%fs:0" "\n\t" /* * Call CopyFileW(nativeSrc, nativeDst, 0) */ "movl %[copyFileW], %%eax" "\n\t" "pushl $0" "\n\t" "pushl %%ebx" "\n\t" "pushl %%ecx" "\n\t" "call *%%eax" "\n\t" /* * Come here on normal exit. Recover the TCLEXCEPTION_REGISTRATION and |
| ︙ | ︙ | |||
640 641 642 643 644 645 646 | : /* No outputs */ : [registration] "m" (registration), [nativeDst] "m" (nativeDst), [nativeSrc] "m" (nativeSrc), | | | | | | | | | 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 |
:
/* No outputs */
:
[registration] "m" (registration),
[nativeDst] "m" (nativeDst),
[nativeSrc] "m" (nativeSrc),
[copyFileW] "r" (CopyFileW)
:
"%eax", "%ebx", "%ecx", "%edx", "memory"
);
if (registration.status != FALSE) {
retval = TCL_OK;
}
#else
#ifndef HAVE_NO_SEH
__try {
#endif
if (CopyFileW(nativeSrc, nativeDst, 0) != FALSE) {
retval = TCL_OK;
}
#ifndef HAVE_NO_SEH
} __except (EXCEPTION_EXECUTE_HANDLER) {}
#endif
#endif
if (retval != -1) {
return retval;
}
TclWinConvertError(GetLastError());
if (Tcl_GetErrno() == EBADF) {
Tcl_SetErrno(EACCES);
return TCL_ERROR;
}
if (Tcl_GetErrno() == EACCES) {
DWORD srcAttr, dstAttr;
srcAttr = GetFileAttributesW(nativeSrc);
dstAttr = GetFileAttributesW(nativeDst);
if (srcAttr != 0xffffffff) {
if (dstAttr == 0xffffffff) {
dstAttr = 0;
}
if ((srcAttr & FILE_ATTRIBUTE_DIRECTORY) ||
(dstAttr & FILE_ATTRIBUTE_DIRECTORY)) {
if (srcAttr & FILE_ATTRIBUTE_REPARSE_POINT) {
/* Source is a symbolic link -- copy it */
if (TclWinSymLinkCopyDirectory(nativeSrc, nativeDst)==0) {
return TCL_OK;
}
}
Tcl_SetErrno(EISDIR);
}
if (dstAttr & FILE_ATTRIBUTE_READONLY) {
SetFileAttributesW(nativeDst,
dstAttr & ~((DWORD)FILE_ATTRIBUTE_READONLY));
if (CopyFileW(nativeSrc, nativeDst,
0) != FALSE) {
return TCL_OK;
}
/*
* Still can't copy onto dst. Return that error, and restore
* attributes of dst.
*/
TclWinConvertError(GetLastError());
SetFileAttributesW(nativeDst, dstAttr);
}
}
}
return TCL_ERROR;
}
/*
|
| ︙ | ︙ | |||
757 758 759 760 761 762 763 |
*/
if (path == NULL || path[0] == '\0') {
Tcl_SetErrno(ENOENT);
return TCL_ERROR;
}
| | | | | | | | 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 |
*/
if (path == NULL || path[0] == '\0') {
Tcl_SetErrno(ENOENT);
return TCL_ERROR;
}
if (DeleteFileW(path) != FALSE) {
return TCL_OK;
}
TclWinConvertError(GetLastError());
if (Tcl_GetErrno() == EACCES) {
attr = GetFileAttributesW(path);
if (attr != 0xffffffff) {
if (attr & FILE_ATTRIBUTE_DIRECTORY) {
if (attr & FILE_ATTRIBUTE_REPARSE_POINT) {
/*
* It is a symbolic link - remove it.
*/
if (TclWinSymLinkDelete(path, 0) == 0) {
return TCL_OK;
}
}
/*
* If we fall through here, it is a directory.
*
* Windows NT reports removing a directory as EACCES instead
* of EISDIR.
*/
Tcl_SetErrno(EISDIR);
} else if (attr & FILE_ATTRIBUTE_READONLY) {
int res = SetFileAttributesW(path,
attr & ~((DWORD) FILE_ATTRIBUTE_READONLY));
if ((res != 0) &&
(DeleteFileW(path) != FALSE)) {
return TCL_OK;
}
TclWinConvertError(GetLastError());
if (res != 0) {
SetFileAttributesW(path, attr);
}
}
}
} else if (Tcl_GetErrno() == ENOENT) {
attr = GetFileAttributesW(path);
if (attr != 0xffffffff) {
if (attr & FILE_ATTRIBUTE_DIRECTORY) {
/*
* Windows 95 reports removing a directory as ENOENT instead
* of EISDIR.
*/
|
| ︙ | ︙ | |||
857 858 859 860 861 862 863 |
return DoCreateDirectory(Tcl_FSGetNativePath(pathPtr));
}
static int
DoCreateDirectory(
const WCHAR *nativePath) /* Pathname of directory to create (native). */
{
| | | 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 |
return DoCreateDirectory(Tcl_FSGetNativePath(pathPtr));
}
static int
DoCreateDirectory(
const WCHAR *nativePath) /* Pathname of directory to create (native). */
{
if (CreateDirectoryW(nativePath, NULL) == 0) {
DWORD error = GetLastError();
TclWinConvertError(error);
return TCL_ERROR;
}
return TCL_OK;
}
|
| ︙ | ︙ | |||
907 908 909 910 911 912 913 |
normSrcPtr = Tcl_FSGetNormalizedPath(NULL,srcPathPtr);
normDestPtr = Tcl_FSGetNormalizedPath(NULL,destPathPtr);
if ((normSrcPtr == NULL) || (normDestPtr == NULL)) {
return TCL_ERROR;
}
| > > | | | 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 |
normSrcPtr = Tcl_FSGetNormalizedPath(NULL,srcPathPtr);
normDestPtr = Tcl_FSGetNormalizedPath(NULL,destPathPtr);
if ((normSrcPtr == NULL) || (normDestPtr == NULL)) {
return TCL_ERROR;
}
Tcl_DStringInit(&srcString);
Tcl_DStringInit(&dstString);
Tcl_UtfToWCharDString(TclGetString(normSrcPtr), -1, &srcString);
Tcl_UtfToWCharDString(TclGetString(normDestPtr), -1, &dstString);
ret = TraverseWinTree(TraversalCopy, &srcString, &dstString, &ds);
Tcl_DStringFree(&srcString);
Tcl_DStringFree(&dstString);
if (ret != TCL_OK) {
|
| ︙ | ︙ | |||
980 981 982 983 984 985 986 |
*/
Tcl_DString native;
normPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
if (normPtr == NULL) {
return TCL_ERROR;
}
| > | | 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 |
*/
Tcl_DString native;
normPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
if (normPtr == NULL) {
return TCL_ERROR;
}
Tcl_DStringInit(&native);
Tcl_UtfToWCharDString(TclGetString(normPtr), -1, &native);
ret = DoRemoveDirectory(&native, recursive, &ds);
Tcl_DStringFree(&native);
} else {
ret = DoRemoveJustDirectory(Tcl_FSGetNativePath(pathPtr), 0, &ds);
}
if (ret != TCL_OK) {
|
| ︙ | ︙ | |||
1026 1027 1028 1029 1030 1031 1032 |
if (nativePath == NULL || nativePath[0] == '\0') {
Tcl_SetErrno(ENOENT);
Tcl_DStringInit(errorPtr);
return TCL_ERROR;
}
| | | | | 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 |
if (nativePath == NULL || nativePath[0] == '\0') {
Tcl_SetErrno(ENOENT);
Tcl_DStringInit(errorPtr);
return TCL_ERROR;
}
attr = GetFileAttributesW(nativePath);
if (attr & FILE_ATTRIBUTE_REPARSE_POINT) {
/*
* It is a symbolic link - remove it.
*/
if (TclWinSymLinkDelete(nativePath, 0) == 0) {
return TCL_OK;
}
} else {
/*
* Ordinary directory.
*/
if (RemoveDirectoryW(nativePath) != FALSE) {
return TCL_OK;
}
}
TclWinConvertError(GetLastError());
if (Tcl_GetErrno() == EACCES) {
attr = GetFileAttributesW(nativePath);
if (attr != 0xffffffff) {
if ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0) {
/*
* Windows 95 reports calling RemoveDirectory on a file as an
* EACCES, not an ENOTDIR.
*/
|
| ︙ | ︙ | |||
1072 1073 1074 1075 1076 1077 1078 |
if (TclWinSymLinkDelete(nativePath, 1) != 0) {
goto end;
}
}
if (attr & FILE_ATTRIBUTE_READONLY) {
attr &= ~FILE_ATTRIBUTE_READONLY;
| | | | | 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 |
if (TclWinSymLinkDelete(nativePath, 1) != 0) {
goto end;
}
}
if (attr & FILE_ATTRIBUTE_READONLY) {
attr &= ~FILE_ATTRIBUTE_READONLY;
if (SetFileAttributesW(nativePath,
attr) == FALSE) {
goto end;
}
if (RemoveDirectoryW(nativePath) != FALSE) {
return TCL_OK;
}
TclWinConvertError(GetLastError());
SetFileAttributesW(nativePath,
attr | FILE_ATTRIBUTE_READONLY);
}
}
}
if (Tcl_GetErrno() == ENOTEMPTY) {
/*
|
| ︙ | ︙ | |||
1105 1106 1107 1108 1109 1110 1111 |
* don't want to initialise the errorPtr yet.
*/
return TCL_ERROR;
}
end:
if (errorPtr != NULL) {
| > > > | | 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 |
* don't want to initialise the errorPtr yet.
*/
return TCL_ERROR;
}
end:
if (errorPtr != NULL) {
char *p;
Tcl_DStringInit(errorPtr);
p = Tcl_WCharToUtfDString(nativePath, -1, errorPtr);
for (; *p; ++p) {
if (*p == '\\') *p = '/';
}
}
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
1179 1180 1181 1182 1183 1184 1185 |
* filled with UTF-8 name of file causing
* error. */
{
DWORD sourceAttr;
WCHAR *nativeSource, *nativeTarget, *nativeErrfile;
int result, found, sourceLen, targetLen = 0, oldSourceLen, oldTargetLen;
HANDLE handle;
| | | | 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 |
* filled with UTF-8 name of file causing
* error. */
{
DWORD sourceAttr;
WCHAR *nativeSource, *nativeTarget, *nativeErrfile;
int result, found, sourceLen, targetLen = 0, oldSourceLen, oldTargetLen;
HANDLE handle;
WIN32_FIND_DATAW data;
nativeErrfile = NULL;
result = TCL_OK;
oldTargetLen = 0; /* lint. */
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) {
/*
|
| ︙ | ︙ | |||
1217 1218 1219 1220 1221 1222 1223 |
return traverseProc(nativeSource, nativeTarget, DOTREE_F, errorPtr);
}
Tcl_DStringAppend(sourcePtr, (char *) L"\\*.*", 4 * sizeof(WCHAR) + 1);
Tcl_DStringSetLength(sourcePtr, Tcl_DStringLength(sourcePtr) - 1);
nativeSource = (WCHAR *) Tcl_DStringValue(sourcePtr);
| | | 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 |
return traverseProc(nativeSource, nativeTarget, DOTREE_F, errorPtr);
}
Tcl_DStringAppend(sourcePtr, (char *) L"\\*.*", 4 * sizeof(WCHAR) + 1);
Tcl_DStringSetLength(sourcePtr, Tcl_DStringLength(sourcePtr) - 1);
nativeSource = (WCHAR *) Tcl_DStringValue(sourcePtr);
handle = FindFirstFileW(nativeSource, &data);
if (handle == INVALID_HANDLE_VALUE) {
/*
* Can't read directory.
*/
TclWinConvertError(GetLastError());
nativeErrfile = nativeSource;
|
| ︙ | ︙ | |||
1250 1251 1252 1253 1254 1255 1256 |
targetLen = oldTargetLen;
targetLen += sizeof(WCHAR);
Tcl_DStringAppend(targetPtr, (char *) L"\\", sizeof(WCHAR) + 1);
Tcl_DStringSetLength(targetPtr, targetLen);
}
found = 1;
| | | 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 |
targetLen = oldTargetLen;
targetLen += sizeof(WCHAR);
Tcl_DStringAppend(targetPtr, (char *) L"\\", sizeof(WCHAR) + 1);
Tcl_DStringSetLength(targetPtr, targetLen);
}
found = 1;
for (; found; found = FindNextFileW(handle, &data)) {
WCHAR *nativeName;
int len;
WCHAR *wp = data.cFileName;
if (*wp == '.') {
wp++;
if (*wp == '.') {
|
| ︙ | ︙ | |||
1319 1320 1321 1322 1323 1324 1325 |
DOTREE_POSTD, errorPtr);
}
end:
if (nativeErrfile != NULL) {
TclWinConvertError(GetLastError());
if (errorPtr != NULL) {
| > | | 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 |
DOTREE_POSTD, errorPtr);
}
end:
if (nativeErrfile != NULL) {
TclWinConvertError(GetLastError());
if (errorPtr != NULL) {
Tcl_DStringInit(errorPtr);
Tcl_WCharToUtfDString(nativeErrfile, -1, errorPtr);
}
result = TCL_ERROR;
}
return result;
}
|
| ︙ | ︙ | |||
1365 1366 1367 1368 1369 1370 1371 |
case DOTREE_LINK:
if (TclWinSymLinkCopyDirectory(nativeSrc, nativeDst) == TCL_OK) {
return TCL_OK;
}
break;
case DOTREE_PRED:
if (DoCreateDirectory(nativeDst) == TCL_OK) {
| | | > | | 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 |
case DOTREE_LINK:
if (TclWinSymLinkCopyDirectory(nativeSrc, nativeDst) == TCL_OK) {
return TCL_OK;
}
break;
case DOTREE_PRED:
if (DoCreateDirectory(nativeDst) == TCL_OK) {
DWORD attr = GetFileAttributesW(nativeSrc);
if (SetFileAttributesW(nativeDst,
attr) != FALSE) {
return TCL_OK;
}
TclWinConvertError(GetLastError());
}
break;
case DOTREE_POSTD:
return TCL_OK;
}
/*
* There shouldn't be a problem with src, because we already checked it to
* get here.
*/
if (errorPtr != NULL) {
Tcl_DStringInit(errorPtr);
Tcl_WCharToUtfDString(nativeDst, -1, errorPtr);
}
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1439 1440 1441 1442 1443 1444 1445 |
if (DoRemoveJustDirectory(nativeSrc, 0, NULL) == TCL_OK) {
return TCL_OK;
}
break;
}
if (errorPtr != NULL) {
| > | | 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 |
if (DoRemoveJustDirectory(nativeSrc, 0, NULL) == TCL_OK) {
return TCL_OK;
}
break;
}
if (errorPtr != NULL) {
Tcl_DStringInit(errorPtr);
Tcl_WCharToUtfDString(nativeSrc, -1, errorPtr);
}
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1503 1504 1505 1506 1507 1508 1509 |
Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */
{
DWORD result;
const WCHAR *nativeName;
int attr;
nativeName = Tcl_FSGetNativePath(fileName);
| | | 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 |
Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */
{
DWORD result;
const WCHAR *nativeName;
int attr;
nativeName = Tcl_FSGetNativePath(fileName);
result = GetFileAttributesW(nativeName);
if (result == 0xffffffff) {
StatError(interp, fileName);
return TCL_ERROR;
}
attr = (int)(result & attributeArray[objIndex]);
|
| ︙ | ︙ | |||
1634 1635 1636 1637 1638 1639 1640 |
pathv[0] = (char) Tcl_UniCharToUpper(UCHAR(pathv[0]));
} else {
Tcl_Obj *tempPath;
Tcl_DString ds;
Tcl_DString dsTemp;
const WCHAR *nativeName;
const char *tempString;
| | > | | | | | 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 |
pathv[0] = (char) Tcl_UniCharToUpper(UCHAR(pathv[0]));
} else {
Tcl_Obj *tempPath;
Tcl_DString ds;
Tcl_DString dsTemp;
const WCHAR *nativeName;
const char *tempString;
WIN32_FIND_DATAW data;
HANDLE handle;
DWORD attr;
tempPath = Tcl_FSJoinPath(splitPath, i+1);
Tcl_IncrRefCount(tempPath);
/*
* We'd like to call Tcl_FSGetNativePath(tempPath) but that is
* likely to lead to infinite loops.
*/
tempString = TclGetStringFromObj(tempPath, &length);
Tcl_DStringInit(&ds);
nativeName = Tcl_UtfToWCharDString(tempString, length, &ds);
Tcl_DecrRefCount(tempPath);
handle = FindFirstFileW(nativeName, &data);
if (handle == INVALID_HANDLE_VALUE) {
/*
* FindFirstFileW() doesn't like root directories. We would
* only get a root directory here if the caller specified "c:"
* or "c:." and the current directory on the drive was the
* root directory
*/
attr = GetFileAttributesW(nativeName);
if ((attr!=0xFFFFFFFF) && (attr & FILE_ATTRIBUTE_DIRECTORY)) {
Tcl_DStringFree(&ds);
goto simple;
}
}
if (handle == INVALID_HANDLE_VALUE) {
|
| ︙ | ︙ | |||
1684 1685 1686 1687 1688 1689 1690 |
} else {
if (data.cAlternateFileName[0] == '\0') {
nativeName = (WCHAR *) data.cFileName;
}
}
/*
| | | | 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 |
} else {
if (data.cAlternateFileName[0] == '\0') {
nativeName = (WCHAR *) data.cFileName;
}
}
/*
* Purify reports a extraneous UMR in Tcl_WCharToUtfDString() trying
* to dereference nativeName as a Unicode string. I have proven to
* myself that purify is wrong by running the following example
* when nativeName == data.w.cAlternateFileName and noting that
* purify doesn't complain about the first line, but does complain
* about the second.
*
* fprintf(stderr, "%d\n", data.w.cAlternateFileName[0]);
* fprintf(stderr, "%d\n", ((WCHAR *) nativeName)[0]);
*/
Tcl_DStringInit(&dsTemp);
Tcl_WCharToUtfDString(nativeName, -1, &dsTemp);
Tcl_DStringFree(&ds);
/*
* Deal with issues of tildes being absolute.
*/
if (Tcl_DStringValue(&dsTemp)[0] == '~') {
|
| ︙ | ︙ | |||
1828 1829 1830 1831 1832 1833 1834 |
Tcl_Obj *attributePtr) /* The new value of the attribute. */
{
DWORD fileAttributes, old;
int yesNo, result;
const WCHAR *nativeName;
nativeName = Tcl_FSGetNativePath(fileName);
| | | | 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 |
Tcl_Obj *attributePtr) /* The new value of the attribute. */
{
DWORD fileAttributes, old;
int yesNo, result;
const WCHAR *nativeName;
nativeName = Tcl_FSGetNativePath(fileName);
fileAttributes = old = GetFileAttributesW(nativeName);
if (fileAttributes == 0xffffffff) {
StatError(interp, fileName);
return TCL_ERROR;
}
result = Tcl_GetBooleanFromObj(interp, attributePtr, &yesNo);
if (result != TCL_OK) {
return result;
}
if (yesNo) {
fileAttributes |= (attributeArray[objIndex]);
} else {
fileAttributes &= ~(attributeArray[objIndex]);
}
if ((fileAttributes != old)
&& !SetFileAttributesW(nativeName, fileAttributes)) {
StatError(interp, fileName);
return TCL_ERROR;
}
return result;
}
|
| ︙ | ︙ | |||
1920 1921 1922 1923 1924 1925 1926 |
* On Win32s:
* GetLogicalDriveStrings() isn't implemented.
* GetLogicalDrives() returns incorrect information.
*/
if (GetLogicalDriveStringsA(sizeof(buf), buf) == 0) {
/*
| | | | 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 |
* On Win32s:
* GetLogicalDriveStrings() isn't implemented.
* GetLogicalDrives() returns incorrect information.
*/
if (GetLogicalDriveStringsA(sizeof(buf), buf) == 0) {
/*
* GetVolumeInformationW() will detects all drives, but causes
* chattering on empty floppy drives. We only do this if
* GetLogicalDriveStrings() didn't work. It has also been reported
* that on some laptops it takes a while for GetVolumeInformationW() to
* return when pinging an empty floppy drive, another reason to try to
* avoid calling it.
*/
buf[1] = ':';
buf[2] = '/';
buf[3] = '\0';
|
| ︙ | ︙ | |||
1991 1992 1993 1994 1995 1996 1997 |
*/
if (dirObj) {
Tcl_GetString(dirObj);
if (dirObj->length < 1) {
goto useSystemTemp;
}
| > | | | < < | | | 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 |
*/
if (dirObj) {
Tcl_GetString(dirObj);
if (dirObj->length < 1) {
goto useSystemTemp;
}
Tcl_DStringInit(&base);
Tcl_UtfToWCharDString(Tcl_GetString(dirObj), -1, &base);
if (dirObj->bytes[dirObj->length - 1] != '\\') {
Tcl_UtfToWCharDString("\\", -1, &base);
}
} else {
useSystemTemp:
Tcl_DStringInit(&base);
Tcl_DStringAppend(&base, (char *) tempBuf, len * sizeof(WCHAR));
}
/*
* Next, the base of the directory name.
*/
#define DEFAULT_TEMP_DIR_PREFIX "tcl"
#define SUFFIX_LENGTH 8
if (basenameObj) {
Tcl_UtfToWCharDString(Tcl_GetString(basenameObj), -1, &base);
} else {
Tcl_UtfToWCharDString(DEFAULT_TEMP_DIR_PREFIX, -1, &base);
}
Tcl_UtfToWCharDString("_", -1, &base);
/*
* Now we keep on trying random suffixes until we get one that works
* (i.e., that doesn't trigger the ERROR_ALREADY_EXISTS error). Note that
* SUFFIX_LENGTH is longer than on Unix because we expect to be not on a
* case-sensitive filesystem.
*/
|
| ︙ | ︙ | |||
2042 2043 2044 2045 2046 2047 2048 |
error = ERROR_SUCCESS;
tempbuf[SUFFIX_LENGTH] = '\0';
for (i = 0 ; i < SUFFIX_LENGTH; i++) {
tempbuf[i] = randChars[(int) (rand() % numRandChars)];
}
Tcl_DStringSetLength(&base, baseLen);
| | > | | 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 |
error = ERROR_SUCCESS;
tempbuf[SUFFIX_LENGTH] = '\0';
for (i = 0 ; i < SUFFIX_LENGTH; i++) {
tempbuf[i] = randChars[(int) (rand() % numRandChars)];
}
Tcl_DStringSetLength(&base, baseLen);
Tcl_UtfToWCharDString(tempbuf, -1, &base);
} while (!CreateDirectoryW((LPCWSTR) Tcl_DStringValue(&base), NULL)
&& (error = GetLastError()) == ERROR_ALREADY_EXISTS);
/*
* Check for other errors. The big ones are ERROR_PATH_NOT_FOUND and
* ERROR_ACCESS_DENIED.
*/
if (error != ERROR_SUCCESS) {
TclWinConvertError(error);
Tcl_DStringFree(&base);
return NULL;
}
/*
* We actually made the directory, so we're done! Report what we made back
* as a (clean) Tcl_Obj.
*/
Tcl_DStringInit(&name);
Tcl_WCharToUtfDString((LPCWSTR) Tcl_DStringValue(&base), -1, &name);
Tcl_DStringFree(&base);
return TclDStringToObj(&name);
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to win/tclWinFile.c.
| ︙ | ︙ | |||
199 200 201 202 203 204 205 |
WCHAR *tempFilePart;
DWORD attr;
/*
* Get the full path referenced by the target.
*/
| | | | | | | 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 |
WCHAR *tempFilePart;
DWORD attr;
/*
* Get the full path referenced by the target.
*/
if (!GetFullPathNameW(linkTargetPath, MAX_PATH, tempFileName,
&tempFilePart)) {
/*
* Invalid file.
*/
TclWinConvertError(GetLastError());
return -1;
}
/*
* Make sure source file doesn't exist.
*/
attr = GetFileAttributesW(linkSourcePath);
if (attr != INVALID_FILE_ATTRIBUTES) {
Tcl_SetErrno(EEXIST);
return -1;
}
/*
* Get the full path referenced by the source file/directory.
*/
if (!GetFullPathNameW(linkSourcePath, MAX_PATH, tempFileName,
&tempFilePart)) {
/*
* Invalid file.
*/
TclWinConvertError(GetLastError());
return -1;
}
/*
* Check the target.
*/
attr = GetFileAttributesW(linkTargetPath);
if (attr == INVALID_FILE_ATTRIBUTES) {
/*
* The target doesn't exist.
*/
TclWinConvertError(GetLastError());
} else if ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0) {
/*
* It is a file.
*/
if (linkAction & TCL_CREATE_HARD_LINK) {
if (CreateHardLinkW(linkSourcePath, linkTargetPath, NULL)) {
/*
* Success!
*/
return 0;
}
|
| ︙ | ︙ | |||
312 313 314 315 316 317 318 |
WCHAR *tempFilePart;
DWORD attr;
/*
* Get the full path referenced by the target.
*/
| | | | 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 |
WCHAR *tempFilePart;
DWORD attr;
/*
* Get the full path referenced by the target.
*/
if (!GetFullPathNameW(linkSourcePath, MAX_PATH, tempFileName,
&tempFilePart)) {
/*
* Invalid file.
*/
TclWinConvertError(GetLastError());
return NULL;
}
/*
* Make sure source file does exist.
*/
attr = GetFileAttributesW(linkSourcePath);
if (attr == INVALID_FILE_ATTRIBUTES) {
/*
* The source doesn't exist.
*/
TclWinConvertError(GetLastError());
return NULL;
|
| ︙ | ︙ | |||
483 484 485 486 487 488 489 |
DUMMY_REPARSE_BUFFER dummy;
REPARSE_DATA_BUFFER *reparseBuffer = (REPARSE_DATA_BUFFER *) &dummy;
HANDLE hFile;
DWORD returnedLength;
memset(reparseBuffer, 0, sizeof(DUMMY_REPARSE_BUFFER));
reparseBuffer->ReparseTag = IO_REPARSE_TAG_MOUNT_POINT;
| | | | 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 |
DUMMY_REPARSE_BUFFER dummy;
REPARSE_DATA_BUFFER *reparseBuffer = (REPARSE_DATA_BUFFER *) &dummy;
HANDLE hFile;
DWORD returnedLength;
memset(reparseBuffer, 0, sizeof(DUMMY_REPARSE_BUFFER));
reparseBuffer->ReparseTag = IO_REPARSE_TAG_MOUNT_POINT;
hFile = CreateFileW(linkOrigPath, GENERIC_WRITE, 0, NULL, OPEN_EXISTING,
FILE_FLAG_OPEN_REPARSE_POINT | FILE_FLAG_BACKUP_SEMANTICS, NULL);
if (hFile != INVALID_HANDLE_VALUE) {
if (!DeviceIoControl(hFile, FSCTL_DELETE_REPARSE_POINT, reparseBuffer,
REPARSE_MOUNTPOINT_HEADER_SIZE,NULL,0,&returnedLength,NULL)) {
/*
* Error setting junction.
*/
TclWinConvertError(GetLastError());
CloseHandle(hFile);
} else {
CloseHandle(hFile);
if (!linkOnly) {
RemoveDirectoryW(linkOrigPath);
}
return 0;
}
}
return -1;
}
|
| ︙ | ︙ | |||
543 544 545 546 547 548 549 |
int attr, len, offset;
DUMMY_REPARSE_BUFFER dummy;
REPARSE_DATA_BUFFER *reparseBuffer = (REPARSE_DATA_BUFFER *) &dummy;
Tcl_Obj *retVal;
Tcl_DString ds;
const char *copy;
| | | 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 |
int attr, len, offset;
DUMMY_REPARSE_BUFFER dummy;
REPARSE_DATA_BUFFER *reparseBuffer = (REPARSE_DATA_BUFFER *) &dummy;
Tcl_Obj *retVal;
Tcl_DString ds;
const char *copy;
attr = GetFileAttributesW(linkDirPath);
if (!(attr & FILE_ATTRIBUTE_REPARSE_POINT)) {
goto invalidError;
}
if (NativeReadReparse(linkDirPath, reparseBuffer, 0)) {
return NULL;
}
|
| ︙ | ︙ | |||
630 631 632 633 634 635 636 | * Strip off the prefix. */ offset = 4; } } | > | | | 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 | * Strip off the prefix. */ offset = 4; } } Tcl_DStringInit(&ds); Tcl_WCharToUtfDString( reparseBuffer->MountPointReparseBuffer.PathBuffer, reparseBuffer->MountPointReparseBuffer .SubstituteNameLength>>1, &ds); copy = Tcl_DStringValue(&ds)+offset; len = Tcl_DStringLength(&ds)-offset; retVal = Tcl_NewStringObj(copy,len); Tcl_IncrRefCount(retVal); Tcl_DStringFree(&ds); return retVal; |
| ︙ | ︙ | |||
676 677 678 679 680 681 682 |
const WCHAR *linkDirPath, /* The junction to read */
REPARSE_DATA_BUFFER *buffer,/* Pointer to buffer. Cannot be NULL */
DWORD desiredAccess)
{
HANDLE hFile;
DWORD returnedLength;
| | | 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 |
const WCHAR *linkDirPath, /* The junction to read */
REPARSE_DATA_BUFFER *buffer,/* Pointer to buffer. Cannot be NULL */
DWORD desiredAccess)
{
HANDLE hFile;
DWORD returnedLength;
hFile = CreateFileW(linkDirPath, desiredAccess, FILE_SHARE_READ, NULL,
OPEN_EXISTING,
FILE_FLAG_OPEN_REPARSE_POINT | FILE_FLAG_BACKUP_SEMANTICS, NULL);
if (hFile == INVALID_HANDLE_VALUE) {
/*
* Error creating directory.
*/
|
| ︙ | ︙ | |||
736 737 738 739 740 741 742 |
HANDLE hFile;
DWORD returnedLength;
/*
* Create the directory - it must not already exist.
*/
| | | | 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 |
HANDLE hFile;
DWORD returnedLength;
/*
* Create the directory - it must not already exist.
*/
if (CreateDirectoryW(linkDirPath, NULL) == 0) {
/*
* Error creating directory.
*/
TclWinConvertError(GetLastError());
return -1;
}
hFile = CreateFileW(linkDirPath, GENERIC_WRITE, 0, NULL,
OPEN_EXISTING, FILE_FLAG_OPEN_REPARSE_POINT
| FILE_FLAG_BACKUP_SEMANTICS, NULL);
if (hFile == INVALID_HANDLE_VALUE) {
/*
* Error creating directory.
*/
|
| ︙ | ︙ | |||
769 770 771 772 773 774 775 |
NULL, 0, &returnedLength, NULL)) {
/*
* Error setting junction.
*/
TclWinConvertError(GetLastError());
CloseHandle(hFile);
| | | 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 |
NULL, 0, &returnedLength, NULL)) {
/*
* Error setting junction.
*/
TclWinConvertError(GetLastError());
CloseHandle(hFile);
RemoveDirectoryW(linkDirPath);
return -1;
}
CloseHandle(hFile);
/*
* We succeeded.
*/
|
| ︙ | ︙ | |||
915 916 917 918 919 920 921 | DWORD attr; WIN32_FILE_ATTRIBUTE_DATA data; size_t length = 0; const char *str = TclGetStringFromObj(norm, &length); native = Tcl_FSGetNativePath(pathPtr); | | | | 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 |
DWORD attr;
WIN32_FILE_ATTRIBUTE_DATA data;
size_t length = 0;
const char *str = TclGetStringFromObj(norm, &length);
native = Tcl_FSGetNativePath(pathPtr);
if (GetFileAttributesExW(native,
GetFileExInfoStandard, &data) != TRUE) {
return TCL_OK;
}
attr = data.dwFileAttributes;
if (NativeMatchType(WinIsDrive(str, length), attr, native, types)) {
Tcl_ListObjAppendElement(interp, resultPtr, pathPtr);
}
}
return TCL_OK;
} else {
DWORD attr;
HANDLE handle;
WIN32_FIND_DATAW data;
const char *dirName; /* UTF-8 dir name, later with pattern
* appended. */
size_t dirLength;
int matchSpecialDots;
Tcl_DString ds; /* Native encoding of dir, also used
* temporarily for other things. */
Tcl_DString dsOrig; /* UTF-8 encoding of dir. */
|
| ︙ | ︙ | |||
958 959 960 961 962 963 964 |
* Verify that the specified path exists and is actually a directory.
*/
native = Tcl_FSGetNativePath(pathPtr);
if (native == NULL) {
return TCL_OK;
}
| | | 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 |
* Verify that the specified path exists and is actually a directory.
*/
native = Tcl_FSGetNativePath(pathPtr);
if (native == NULL) {
return TCL_OK;
}
attr = GetFileAttributesW(native);
if ((attr == INVALID_FILE_ATTRIBUTES)
|| ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0)) {
return TCL_OK;
}
/*
|
| ︙ | ︙ | |||
999 1000 1001 1002 1003 1004 1005 |
*/
dirName = Tcl_DStringAppend(&dsOrig, pattern, -1);
} else {
dirName = TclDStringAppendLiteral(&dsOrig, "*.*");
}
| > | | | | 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 |
*/
dirName = Tcl_DStringAppend(&dsOrig, pattern, -1);
} else {
dirName = TclDStringAppendLiteral(&dsOrig, "*.*");
}
Tcl_DStringInit(&ds);
native = Tcl_UtfToWCharDString(dirName, -1, &ds);
if ((types == NULL) || (types->type != TCL_GLOB_TYPE_DIR)) {
handle = FindFirstFileW(native, &data);
} else {
/*
* We can be more efficient, for pure directory requests.
*/
handle = FindFirstFileExW(native,
FindExInfoStandard, &data,
FindExSearchLimitToDirectories, NULL, 0);
}
if (handle == INVALID_HANDLE_VALUE) {
DWORD err = GetLastError();
|
| ︙ | ︙ | |||
1072 1073 1074 1075 1076 1077 1078 |
do {
const char *utfname;
int checkDrive = 0, isDrive;
DWORD attr;
native = data.cFileName;
attr = data.dwFileAttributes;
| > | | 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 |
do {
const char *utfname;
int checkDrive = 0, isDrive;
DWORD attr;
native = data.cFileName;
attr = data.dwFileAttributes;
Tcl_DStringInit(&ds);
utfname = Tcl_WCharToUtfDString(native, -1, &ds);
if (!matchSpecialDots) {
/*
* If it is exactly '.' or '..' then we ignore it.
*/
if ((utfname[0] == '.') && (utfname[1] == '\0'
|
| ︙ | ︙ | |||
1132 1133 1134 1135 1136 1137 1138 | } /* * Free ds here to ensure that native is valid above. */ Tcl_DStringFree(&ds); | | | 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 |
}
/*
* Free ds here to ensure that native is valid above.
*/
Tcl_DStringFree(&ds);
} while (FindNextFileW(handle, &data) == TRUE);
FindClose(handle);
Tcl_DStringFree(&dsOrig);
return TCL_OK;
}
}
|
| ︙ | ︙ | |||
1447 1448 1449 1450 1451 1452 1453 |
rc = 1;
result = Tcl_DStringValue(bufferPtr);
}
}
Tcl_DStringFree(&ds);
} else {
Tcl_DStringInit(&ds);
| | | | 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 |
rc = 1;
result = Tcl_DStringValue(bufferPtr);
}
}
Tcl_DStringFree(&ds);
} else {
Tcl_DStringInit(&ds);
wName = Tcl_UtfToWCharDString(domain + 1, -1, &ds);
rc = NetGetDCName(NULL, wName, (LPBYTE *) &wDomain);
Tcl_DStringFree(&ds);
nameLen = domain - name;
}
if (rc == 0) {
Tcl_DStringInit(&ds);
wName = Tcl_UtfToWCharDString(name, nameLen, &ds);
while (NetUserGetInfo(wDomain, wName, 1, (LPBYTE *) &uiPtr) != 0) {
/*
* User does not exist; if domain was not specified, try again
* using current domain.
*/
rc = 1;
|
| ︙ | ︙ | |||
1482 1483 1484 1485 1486 1487 1488 |
}
if (rc == 0) {
DWORD i, size = MAX_PATH;
wHomeDir = uiPtr->usri1_home_dir;
if ((wHomeDir != NULL) && (wHomeDir[0] != '\0')) {
size = lstrlenW(wHomeDir);
| | | | 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 |
}
if (rc == 0) {
DWORD i, size = MAX_PATH;
wHomeDir = uiPtr->usri1_home_dir;
if ((wHomeDir != NULL) && (wHomeDir[0] != '\0')) {
size = lstrlenW(wHomeDir);
Tcl_WCharToUtfDString(wHomeDir, size, bufferPtr);
} else {
/*
* User exists but has no home dir. Return
* "{GetProfilesDirectory}/<user>".
*/
GetProfilesDirectoryW(buf, &size);
Tcl_WCharToUtfDString(buf, size-1, bufferPtr);
Tcl_DStringAppend(bufferPtr, "/", 1);
Tcl_DStringAppend(bufferPtr, name, nameLen);
}
result = Tcl_DStringValue(bufferPtr);
/*
* Be sure we return normalized path
|
| ︙ | ︙ | |||
1566 1567 1568 1569 1570 1571 1572 |
static int
NativeAccess(
const WCHAR *nativePath, /* Path of file to access, native encoding. */
int mode) /* Permission setting. */
{
DWORD attr;
| | | 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 |
static int
NativeAccess(
const WCHAR *nativePath, /* Path of file to access, native encoding. */
int mode) /* Permission setting. */
{
DWORD attr;
attr = GetFileAttributesW(nativePath);
if (attr == INVALID_FILE_ATTRIBUTES) {
/*
* File might not exist.
*/
DWORD lasterror = GetLastError();
|
| ︙ | ︙ | |||
1635 1636 1637 1638 1639 1640 1641 |
if (mode & W_OK) {
mask |= GENERIC_WRITE;
}
if (mode & X_OK) {
mask |= GENERIC_EXECUTE;
}
| | | 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 |
if (mode & W_OK) {
mask |= GENERIC_WRITE;
}
if (mode & X_OK) {
mask |= GENERIC_EXECUTE;
}
hFile = CreateFileW(nativePath, mask,
FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE,
NULL, OPEN_EXISTING, FILE_FLAG_NO_BUFFERING, NULL);
if (hFile != INVALID_HANDLE_VALUE) {
CloseHandle(hFile);
return 0;
}
|
| ︙ | ︙ | |||
1685 1686 1687 1688 1689 1690 1691 | int error; /* * First find out how big the buffer needs to be. */ size = 0; | | | 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 | int error; /* * First find out how big the buffer needs to be. */ size = 0; GetFileSecurityW(nativePath, OWNER_SECURITY_INFORMATION | GROUP_SECURITY_INFORMATION | DACL_SECURITY_INFORMATION | LABEL_SECURITY_INFORMATION, 0, 0, &size); /* * Should have failed with ERROR_INSUFFICIENT_BUFFER */ |
| ︙ | ︙ | |||
1716 1717 1718 1719 1720 1721 1722 |
sdPtr = (SECURITY_DESCRIPTOR *) HeapAlloc(GetProcessHeap(), 0, size);
if (sdPtr == NULL) {
goto accessError;
}
/*
| | | | 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 |
sdPtr = (SECURITY_DESCRIPTOR *) HeapAlloc(GetProcessHeap(), 0, size);
if (sdPtr == NULL) {
goto accessError;
}
/*
* Call GetFileSecurityW() for real.
*/
if (!GetFileSecurityW(nativePath,
OWNER_SECURITY_INFORMATION | GROUP_SECURITY_INFORMATION
| DACL_SECURITY_INFORMATION | LABEL_SECURITY_INFORMATION,
sdPtr, size, &size)) {
/*
* Error getting owner SD
*/
|
| ︙ | ︙ | |||
1860 1861 1862 1863 1864 1865 1866 |
}
if (path[len-4] != '.') {
return 0;
}
path += len-3;
| | | | | | | 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 |
}
if (path[len-4] != '.') {
return 0;
}
path += len-3;
if ((_wcsicmp(path, L"exe") == 0)
|| (_wcsicmp(path, L"com") == 0)
|| (_wcsicmp(path, L"cmd") == 0)
|| (_wcsicmp(path, L"cmd") == 0)
|| (_wcsicmp(path, L"bat") == 0)) {
return 1;
}
return 0;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
1898 1899 1900 1901 1902 1903 1904 |
const WCHAR *nativePath;
nativePath = Tcl_FSGetNativePath(pathPtr);
if (!nativePath) {
return -1;
}
| | | 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 |
const WCHAR *nativePath;
nativePath = Tcl_FSGetNativePath(pathPtr);
if (!nativePath) {
return -1;
}
result = SetCurrentDirectoryW(nativePath);
if (result == 0) {
TclWinConvertError(GetLastError());
return -1;
}
return 0;
}
|
| ︙ | ︙ | |||
1939 1940 1941 1942 1943 1944 1945 |
Tcl_DString *bufferPtr) /* Uninitialized or free DString filled with
* name of current directory. */
{
WCHAR buffer[MAX_PATH];
char *p;
WCHAR *native;
| | > | | 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 |
Tcl_DString *bufferPtr) /* Uninitialized or free DString filled with
* name of current directory. */
{
WCHAR buffer[MAX_PATH];
char *p;
WCHAR *native;
if (GetCurrentDirectoryW(MAX_PATH, buffer) == 0) {
TclWinConvertError(GetLastError());
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"error getting working directory name: %s",
Tcl_PosixError(interp)));
}
return NULL;
}
/*
* Watch for the weird Windows c:\\UNC syntax.
*/
native = (WCHAR *) buffer;
if ((native[0] != '\0') && (native[1] == ':')
&& (native[2] == '\\') && (native[3] == '\\')) {
native += 2;
}
Tcl_DStringInit(bufferPtr);
Tcl_WCharToUtfDString(native, -1, bufferPtr);
/*
* Convert to forward slashes for easier use in scripts.
*/
for (p = Tcl_DStringValue(bufferPtr); *p != '\0'; p++) {
if (*p == '\\') {
|
| ︙ | ︙ | |||
2039 2040 2041 2042 2043 2044 2045 |
* CON, NULL, COM1, LPT1 etc. For these, we still need to do the
* CreateFile as some may not exist (e.g. there is no CON in wish by
* default). However the subsequent GetFileInformationByHandle will
* fail. We do a WinIsReserved to see if it is one of the special names,
* and if successful, mock up a BY_HANDLE_FILE_INFORMATION structure.
*/
| | | 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 |
* CON, NULL, COM1, LPT1 etc. For these, we still need to do the
* CreateFile as some may not exist (e.g. there is no CON in wish by
* default). However the subsequent GetFileInformationByHandle will
* fail. We do a WinIsReserved to see if it is one of the special names,
* and if successful, mock up a BY_HANDLE_FILE_INFORMATION structure.
*/
fileHandle = CreateFileW(nativePath, GENERIC_READ,
FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE,
NULL, OPEN_EXISTING,
FILE_FLAG_BACKUP_SEMANTICS | FILE_FLAG_OPEN_REPARSE_POINT, NULL);
if (fileHandle != INVALID_HANDLE_VALUE) {
BY_HANDLE_FILE_INFORMATION data;
|
| ︙ | ︙ | |||
2097 2098 2099 2100 2101 2102 2103 |
} else {
/*
* Fall back on the less capable routines. This means no nlink or ino.
*/
WIN32_FILE_ATTRIBUTE_DATA data;
| | | | | 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 |
} else {
/*
* Fall back on the less capable routines. This means no nlink or ino.
*/
WIN32_FILE_ATTRIBUTE_DATA data;
if (GetFileAttributesExW(nativePath,
GetFileExInfoStandard, &data) != TRUE) {
HANDLE hFind;
WIN32_FIND_DATAW ffd;
DWORD lasterror = GetLastError();
if (lasterror != ERROR_SHARING_VIOLATION) {
TclWinConvertError(lasterror);
return -1;
}
hFind = FindFirstFileW(nativePath, &ffd);
if (hFind == INVALID_HANDLE_VALUE) {
TclWinConvertError(GetLastError());
return -1;
}
memcpy(&data, &ffd, sizeof(data));
FindClose(hFind);
}
|
| ︙ | ︙ | |||
2165 2166 2167 2168 2169 2170 2171 |
{
int dev;
Tcl_DString ds;
WCHAR nativeFullPath[MAX_PATH];
WCHAR *nativePart;
const char *fullPath;
| | > | > | | | | | 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 |
{
int dev;
Tcl_DString ds;
WCHAR nativeFullPath[MAX_PATH];
WCHAR *nativePart;
const char *fullPath;
GetFullPathNameW(nativePath, MAX_PATH, nativeFullPath, &nativePart);
Tcl_DStringInit(&ds);
fullPath = Tcl_WCharToUtfDString(nativeFullPath, -1, &ds);
if ((fullPath[0] == '\\') && (fullPath[1] == '\\')) {
const char *p;
DWORD dw;
const WCHAR *nativeVol;
Tcl_DString volString;
p = strchr(fullPath + 2, '\\');
p = strchr(p + 1, '\\');
if (p == NULL) {
/*
* Add terminating backslash to fullpath or GetVolumeInformation()
* won't work.
*/
fullPath = TclDStringAppendLiteral(&ds, "\\");
p = fullPath + Tcl_DStringLength(&ds);
} else {
p++;
}
Tcl_DStringInit(&volString);
nativeVol = Tcl_UtfToWCharDString(fullPath, p - fullPath, &volString);
dw = (DWORD) -1;
GetVolumeInformationW(nativeVol, NULL, 0, &dw, NULL, NULL, NULL, 0);
/*
* GetFullPathNameW() turns special devices like "NUL" into "\\.\NUL",
* but GetVolumeInformationW() returns failure for "\\.\NUL". This will
* cause "NUL" to get a drive number of -1, which makes about as much
* sense as anything since the special devices don't live on any
* drive.
*/
dev = dw;
Tcl_DStringFree(&volString);
|
| ︙ | ︙ | |||
2335 2336 2337 2338 2339 2340 2341 |
ClientData
TclpGetNativeCwd(
ClientData clientData)
{
WCHAR buffer[MAX_PATH];
| | | 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 |
ClientData
TclpGetNativeCwd(
ClientData clientData)
{
WCHAR buffer[MAX_PATH];
if (GetCurrentDirectoryW(MAX_PATH, buffer) == 0) {
TclWinConvertError(GetLastError());
return NULL;
}
if (clientData != NULL) {
if (wcscmp((const WCHAR *) clientData, buffer) == 0) {
return clientData;
|
| ︙ | ︙ | |||
2451 2452 2453 2454 2455 2456 2457 |
path = TclGetString(normPath);
if (path == NULL) {
return NULL;
}
firstSeparator = strchr(path, '/');
if (firstSeparator == NULL) {
| | | > | | 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 |
path = TclGetString(normPath);
if (path == NULL) {
return NULL;
}
firstSeparator = strchr(path, '/');
if (firstSeparator == NULL) {
found = GetVolumeInformationW(Tcl_FSGetNativePath(pathPtr),
NULL, 0, NULL, NULL, NULL, volType, VOL_BUF_SIZE);
} else {
Tcl_Obj *driveName = Tcl_NewStringObj(path, firstSeparator - path+1);
Tcl_IncrRefCount(driveName);
found = GetVolumeInformationW(Tcl_FSGetNativePath(driveName),
NULL, 0, NULL, NULL, NULL, volType, VOL_BUF_SIZE);
Tcl_DecrRefCount(driveName);
}
if (found == 0) {
return NULL;
} else {
Tcl_DString ds;
Tcl_DStringInit(&ds);
Tcl_WCharToUtfDString(volType, -1, &ds);
return TclDStringToObj(&ds);
}
#undef VOL_BUF_SIZE
}
/*
* This define can be turned on to experiment with a different way of
|
| ︙ | ︙ | |||
2537 2538 2539 2540 2541 2542 2543 |
if ((cur=='/' || cur==0) && (path != currentPathEndPosition)) {
/*
* Reached directory separator, or end of string.
*/
WIN32_FILE_ATTRIBUTE_DATA data;
| | > > > | | 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 |
if ((cur=='/' || cur==0) && (path != currentPathEndPosition)) {
/*
* Reached directory separator, or end of string.
*/
WIN32_FILE_ATTRIBUTE_DATA data;
const WCHAR *nativePath;
Tcl_DStringInit(&ds);
nativePath = Tcl_UtfToWCharDString(path,
currentPathEndPosition - path, &ds);
if (GetFileAttributesExW(nativePath,
GetFileExInfoStandard, &data) != TRUE) {
/*
* File doesn't exist.
*/
if (isDrive) {
int len = WinIsReserved(path);
|
| ︙ | ︙ | |||
2739 2740 2741 2742 2743 2744 2745 |
#ifdef TclNORM_LONG_PATH
/*
* Convert the entire known path to long form.
*/
if (1) {
WCHAR wpath[MAX_PATH];
| | > > > > | | < | 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 |
#ifdef TclNORM_LONG_PATH
/*
* Convert the entire known path to long form.
*/
if (1) {
WCHAR wpath[MAX_PATH];
const WCHAR *nativePath;
DWORD wpathlen;
Tcl_DStringInit(&ds);
nativePath =
Tcl_UtfToWCharDString(path, lastValidPathEnd - path, &ds);
wpathlen = GetLongPathNameProc(nativePath,
(WCHAR *) wpath, MAX_PATH);
/*
* We have to make the drive letter uppercase.
*/
if (wpath[0] >= 'a') {
wpath[0] -= ('a' - 'A');
}
|
| ︙ | ︙ | |||
2770 2771 2772 2773 2774 2775 2776 |
if (lastValidPathEnd != NULL) {
/*
* Concatenate the normalized string in dsNorm with the tail of the
* path which we didn't recognise. The string in dsNorm is in the
* native encoding, so we have to convert it to Utf.
*/
| > | | | 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 |
if (lastValidPathEnd != NULL) {
/*
* Concatenate the normalized string in dsNorm with the tail of the
* path which we didn't recognise. The string in dsNorm is in the
* native encoding, so we have to convert it to Utf.
*/
Tcl_DStringInit(&ds);
Tcl_WCharToUtfDString((const WCHAR *) Tcl_DStringValue(&dsNorm),
Tcl_DStringLength(&dsNorm)>>1, &ds);
nextCheckpoint = Tcl_DStringLength(&ds);
if (*lastValidPathEnd != 0) {
/*
* Not the end of the string.
*/
char *path;
|
| ︙ | ︙ | |||
2946 2947 2948 2949 2950 2951 2952 |
ClientData clientData)
{
Tcl_DString ds;
Tcl_Obj *objPtr;
size_t len;
char *copy, *p;
| > | | 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 |
ClientData clientData)
{
Tcl_DString ds;
Tcl_Obj *objPtr;
size_t len;
char *copy, *p;
Tcl_DStringInit(&ds);
Tcl_WCharToUtfDString((const WCHAR *) clientData, -1, &ds);
copy = Tcl_DStringValue(&ds);
len = Tcl_DStringLength(&ds);
/*
* Certain native path representations on Windows have this special prefix
* to indicate that they are to be treated specially. For example
* extremely long paths, or symlinks.
|
| ︙ | ︙ | |||
3210 3211 3212 3213 3214 3215 3216 |
FILETIME lastAccessTime, lastModTime;
FromCTime(tval->actime, &lastAccessTime);
FromCTime(tval->modtime, &lastModTime);
native = Tcl_FSGetNativePath(pathPtr);
| | | | 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 |
FILETIME lastAccessTime, lastModTime;
FromCTime(tval->actime, &lastAccessTime);
FromCTime(tval->modtime, &lastModTime);
native = Tcl_FSGetNativePath(pathPtr);
attr = GetFileAttributesW(native);
if (attr != INVALID_FILE_ATTRIBUTES && attr & FILE_ATTRIBUTE_DIRECTORY) {
flags = FILE_FLAG_BACKUP_SEMANTICS;
}
/*
* We use the native APIs (not 'utime') because there are some daylight
* savings complications that utime gets wrong.
*/
fileHandle = CreateFileW(native, FILE_WRITE_ATTRIBUTES, 0, NULL,
OPEN_EXISTING, flags, NULL);
if (fileHandle == INVALID_HANDLE_VALUE ||
!SetFileTime(fileHandle, NULL, &lastAccessTime, &lastModTime)) {
TclWinConvertError(GetLastError());
res = -1;
}
|
| ︙ | ︙ | |||
3261 3262 3263 3264 3265 3266 3267 |
HANDLE token;
LPBYTE buf = NULL;
DWORD bufsz;
int owned = 0;
native = Tcl_FSGetNativePath(pathPtr);
| | | 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 |
HANDLE token;
LPBYTE buf = NULL;
DWORD bufsz;
int owned = 0;
native = Tcl_FSGetNativePath(pathPtr);
if (GetNamedSecurityInfoW((LPWSTR) native, SE_FILE_OBJECT,
OWNER_SECURITY_INFORMATION, &ownerSid, NULL, NULL, NULL,
&secd) != ERROR_SUCCESS) {
/*
* Either not a file, or we do not have access to it in which case we
* are in all likelihood not the owner.
*/
|
| ︙ | ︙ |
Changes to win/tclWinInit.c.
| ︙ | ︙ | |||
13 14 15 16 17 18 19 | #include "tclWinInt.h" #include <winnt.h> #include <winbase.h> #include <lmcons.h> /* | | | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 | #include "tclWinInt.h" #include <winnt.h> #include <winbase.h> #include <lmcons.h> /* * GetUserNameW() is found in advapi32.dll */ #ifdef _MSC_VER # pragma comment(lib, "advapi32.lib") #endif /* * The following declaration is a workaround for some Microsoft brain damage. |
| ︙ | ︙ | |||
109 110 111 112 113 114 115 | static void AppendEnvironment(Tcl_Obj *listPtr, const char *lib); /* *--------------------------------------------------------------------------- * * TclpInitPlatform -- * | | | 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 | static void AppendEnvironment(Tcl_Obj *listPtr, const char *lib); /* *--------------------------------------------------------------------------- * * TclpInitPlatform -- * * Initialize all the platform-dependent things like signals, * floating-point error handling and sockets. * * Called at process initialization time. * * Results: * None. * |
| ︙ | ︙ | |||
145 146 147 148 149 150 151 |
#ifdef STATIC_BUILD
/*
* If we are in a statically linked executable, then we need to explicitly
* initialize the Windows function tables here since DllMain() will not be
* invoked.
*/
| | | | 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 |
#ifdef STATIC_BUILD
/*
* If we are in a statically linked executable, then we need to explicitly
* initialize the Windows function tables here since DllMain() will not be
* invoked.
*/
TclWinInit(GetModuleHandleW(NULL));
#endif
/*
* Fill available functions depending on windows version
*/
handle = GetModuleHandleW(L"KERNEL32");
tclWinProcs.cancelSynchronousIo =
(BOOL (WINAPI *)(HANDLE)) GetProcAddress(handle,
"CancelSynchronousIo");
}
/*
*-------------------------------------------------------------------------
|
| ︙ | ︙ | |||
293 294 295 296 297 298 299 | objPtr = Tcl_NewStringObj(buf, -1); Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); TclWinNoBackslash(buf); Tcl_SplitPath(buf, &pathc, &pathv); /* | | | 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 |
objPtr = Tcl_NewStringObj(buf, -1);
Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
TclWinNoBackslash(buf);
Tcl_SplitPath(buf, &pathc, &pathv);
/*
* The lstrcmpiA() will work even if pathv[pathc-1] is random UTF-8
* chars because I know shortlib is ascii.
*/
if ((pathc > 0) && (lstrcmpiA(shortlib, pathv[pathc - 1]) != 0)) {
/*
* TCL_LIBRARY is set but refers to a different tcl installation
* than the current version. Try fiddling with the specified
|
| ︙ | ︙ | |||
468 469 470 471 472 473 474 |
{
Tcl_DStringInit(bufferPtr);
if (TclGetEnv("USERNAME", bufferPtr) == NULL) {
WCHAR szUserName[UNLEN+1];
DWORD cchUserNameLen = UNLEN;
| | | | | 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 |
{
Tcl_DStringInit(bufferPtr);
if (TclGetEnv("USERNAME", bufferPtr) == NULL) {
WCHAR szUserName[UNLEN+1];
DWORD cchUserNameLen = UNLEN;
if (!GetUserNameW(szUserName, &cchUserNameLen)) {
return NULL;
}
cchUserNameLen--;
Tcl_DStringInit(bufferPtr);
Tcl_WCharToUtfDString(szUserName, cchUserNameLen, bufferPtr);
}
return Tcl_DStringValue(bufferPtr);
}
/*
*---------------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
513 514 515 516 517 518 519 |
static int osInfoInitialized = 0;
Tcl_DString ds;
Tcl_SetVar2Ex(interp, "tclDefaultLibrary", NULL,
TclGetProcessGlobalValue(&defaultLibraryDir), TCL_GLOBAL_ONLY);
if (!osInfoInitialized) {
| | | 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 |
static int osInfoInitialized = 0;
Tcl_DString ds;
Tcl_SetVar2Ex(interp, "tclDefaultLibrary", NULL,
TclGetProcessGlobalValue(&defaultLibraryDir), TCL_GLOBAL_ONLY);
if (!osInfoInitialized) {
HMODULE handle = GetModuleHandleW(L"NTDLL");
int(__stdcall *getversion)(void *) =
(int(__stdcall *)(void *)) GetProcAddress(handle, "RtlGetVersion");
osInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFOW);
if (!getversion || getversion(&osInfo)) {
GetVersionExW(&osInfo);
}
osInfoInitialized = 1;
|
| ︙ | ︙ | |||
539 540 541 542 543 544 545 |
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);
}
| | | 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 |
Tcl_SetVar2(interp, "tcl_platform", "osVersion", buffer, TCL_GLOBAL_ONLY);
if (sys.oemId.wProcessorArchitecture < NUMPROCESSORS) {
Tcl_SetVar2(interp, "tcl_platform", "machine",
processors[sys.oemId.wProcessorArchitecture],
TCL_GLOBAL_ONLY);
}
#ifndef NDEBUG
/*
* The existence of the "debug" element of the tcl_platform array
* indicates that this particular Tcl shell has been compiled with debug
* information. Using "info exists tcl_platform(debug)" a Tcl script can
* direct the interpreter to load debug versions of DLLs with the load
* command.
*/
|
| ︙ | ︙ |
Changes to win/tclWinLoad.c.
| ︙ | ︙ | |||
72 73 74 75 76 77 78 |
* First try the full path the user gave us. This is particularly
* important if the cwd is inside a vfs, and we are trying to load using a
* relative path.
*/
nativeName = Tcl_FSGetNativePath(pathPtr);
if (nativeName != NULL) {
| | > | | | 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 |
* First try the full path the user gave us. This is particularly
* important if the cwd is inside a vfs, and we are trying to load using a
* relative path.
*/
nativeName = Tcl_FSGetNativePath(pathPtr);
if (nativeName != NULL) {
hInstance = LoadLibraryExW(nativeName, NULL,
LOAD_WITH_ALTERED_SEARCH_PATH);
}
if (hInstance == NULL) {
/*
* Let the OS loader examine the binary search path for whatever
* string the user gave us which hopefully refers to a file on the
* binary path.
*/
Tcl_DString ds;
/*
* Remember the first error on load attempt to be used if the
* second load attempt below also fails.
*/
firstError = (nativeName == NULL) ?
ERROR_MOD_NOT_FOUND : GetLastError();
Tcl_DStringInit(&ds);
nativeName = Tcl_UtfToWCharDString(TclGetString(pathPtr), -1, &ds);
hInstance = LoadLibraryExW(nativeName, NULL,
LOAD_WITH_ALTERED_SEARCH_PATH);
Tcl_DStringFree(&ds);
}
if (hInstance == NULL) {
DWORD lastError;
Tcl_Obj *errMsg;
|
| ︙ | ︙ |
Changes to win/tclWinNotify.c.
| ︙ | ︙ | |||
94 95 96 97 98 99 100 |
/*
* Register Notifier window class if this is the first thread to use
* this module.
*/
EnterCriticalSection(¬ifierMutex);
if (notifierCount == 0) {
| | | | | 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 |
/*
* Register Notifier window class if this is the first thread to use
* this module.
*/
EnterCriticalSection(¬ifierMutex);
if (notifierCount == 0) {
WNDCLASSW clazz;
clazz.style = 0;
clazz.cbClsExtra = 0;
clazz.cbWndExtra = 0;
clazz.hInstance = TclWinGetTclInstance();
clazz.hbrBackground = NULL;
clazz.lpszMenuName = NULL;
clazz.lpszClassName = className;
clazz.lpfnWndProc = NotifierProc;
clazz.hIcon = NULL;
clazz.hCursor = NULL;
if (!RegisterClassW(&clazz)) {
Tcl_Panic("Unable to register TclNotifier window class");
}
}
notifierCount++;
LeaveCriticalSection(¬ifierMutex);
tsdPtr->pending = 0;
tsdPtr->timerActive = 0;
InitializeCriticalSection(&tsdPtr->crit);
tsdPtr->hwnd = NULL;
tsdPtr->thread = GetCurrentThreadId();
tsdPtr->event = CreateEventW(NULL, TRUE /* manual */,
FALSE /* !signaled */, NULL);
return tsdPtr;
}
}
/*
|
| ︙ | ︙ | |||
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, TclWinGetTclInstance());
}
}
LeaveCriticalSection(¬ifierMutex);
}
}
/*
|
| ︙ | ︙ | |||
243 244 245 246 247 248 249 |
if (tsdPtr->hwnd) {
/*
* We do need to lock around access to the pending flag.
*/
EnterCriticalSection(&tsdPtr->crit);
if (!tsdPtr->pending) {
| | | 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 |
if (tsdPtr->hwnd) {
/*
* We do need to lock around access to the pending flag.
*/
EnterCriticalSection(&tsdPtr->crit);
if (!tsdPtr->pending) {
PostMessageW(tsdPtr->hwnd, WM_WAKEUP, 0, 0);
}
tsdPtr->pending = 1;
LeaveCriticalSection(&tsdPtr->crit);
} else {
SetEvent(tsdPtr->event);
}
}
|
| ︙ | ︙ | |||
355 356 357 358 359 360 361 |
* or Windows will hang waiting for the window to respond to
* synchronous system messages. At some point, we may want to consider
* destroying the window if we leave the modal loop, but for now we'll
* leave it around.
*/
if (mode == TCL_SERVICE_ALL && !tsdPtr->hwnd) {
| | | 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 |
* or Windows will hang waiting for the window to respond to
* synchronous system messages. At some point, we may want to consider
* destroying the window if we leave the modal loop, but for now we'll
* leave it around.
*/
if (mode == TCL_SERVICE_ALL && !tsdPtr->hwnd) {
tsdPtr->hwnd = CreateWindowW(className, className,
WS_TILED, 0, 0, 0, 0, NULL, NULL, TclWinGetTclInstance(),
NULL);
/*
* Send an initial message to the window to ensure that we wake up
* the notifier once we get into the modal loop. This will force
* the notifier to recompute the timeout value and schedule a timer
|
| ︙ | ︙ | |||
403 404 405 406 407 408 409 |
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (message == WM_WAKEUP) {
EnterCriticalSection(&tsdPtr->crit);
tsdPtr->pending = 0;
LeaveCriticalSection(&tsdPtr->crit);
} else if (message != WM_TIMER) {
| | | 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 |
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (message == WM_WAKEUP) {
EnterCriticalSection(&tsdPtr->crit);
tsdPtr->pending = 0;
LeaveCriticalSection(&tsdPtr->crit);
} else if (message != WM_TIMER) {
return DefWindowProcW(hwnd, message, wParam, lParam);
}
/*
* Process all of the runnable events.
*/
Tcl_ServiceAll();
|
| ︙ | ︙ | |||
475 476 477 478 479 480 481 | /* * Check to see if there are any messages in the queue before waiting * because MsgWaitForMultipleObjects will not wake up if there are * events currently sitting in the queue. */ | | | 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 |
/*
* Check to see if there are any messages in the queue before waiting
* because MsgWaitForMultipleObjects will not wake up if there are
* events currently sitting in the queue.
*/
if (!PeekMessageW(&msg, NULL, 0, 0, PM_NOREMOVE)) {
/*
* Wait for something to happen (a signal from another thread, a
* message, or timeout) or loop servicing asynchronous procedure
* calls queued to this thread.
*/
again:
|
| ︙ | ︙ | |||
497 498 499 500 501 502 503 | } } /* * Check to see if there are any messages to process. */ | | | | | 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 |
}
}
/*
* Check to see if there are any messages to process.
*/
if (PeekMessageW(&msg, NULL, 0, 0, PM_NOREMOVE)) {
/*
* Retrieve and dispatch the first message.
*/
result = GetMessageW(&msg, NULL, 0, 0);
if (result == 0) {
/*
* We received a request to exit this thread (WM_QUIT), so
* propagate the quit message and start unwinding.
*/
PostQuitMessage((int) msg.wParam);
status = -1;
} else if (result == (DWORD)-1) {
/*
* We got an error from the system. I have no idea why this
* would happen, so we'll just unwind.
*/
status = -1;
} else {
TranslateMessage(&msg);
DispatchMessageW(&msg);
status = 1;
}
} else {
status = 0;
}
end:
|
| ︙ | ︙ |
Changes to win/tclWinPipe.c.
| ︙ | ︙ | |||
462 463 464 465 466 467 468 |
static int
TempFileName(
WCHAR name[MAX_PATH]) /* Buffer in which name for temporary file
* gets stored. */
{
const WCHAR *prefix = L"TCL";
| | | | | 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 |
static int
TempFileName(
WCHAR name[MAX_PATH]) /* Buffer in which name for temporary file
* gets stored. */
{
const WCHAR *prefix = L"TCL";
if (GetTempPathW(MAX_PATH, name) != 0) {
if (GetTempFileNameW(name, prefix, 0, name) != 0) {
return 1;
}
}
name[0] = '.';
name[1] = '\0';
return GetTempFileNameW(name, prefix, 0, name);
}
/*
*----------------------------------------------------------------------
*
* TclpMakeFile --
*
|
| ︙ | ︙ | |||
573 574 575 576 577 578 579 |
createMode = TRUNCATE_EXISTING;
break;
default:
createMode = OPEN_EXISTING;
break;
}
| > | | | | 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 |
createMode = TRUNCATE_EXISTING;
break;
default:
createMode = OPEN_EXISTING;
break;
}
Tcl_DStringInit(&ds);
nativePath = Tcl_UtfToWCharDString(path, -1, &ds);
/*
* If the file is not being created, use the existing file attributes.
*/
flags = 0;
if (!(mode & O_CREAT)) {
flags = GetFileAttributesW(nativePath);
if (flags == 0xFFFFFFFF) {
flags = 0;
}
}
/*
* Set up the file sharing mode. We want to allow simultaneous access.
*/
shareMode = FILE_SHARE_READ | FILE_SHARE_WRITE;
/*
* Now we get to create the file.
*/
handle = CreateFileW(nativePath, accessMode, shareMode,
NULL, createMode, flags, NULL);
Tcl_DStringFree(&ds);
if (handle == INVALID_HANDLE_VALUE) {
DWORD err;
err = GetLastError();
|
| ︙ | ︙ | |||
654 655 656 657 658 659 660 |
Tcl_DString dstring;
HANDLE handle;
if (TempFileName(name) == 0) {
return NULL;
}
| | | 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 |
Tcl_DString dstring;
HANDLE handle;
if (TempFileName(name) == 0) {
return NULL;
}
handle = CreateFileW(name,
GENERIC_READ | GENERIC_WRITE, 0, NULL, CREATE_ALWAYS,
FILE_ATTRIBUTE_TEMPORARY|FILE_FLAG_DELETE_ON_CLOSE, NULL);
if (handle == INVALID_HANDLE_VALUE) {
goto error;
}
/*
|
| ︙ | ︙ | |||
716 717 718 719 720 721 722 |
if (contents != NULL) {
Tcl_DStringFree(&dstring);
}
TclWinConvertError(GetLastError());
CloseHandle(handle);
| | | 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 |
if (contents != NULL) {
Tcl_DStringFree(&dstring);
}
TclWinConvertError(GetLastError());
CloseHandle(handle);
DeleteFileW(name);
return NULL;
}
/*
*----------------------------------------------------------------------
*
* TclpTempFileName --
|
| ︙ | ︙ | |||
932 933 934 935 936 937 938 |
* may be the same as outputFile. */
Tcl_Pid *pidPtr) /* If this function is successful, pidPtr is
* filled with the process id of the child
* process. */
{
int result, applType, createFlags;
Tcl_DString cmdLine; /* Complete command line (WCHAR). */
| | | 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 |
* may be the same as outputFile. */
Tcl_Pid *pidPtr) /* If this function is successful, pidPtr is
* filled with the process id of the child
* process. */
{
int result, applType, createFlags;
Tcl_DString cmdLine; /* Complete command line (WCHAR). */
STARTUPINFOW startInfo;
PROCESS_INFORMATION procInfo;
SECURITY_ATTRIBUTES secAtts;
HANDLE hProcess, h, inputHandle, outputHandle, errorHandle;
char execPath[MAX_PATH * 3];
WinFile *filePtr;
PipeInit();
|
| ︙ | ︙ | |||
1043 1044 1045 1046 1047 1048 1049 | * the child process would hang forever waiting for input from the * unmapped console window used by the helper application. * * Fortunately, the helper application will detect a closed pipe as a * sink. */ | | | | 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 |
* the child process would hang forever waiting for input from the
* unmapped console window used by the helper application.
*
* Fortunately, the helper application will detect a closed pipe as a
* sink.
*/
startInfo.hStdOutput = CreateFileW(L"NUL:", GENERIC_WRITE, 0,
&secAtts, OPEN_ALWAYS, FILE_ATTRIBUTE_NORMAL, NULL);
} else {
DuplicateHandle(hProcess, outputHandle, hProcess,
&startInfo.hStdOutput, 0, TRUE, DUPLICATE_SAME_ACCESS);
}
if (startInfo.hStdOutput == INVALID_HANDLE_VALUE) {
TclWinConvertError(GetLastError());
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't duplicate output handle: %s",
Tcl_PosixError(interp)));
goto end;
}
if (errorHandle == INVALID_HANDLE_VALUE) {
/*
* If handle was not set, errors should be sent to an infinitely deep
* sink.
*/
startInfo.hStdError = CreateFileW(L"NUL:", GENERIC_WRITE, 0,
&secAtts, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL);
} else {
DuplicateHandle(hProcess, errorHandle, hProcess, &startInfo.hStdError,
0, TRUE, DUPLICATE_SAME_ACCESS);
}
if (startInfo.hStdError == INVALID_HANDLE_VALUE) {
TclWinConvertError(GetLastError());
|
| ︙ | ︙ | |||
1129 1130 1131 1132 1133 1134 1135 |
* Additionally, when calling a 16-bit dos or windows application, all
* path names must use the short, cryptic, path format (e.g., using
* ab~1.def instead of "a b.default").
*/
BuildCommandLine(execPath, argc, argv, &cmdLine);
| | | 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 |
* Additionally, when calling a 16-bit dos or windows application, all
* path names must use the short, cryptic, path format (e.g., using
* ab~1.def instead of "a b.default").
*/
BuildCommandLine(execPath, argc, argv, &cmdLine);
if (CreateProcessW(NULL, (WCHAR *) Tcl_DStringValue(&cmdLine),
NULL, NULL, TRUE, (DWORD) createFlags, NULL, NULL, &startInfo,
&procInfo) == 0) {
TclWinConvertError(GetLastError());
Tcl_SetObjResult(interp, Tcl_ObjPrintf("couldn't execute \"%s\": %s",
argv[0], Tcl_PosixError(interp)));
goto end;
}
|
| ︙ | ︙ | |||
1151 1152 1153 1154 1155 1156 1157 |
}
/*
* "When an application spawns a process repeatedly, a new thread instance
* will be created for each process but the previous instances may not be
* cleaned up. This results in a significant virtual memory loss each time
* the process is spawned. If there is a WaitForInputIdle() call between
| | | 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 |
}
/*
* "When an application spawns a process repeatedly, a new thread instance
* will be created for each process but the previous instances may not be
* cleaned up. This results in a significant virtual memory loss each time
* the process is spawned. If there is a WaitForInputIdle() call between
* CreateProcessW() and CloseHandle(), the problem does not occur." PSS ID
* Number: Q124121
*/
WaitForInputIdle(procInfo.hProcess, 5000);
CloseHandle(procInfo.hThread);
*pidPtr = (Tcl_Pid) (size_t) procInfo.dwProcessId;
|
| ︙ | ︙ | |||
1200 1201 1202 1203 1204 1205 1206 |
*/
static BOOL
HasConsole(void)
{
HANDLE handle;
| | | 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 |
*/
static BOOL
HasConsole(void)
{
HANDLE handle;
handle = CreateFileW(L"CONOUT$", GENERIC_WRITE, FILE_SHARE_WRITE,
NULL, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL);
if (handle != INVALID_HANDLE_VALUE) {
CloseHandle(handle);
return TRUE;
} else {
return FALSE;
|
| ︙ | ︙ | |||
1270 1271 1272 1273 1274 1275 1276 |
static const char extensions[][5] = {"", ".com", ".exe", ".bat", ".cmd"};
/*
* Look for the program as an external program. First try the name as it
* is, then try adding .com, .exe, .bat and .cmd, in that order, to the name,
* looking for an executable.
*
| | > | | | > | | | 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 |
static const char extensions[][5] = {"", ".com", ".exe", ".bat", ".cmd"};
/*
* Look for the program as an external program. First try the name as it
* is, then try adding .com, .exe, .bat and .cmd, in that order, to the name,
* looking for an executable.
*
* Using the raw SearchPathW() function doesn't do quite what is necessary.
* If the name of the executable already contains a '.' character, it will
* not try appending the specified extension when searching (in other
* words, SearchPath will not find the program "a.b.exe" if the arguments
* specified "a.b" and ".exe"). So, first look for the file as it is
* named. Then manually append the extensions, looking for a match.
*/
applType = APPL_NONE;
Tcl_DStringInit(&nameBuf);
Tcl_DStringAppend(&nameBuf, originalName, -1);
nameLen = Tcl_DStringLength(&nameBuf);
for (i = 0; i < (int) (sizeof(extensions) / sizeof(extensions[0])); i++) {
Tcl_DStringSetLength(&nameBuf, nameLen);
Tcl_DStringAppend(&nameBuf, extensions[i], -1);
Tcl_DStringInit(&ds);
nativeName = Tcl_UtfToWCharDString(Tcl_DStringValue(&nameBuf),
Tcl_DStringLength(&nameBuf), &ds);
found = SearchPathW(NULL, nativeName, NULL, MAX_PATH,
nativeFullPath, &rest);
Tcl_DStringFree(&ds);
if (found == 0) {
continue;
}
/*
* Ignore matches on directories or data files, return if identified a
* known type.
*/
attr = GetFileAttributesW(nativeFullPath);
if ((attr == 0xffffffff) || (attr & FILE_ATTRIBUTE_DIRECTORY)) {
continue;
}
Tcl_DStringInit(&ds);
strcpy(fullName, Tcl_WCharToUtfDString(nativeFullPath, -1, &ds));
Tcl_DStringFree(&ds);
ext = strrchr(fullName, '.');
if ((ext != NULL) &&
(strcasecmp(ext, ".cmd") == 0 || strcasecmp(ext, ".bat") == 0)) {
applType = APPL_DOS;
break;
}
hFile = CreateFileW(nativeFullPath,
GENERIC_READ, FILE_SHARE_READ, NULL, OPEN_EXISTING,
FILE_ATTRIBUTE_NORMAL, NULL);
if (hFile == INVALID_HANDLE_VALUE) {
continue;
}
header.e_magic = 0;
|
| ︙ | ︙ | |||
1394 1395 1396 1397 1398 1399 1400 | /* * Replace long path name of executable with short path name for * 16-bit applications. Otherwise the application may not be able to * correctly parse its own command line to separate off the * application name from the arguments. */ | | > | | | 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 |
/*
* Replace long path name of executable with short path name for
* 16-bit applications. Otherwise the application may not be able to
* correctly parse its own command line to separate off the
* application name from the arguments.
*/
GetShortPathNameW(nativeFullPath, nativeFullPath, MAX_PATH);
Tcl_DStringInit(&ds);
strcpy(fullName, Tcl_WCharToUtfDString(nativeFullPath, -1, &ds));
Tcl_DStringFree(&ds);
}
return applType;
}
/*
*----------------------------------------------------------------------
*
* BuildCommandLine --
*
* The command line arguments are stored in linePtr separated by spaces,
* in a form that CreateProcessW() understands. Special characters in
* individual arguments from argv[] must be quoted when being stored in
* cmdLine.
*
* Results:
* None.
*
* Side effects:
|
| ︙ | ︙ | |||
1723 1724 1725 1726 1727 1728 1729 |
* End of argument (main closing quote-char)
*/
TclDStringAppendLiteral(&ds, "\"");
}
}
Tcl_DStringFree(linePtr);
| > | | 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 |
* End of argument (main closing quote-char)
*/
TclDStringAppendLiteral(&ds, "\"");
}
}
Tcl_DStringFree(linePtr);
Tcl_DStringInit(linePtr);
Tcl_UtfToWCharDString(Tcl_DStringValue(&ds), Tcl_DStringLength(&ds), linePtr);
Tcl_DStringFree(&ds);
}
/*
*----------------------------------------------------------------------
*
* TclpCreateCommandChannel --
|
| ︙ | ︙ | |||
1780 1781 1782 1783 1784 1785 1786 |
infoPtr->threadId = Tcl_GetCurrentThread();
if (readFile != NULL) {
/*
* Start the background reader thread.
*/
| | | | 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 |
infoPtr->threadId = Tcl_GetCurrentThread();
if (readFile != NULL) {
/*
* Start the background reader thread.
*/
infoPtr->readable = CreateEventW(NULL, TRUE, TRUE, NULL);
infoPtr->readThread = CreateThread(NULL, 256, PipeReaderThread,
TclPipeThreadCreateTI(&infoPtr->readTI, infoPtr, infoPtr->readable),
0, NULL);
SetThreadPriority(infoPtr->readThread, THREAD_PRIORITY_HIGHEST);
infoPtr->validMask |= TCL_READABLE;
} else {
infoPtr->readTI = NULL;
infoPtr->readThread = 0;
}
if (writeFile != NULL) {
/*
* Start the background writer thread.
*/
infoPtr->writable = CreateEventW(NULL, TRUE, TRUE, NULL);
infoPtr->writeThread = CreateThread(NULL, 256, PipeWriterThread,
TclPipeThreadCreateTI(&infoPtr->writeTI, infoPtr, infoPtr->writable),
0, NULL);
SetThreadPriority(infoPtr->writeThread, THREAD_PRIORITY_HIGHEST);
infoPtr->validMask |= TCL_WRITABLE;
} else {
infoPtr->writeTI = NULL;
|
| ︙ | ︙ | |||
3198 3199 3200 3201 3202 3203 3204 |
Tcl_DString buf;
if (!resultingNameObj) {
flags |= FILE_FLAG_DELETE_ON_CLOSE;
}
namePtr = (char *) name;
| | > | > | | | 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 |
Tcl_DString buf;
if (!resultingNameObj) {
flags |= FILE_FLAG_DELETE_ON_CLOSE;
}
namePtr = (char *) name;
length = GetTempPathW(MAX_PATH, name);
if (length == 0) {
goto gotError;
}
namePtr += length * sizeof(WCHAR);
if (basenameObj) {
const char *string = TclGetStringFromObj(basenameObj, &length);
Tcl_DStringInit(&buf);
Tcl_UtfToWCharDString(string, length, &buf);
memcpy(namePtr, Tcl_DStringValue(&buf), Tcl_DStringLength(&buf));
namePtr += Tcl_DStringLength(&buf);
Tcl_DStringFree(&buf);
} else {
const WCHAR *baseStr = L"TCL";
length = 3 * sizeof(WCHAR);
memcpy(namePtr, baseStr, length);
namePtr += length;
}
counter = TclpGetClicks() % 65533;
counter2 = 1024; /* Only try this many times! Prevents
* an infinite loop. */
do {
char number[TCL_INTEGER_SPACE + 4];
sprintf(number, "%d.TMP", counter);
counter = (unsigned short) (counter + 1);
Tcl_DStringInit(&buf);
Tcl_UtfToWCharDString(number, strlen(number), &buf);
Tcl_DStringSetLength(&buf, Tcl_DStringLength(&buf) + 1);
memcpy(namePtr, Tcl_DStringValue(&buf), Tcl_DStringLength(&buf) + 1);
Tcl_DStringFree(&buf);
handle = CreateFileW(name,
GENERIC_READ|GENERIC_WRITE, 0, NULL, CREATE_NEW, flags, NULL);
} while (handle == INVALID_HANDLE_VALUE
&& --counter2 > 0
&& GetLastError() == ERROR_FILE_EXISTS);
if (handle == INVALID_HANDLE_VALUE) {
goto gotError;
}
|
| ︙ | ︙ | |||
3280 3281 3282 3283 3284 3285 3286 |
{
TclPipeThreadInfo *pipeTI;
#ifndef _PTI_USE_CKALLOC
pipeTI = malloc(sizeof(TclPipeThreadInfo));
#else
pipeTI = Tcl_Alloc(sizeof(TclPipeThreadInfo));
#endif /* !_PTI_USE_CKALLOC */
| | | 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 |
{
TclPipeThreadInfo *pipeTI;
#ifndef _PTI_USE_CKALLOC
pipeTI = malloc(sizeof(TclPipeThreadInfo));
#else
pipeTI = Tcl_Alloc(sizeof(TclPipeThreadInfo));
#endif /* !_PTI_USE_CKALLOC */
pipeTI->evControl = CreateEventW(NULL, FALSE, FALSE, NULL);
pipeTI->state = PTI_STATE_IDLE;
pipeTI->clientData = clientData;
pipeTI->evWakeUp = wakeEvent;
return (*pipeTIPtr = pipeTI);
}
/*
|
| ︙ | ︙ | |||
3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 |
case PTI_STATE_IDLE:
/*
* Thread was idle/waiting, notify it goes teardown
*/
SetEvent(evControl);
*pipeTIPtr = NULL;
case PTI_STATE_DOWN:
return 1;
default:
/*
* Thread works currently, we should try to end it, own the TI
* structure (because of possible sharing the joint structures with
| > | 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 |
case PTI_STATE_IDLE:
/*
* Thread was idle/waiting, notify it goes teardown
*/
SetEvent(evControl);
*pipeTIPtr = NULL;
/* FALLTHRU */
case PTI_STATE_DOWN:
return 1;
default:
/*
* Thread works currently, we should try to end it, own the TI
* structure (because of possible sharing the joint structures with
|
| ︙ | ︙ |
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 | * 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) # define __MINGW_USE_VC2005_COMPAT #endif /* * We must specify the lower version we intend to support. * * WINVER = 0x0501 means Windows XP and above |
| ︙ | ︙ |
Changes to win/tclWinReg.c.
| ︙ | ︙ | |||
90 91 92 93 94 95 96 | * Declarations for functions defined in this file. */ static void AppendSystemError(Tcl_Interp *interp, DWORD error); static int BroadcastValue(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static DWORD ConvertDWORD(DWORD type, DWORD value); | | | 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 | * Declarations for functions defined in this file. */ static void AppendSystemError(Tcl_Interp *interp, DWORD error); static int BroadcastValue(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static DWORD ConvertDWORD(DWORD type, DWORD value); static void DeleteCmd(void *clientData); static int DeleteKey(Tcl_Interp *interp, Tcl_Obj *keyNameObj, REGSAM mode); static int DeleteValue(Tcl_Interp *interp, Tcl_Obj *keyNameObj, Tcl_Obj *valueNameObj, REGSAM mode); static int GetKeyNames(Tcl_Interp *interp, Tcl_Obj *keyNameObj, Tcl_Obj *patternObj, REGSAM mode); static int GetType(Tcl_Interp *interp, Tcl_Obj *keyNameObj, |
| ︙ | ︙ | |||
112 113 114 115 116 117 118 | static DWORD OpenSubKey(char *hostName, HKEY rootKey, char *keyName, REGSAM mode, int flags, HKEY *keyPtr); static int ParseKeyName(Tcl_Interp *interp, char *name, char **hostNamePtr, HKEY *rootKeyPtr, char **keyNamePtr); static DWORD RecursiveDeleteKey(HKEY hStartKey, | | | > > > > > > > > > > > > > > > > | 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 |
static DWORD OpenSubKey(char *hostName, HKEY rootKey,
char *keyName, REGSAM mode, int flags,
HKEY *keyPtr);
static int ParseKeyName(Tcl_Interp *interp, char *name,
char **hostNamePtr, HKEY *rootKeyPtr,
char **keyNamePtr);
static DWORD RecursiveDeleteKey(HKEY hStartKey,
const WCHAR * pKeyName, REGSAM mode);
static int RegistryObjCmd(void *clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
static int SetValue(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
Tcl_Obj *valueNameObj, Tcl_Obj *dataObj,
Tcl_Obj *typeObj, REGSAM mode);
#if (TCL_MAJOR_VERSION < 9) && (TCL_MINOR_VERSION < 7)
# if TCL_UTF_MAX > 3
# define Tcl_WCharToUtfDString(a,b,c) Tcl_WinTCharToUtf(a,(b)*sizeof(WCHAR),c)
# define Tcl_UtfToWCharDString(a,b,c) Tcl_WinUtfToTChar(a,b,c)
# else
# define Tcl_WCharToUtfDString Tcl_UniCharToUtfDString
# define Tcl_UtfToWCharDString Tcl_UtfToUniCharDString
# endif
#endif
static unsigned char *
getByteArrayFromObj(
Tcl_Obj *objPtr,
size_t *lengthPtr
) {
int length;
unsigned char *result = Tcl_GetByteArrayFromObj(objPtr, &length);
#if TCL_MAJOR_VERSION > 8
if (sizeof(TCL_HASH_TYPE) > sizeof(int)) {
/* 64-bit and TIP #494 situation: */
*lengthPtr = *(TCL_HASH_TYPE *) objPtr->internalRep.twoPtrValue.ptr1;
} else
#endif
/* 32-bit or without TIP #494 */
*lengthPtr = (size_t) (unsigned) length;
return result;
}
#ifdef __cplusplus
extern "C" {
#endif
DLLEXPORT int Registry_Init(Tcl_Interp *interp);
DLLEXPORT int Registry_Unload(Tcl_Interp *interp, int flags);
#ifdef __cplusplus
}
#endif
/*
*----------------------------------------------------------------------
*
* Registry_Init --
*
* This function initializes the registry command.
|
| ︙ | ︙ | |||
164 165 166 167 168 169 170 |
int
Registry_Init(
Tcl_Interp *interp)
{
Tcl_Command cmd;
| | | | 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 |
int
Registry_Init(
Tcl_Interp *interp)
{
Tcl_Command cmd;
if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) {
return TCL_ERROR;
}
cmd = Tcl_CreateObjCommand(interp, "registry", RegistryObjCmd,
interp, DeleteCmd);
Tcl_SetAssocData(interp, REGISTRY_ASSOC_KEY, NULL, cmd);
return Tcl_PkgProvideEx(interp, "registry", "1.3.3", NULL);
}
/*
*----------------------------------------------------------------------
*
* Registry_Unload --
*
|
| ︙ | ︙ | |||
197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 |
int
Registry_Unload(
Tcl_Interp *interp, /* Interpreter for unloading */
int flags) /* Flags passed by the unload system */
{
Tcl_Command cmd;
Tcl_Obj *objv[3];
/*
* Unregister the registry package. There is no Tcl_PkgForget()
*/
objv[0] = Tcl_NewStringObj("package", -1);
objv[1] = Tcl_NewStringObj("forget", -1);
objv[2] = Tcl_NewStringObj("registry", -1);
Tcl_EvalObjv(interp, 3, objv, TCL_EVAL_GLOBAL);
/*
* Delete the originally registered command.
*/
| > | | 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 |
int
Registry_Unload(
Tcl_Interp *interp, /* Interpreter for unloading */
int flags) /* Flags passed by the unload system */
{
Tcl_Command cmd;
Tcl_Obj *objv[3];
(void)flags;
/*
* Unregister the registry package. There is no Tcl_PkgForget()
*/
objv[0] = Tcl_NewStringObj("package", -1);
objv[1] = Tcl_NewStringObj("forget", -1);
objv[2] = Tcl_NewStringObj("registry", -1);
Tcl_EvalObjv(interp, 3, objv, TCL_EVAL_GLOBAL);
/*
* Delete the originally registered command.
*/
cmd = (Tcl_Command)Tcl_GetAssocData(interp, REGISTRY_ASSOC_KEY, NULL);
if (cmd != NULL) {
Tcl_DeleteCommandFromToken(interp, cmd);
}
return TCL_OK;
}
|
| ︙ | ︙ | |||
238 239 240 241 242 243 244 | * The unload command will not attempt to delete this command. * *---------------------------------------------------------------------- */ static void DeleteCmd( | | | | 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 |
* The unload command will not attempt to delete this command.
*
*----------------------------------------------------------------------
*/
static void
DeleteCmd(
void *clientData)
{
Tcl_Interp *interp = (Tcl_Interp *)clientData;
Tcl_SetAssocData(interp, REGISTRY_ASSOC_KEY, NULL, NULL);
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
263 264 265 266 267 268 269 | * None. * *---------------------------------------------------------------------- */ static int RegistryObjCmd( | | > | 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 |
* None.
*
*----------------------------------------------------------------------
*/
static int
RegistryObjCmd(
void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument values. */
{
int n = 1;
int index, argc;
REGSAM mode = 0;
const char *errString = NULL;
static const char *const subcommands[] = {
"broadcast", "delete", "get", "keys", "set", "type", "values", NULL
};
enum SubCmdIdx {
BroadcastIdx, DeleteIdx, GetIdx, KeysIdx, SetIdx, TypeIdx, ValuesIdx
};
static const char *const modes[] = {
"-32bit", "-64bit", NULL
};
(void)dummy;
if (objc < 2) {
wrongArgs:
Tcl_WrongNumArgs(interp, 1, objv, "?-32bit|-64bit? option ?arg ...?");
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
411 412 413 414 415 416 417 |
static int
DeleteKey(
Tcl_Interp *interp, /* Current interpreter. */
Tcl_Obj *keyNameObj, /* Name of key to delete. */
REGSAM mode) /* Mode flags to pass. */
{
char *tail, *buffer, *hostName, *keyName;
| | | 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 |
static int
DeleteKey(
Tcl_Interp *interp, /* Current interpreter. */
Tcl_Obj *keyNameObj, /* Name of key to delete. */
REGSAM mode) /* Mode flags to pass. */
{
char *tail, *buffer, *hostName, *keyName;
const WCHAR *nativeTail;
HKEY rootKey, subkey;
DWORD result;
Tcl_DString buf;
REGSAM saveMode = mode;
/*
* Find the parent of the key being deleted and open it.
|
| ︙ | ︙ | |||
464 465 466 467 468 469 470 |
return TCL_ERROR;
}
/*
* Now we recursively delete the key and everything below it.
*/
| > | | 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 |
return TCL_ERROR;
}
/*
* Now we recursively delete the key and everything below it.
*/
Tcl_DStringInit(&buf);
nativeTail = Tcl_UtfToWCharDString(tail, -1, &buf);
result = RecursiveDeleteKey(subkey, nativeTail, saveMode);
Tcl_DStringFree(&buf);
if (result != ERROR_SUCCESS && result != ERROR_FILE_NOT_FOUND) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("unable to delete key: ", -1));
AppendSystemError(interp, result);
|
| ︙ | ︙ | |||
520 521 522 523 524 525 526 |
mode |= KEY_SET_VALUE;
if (OpenKey(interp, keyNameObj, mode, 0, &key) != TCL_OK) {
return TCL_ERROR;
}
valueName = Tcl_GetString(valueNameObj);
| > | | | 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 |
mode |= KEY_SET_VALUE;
if (OpenKey(interp, keyNameObj, mode, 0, &key) != TCL_OK) {
return TCL_ERROR;
}
valueName = Tcl_GetString(valueNameObj);
Tcl_DStringInit(&ds);
Tcl_UtfToWCharDString(valueName, valueNameObj->length, &ds);
result = RegDeleteValueW(key, (const WCHAR *)Tcl_DStringValue(&ds));
Tcl_DStringFree(&ds);
if (result != ERROR_SUCCESS) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unable to delete value \"%s\" from key \"%s\": ",
Tcl_GetString(valueNameObj), Tcl_GetString(keyNameObj)));
AppendSystemError(interp, result);
result = TCL_ERROR;
|
| ︙ | ︙ | |||
564 565 566 567 568 569 570 |
Tcl_Interp *interp, /* Current interpreter. */
Tcl_Obj *keyNameObj, /* Key to enumerate. */
Tcl_Obj *patternObj, /* Optional match pattern. */
REGSAM mode) /* Mode flags to pass. */
{
const char *pattern; /* Pattern being matched against subkeys */
HKEY key; /* Handle to the key being examined */
| | | 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 |
Tcl_Interp *interp, /* Current interpreter. */
Tcl_Obj *keyNameObj, /* Key to enumerate. */
Tcl_Obj *patternObj, /* Optional match pattern. */
REGSAM mode) /* Mode flags to pass. */
{
const char *pattern; /* Pattern being matched against subkeys */
HKEY key; /* Handle to the key being examined */
WCHAR buffer[MAX_KEY_LENGTH];
/* Buffer to hold the subkey name */
DWORD bufSize; /* Size of the buffer */
DWORD index; /* Position of the current subkey */
char *name; /* Subkey name */
Tcl_Obj *resultPtr; /* List of subkeys being accumulated */
int result = TCL_OK; /* Return value from this command */
Tcl_DString ds; /* Buffer to translate subkey name to UTF-8 */
|
| ︙ | ︙ | |||
595 596 597 598 599 600 601 |
/*
* Enumerate the subkeys.
*/
resultPtr = Tcl_NewObj();
for (index = 0;; ++index) {
bufSize = MAX_KEY_LENGTH;
| | > | | 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 |
/*
* Enumerate the subkeys.
*/
resultPtr = Tcl_NewObj();
for (index = 0;; ++index) {
bufSize = MAX_KEY_LENGTH;
result = RegEnumKeyExW(key, index, buffer, &bufSize,
NULL, NULL, NULL, NULL);
if (result != ERROR_SUCCESS) {
if (result == ERROR_NO_MORE_ITEMS) {
result = TCL_OK;
} else {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unable to enumerate subkeys of \"%s\": ",
Tcl_GetString(keyNameObj)));
AppendSystemError(interp, result);
result = TCL_ERROR;
}
break;
}
Tcl_DStringInit(&ds);
name = Tcl_WCharToUtfDString(buffer, bufSize, &ds);
if (pattern && !Tcl_StringMatch(name, pattern)) {
Tcl_DStringFree(&ds);
continue;
}
result = Tcl_ListObjAppendElement(interp, resultPtr,
Tcl_NewStringObj(name, Tcl_DStringLength(&ds)));
Tcl_DStringFree(&ds);
|
| ︙ | ︙ | |||
659 660 661 662 663 664 665 |
Tcl_Obj *valueNameObj, /* Name of value to get. */
REGSAM mode) /* Mode flags to pass. */
{
HKEY key;
DWORD result, type;
Tcl_DString ds;
const char *valueName;
| | > | | | 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 |
Tcl_Obj *valueNameObj, /* Name of value to get. */
REGSAM mode) /* Mode flags to pass. */
{
HKEY key;
DWORD result, type;
Tcl_DString ds;
const char *valueName;
const WCHAR *nativeValue;
/*
* Attempt to open the key for reading.
*/
mode |= KEY_QUERY_VALUE;
if (OpenKey(interp, keyNameObj, mode, 0, &key) != TCL_OK) {
return TCL_ERROR;
}
/*
* Get the type of the value.
*/
valueName = Tcl_GetString(valueNameObj);
Tcl_DStringInit(&ds);
nativeValue = Tcl_UtfToWCharDString(valueName, valueNameObj->length, &ds);
result = RegQueryValueExW(key, nativeValue, NULL, &type,
NULL, NULL);
Tcl_DStringFree(&ds);
RegCloseKey(key);
if (result != ERROR_SUCCESS) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unable to get type of value \"%s\" from key \"%s\": ",
|
| ︙ | ︙ | |||
728 729 730 731 732 733 734 |
Tcl_Interp *interp, /* Current interpreter. */
Tcl_Obj *keyNameObj, /* Name of key. */
Tcl_Obj *valueNameObj, /* Name of value to get. */
REGSAM mode) /* Mode flags to pass. */
{
HKEY key;
const char *valueName;
| | | 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 |
Tcl_Interp *interp, /* Current interpreter. */
Tcl_Obj *keyNameObj, /* Name of key. */
Tcl_Obj *valueNameObj, /* Name of value to get. */
REGSAM mode) /* Mode flags to pass. */
{
HKEY key;
const char *valueName;
const WCHAR *nativeValue;
DWORD result, length, type;
Tcl_DString data, buf;
/*
* Attempt to open the key for reading.
*/
|
| ︙ | ︙ | |||
753 754 755 756 757 758 759 |
*
* This allows short values to be read from the registy in one call.
* Longer values need a second call with an expanded DString.
*/
Tcl_DStringInit(&data);
Tcl_DStringSetLength(&data, TCL_DSTRING_STATIC_SIZE - 1);
| | > | | | | | | 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 |
*
* This allows short values to be read from the registy in one call.
* Longer values need a second call with an expanded DString.
*/
Tcl_DStringInit(&data);
Tcl_DStringSetLength(&data, TCL_DSTRING_STATIC_SIZE - 1);
length = TCL_DSTRING_STATIC_SIZE/sizeof(WCHAR) - 1;
valueName = Tcl_GetString(valueNameObj);
Tcl_DStringInit(&buf);
nativeValue = Tcl_UtfToWCharDString(valueName, valueNameObj->length, &buf);
result = RegQueryValueExW(key, nativeValue, NULL, &type,
(BYTE *) Tcl_DStringValue(&data), &length);
while (result == ERROR_MORE_DATA) {
/*
* The Windows docs say that in this error case, we just need to
* expand our buffer and request more data. Required for
* HKEY_PERFORMANCE_DATA
*/
length = Tcl_DStringLength(&data) * (2 / sizeof(WCHAR));
Tcl_DStringSetLength(&data, (int) length * sizeof(WCHAR));
result = RegQueryValueExW(key, nativeValue,
NULL, &type, (BYTE *) Tcl_DStringValue(&data), &length);
}
Tcl_DStringFree(&buf);
RegCloseKey(key);
if (result != ERROR_SUCCESS) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unable to get value \"%s\" from key \"%s\": ",
|
| ︙ | ︙ | |||
805 806 807 808 809 810 811 |
/*
* Multistrings are stored as an array of null-terminated strings,
* terminated by two null characters. Also do a bounds check in case
* we get bogus data.
*/
while ((p < end) && *((WCHAR *) p) != 0) {
| | > | < | > > | 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 |
/*
* Multistrings are stored as an array of null-terminated strings,
* terminated by two null characters. Also do a bounds check in case
* we get bogus data.
*/
while ((p < end) && *((WCHAR *) p) != 0) {
WCHAR *wp = (WCHAR *) p;
Tcl_DStringInit(&buf);
Tcl_WCharToUtfDString(wp, wcslen(wp), &buf);
Tcl_ListObjAppendElement(interp, resultPtr,
Tcl_NewStringObj(Tcl_DStringValue(&buf),
Tcl_DStringLength(&buf)));
while (*wp++ != 0) {/* empty body */}
p = (char *) wp;
Tcl_DStringFree(&buf);
}
Tcl_SetObjResult(interp, resultPtr);
} else if ((type == REG_SZ) || (type == REG_EXPAND_SZ)) {
WCHAR *wp = (WCHAR *) Tcl_DStringValue(&data);
Tcl_DStringInit(&buf);
Tcl_WCharToUtfDString((const WCHAR *)Tcl_DStringValue(&data), wcslen(wp), &buf);
Tcl_DStringResult(interp, &buf);
} else {
/*
* Save binary data as a byte array.
*/
Tcl_SetObjResult(interp, Tcl_NewByteArrayObj(
|
| ︙ | ︙ | |||
876 877 878 879 880 881 882 |
mode |= KEY_QUERY_VALUE;
if (OpenKey(interp, keyNameObj, mode, 0, &key) != TCL_OK) {
return TCL_ERROR;
}
resultPtr = Tcl_NewObj();
Tcl_DStringInit(&buffer);
| | | < < | > | 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 |
mode |= KEY_QUERY_VALUE;
if (OpenKey(interp, keyNameObj, mode, 0, &key) != TCL_OK) {
return TCL_ERROR;
}
resultPtr = Tcl_NewObj();
Tcl_DStringInit(&buffer);
Tcl_DStringSetLength(&buffer, (int) (MAX_KEY_LENGTH * sizeof(WCHAR)));
index = 0;
result = TCL_OK;
if (patternObj) {
pattern = Tcl_GetString(patternObj);
} else {
pattern = NULL;
}
/*
* Enumerate the values under the given subkey until we get an error,
* indicating the end of the list. Note that we need to reset size after
* each iteration because RegEnumValue smashes the old value.
*/
size = MAX_KEY_LENGTH;
while (RegEnumValueW(key,index, (WCHAR *)Tcl_DStringValue(&buffer),
&size, NULL, NULL, NULL, NULL) == ERROR_SUCCESS) {
Tcl_DStringInit(&ds);
Tcl_WCharToUtfDString((const WCHAR *)Tcl_DStringValue(&buffer), size, &ds);
name = Tcl_DStringValue(&ds);
if (!pattern || Tcl_StringMatch(name, pattern)) {
result = Tcl_ListObjAppendElement(interp, resultPtr,
Tcl_NewStringObj(name, Tcl_DStringLength(&ds)));
if (result != TCL_OK) {
Tcl_DStringFree(&ds);
break;
|
| ︙ | ︙ | |||
1004 1005 1006 1007 1008 1009 1010 |
Tcl_DString buf;
/*
* Attempt to open the root key on a remote host if necessary.
*/
if (hostName) {
| > | | > | | | | 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 |
Tcl_DString buf;
/*
* Attempt to open the root key on a remote host if necessary.
*/
if (hostName) {
Tcl_DStringInit(&buf);
hostName = (char *) Tcl_UtfToWCharDString(hostName, -1, &buf);
result = RegConnectRegistryW((WCHAR *)hostName, rootKey,
&rootKey);
Tcl_DStringFree(&buf);
if (result != ERROR_SUCCESS) {
return result;
}
}
/*
* Now open the specified key with the requested permissions. Note that
* this key must be closed by the caller.
*/
if (keyName) {
Tcl_DStringInit(&buf);
keyName = (char *) Tcl_UtfToWCharDString(keyName, -1, &buf);
}
if (flags & REG_CREATE) {
DWORD create;
result = RegCreateKeyExW(rootKey, (WCHAR *)keyName, 0, NULL,
REG_OPTION_NON_VOLATILE, mode, NULL, keyPtr, &create);
} else if (rootKey == HKEY_PERFORMANCE_DATA) {
/*
* Here we fudge it for this special root key. See MSDN for more info
* on HKEY_PERFORMANCE_DATA and the peculiarities surrounding it.
*/
*keyPtr = HKEY_PERFORMANCE_DATA;
result = ERROR_SUCCESS;
} else {
result = RegOpenKeyExW(rootKey, (WCHAR *)keyName, 0, mode,
keyPtr);
}
if (keyName) {
Tcl_DStringFree(&buf);
}
/*
|
| ︙ | ︙ | |||
1155 1156 1157 1158 1159 1160 1161 |
*
*----------------------------------------------------------------------
*/
static DWORD
RecursiveDeleteKey(
HKEY startKey, /* Parent of key to be deleted. */
| | | | | | | | | | | 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 |
*
*----------------------------------------------------------------------
*/
static DWORD
RecursiveDeleteKey(
HKEY startKey, /* Parent of key to be deleted. */
const WCHAR *keyName, /* Name of key to be deleted in external
* encoding, not UTF. */
REGSAM mode) /* Mode flags to pass. */
{
DWORD result, size;
Tcl_DString subkey;
HKEY hKey;
REGSAM saveMode = mode;
static int checkExProc = 0;
static LSTATUS (* regDeleteKeyExProc) (HKEY, LPCWSTR, REGSAM, DWORD) = (LSTATUS (*) (HKEY, LPCWSTR, REGSAM, DWORD)) NULL;
/*
* Do not allow NULL or empty key name.
*/
if (!keyName || *keyName == '\0') {
return ERROR_BADKEY;
}
mode |= KEY_ENUMERATE_SUB_KEYS | DELETE | KEY_QUERY_VALUE;
result = RegOpenKeyExW(startKey, keyName, 0, mode, &hKey);
if (result != ERROR_SUCCESS) {
return result;
}
Tcl_DStringInit(&subkey);
Tcl_DStringSetLength(&subkey, (int) (MAX_KEY_LENGTH * sizeof(WCHAR)));
mode = saveMode;
while (result == ERROR_SUCCESS) {
/*
* Always get index 0 because key deletion changes ordering.
*/
size = MAX_KEY_LENGTH;
result = RegEnumKeyExW(hKey, 0, (WCHAR *)Tcl_DStringValue(&subkey),
&size, NULL, NULL, NULL, NULL);
if (result == ERROR_NO_MORE_ITEMS) {
/*
* RegDeleteKeyEx doesn't exist on non-64bit XP platforms, so we
* can't compile with it in. We need to check for it at runtime
* and use it if we find it.
*/
if (mode && !checkExProc) {
HMODULE handle;
checkExProc = 1;
handle = GetModuleHandleW(L"ADVAPI32");
regDeleteKeyExProc = (LSTATUS (*) (HKEY, LPCWSTR, REGSAM, DWORD))
GetProcAddress(handle, "RegDeleteKeyExW");
}
if (mode && regDeleteKeyExProc) {
result = regDeleteKeyExProc(startKey, keyName, mode, 0);
} else {
result = RegDeleteKeyW(startKey, keyName);
}
break;
} else if (result == ERROR_SUCCESS) {
result = RecursiveDeleteKey(hKey,
(const WCHAR *) Tcl_DStringValue(&subkey), mode);
}
}
Tcl_DStringFree(&subkey);
RegCloseKey(hKey);
return result;
}
|
| ︙ | ︙ | |||
1271 1272 1273 1274 1275 1276 1277 |
}
mode |= KEY_ALL_ACCESS;
if (OpenKey(interp, keyNameObj, mode, 1, &key) != TCL_OK) {
return TCL_ERROR;
}
valueName = Tcl_GetString(valueNameObj);
| > | | | 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 |
}
mode |= KEY_ALL_ACCESS;
if (OpenKey(interp, keyNameObj, mode, 1, &key) != TCL_OK) {
return TCL_ERROR;
}
valueName = Tcl_GetString(valueNameObj);
Tcl_DStringInit(&nameBuf);
valueName = (char *) Tcl_UtfToWCharDString(valueName, valueNameObj->length, &nameBuf);
if (type == REG_DWORD || type == REG_DWORD_BIG_ENDIAN) {
int value;
if (Tcl_GetIntFromObj(interp, dataObj, &value) != TCL_OK) {
RegCloseKey(key);
Tcl_DStringFree(&nameBuf);
return TCL_ERROR;
}
value = ConvertDWORD((DWORD) type, (DWORD) value);
result = RegSetValueExW(key, (WCHAR *) valueName, 0,
(DWORD) type, (BYTE *) &value, sizeof(DWORD));
} else if (type == REG_MULTI_SZ) {
Tcl_DString data, buf;
int objc, i;
Tcl_Obj **objv;
if (Tcl_ListObjGetElements(interp, dataObj, &objc, &objv) != TCL_OK) {
|
| ︙ | ︙ | |||
1315 1316 1317 1318 1319 1320 1321 | /* * Add a null character to separate this value from the next. */ Tcl_DStringAppend(&data, "", 1); /* NUL-terminated string */ } | > | | > | | | | 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 |
/*
* Add a null character to separate this value from the next.
*/
Tcl_DStringAppend(&data, "", 1); /* NUL-terminated string */
}
Tcl_DStringInit(&buf);
Tcl_UtfToWCharDString(Tcl_DStringValue(&data), Tcl_DStringLength(&data)+1,
&buf);
result = RegSetValueExW(key, (WCHAR *) valueName, 0,
(DWORD) type, (BYTE *) Tcl_DStringValue(&buf),
(DWORD) Tcl_DStringLength(&buf));
Tcl_DStringFree(&data);
Tcl_DStringFree(&buf);
} else if (type == REG_SZ || type == REG_EXPAND_SZ) {
Tcl_DString buf;
const char *data = Tcl_GetString(dataObj);
Tcl_DStringInit(&buf);
data = (char *) Tcl_UtfToWCharDString(data, dataObj->length, &buf);
/*
* Include the null in the length, padding if needed for WCHAR.
*/
Tcl_DStringSetLength(&buf, Tcl_DStringLength(&buf)+1);
result = RegSetValueExW(key, (WCHAR *) valueName, 0,
(DWORD) type, (BYTE *) data, (DWORD) Tcl_DStringLength(&buf) + 1);
Tcl_DStringFree(&buf);
} else {
BYTE *data;
size_t bytelength;
/*
* Store binary data in the registry.
*/
data = (BYTE *) getByteArrayFromObj(dataObj, &bytelength);
result = RegSetValueExW(key, (WCHAR *) valueName, 0,
(DWORD) type, data, (DWORD) bytelength);
}
Tcl_DStringFree(&nameBuf);
RegCloseKey(key);
if (result != ERROR_SUCCESS) {
|
| ︙ | ︙ | |||
1406 1407 1408 1409 1410 1411 1412 |
}
if (Tcl_GetIntFromObj(interp, objv[2], &timeout) != TCL_OK) {
return TCL_ERROR;
}
}
str = Tcl_GetString(objv[0]);
| > | | | 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 |
}
if (Tcl_GetIntFromObj(interp, objv[2], &timeout) != TCL_OK) {
return TCL_ERROR;
}
}
str = Tcl_GetString(objv[0]);
Tcl_DStringInit(&ds);
wstr = Tcl_UtfToWCharDString(str, objv[0]->length, &ds);
if (Tcl_DStringLength(&ds) == 0) {
wstr = NULL;
}
/*
* Use the ignore the result.
*/
result = SendMessageTimeoutW(HWND_BROADCAST, WM_SETTINGCHANGE,
(WPARAM) 0, (LPARAM) wstr, SMTO_ABORTIFHUNG, (UINT) timeout, &sendResult);
Tcl_DStringFree(&ds);
objPtr = Tcl_NewObj();
Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewWideIntObj((Tcl_WideInt) result));
Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewWideIntObj((Tcl_WideInt) sendResult));
Tcl_SetObjResult(interp, objPtr);
|
| ︙ | ︙ | |||
1450 1451 1452 1453 1454 1455 1456 |
static void
AppendSystemError(
Tcl_Interp *interp, /* Current interpreter. */
DWORD error) /* Result code from error. */
{
int length;
| | | | > | | 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 |
static void
AppendSystemError(
Tcl_Interp *interp, /* Current interpreter. */
DWORD error) /* Result code from error. */
{
int length;
WCHAR *tMsgPtr, **tMsgPtrPtr = &tMsgPtr;
const char *msg;
char id[TCL_INTEGER_SPACE], msgBuf[24 + TCL_INTEGER_SPACE];
Tcl_DString ds;
Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
if (Tcl_IsShared(resultPtr)) {
resultPtr = Tcl_DuplicateObj(resultPtr);
}
length = FormatMessageW(FORMAT_MESSAGE_FROM_SYSTEM
| FORMAT_MESSAGE_ALLOCATE_BUFFER, NULL, error,
MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), (WCHAR *) tMsgPtrPtr,
0, NULL);
if (length == 0) {
sprintf(msgBuf, "unknown error: %ld", error);
msg = msgBuf;
} else {
char *msgPtr;
Tcl_DStringInit(&ds);
Tcl_WCharToUtfDString(tMsgPtr, wcslen(tMsgPtr), &ds);
LocalFree(tMsgPtr);
msgPtr = Tcl_DStringValue(&ds);
length = Tcl_DStringLength(&ds);
/*
* Trim the trailing CR/LF from the system message.
|
| ︙ | ︙ |
Changes to win/tclWinSerial.c.
| ︙ | ︙ | |||
1287 1288 1289 1290 1291 1292 1293 | break; } infoPtr = (SerialInfo *) pipeTI->clientData; buf = infoPtr->writeBuf; toWrite = infoPtr->toWrite; | | | 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 |
break;
}
infoPtr = (SerialInfo *) pipeTI->clientData;
buf = infoPtr->writeBuf;
toWrite = infoPtr->toWrite;
myWrite.hEvent = CreateEventW(NULL, TRUE, FALSE, NULL);
/*
* Loop until all of the bytes are written or an error occurs.
*/
while (toWrite > 0) {
/*
|
| ︙ | ︙ | |||
1399 1400 1401 1402 1403 1404 1405 |
{
SerialInit();
/*
* If an open channel is specified, close it
*/
| | | | 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 |
{
SerialInit();
/*
* If an open channel is specified, close it
*/
if (handle != INVALID_HANDLE_VALUE && CloseHandle(handle) == FALSE) {
return INVALID_HANDLE_VALUE;
}
/*
* Multithreaded I/O needs the overlapped flag set otherwise
* ClearCommError blocks under Windows NT/2000 until serial output is
* finished
*/
handle = CreateFileW(name, access, 0, 0, OPEN_EXISTING,
FILE_FLAG_OVERLAPPED, 0);
return handle;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
1482 1483 1484 1485 1486 1487 1488 |
* Default is blocking.
*/
SetCommTimeouts(handle, &no_timeout);
InitializeCriticalSection(&infoPtr->csWrite);
if (permissions & TCL_READABLE) {
| | | | | 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 |
* Default is blocking.
*/
SetCommTimeouts(handle, &no_timeout);
InitializeCriticalSection(&infoPtr->csWrite);
if (permissions & TCL_READABLE) {
infoPtr->osRead.hEvent = CreateEventW(NULL, TRUE, FALSE, NULL);
}
if (permissions & TCL_WRITABLE) {
/*
* Initially the channel is writable and the writeThread is idle.
*/
infoPtr->osWrite.hEvent = CreateEventW(NULL, TRUE, FALSE, NULL);
infoPtr->evWritable = CreateEventW(NULL, TRUE, TRUE, NULL);
infoPtr->writeThread = CreateThread(NULL, 256, SerialWriterThread,
TclPipeThreadCreateTI(&infoPtr->writeTI, infoPtr,
infoPtr->evWritable), 0, NULL);
}
/*
* Files have default translation of AUTO and ^Z eof char, which means
|
| ︙ | ︙ | |||
1665 1666 1667 1668 1669 1670 1671 |
* Option -mode baud,parity,databits,stopbits
*/
if ((len > 2) && (strncmp(optionName, "-mode", len) == 0)) {
if (!GetCommState(infoPtr->handle, &dcb)) {
goto getStateFailed;
}
| > | | | 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 |
* Option -mode baud,parity,databits,stopbits
*/
if ((len > 2) && (strncmp(optionName, "-mode", len) == 0)) {
if (!GetCommState(infoPtr->handle, &dcb)) {
goto getStateFailed;
}
Tcl_DStringInit(&ds);
native = Tcl_UtfToWCharDString(value, -1, &ds);
result = BuildCommDCBW(native, &dcb);
Tcl_DStringFree(&ds);
if (result == FALSE) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad value \"%s\" for -mode: should be baud,parity,data,stop",
value));
|
| ︙ | ︙ |
Changes to win/tclWinSock.c.
| ︙ | ︙ | |||
231 232 233 234 235 236 237 |
* list. This value is also checked by
* the event structure. */
TcpState *socketList; /* Every open socket in this thread has an
* entry on this list. */
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
| | | 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 |
* list. This value is also checked by
* the event structure. */
TcpState *socketList; /* Every open socket in this thread has an
* entry on this list. */
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
static WNDCLASSW windowClass;
/*
* Static routines for this file:
*/
static int TcpConnect(Tcl_Interp *interp,
TcpState *state);
|
| ︙ | ︙ | |||
359 360 361 362 363 364 365 |
void
InitializeHostName(
char **valuePtr,
size_t *lengthPtr,
Tcl_Encoding *encodingPtr)
{
| | > | | < | 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 |
void
InitializeHostName(
char **valuePtr,
size_t *lengthPtr,
Tcl_Encoding *encodingPtr)
{
WCHAR wbuf[MAX_COMPUTERNAME_LENGTH + 1];
DWORD length = MAX_COMPUTERNAME_LENGTH + 1;
Tcl_DString ds;
Tcl_DStringInit(&ds);
if (GetComputerNameW(wbuf, &length) != 0) {
/*
* Convert string from native to UTF then change to lowercase.
*/
Tcl_UtfToLower(Tcl_WCharToUtfDString(wbuf, -1, &ds));
} else {
if (TclpHasSockets(NULL) == TCL_OK) {
/*
* The buffer size of 256 is recommended by the MSDN page that
* documents gethostname() as being always adequate.
*/
Tcl_DString inDs;
|
| ︙ | ︙ | |||
2500 2501 2502 2503 2504 2505 2506 | windowClass.hbrBackground = NULL; windowClass.lpszMenuName = NULL; windowClass.lpszClassName = className; windowClass.lpfnWndProc = SocketProc; windowClass.hIcon = NULL; windowClass.hCursor = NULL; | | | 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 |
windowClass.hbrBackground = NULL;
windowClass.lpszMenuName = NULL;
windowClass.lpszClassName = className;
windowClass.lpfnWndProc = SocketProc;
windowClass.hIcon = NULL;
windowClass.hCursor = NULL;
if (!RegisterClassW(&windowClass)) {
TclWinConvertError(GetLastError());
goto initFailure;
}
}
/*
* Check for per-thread initialization.
|
| ︙ | ︙ | |||
2625 2626 2627 2628 2629 2630 2631 |
/*
* Make sure the socket event handling window is cleaned-up for, at
* most, this thread.
*/
TclpFinalizeSockets();
| | | 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 |
/*
* Make sure the socket event handling window is cleaned-up for, at
* most, this thread.
*/
TclpFinalizeSockets();
UnregisterClassW(className, TclWinGetTclInstance());
initialized = 0;
Tcl_MutexUnlock(&socketMutex);
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
3172 3173 3174 3175 3176 3177 3178 |
MSG msg;
ThreadSpecificData *tsdPtr = arg;
/*
* Create a dummy window receiving socket events.
*/
| | | 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 |
MSG msg;
ThreadSpecificData *tsdPtr = arg;
/*
* Create a dummy window receiving socket events.
*/
tsdPtr->hwnd = CreateWindowW(className, className, WS_TILED, 0, 0, 0, 0,
NULL, NULL, windowClass.hInstance, arg);
/*
* Signalize thread creator that we are done creating the window.
*/
SetEvent(tsdPtr->readyEvent);
|
| ︙ | ︙ | |||
3195 3196 3197 3198 3199 3200 3201 |
/*
* Process all messages on the socket window until WM_QUIT. This threads
* exits only when instructed to do so by the call to
* PostMessage(SOCKET_TERMINATE) in TclpFinalizeSockets().
*/
| | | | 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 |
/*
* Process all messages on the socket window until WM_QUIT. This threads
* exits only when instructed to do so by the call to
* PostMessage(SOCKET_TERMINATE) in TclpFinalizeSockets().
*/
while (GetMessageW(&msg, NULL, 0, 0) > 0) {
DispatchMessageW(&msg);
}
/*
* This releases waiters on thread exit in TclpFinalizeSockets()
*/
SetEvent(tsdPtr->readyEvent);
|
| ︙ | ︙ | |||
3241 3242 3243 3244 3245 3246 3247 |
int event, error;
SOCKET socket;
TcpState *statePtr;
int info_found = 0;
TcpFdList *fds = NULL;
ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
#ifdef _WIN64
| | | | | | 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 |
int event, error;
SOCKET socket;
TcpState *statePtr;
int info_found = 0;
TcpFdList *fds = NULL;
ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
#ifdef _WIN64
GetWindowLongPtrW(hwnd, GWLP_USERDATA);
#else
GetWindowLongW(hwnd, GWL_USERDATA);
#endif
switch (message) {
default:
return DefWindowProcW(hwnd, message, wParam, lParam);
break;
case WM_CREATE:
/*
* Store the initial tsdPtr, it's from a different thread, so it's not
* directly accessible, but needed.
*/
#ifdef _WIN64
SetWindowLongPtr(hwnd, GWLP_USERDATA,
(LONG_PTR) ((LPCREATESTRUCT)lParam)->lpCreateParams);
#else
SetWindowLongW(hwnd, GWL_USERDATA,
(LONG) ((LPCREATESTRUCT)lParam)->lpCreateParams);
#endif
break;
case WM_DESTROY:
PostQuitMessage(0);
break;
|
| ︙ | ︙ |
Changes to win/tclWinTest.c.
| ︙ | ︙ | |||
132 133 134 135 136 137 138 |
* that we do not explicitly call Tcl_ServiceEvent().
*/
done = 0;
while (!done) {
MSG msg;
| | | | 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 |
* that we do not explicitly call Tcl_ServiceEvent().
*/
done = 0;
while (!done) {
MSG msg;
if (!GetMessageW(&msg, NULL, 0, 0)) {
/*
* The application is exiting, so repost the quit message and
* start unwinding.
*/
PostQuitMessage((int) msg.wParam);
break;
}
TranslateMessage(&msg);
DispatchMessageW(&msg);
}
(void) Tcl_SetServiceMode(oldMode);
framePtr = oldFramePtr;
} else {
Tcl_AppendResult(interp, "bad option \"", Tcl_GetString(objv[1]),
"\": must be done or wait", NULL);
return TCL_ERROR;
|
| ︙ | ︙ |
Changes to win/tclWinThrd.c.
| ︙ | ︙ | |||
678 679 680 681 682 683 684 |
TclpMasterLock();
/*
* Create the per-thread event and queue pointers.
*/
if (tsdPtr->flags == WIN_THREAD_UNINIT) {
| | | 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 |
TclpMasterLock();
/*
* Create the per-thread event and queue pointers.
*/
if (tsdPtr->flags == WIN_THREAD_UNINIT) {
tsdPtr->condEvent = CreateEventW(NULL, TRUE /* manual reset */,
FALSE /* non signaled */, NULL);
tsdPtr->nextPtr = NULL;
tsdPtr->prevPtr = NULL;
tsdPtr->flags = WIN_THREAD_RUNNING;
doExit = 1;
}
TclpMasterUnlock();
|
| ︙ | ︙ |
Changes to win/tclWinTime.c.
| ︙ | ︙ | |||
166 167 168 169 170 171 172 | *---------------------------------------------------------------------- * * TclpGetClicks -- * * This procedure returns a value that represents the highest resolution * clock available on the system. There are no guarantees on what the * resolution will be. In Tcl we will call this value a "click". The | | | 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 | *---------------------------------------------------------------------- * * TclpGetClicks -- * * This procedure returns a value that represents the highest resolution * clock available on the system. There are no guarantees on what the * resolution will be. In Tcl we will call this value a "click". The * start time is also system dependent. * * Results: * Number of clicks from some start time. * * Side effects: * None. * |
| ︙ | ︙ | |||
516 517 518 519 520 521 522 |
* calibrate it.
*/
if (timeInfo.perfCounterAvailable) {
DWORD id;
InitializeCriticalSection(&timeInfo.cs);
| | | | 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 |
* calibrate it.
*/
if (timeInfo.perfCounterAvailable) {
DWORD id;
InitializeCriticalSection(&timeInfo.cs);
timeInfo.readyEvent = CreateEventW(NULL, FALSE, FALSE, NULL);
timeInfo.exitEvent = CreateEventW(NULL, FALSE, FALSE, NULL);
timeInfo.calibrationThread = CreateThread(NULL, 256,
CalibrationThread, (LPVOID) NULL, 0, &id);
SetThreadPriority(timeInfo.calibrationThread,
THREAD_PRIORITY_HIGHEST);
/*
* Wait for the thread just launched to start running, and
|
| ︙ | ︙ |