diff options
Diffstat (limited to 'win')
-rw-r--r-- | win/Makefile.in | 207 | ||||
-rw-r--r-- | win/README | 2 | ||||
-rwxr-xr-x[-rw-r--r--] | win/buildall.vc.bat | 0 | ||||
-rw-r--r-- | win/cat.c | 6 | ||||
-rwxr-xr-x | win/configure | 131 | ||||
-rw-r--r-- | win/configure.ac | 14 | ||||
-rw-r--r-- | win/makefile.vc | 207 | ||||
-rw-r--r-- | win/nmakehlp.c | 4 | ||||
-rw-r--r-- | win/rules.vc | 216 | ||||
-rw-r--r-- | win/targets.vc | 2 | ||||
-rw-r--r-- | win/tcl.dsp | 12 | ||||
-rw-r--r-- | win/tcl.m4 | 14 | ||||
-rw-r--r-- | win/tclWin32Dll.c | 48 | ||||
-rw-r--r-- | win/tclWinChan.c | 12 | ||||
-rw-r--r-- | win/tclWinConsole.c | 267 | ||||
-rw-r--r-- | win/tclWinDde.c | 321 | ||||
-rw-r--r-- | win/tclWinError.c | 4 | ||||
-rw-r--r-- | win/tclWinFCmd.c | 382 | ||||
-rw-r--r-- | win/tclWinFile.c | 628 | ||||
-rw-r--r-- | win/tclWinInit.c | 37 | ||||
-rw-r--r-- | win/tclWinInt.h | 10 | ||||
-rw-r--r-- | win/tclWinLoad.c | 9 | ||||
-rw-r--r-- | win/tclWinNotify.c | 47 | ||||
-rw-r--r-- | win/tclWinPanic.c | 6 | ||||
-rw-r--r-- | win/tclWinPipe.c | 572 | ||||
-rw-r--r-- | win/tclWinPort.h | 29 | ||||
-rw-r--r-- | win/tclWinReg.c | 176 | ||||
-rw-r--r-- | win/tclWinSerial.c | 122 | ||||
-rw-r--r-- | win/tclWinSock.c | 30 | ||||
-rw-r--r-- | win/tclWinTest.c | 50 | ||||
-rw-r--r-- | win/tclWinThrd.c | 2 | ||||
-rw-r--r-- | win/tclWinTime.c | 466 |
32 files changed, 2727 insertions, 1306 deletions
diff --git a/win/Makefile.in b/win/Makefile.in index 8199a40..29af7b7 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -23,6 +23,7 @@ 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 @@ -81,7 +82,7 @@ CFLAGS_OPTIMIZE = @CFLAGS_OPTIMIZE@ #CFLAGS = $(CFLAGS_DEBUG) #CFLAGS = $(CFLAGS_OPTIMIZE) #CFLAGS = $(CFLAGS_DEBUG) $(CFLAGS_OPTIMIZE) -CFLAGS = @CFLAGS@ @CFLAGS_DEFAULT@ -DUNICODE -D_UNICODE -D_ATL_XP_TARGETING +CFLAGS = @CFLAGS@ @CFLAGS_DEFAULT@ -D_ATL_XP_TARGETING -DMP_FIXED_CUTOFFS -DMP_NO_STDINT -DMP_WUR= # To compile without backward compatibility and deprecated code uncomment the # following @@ -96,7 +97,7 @@ COMPILE_DEBUG_FLAGS = SRC_DIR = @srcdir@ ROOT_DIR = @srcdir@/.. -TOP_DIR = $(shell cd @srcdir@/..; pwd -P) +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 @@ -116,6 +117,7 @@ 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) @@ -150,7 +152,13 @@ DDE_LIB_FILE = @LIBPREFIX@tcldde$(DDEVER)${LIBSUFFIX} REG_DLL_FILE = tclreg$(REGVER)${DLLSUFFIX} REG_LIB_FILE = @LIBPREFIX@tclreg$(REGVER)${LIBSUFFIX} TEST_DLL_FILE = tcltest$(VER)${DLLSUFFIX} +TEST_EXE_FILE = tcltest${EXESUFFIX} TEST_LIB_FILE = @LIBPREFIX@tcltest$(VER)${LIBSUFFIX} +TEST_LOAD_PRMS = lappend ::auto_path {$(ROOT_DIR_WIN_NATIVE)/tests};\ + package ifneeded dde 1.4.2 [list load [file normalize ${DDE_DLL_FILE}] dde];\ + package ifneeded registry 1.3.4 [list load [file normalize ${REG_DLL_FILE}] registry] +TEST_LOAD_FACILITIES = package ifneeded Tcltest ${VERSION}@TCL_PATCH_LEVEL@ [list load [file normalize ${TEST_DLL_FILE}] Tcltest];\ + $(TEST_LOAD_PRMS) ZLIB_DLL_FILE = zlib1.dll SHARED_LIBRARIES = $(TCL_DLL_FILE) @ZLIB_DLL_FILE@ @@ -201,6 +209,7 @@ MKDIR = mkdir -p SHELL = @SHELL@ RM = rm -f COPY = cp +LN = ln ### # Tip 430 - ZipFS Modifications @@ -308,8 +317,8 @@ GENERIC_OBJS = \ tclLiteral.$(OBJEXT) \ tclListObj.$(OBJEXT) \ tclLoad.$(OBJEXT) \ + tclMainW.$(OBJEXT) \ tclMain.$(OBJEXT) \ - tclMain2.$(OBJEXT) \ tclNamesp.$(OBJEXT) \ tclNotify.$(OBJEXT) \ tclOO.$(OBJEXT) \ @@ -352,10 +361,6 @@ GENERIC_OBJS = \ tclZlib.$(OBJEXT) TOMMATH_OBJS = \ - bncore.${OBJEXT} \ - bn_reverse.${OBJEXT} \ - bn_fast_s_mp_mul_digs.${OBJEXT} \ - bn_fast_s_mp_sqr.${OBJEXT} \ bn_mp_add.${OBJEXT} \ bn_mp_add_d.${OBJEXT} \ bn_mp_and.${OBJEXT} \ @@ -374,20 +379,18 @@ TOMMATH_OBJS = \ bn_mp_div_2d.${OBJEXT} \ bn_mp_div_3.${OBJEXT} \ bn_mp_exch.${OBJEXT} \ - bn_mp_expt_d.${OBJEXT} \ - bn_mp_expt_d_ex.${OBJEXT} \ - bn_mp_get_int.${OBJEXT} \ - bn_mp_get_long.${OBJEXT} \ - bn_mp_get_long_long.${OBJEXT} \ + bn_mp_expt_u32.${OBJEXT} \ + bn_mp_get_mag_ul.${OBJEXT} \ bn_mp_grow.${OBJEXT} \ bn_mp_init.${OBJEXT} \ bn_mp_init_copy.${OBJEXT} \ + bn_mp_init_l.${OBJEXT} \ + bn_mp_init_ll.${OBJEXT} \ bn_mp_init_multi.${OBJEXT} \ bn_mp_init_set.${OBJEXT} \ - bn_mp_init_set_int.${OBJEXT} \ bn_mp_init_size.${OBJEXT} \ - bn_mp_karatsuba_mul.${OBJEXT} \ - bn_mp_karatsuba_sqr.$(OBJEXT) \ + bn_mp_init_ul.${OBJEXT} \ + bn_mp_init_ull.${OBJEXT} \ bn_mp_lshd.${OBJEXT} \ bn_mp_mod.${OBJEXT} \ bn_mp_mod_2d.${OBJEXT} \ @@ -402,26 +405,31 @@ TOMMATH_OBJS = \ bn_mp_read_radix.${OBJEXT} \ bn_mp_rshd.${OBJEXT} \ bn_mp_set.${OBJEXT} \ - bn_mp_set_int.${OBJEXT} \ - bn_mp_set_long.${OBJEXT} \ - bn_mp_set_long_long.${OBJEXT} \ + bn_mp_set_l.${OBJEXT} \ + bn_mp_set_ul.${OBJEXT} \ bn_mp_shrink.${OBJEXT} \ bn_mp_sqr.${OBJEXT} \ bn_mp_sqrt.${OBJEXT} \ bn_mp_sub.${OBJEXT} \ bn_mp_sub_d.${OBJEXT} \ - bn_mp_to_unsigned_bin.${OBJEXT} \ - bn_mp_to_unsigned_bin_n.${OBJEXT} \ - bn_mp_toom_mul.${OBJEXT} \ - bn_mp_toom_sqr.${OBJEXT} \ - bn_mp_toradix_n.${OBJEXT} \ - bn_mp_unsigned_bin_size.${OBJEXT} \ + bn_mp_signed_rsh.${OBJEXT} \ + bn_mp_to_ubin.${OBJEXT} \ + bn_mp_to_radix.${OBJEXT} \ + bn_mp_ubin_size.${OBJEXT} \ bn_mp_xor.${OBJEXT} \ bn_mp_zero.${OBJEXT} \ bn_s_mp_add.${OBJEXT} \ + bn_s_mp_balance_mul.$(OBJEXT) \ + bn_s_mp_karatsuba_mul.${OBJEXT} \ + bn_s_mp_karatsuba_sqr.$(OBJEXT) \ bn_s_mp_mul_digs.${OBJEXT} \ + bn_s_mp_mul_digs_fast.${OBJEXT} \ + bn_s_mp_reverse.${OBJEXT} \ + bn_s_mp_sqr_fast.${OBJEXT} \ bn_s_mp_sqr.${OBJEXT} \ - bn_s_mp_sub.${OBJEXT} + bn_s_mp_sub.${OBJEXT} \ + bn_s_mp_toom_mul.${OBJEXT} \ + bn_s_mp_toom_sqr.${OBJEXT} WIN_OBJS = \ @@ -471,7 +479,36 @@ TCL_DOCS = "$(ROOT_DIR_NATIVE)"/doc/*.[13n] all: binaries libraries doc packages -tcltest: $(TCLSH) $(TEST_DLL_FILE) +# 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) @@ -484,20 +521,39 @@ doc: tclzipfile: ${TCL_ZIP_FILE} ${TCL_ZIP_FILE}: ${ZIP_INSTALL_OBJS} ${DDE_DLL_FILE} ${REG_DLL_FILE} - rm -rf ${TCL_VFS_ROOT} - mkdir -p ${TCL_VFS_PATH} - $(COPY) -a $(TOP_DIR)/library/* ${TCL_VFS_PATH} - $(COPY) ${DDE_DLL_FILE} ${TCL_VFS_PATH}/dde - $(COPY) ${REG_DLL_FILE} ${TCL_VFS_PATH}/reg - cd ${TCL_VFS_ROOT} ; ${NATIVE_ZIP} ${ZIP_PROG_OPTIONS} ../${TCL_ZIP_FILE} ${ZIP_PROG_VFSSEARCH} + @rm -rf ${TCL_VFS_ROOT} + @mkdir -p ${TCL_VFS_PATH} + @echo "creating ${TCL_VFS_PATH} (prepare compression)" + @( \ + $(LN) $$(find $(TOP_DIR)/library/* -maxdepth 0 -type f) ${TCL_VFS_PATH}/ && \ + (for D in $$(find $(TOP_DIR)/library/* -maxdepth 0 -type d); do \ + mkdir -p "${TCL_VFS_PATH}/$$(basename $$D)"; \ + $(LN) -s $$D/* ${TCL_VFS_PATH}/$$(basename $$D)/; \ + done) && \ + $(LN) ${TCL_VFS_PATH}/manifest.txt ${TCL_VFS_PATH}/pkgIndex.tcl && \ + $(LN) ${DDE_DLL_FILE} ${TCL_VFS_PATH}/dde/ && \ + $(LN) ${REG_DLL_FILE} ${TCL_VFS_PATH}/reg/ \ + ) || ( \ + $(COPY) -a $(TOP_DIR)/library/* ${TCL_VFS_PATH}; \ + $(COPY) -a ${TCL_VFS_PATH}/manifest.txt ${TCL_VFS_PATH}/pkgIndex.tcl; \ + $(COPY) ${DDE_DLL_FILE} ${TCL_VFS_PATH}/dde; \ + $(COPY) ${REG_DLL_FILE} ${TCL_VFS_PATH}/reg; \ + ) + (zip=`(realpath '${NATIVE_ZIP}' || readlink -m '${NATIVE_ZIP}') 2>/dev/null || \ + (echo '${NATIVE_ZIP}' | sed "s?^\./?$$(pwd)/?")`; \ + cd ${TCL_VFS_ROOT} && \ + $$zip ${ZIP_PROG_OPTIONS} ../${TCL_ZIP_FILE} ${ZIP_PROG_VFSSEARCH} >/dev/null && \ + echo "${TCL_ZIP_FILE} successful created with $$zip" && \ + cd ..) $(TCLSH): $(TCLSH_OBJS) @LIBRARIES@ $(TCL_STUB_LIB_FILE) tclsh.$(RES) $(CC) $(CFLAGS) $(TCLSH_OBJS) $(TCL_LIB_FILE) $(TCL_STUB_LIB_FILE) $(LIBS) \ tclsh.$(RES) $(CC_EXENAME) $(LDFLAGS_CONSOLE) + $(COPY) tclsh.exe.manifest $(TCLSH).manifest @VC_MANIFEST_EMBED_EXE@ cat32.$(OBJEXT): cat.c - $(CC) -c $(CC_SWITCHES) @DEPARG@ $(CC_OBJNAME) + $(CC) -c $(CC_SWITCHES) -DUNICODE -D_UNICODE @DEPARG@ $(CC_OBJNAME) $(CAT32): cat32.$(OBJEXT) $(CC) $(CFLAGS) cat32.$(OBJEXT) $(CC_EXENAME) $(LIBS) $(LDFLAGS_CONSOLE) @@ -513,11 +569,13 @@ ${TCL_STUB_LIB_FILE}: ${STUB_OBJS} ${TCL_DLL_FILE}: ${TCL_OBJS} tcl.$(RES) @ZLIB_DLL_FILE@ ${TCL_ZIP_FILE} @$(RM) ${TCL_DLL_FILE} $(TCL_LIB_FILE) @MAKE_DLL@ ${TCL_OBJS} tcl.$(RES) $(SHLIB_LD_LIBS) + $(COPY) tclsh.exe.manifest ${TCL_DLL_FILE}.manifest @VC_MANIFEST_EMBED_DLL@ -ifeq (${ZIPFS_BUILD},1) - cat ${TCL_ZIP_FILE} >> ${TCL_DLL_FILE} - ${NATIVE_ZIP} -A ${TCL_DLL_FILE} -endif + @if test "${ZIPFS_BUILD}" = "1" ; then \ + cat ${TCL_ZIP_FILE} >> ${TCL_DLL_FILE}; \ + ${NATIVE_ZIP} -A ${TCL_DLL_FILE} \ + || echo 'ignore zip-error by adjust sfx process (not executable?)'; \ + fi ${TCL_LIB_FILE}: ${TCL_OBJS} ${DDE_OBJS} ${REG_OBJS} @$(RM) ${TCL_LIB_FILE} @@ -526,13 +584,22 @@ ${TCL_LIB_FILE}: ${TCL_OBJS} ${DDE_OBJS} ${REG_OBJS} ${DDE_DLL_FILE}: ${TCL_STUB_LIB_FILE} ${DDE_OBJS} @MAKE_DLL@ ${DDE_OBJS} $(TCL_STUB_LIB_FILE) $(SHLIB_LD_LIBS) + $(COPY) tclsh.exe.manifest ${DDE_DLL_FILE}.manifest ${REG_DLL_FILE}: ${TCL_STUB_LIB_FILE} ${REG_OBJS} @MAKE_DLL@ ${REG_OBJS} $(TCL_STUB_LIB_FILE) $(SHLIB_LD_LIBS) + $(COPY) tclsh.exe.manifest ${REG_DLL_FILE}.manifest ${TEST_DLL_FILE}: ${TCL_STUB_LIB_FILE} ${TCLTEST_OBJS} @$(RM) ${TEST_DLL_FILE} ${TEST_LIB_FILE} @MAKE_DLL@ ${TCLTEST_OBJS} $(TCL_STUB_LIB_FILE) $(SHLIB_LD_LIBS) + $(COPY) tclsh.exe.manifest ${TEST_DLL_FILE}.manifest + +${TEST_EXE_FILE}: ${TCL_STUB_LIB_FILE} ${TCLTEST_OBJS} tclTestMain.${OBJEXT} + @$(RM) ${TEST_EXE_FILE} + $(CC) $(CFLAGS) $(TCLTEST_OBJS) tclTestMain.$(OBJEXT) $(TCL_LIB_FILE) $(TCL_STUB_LIB_FILE) $(LIBS) \ + tclsh.$(RES) $(CC_EXENAME) $(LDFLAGS_CONSOLE) + $(COPY) tclsh.exe.manifest ${TEST_EXE_FILE}.manifest # use pre-built zlib1.dll ${ZLIB_DLL_FILE}: ${TCL_STUB_LIB_FILE} @@ -551,17 +618,26 @@ ${ZLIB_DLL_FILE}: ${TCL_STUB_LIB_FILE} # 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) -testMain.${OBJEXT}: tclAppInit.c - $(CC) -c $(CC_SWITCHES) -DTCL_TEST @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) -tclMain2.${OBJEXT}: tclMain.c - $(CC) -c $(CC_SWITCHES) -DBUILD_tcl -DTCL_ASCII_MAIN @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 @@ -584,17 +660,17 @@ tclZipfs.${OBJEXT}: $(GENERIC_DIR)/tclZipfs.c tclPkgConfig.${OBJEXT}: tclPkgConfig.c $(CC) -c $(CC_SWITCHES) \ - -DCFG_INSTALL_LIBDIR=\"$(LIB_INSTALL_DIR_NATIVE)\" \ - -DCFG_INSTALL_BINDIR=\"$(BIN_INSTALL_DIR_NATIVE)\" \ - -DCFG_INSTALL_SCRDIR=\"$(SCRIPT_INSTALL_DIR_NATIVE)\" \ - -DCFG_INSTALL_INCDIR=\"$(INCLUDE_INSTALL_DIR_NATIVE)\" \ - -DCFG_INSTALL_DOCDIR=\"$(MAN_INSTALL_DIR)\" \ + -DCFG_INSTALL_LIBDIR="\"$(LIB_INSTALL_DIR_NATIVE)\"" \ + -DCFG_INSTALL_BINDIR="\"$(BIN_INSTALL_DIR_NATIVE)\"" \ + -DCFG_INSTALL_SCRDIR="\"$(SCRIPT_INSTALL_DIR_NATIVE)\"" \ + -DCFG_INSTALL_INCDIR="\"$(INCLUDE_INSTALL_DIR_NATIVE)\"" \ + -DCFG_INSTALL_DOCDIR="\"$(MAN_INSTALL_DIR)\"" \ \ - -DCFG_RUNTIME_LIBDIR=\"$(libdir_native)\" \ - -DCFG_RUNTIME_BINDIR=\"$(bindir_native)\" \ - -DCFG_RUNTIME_SCRDIR=\"$(TCL_LIBRARY_NATIVE)\" \ - -DCFG_RUNTIME_INCDIR=\"$(includedir_native)\" \ - -DCFG_RUNTIME_DOCDIR=\"$(mandir_native)\" \ + -DCFG_RUNTIME_LIBDIR="\"$(libdir_native)\"" \ + -DCFG_RUNTIME_BINDIR="\"$(bindir_native)\"" \ + -DCFG_RUNTIME_SCRDIR="\"$(TCL_LIBRARY_NATIVE)\"" \ + -DCFG_RUNTIME_INCDIR="\"$(includedir_native)\"" \ + -DCFG_RUNTIME_DOCDIR="\"$(mandir_native)\"" \ -DCFG_RUNTIME_DLLFILE="\"$(TCL_DLL_FILE)\"" \ -DCFG_RUNTIME_ZIPFILE="\"$(TCL_ZIP_FILE)\"" \ -DBUILD_tcl \ @@ -641,7 +717,7 @@ deflate.$(HOST_OBJEXT): $(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/deflate.c ioapi.$(HOST_OBJEXT): - $(HOST_CC) -o $@ -DIOAPI_NO_64 -I$(ZLIB_DIR) -I$(ZLIB_DIR)/contrib/minizip -c $(ZLIB_DIR)/contrib/minizip/ioapi.c + $(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 @@ -671,7 +747,7 @@ zutil.$(HOST_OBJEXT): $(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/zutil.c minizip.$(HOST_OBJEXT): - $(HOST_CC) -o $@ -I$(ZLIB_DIR) -DIOAPI_NO_64 -I$(ZLIB_DIR)/contrib/minizip -c $(ZLIB_DIR)/contrib/minizip/minizip.c + $(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) @@ -707,7 +783,7 @@ INSTALL_TARGETS = $(INSTALL_BASE_TARGETS) $(INSTALL_DOC_TARGETS) $(INSTALL_DEV_T install: $(INSTALL_TARGETS) install-binaries: binaries - @for i in "$(LIB_INSTALL_DIR)" "$(BIN_INSTALL_DIR)" ; \ + @for i in "$(LIB_INSTALL_DIR)" "$(BIN_INSTALL_DIR)"; \ do \ if [ ! -d $$i ] ; then \ echo "Making directory $$i"; \ @@ -797,13 +873,13 @@ install-libraries: libraries install-tzdata install-msgs @echo "Installing package msgcat 1.7.0 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.7/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)/../tcl8/8.5/tcltest-2.4.0.tm; + @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/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)/../tcl8/8.4/platform-1.0.14.tm; @echo "Installing package platform::shell 1.1.4 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/platform/shell.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.4/platform/shell-1.1.4.tm; @echo "Installing encodings"; - @for i in $(ROOT_DIR)/library/encoding/*.enc ; do \ + @for i in $(ROOT_DIR)/library/encoding/*.enc; do \ $(COPY) "$$i" "$(SCRIPT_INSTALL_DIR)/encoding"; \ done; @@ -824,7 +900,8 @@ install-headers: do \ if [ ! -d "$$i" ] ; then \ echo "Making directory $$i"; \ - $(INSTALL_DATA_DIR) "$$i"; \ + $(MKDIR) "$$i"; \ + chmod 755 "$$i"; \ else true; \ fi; \ done; @@ -863,21 +940,15 @@ install-private-headers: libraries test: test-tcl test-packages -test-tcl: binaries $(TCLSH) $(CAT32) $(TEST_DLL_FILE) +test-tcl: tcltest TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \ $(WINE) ./$(TCLSH) "$(ROOT_DIR_NATIVE)/tests/all.tcl" $(TESTFLAGS) \ - -load "package ifneeded Tcltest ${VERSION}@TCL_PATCH_LEVEL@ [list load [file normalize ${TEST_DLL_FILE}] Tcltest]; \ - package ifneeded tcltests 0.1 \"[list source [file normalize $(ROOT_DIR_NATIVE)/tests/tcltests.tcl]];package provide tcltests 0.1\"; \ - package ifneeded dde 1.4.1 [list load [file normalize ${DDE_DLL_FILE}] dde]; \ - package ifneeded registry 1.3.3 [list load [file normalize ${REG_DLL_FILE}] registry]" | $(WINE) ./$(CAT32) + -load "$(TEST_LOAD_FACILITIES)" # Useful target to launch a built tclsh with the proper path,... -runtest: binaries $(TCLSH) $(TEST_DLL_FILE) +runtest: tcltest @TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \ - $(WINE) ./$(TCLSH) $(TESTFLAGS) -load "package ifneeded Tcltest ${VERSION}@TCL_PATCH_LEVEL@ [list load [file normalize ${TEST_DLL_FILE}] Tcltest]; \ - package ifneeded tcltests 0.1 \"[list source [file normalize $(ROOT_DIR_NATIVE)/tests/tcltests.tcl]];package provide tcltests 0.1\"; \ - package ifneeded dde 1.4.1 [list load [file normalize ${DDE_DLL_FILE}] dde]; \ - package ifneeded registry 1.3.3 [list load [file normalize ${REG_DLL_FILE}] registry]" $(SCRIPT) + $(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` @@ -901,7 +972,7 @@ cleanhelp: clean: cleanhelp clean-packages $(RM) *.lib *.a *.exp *.dll *.$(RES) *.${OBJEXT} *~ \#* TAGS a.out - $(RM) $(TCLSH) $(CAT32) + $(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 @@ -93,7 +93,7 @@ tests are timing dependent and will fail from time to time. If a test is failing consistently, please send us a bug report with as much detail as you can manage to our tracker: - http://core.tcl.tk/tcl/reportlist + https://core.tcl-lang.org/tcl/reportlist In order to run the test suite, you build the "test" target using the appropriate makefile for your compiler. diff --git a/win/buildall.vc.bat b/win/buildall.vc.bat index cb136be..cb136be 100644..100755 --- a/win/buildall.vc.bat +++ b/win/buildall.vc.bat @@ -28,14 +28,14 @@ _tmain(void) const char *err; while (1) { - n = read(0, buf, sizeof(buf)); + n = _read(0, buf, sizeof(buf)); if (n <= 0) { break; } - write(1, buf, n); + _write(1, buf, n); } err = (sizeof(int) == 2) ? "stderr16" : "stderr32"; - write(2, err, strlen(err)); + _write(2, err, (unsigned int)strlen(err)); return 0; } diff --git a/win/configure b/win/configure index 21c3cc7..ad107c8 100755 --- a/win/configure +++ b/win/configure @@ -778,6 +778,7 @@ ac_user_opts=' enable_option_checking with_encoding enable_shared +enable_time64bit enable_64bit enable_zipfs enable_symbols @@ -1400,6 +1401,7 @@ Optional Features: --disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no) --enable-FEATURE[=ARG] include FEATURE [ARG=yes] --enable-shared build and link with shared libraries (default: on) + --enable-time64bit force 64-bit time_t for 32-bit build (default: off) --enable-64bit enable 64bit support (where applicable) --enable-zipfs build with Zipfs support (default: on) --enable-symbols build with debugging symbols (default: off) @@ -1695,6 +1697,93 @@ $as_echo "$ac_res" >&6; } } # ac_fn_c_check_header_compile +# ac_fn_c_check_header_mongrel LINENO HEADER VAR INCLUDES +# ------------------------------------------------------- +# Tests whether HEADER exists, giving a warning if it cannot be compiled using +# the include files in INCLUDES and setting the cache variable VAR +# accordingly. +ac_fn_c_check_header_mongrel () +{ + as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + if eval \${$3+:} false; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 +$as_echo_n "checking for $2... " >&6; } +if eval \${$3+:} false; then : + $as_echo_n "(cached) " >&6 +fi +eval ac_res=\$$3 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 +$as_echo "$ac_res" >&6; } +else + # Is the header compilable? +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking $2 usability" >&5 +$as_echo_n "checking $2 usability... " >&6; } +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +$4 +#include <$2> +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + ac_header_compiler=yes +else + ac_header_compiler=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_header_compiler" >&5 +$as_echo "$ac_header_compiler" >&6; } + +# Is the header present? +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking $2 presence" >&5 +$as_echo_n "checking $2 presence... " >&6; } +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include <$2> +_ACEOF +if ac_fn_c_try_cpp "$LINENO"; then : + ac_header_preproc=yes +else + ac_header_preproc=no +fi +rm -f conftest.err conftest.i conftest.$ac_ext +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_header_preproc" >&5 +$as_echo "$ac_header_preproc" >&6; } + +# So? What about this header? +case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in #(( + yes:no: ) + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: accepted by the compiler, rejected by the preprocessor!" >&5 +$as_echo "$as_me: WARNING: $2: accepted by the compiler, rejected by the preprocessor!" >&2;} + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: proceeding with the compiler's result" >&5 +$as_echo "$as_me: WARNING: $2: proceeding with the compiler's result" >&2;} + ;; + no:yes:* ) + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: present but cannot be compiled" >&5 +$as_echo "$as_me: WARNING: $2: present but cannot be compiled" >&2;} + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: check for missing prerequisite headers?" >&5 +$as_echo "$as_me: WARNING: $2: check for missing prerequisite headers?" >&2;} + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: see the Autoconf documentation" >&5 +$as_echo "$as_me: WARNING: $2: see the Autoconf documentation" >&2;} + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: section \"Present But Cannot Be Compiled\"" >&5 +$as_echo "$as_me: WARNING: $2: section \"Present But Cannot Be Compiled\"" >&2;} + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: proceeding with the compiler's result" >&5 +$as_echo "$as_me: WARNING: $2: proceeding with the compiler's result" >&2;} + ;; +esac + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 +$as_echo_n "checking for $2... " >&6; } +if eval \${$3+:} false; then : + $as_echo_n "(cached) " >&6 +else + eval "$3=\$ac_header_compiler" +fi +eval ac_res=\$$3 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 +$as_echo "$ac_res" >&6; } +fi + eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + +} # ac_fn_c_check_header_mongrel + # ac_fn_c_check_type LINENO TYPE VAR INCLUDES # ------------------------------------------- # Tests whether TYPE exists after having included INCLUDES, setting cache @@ -3749,6 +3838,25 @@ $as_echo "#define STATIC_BUILD 1" >>confdefs.h #-------------------------------------------------------------------- +# Check whether --enable-time64bit was given. +#-------------------------------------------------------------------- + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking force of 64-bit time_t" >&5 +$as_echo_n "checking force of 64-bit time_t... " >&6; } +# Check whether --enable-time64bit was given. +if test "${enable_time64bit+set}" = set; then : + enableval=$enable_time64bit; tcl_ok=$enableval +else + tcl_ok=no +fi + +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: \"$tcl_ok\"" >&5 +$as_echo "\"$tcl_ok\"" >&6; } +if test "$tcl_ok" = "yes"; then + CFLAGS="${CFLAGS} -D_USE_64BIT_TIME_T" +fi + +#-------------------------------------------------------------------- # The statements below define a collection of compile flags. This # macro depends on the value of SHARED_BUILD, and should be called # after SC_ENABLE_SHARED checks the configure switches. @@ -4152,7 +4260,7 @@ $as_echo "using shared flags" >&6; } CFLAGS_DEBUG=-g CFLAGS_OPTIMIZE="-O2 -fomit-frame-pointer" - CFLAGS_WARNING="-Wall -Wwrite-strings -Wsign-compare -Wdeclaration-after-statement" + CFLAGS_WARNING="-Wall -Wwrite-strings -Wsign-compare -Wdeclaration-after-statement -Wpointer-arith" LDFLAGS_DEBUG= LDFLAGS_OPTIMIZE= @@ -4503,6 +4611,15 @@ $as_echo "#define HAVE_WINNT_IGNORE_VOID 1" >>confdefs.h fi + ac_fn_c_check_header_mongrel "$LINENO" "stdbool.h" "ac_cv_header_stdbool_h" "$ac_includes_default" +if test "x$ac_cv_header_stdbool_h" = xyes; then : + +$as_echo "#define HAVE_STDBOOL_H 1" >>confdefs.h + +fi + + + # See if the compiler supports casting to a union type. # This is used to stop gcc from printing a compiler # warning when initializing a union member. @@ -4543,6 +4660,10 @@ $as_echo "#define HAVE_CAST_TO_UNION 1" >>confdefs.h fi fi + +$as_echo "#define MP_32BIT 1" >>confdefs.h + + # DL_LIBS is empty, but then we match the Unix version @@ -4855,20 +4976,20 @@ else fi if test -f "$ac_cv_path_zip" ; then - ZIP_PROG="$ac_cv_path_zip " + ZIP_PROG="$ac_cv_path_zip" { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ZIP_PROG" >&5 $as_echo "$ZIP_PROG" >&6; } ZIP_PROG_OPTIONS="-rq" - ZIP_PROG_VFSSEARCH="." + ZIP_PROG_VFSSEARCH="*" { $as_echo "$as_me:${as_lineno-$LINENO}: result: Found INFO Zip in environment" >&5 $as_echo "Found INFO Zip in environment" >&6; } # Use standard arguments for zip else # It is not an error if an installed version of Zip can't be located. # We can use the locally distributed minizip instead - ZIP_PROG="../minizip${EXEEXT_FOR_BUILD}" + ZIP_PROG="./minizip${EXEEXT_FOR_BUILD}" ZIP_PROG_OPTIONS="-o -r" - ZIP_PROG_VFSSEARCH="." + ZIP_PROG_VFSSEARCH="*" ZIP_INSTALL_OBJS="minizip${EXEEXT_FOR_BUILD}" { $as_echo "$as_me:${as_lineno-$LINENO}: result: No zip found on PATH building minizip" >&5 $as_echo "No zip found on PATH building minizip" >&6; } diff --git a/win/configure.ac b/win/configure.ac index 7b63c61..82d713a 100644 --- a/win/configure.ac +++ b/win/configure.ac @@ -92,6 +92,20 @@ SC_TCL_CFG_ENCODING SC_ENABLE_SHARED #-------------------------------------------------------------------- +# Check whether --enable-time64bit was given. +#-------------------------------------------------------------------- + +AC_MSG_CHECKING([force of 64-bit time_t]) +AC_ARG_ENABLE(time64bit, + AC_HELP_STRING([--enable-time64bit], + [force 64-bit time_t for 32-bit build (default: off)]), + [tcl_ok=$enableval], [tcl_ok=no]) +AC_MSG_RESULT("$tcl_ok") +if test "$tcl_ok" = "yes"; then + CFLAGS="${CFLAGS} -D_USE_64BIT_TIME_T" +fi + +#-------------------------------------------------------------------- # The statements below define a collection of compile flags. This # macro depends on the value of SHARED_BUILD, and should be called # after SC_ENABLE_SHARED checks the configure switches. diff --git a/win/makefile.vc b/win/makefile.vc index 1278a41..44597a3 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -16,7 +16,7 @@ # General usage:
# nmake [-nologo] -f makefile.vc [TARGET|MACRODEF [TARGET|MACRODEF] [...]]
#
-# For MACRODEF, see TIP 477 (https://core.tcl.tk/tips/doc/trunk/tip/477.md)
+# For MACRODEF, see TIP 477 (https://core.tcl-lang.org/tips/doc/trunk/tip/477.md)
# or examine Sections 6-8 in rules.vc.
#
# Possible values of TARGET are:
@@ -51,6 +51,71 @@ # vcvars32.bat according to the instructions for it. This can also
# turn on the 64-bit compiler, if your SDK has it.
#
+# Basic macros and options usable on the commandline (see rules.vc for more info):
+# OPTS=msvcrt,static,staticpkg,symbols,profile,unchecked,time64bit,utfmax,none
+# Sets special options for the core. The default is for none.
+# Any combination of the above may be used (comma separated).
+# 'none' will over-ride everything to nothing.
+#
+# msvcrt = Affects the static option only to switch it from
+# using libcmt(d) as the C runtime [by default] to
+# msvcrt(d). This is useful for static embedding
+# support.
+# static = Builds a static library of the core instead of a
+# dll. The shell will be static (and large), as well.
+# staticpkg= Affects the static option only to switch
+# tclshXX.exe to have the dde and reg extension linked
+# inside it.
+# thrdalloc = Use the thread allocator (shared global free pool).
+# symbols = Adds symbols for step debugging.
+# profile = Adds profiling hooks. Map file is assumed.
+# unchecked = Allows a symbols build to not use the debug
+# enabled runtime (msvcrt.dll not msvcrtd.dll
+# or libcmt.lib not libcmtd.lib).
+# time64bit = Forces a build using 64-bit time_t for 32-bit build
+# (CRT library should support this).
+# utfmax = Forces Tcl_UniChar to be a 32-bit quantity in stead
+# of 16-bits
+#
+# STATS=compdbg,memdbg,none
+# Sets optional memory and bytecode compiler debugging code added
+# to the core. The default is for none. Any combination of the
+# above may be used (comma separated). 'none' will over-ride
+# everything to nothing.
+#
+# compdbg = Enables byte compilation logging.
+# memdbg = Enables the debugging memory allocator.
+#
+# CHECKS=64bit,fullwarn,nodep,none
+# Sets special macros for checking compatibility.
+#
+# 64bit = Enable 64bit portability warnings (if available)
+# fullwarn = Builds with full compiler and link warnings enabled.
+# Very verbose.
+# nodep = Turns off compatibility macros to ensure the core
+# isn't being built with deprecated functions.
+#
+# MACHINE=(ALPHA|AMD64|IA64|IX86)
+# Set the machine type used for the compiler, linker, and
+# resource compiler. This hook is needed to tell the tools
+# when alternate platforms are requested. IX86 is the default
+# when not specified. If the CPU environment variable has been
+# set (ie: recent Platform SDK) then MACHINE is set from CPU.
+#
+# TMP_DIR=<path>
+# OUT_DIR=<path>
+# Hooks to allow the intermediate and output directories to be
+# changed. $(OUT_DIR) is assumed to be
+# $(BINROOT)\(Release|Debug) based on if symbols are requested.
+# $(TMP_DIR) will de $(OUT_DIR)\<buildtype> by default.
+#
+# TESTPAT=<file>
+# Reads the tests requested to be run from this file.
+#
+# CFG_ENCODING=encoding
+# name of encoding for configuration information. Defaults
+# to cp1252
+#
# Examples:
# c:\tcl_src\win\>nmake -f makefile.vc release
# c:\tcl_src\win\>nmake -f makefile.vc test
@@ -195,8 +260,8 @@ COREOBJS = \ $(TMP_DIR)\tclListObj.obj \
$(TMP_DIR)\tclLiteral.obj \
$(TMP_DIR)\tclLoad.obj \
+ $(TMP_DIR)\tclMainW.obj \
$(TMP_DIR)\tclMain.obj \
- $(TMP_DIR)\tclMain2.obj \
$(TMP_DIR)\tclNamesp.obj \
$(TMP_DIR)\tclNotify.obj \
$(TMP_DIR)\tclOO.obj \
@@ -252,10 +317,6 @@ ZLIBOBJS = \ $(TMP_DIR)\zutil.obj
TOMMATHOBJS = \
- $(TMP_DIR)\bncore.obj \
- $(TMP_DIR)\bn_reverse.obj \
- $(TMP_DIR)\bn_fast_s_mp_mul_digs.obj \
- $(TMP_DIR)\bn_fast_s_mp_sqr.obj \
$(TMP_DIR)\bn_mp_add.obj \
$(TMP_DIR)\bn_mp_add_d.obj \
$(TMP_DIR)\bn_mp_and.obj \
@@ -274,20 +335,18 @@ TOMMATHOBJS = \ $(TMP_DIR)\bn_mp_div_2d.obj \
$(TMP_DIR)\bn_mp_div_3.obj \
$(TMP_DIR)\bn_mp_exch.obj \
- $(TMP_DIR)\bn_mp_expt_d.obj \
- $(TMP_DIR)\bn_mp_expt_d_ex.obj \
- $(TMP_DIR)\bn_mp_get_int.obj \
- $(TMP_DIR)\bn_mp_get_long.obj \
- $(TMP_DIR)\bn_mp_get_long_long.obj \
+ $(TMP_DIR)\bn_mp_expt_u32.obj \
+ $(TMP_DIR)\bn_mp_get_mag_ul.obj \
$(TMP_DIR)\bn_mp_grow.obj \
$(TMP_DIR)\bn_mp_init.obj \
$(TMP_DIR)\bn_mp_init_copy.obj \
+ $(TMP_DIR)\bn_mp_init_l.obj \
+ $(TMP_DIR)\bn_mp_init_ll.obj \
$(TMP_DIR)\bn_mp_init_multi.obj \
$(TMP_DIR)\bn_mp_init_set.obj \
- $(TMP_DIR)\bn_mp_init_set_int.obj \
$(TMP_DIR)\bn_mp_init_size.obj \
- $(TMP_DIR)\bn_mp_karatsuba_mul.obj \
- $(TMP_DIR)\bn_mp_karatsuba_sqr.obj \
+ $(TMP_DIR)\bn_mp_init_ul.obj \
+ $(TMP_DIR)\bn_mp_init_ull.obj \
$(TMP_DIR)\bn_mp_lshd.obj \
$(TMP_DIR)\bn_mp_mod.obj \
$(TMP_DIR)\bn_mp_mod_2d.obj \
@@ -302,26 +361,31 @@ TOMMATHOBJS = \ $(TMP_DIR)\bn_mp_read_radix.obj \
$(TMP_DIR)\bn_mp_rshd.obj \
$(TMP_DIR)\bn_mp_set.obj \
- $(TMP_DIR)\bn_mp_set_int.obj \
- $(TMP_DIR)\bn_mp_set_long.obj \
- $(TMP_DIR)\bn_mp_set_long_long.obj \
+ $(TMP_DIR)\bn_mp_set_l.obj \
+ $(TMP_DIR)\bn_mp_set_ul.obj \
$(TMP_DIR)\bn_mp_shrink.obj \
$(TMP_DIR)\bn_mp_sqr.obj \
$(TMP_DIR)\bn_mp_sqrt.obj \
$(TMP_DIR)\bn_mp_sub.obj \
$(TMP_DIR)\bn_mp_sub_d.obj \
- $(TMP_DIR)\bn_mp_to_unsigned_bin.obj \
- $(TMP_DIR)\bn_mp_to_unsigned_bin_n.obj \
- $(TMP_DIR)\bn_mp_toom_mul.obj \
- $(TMP_DIR)\bn_mp_toom_sqr.obj \
- $(TMP_DIR)\bn_mp_toradix_n.obj \
- $(TMP_DIR)\bn_mp_unsigned_bin_size.obj \
+ $(TMP_DIR)\bn_mp_signed_rsh.obj \
+ $(TMP_DIR)\bn_mp_to_ubin.obj \
+ $(TMP_DIR)\bn_mp_to_radix.obj \
+ $(TMP_DIR)\bn_mp_ubin_size.obj \
$(TMP_DIR)\bn_mp_xor.obj \
$(TMP_DIR)\bn_mp_zero.obj \
$(TMP_DIR)\bn_s_mp_add.obj \
+ $(TMP_DIR)\bn_s_mp_balance_mul.obj \
+ $(TMP_DIR)\bn_s_mp_karatsuba_mul.obj \
+ $(TMP_DIR)\bn_s_mp_karatsuba_sqr.obj \
$(TMP_DIR)\bn_s_mp_mul_digs.obj \
+ $(TMP_DIR)\bn_s_mp_mul_digs_fast.obj \
+ $(TMP_DIR)\bn_s_mp_reverse.obj \
$(TMP_DIR)\bn_s_mp_sqr.obj \
- $(TMP_DIR)\bn_s_mp_sub.obj
+ $(TMP_DIR)\bn_s_mp_sqr_fast.obj \
+ $(TMP_DIR)\bn_s_mp_sub.obj \
+ $(TMP_DIR)\bn_s_mp_toom_sqr.obj \
+ $(TMP_DIR)\bn_s_mp_toom_mul.obj
PLATFORMOBJS = \
$(TMP_DIR)\tclWin32Dll.obj \
@@ -361,7 +425,7 @@ 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
+PRJ_DEFINES = /DTCL_TOMMATH /DMP_PREC=4 /Dinline=__inline /DHAVE_ZLIB=1 /D_CRT_SECURE_NO_DEPRECATE /D_CRT_NONSTDC_NO_DEPRECATE /DMP_FIXED_CUTOFFS /DMP_NO_STDINT /DMP_WUR=
# Additional Link libraries needed beyond those in rules.vc
PRJ_LIBS = netapi32.lib user32.lib userenv.lib ws2_32.lib
@@ -386,14 +450,17 @@ dlls: setup $(TCLREGLIB) $(TCLDDELIB) all: setup $(TCLSH) $(TCLSTUBLIB) dlls pkgs
tcltest: setup $(TCLTEST) dlls
install: install-binaries install-libraries install-docs install-pkgs
+!if $(SYMBOLS)
+install: install-pdbs
+!endif
setup: default-setup
test: test-core test-pkgs
test-core: setup $(TCLTEST) dlls
set TCL_LIBRARY=$(ROOT:\=/)/library
$(DEBUGGER) $(TCLTEST) "$(ROOT:\=/)/tests/all.tcl" $(TESTFLAGS) -loadfile <<
- package ifneeded dde 1.4.1 [list load "$(TCLDDELIB:\=/)" dde]
- package ifneeded registry 1.3.3 [list load "$(TCLREGLIB:\=/)" registry]
+ package ifneeded dde 1.4.2 [list load "$(TCLDDELIB:\=/)" dde]
+ package ifneeded registry 1.3.4 [list load "$(TCLREGLIB:\=/)" registry]
<<
runtest: setup $(TCLTEST) dlls
@@ -578,7 +645,6 @@ $(OUT_DIR)\tcl.nmake: CORE_MACHINE = $(MACHINE)
CORE_DEBUG = $(DEBUG)
CORE_USE_THREAD_ALLOC = $(USE_THREAD_ALLOC)
-CORE_USE_WIDECHAR_API = $(USE_WIDECHAR_API)
<<
#---------------------------------------------------------------------
@@ -588,7 +654,7 @@ CORE_USE_WIDECHAR_API = $(USE_WIDECHAR_API) tclConfig: $(OUT_DIR)\tclConfig.sh
# TBD - is this tclConfig.sh file ever used? The values are incorrect!
-$(OUT_DIR)\tclConfig.sh: $(WINDIR)\tclConfig.sh.in
+$(OUT_DIR)\tclConfig.sh: $(WIN_DIR)\tclConfig.sh.in
@echo Creating tclConfig.sh
@nmakehlp -s << $** >$@
@TCL_DLL_FILE@ $(TCLLIBNAME)
@@ -663,13 +729,13 @@ gendate: # Special case object file targets
#---------------------------------------------------------------------
-$(TMP_DIR)\testMain.obj: $(WINDIR)\tclAppInit.c
- $(cc32) $(appcflags) -DTCL_TEST \
- -DTCL_USE_STATIC_PACKAGES=$(TCL_USE_STATIC_PACKAGES) \
+$(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)\tclMain2.obj: $(GENERICDIR)\tclMain.c
- $(cc32) $(pkgcflags) -DTCL_ASCII_MAIN \
+$(TMP_DIR)\tclMainW.obj: $(GENERICDIR)\tclMain.c
+ $(cc32) $(pkgcflags) /DUNICODE /D_UNICODE \
-Fo$@ $?
$(TMP_DIR)\tclTest.obj: $(GENERICDIR)\tclTest.c
@@ -678,7 +744,7 @@ $(TMP_DIR)\tclTest.obj: $(GENERICDIR)\tclTest.c $(TMP_DIR)\tclTestObj.obj: $(GENERICDIR)\tclTestObj.c
$(cc32) $(appcflags) -Fo$@ $?
-$(TMP_DIR)\tclWinTest.obj: $(WINDIR)\tclWinTest.c
+$(TMP_DIR)\tclWinTest.obj: $(WIN_DIR)\tclWinTest.c
$(CCAPPCMD) $?
$(TMP_DIR)\tclZipfs.obj: $(GENERICDIR)\tclZipfs.c
@@ -689,41 +755,33 @@ $(TMP_DIR)\tclZlib.obj: $(GENERICDIR)\tclZlib.c $(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:\=\\)\"" \
+ /DCFG_INSTALL_LIBDIR="\"$(LIB_INSTALL_DIR:\=\\)\"" \
+ /DCFG_INSTALL_BINDIR="\"$(BIN_INSTALL_DIR:\=\\)\"" \
+ /DCFG_INSTALL_SCRDIR="\"$(SCRIPT_INSTALL_DIR:\=\\)\"" \
+ /DCFG_INSTALL_INCDIR="\"$(INCLUDE_INSTALL_DIR:\=\\)\"" \
+ /DCFG_INSTALL_DOCDIR="\"$(DOC_INSTALL_DIR:\=\\)\"" \
+ /DCFG_RUNTIME_LIBDIR="\"$(LIB_INSTALL_DIR:\=\\)\"" \
+ /DCFG_RUNTIME_BINDIR="\"$(BIN_INSTALL_DIR:\=\\)\"" \
+ /DCFG_RUNTIME_SCRDIR="\"$(SCRIPT_INSTALL_DIR:\=\\)\"" \
+ /DCFG_RUNTIME_INCDIR="\"$(INCLUDE_INSTALL_DIR:\=\\)\"" \
+ /DCFG_RUNTIME_DOCDIR="\"$(DOC_INSTALL_DIR:\=\\)\"" \
+ /DCFG_RUNTIME_DLLFILE="\"$(CFG_RUNTIME_DLLFILE:\=\\)\"" \
+ /DCFG_RUNTIME_ZIPFILE="\"$(CFG_RUNTIME_ZIPFILE:\=\\)\"" \
-Fo$@ $?
-$(TMP_DIR)\tclAppInit.obj: $(WINDIR)\tclAppInit.c
- $(cc32) $(appcflags) \
- -DTCL_USE_STATIC_PACKAGES=$(TCL_USE_STATIC_PACKAGES) \
+$(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: $(WINDIR)\tclWinReg.c
-!if $(STATIC_BUILD)
- $(cc32) $(appcflags) -DSTATIC_BUILD -Fo$@ $?
-!else
- $(cc32) $(appcflags) -DUSE_TCL_STUBS -Fo$@ $?
-!endif
+$(TMP_DIR)\tclWinReg.obj: $(WIN_DIR)\tclWinReg.c
+ $(cc32) $(appcflags) /DUSE_TCL_STUBS -Fo$@ $?
-$(TMP_DIR)\tclWinDde.obj: $(WINDIR)\tclWinDde.c
-!if $(STATIC_BUILD)
- $(cc32) $(appcflags) -DSTATIC_BUILD -Fo$@ $?
-!else
- $(cc32) $(appcflags) -DUSE_TCL_STUBS -Fo$@ $?
-!endif
+$(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
@@ -739,10 +797,10 @@ $(TMP_DIR)\tclTomMathStubLib.obj: $(GENERICDIR)\tclTomMathStubLib.c $(TMP_DIR)\tclOOStubLib.obj: $(GENERICDIR)\tclOOStubLib.c
$(cc32) $(stubscflags) -Fo$@ $?
-$(TMP_DIR)\tclWinPanic.obj: $(WINDIR)\tclWinPanic.c
+$(TMP_DIR)\tclWinPanic.obj: $(WIN_DIR)\tclWinPanic.c
$(cc32) $(stubscflags) -Fo$@ $?
-$(TMP_DIR)\tclsh.exe.manifest: $(WINDIR)\tclsh.exe.manifest.in
+$(TMP_DIR)\tclsh.exe.manifest: $(WIN_DIR)\tclsh.exe.manifest.in
@nmakehlp -s << $** >$@
@MACHINE@ $(MACHINE:IX86=X86)
@TCL_WIN_VERSION@ $(DOTVERSION).0.0
@@ -761,8 +819,8 @@ depend: @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) $(WINDIR),$$(WINDIR) @<<
+ -passthru:"/DBUILD_tcl $(TCL_INCLUDES) $(PRJ_INCLUDES)" $(GENERICDIR),$$(GENERICDIR) \
+ $(COMPATDIR),$$(COMPATDIR) $(TOMMATHDIR),$$(TOMMATHDIR) $(WIN_DIR),$$(WIN_DIR) @<<
$(TCLOBJS)
<<
!endif
@@ -799,7 +857,7 @@ $< $<
<<
-$(TMP_DIR)\tclsh.res: $(TMP_DIR)\tclsh.exe.manifest $(WINDIR)\tclsh.rc
+$(TMP_DIR)\tclsh.res: $(TMP_DIR)\tclsh.exe.manifest $(WIN_DIR)\tclsh.rc
#---------------------------------------------------------------------
@@ -845,8 +903,6 @@ install-libraries: tclConfig tcl-nmake install-msgs install-tzdata @$(CPY) "$(GENERICDIR)\tclPlatDecls.h" "$(INCLUDE_INSTALL_DIR)\"
@$(CPY) "$(GENERICDIR)\tclTomMath.h" "$(INCLUDE_INSTALL_DIR)\"
@$(CPY) "$(GENERICDIR)\tclTomMathDecls.h" "$(INCLUDE_INSTALL_DIR)\"
- @$(CPY) "$(TOMMATHDIR)\tommath_class.h" "$(INCLUDE_INSTALL_DIR)\"
- @$(CPY) "$(TOMMATHDIR)\tommath_superclass.h" "$(INCLUDE_INSTALL_DIR)\"
@echo Installing library files to $(SCRIPT_INSTALL_DIR)
@$(CPY) "$(ROOT)\library\history.tcl" "$(SCRIPT_INSTALL_DIR)\"
@$(CPY) "$(ROOT)\library\init.tcl" "$(SCRIPT_INSTALL_DIR)\"
@@ -859,10 +915,10 @@ install-libraries: tclConfig tcl-nmake install-msgs install-tzdata @$(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) "$(WINDIR)\tclooConfig.sh" "$(LIB_INSTALL_DIR)\"
- @$(CPY) "$(WINDIR)\rules.vc" "$(LIB_INSTALL_DIR)\nmake\"
- @$(CPY) "$(WINDIR)\targets.vc" "$(LIB_INSTALL_DIR)\nmake\"
- @$(CPY) "$(WINDIR)\nmakehlp.c" "$(LIB_INSTALL_DIR)\nmake\"
+ @$(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" \
@@ -919,6 +975,11 @@ install-msgs: @$(TCLSH_NATIVE) "$(ROOT:\=/)/tools/installData.tcl" \
"$(ROOT:\=/)/library/msgs" "$(SCRIPT_INSTALL_DIR)/msgs"
+install-pdbs:
+ @echo Installing debug symbols
+ @$(CPY) "$(OUT_DIR)\*.pdb" "$(BIN_INSTALL_DIR)\"
+# "emacs font-lock highlighting fix
+
#---------------------------------------------------------------------
# Clean up
#---------------------------------------------------------------------
diff --git a/win/nmakehlp.c b/win/nmakehlp.c index 1655d48..fac32ee 100644 --- a/win/nmakehlp.c +++ b/win/nmakehlp.c @@ -643,7 +643,7 @@ SubstituteFile( } /* debug: dump the list */ -#ifdef _DEBUG +#ifndef NDEBUG { int n = 0; list_item_t *p = NULL; @@ -793,7 +793,7 @@ static int LocateDependencyHelper(const char *dir, const char *keypath) static int LocateDependency(const char *keypath) { int i, ret; - static char *paths[] = {"..", "..\\..", "..\\..\\.."}; + static const char *paths[] = {"..", "..\\..", "..\\..\\.."}; for (i = 0; i < (sizeof(paths)/sizeof(paths[0])); ++i) { ret = LocateDependencyHelper(paths[i], keypath); diff --git a/win/rules.vc b/win/rules.vc index fbcb235..2b11b01 100644 --- a/win/rules.vc +++ b/win/rules.vc @@ -6,7 +6,7 @@ # compiler switches, defining common targets and macros. The Tcl makefile
# directly includes this. Extensions include it via "rules-ext.vc".
#
-# See TIP 477 (https://core.tcl.tk/tips/doc/trunk/tip/477.md) for
+# See TIP 477 (https://core.tcl-lang.org/tips/doc/trunk/tip/477.md) for
# detailed documentation.
#
# See the file "license.terms" for information on usage and redistribution
@@ -24,7 +24,7 @@ _RULES_VC = 1 # For modifications that are not backward-compatible, you *must* change
# the major version.
RULES_VERSION_MAJOR = 1
-RULES_VERSION_MINOR = 3
+RULES_VERSION_MINOR = 4
# The PROJECT macro must be defined by parent makefile.
!if "$(PROJECT)" == ""
@@ -162,7 +162,7 @@ MKDIR = mkdir # COMPATDIR - source directory that holds compatibility sources
# DOCDIR - source directory containing documentation files
# GENERICDIR - platform-independent source directory
-# WINDIR - Windows-specific 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
@@ -215,17 +215,15 @@ DEMODIR = $(LIBDIR)\demos DEMODIR = $(ROOT)\demos
!endif
!endif # ifndef DEMODIR
-# Do NOT enclose WINDIR in a !ifndef because Windows always defines
-# WINDIR env var to point to c:\windows!
-# TBD - This is a potentially dangerous conflict, rename WINDIR to
-# something else
-WINDIR = $(ROOT)\win
+# Do NOT use WINDIR because it is Windows internal environment
+# variable to point to c:\windows!
+WIN_DIR = $(ROOT)\win
!ifndef RCDIR
-!if exist("$(WINDIR)\rc")
-RCDIR = $(WINDIR)\rc
+!if exist("$(WIN_DIR)\rc")
+RCDIR = $(WIN_DIR)\rc
!else
-RCDIR = $(WINDIR)
+RCDIR = $(WIN_DIR)
!endif
!endif
RCDIR = $(RCDIR:/=\)
@@ -475,6 +473,21 @@ MACHINE = AMD64 MACHINE=$(ARCH)
!endif
+#---------------------------------------------------------------
+# The PLATFORM_IDENTIFY macro matches the values returned by
+# the Tcl platform::identify command
+!if "$(MACHINE)" == "AMD64"
+PLATFORM_IDENTIFY = win32-x86_64
+!else
+PLATFORM_IDENTIFY = win32-ix86
+!endif
+
+# The MULTIPLATFORM macro controls whether binary extensions are installed
+# in platform-specific directories. Intended to be set/used by extensions.
+!ifndef MULTIPLATFORM_INSTALL
+MULTIPLATFORM_INSTALL = 0
+!endif
+
#------------------------------------------------------------
# Figure out the *host* architecture by reading the registry
@@ -671,6 +684,9 @@ LINKERFLAGS = $(LINKERFLAGS) -ltcg # USE_STUBS - 1 -> compile to use stubs interfaces, 0 -> direct linking
# CONFIG_CHECK - 1 -> check current build configuration against Tcl
# configuration (ignored for Tcl itself)
+# _USE_64BIT_TIME_T - forces a build using 64-bit time_t for 32-bit build
+# (CRT library should support this)
+# TCL_UTF_MAX=6 - forces a build using 32-bit Tcl_UniChar in stead of 16-bit.
# Further, LINKERFLAGS are modified based on above.
# Default values for all the above
@@ -730,6 +746,18 @@ TCL_USE_STATIC_PACKAGES = 1 TCL_USE_STATIC_PACKAGES = 0
!endif
+!if [nmakehlp -f $(OPTS) "time64bit"]
+!message *** Force 64-bit time_t
+_USE_64BIT_TIME_T = 1
+!endif
+
+!if [nmakehlp -f $(OPTS) "utfmax"]
+!message *** Force 32-bit Tcl_UniChar
+TCL_UTF_MAX = 6
+!endif
+
+# Yes, it's weird that the "symbols" option controls DEBUG and
+# the "pdbs" option controls SYMBOLS. That's historical.
!if [nmakehlp -f $(OPTS) "symbols"]
!message *** Doing symbols
DEBUG = 1
@@ -1054,7 +1082,7 @@ TCLLIB = $(OUT_DIR)\$(TCLLIBNAME) TCLSTUBLIBNAME = $(STUBPREFIX)$(VERSION).lib
TCLSTUBLIB = $(OUT_DIR)\$(TCLSTUBLIBNAME)
-TCL_INCLUDES = -I"$(WINDIR)" -I"$(GENERICDIR)"
+TCL_INCLUDES = -I"$(WIN_DIR)" -I"$(GENERICDIR)"
!else # ! $(DOING_TCL)
@@ -1129,7 +1157,7 @@ WISH = $(OUT_DIR)\$(WISHNAME) TKSTUBLIB = $(OUT_DIR)\$(TKSTUBLIBNAME)
TKIMPLIB = $(OUT_DIR)\$(TKIMPLIBNAME)
TKLIB = $(OUT_DIR)\$(TKLIBNAME)
-TK_INCLUDES = -I"$(WINDIR)" -I"$(GENERICDIR)"
+TK_INCLUDES = -I"$(WIN_DIR)" -I"$(GENERICDIR)"
!else # effectively NEED_TK
@@ -1205,8 +1233,13 @@ INCLUDE_INSTALL_DIR = $(_INSTALLDIR)\include !else # extension other than Tk
PRJ_INSTALL_DIR = $(_INSTALLDIR)\$(PROJECT)$(DOTVERSION)
+!if $(MULTIPLATFORM_INSTALL)
+LIB_INSTALL_DIR = $(PRJ_INSTALL_DIR)\$(PLATFORM_IDENTIFY)
+BIN_INSTALL_DIR = $(PRJ_INSTALL_DIR)\$(PLATFORM_IDENTIFY)
+!else
LIB_INSTALL_DIR = $(PRJ_INSTALL_DIR)
BIN_INSTALL_DIR = $(PRJ_INSTALL_DIR)
+!endif
DOC_INSTALL_DIR = $(PRJ_INSTALL_DIR)
SCRIPT_INSTALL_DIR = $(PRJ_INSTALL_DIR)
DEMO_INSTALL_DIR = $(PRJ_INSTALL_DIR)\demos
@@ -1235,82 +1268,72 @@ INCLUDE_INSTALL_DIR = $(_INSTALLDIR)\..\include # 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
+OPTDEFINES = /DTCL_CFGVAL_ENCODING=$(CFG_ENCODING) /DSTDC_HEADERS
!if $(TCL_MEM_DEBUG)
-OPTDEFINES = $(OPTDEFINES) -DTCL_MEM_DEBUG
+OPTDEFINES = $(OPTDEFINES) /DTCL_MEM_DEBUG
!endif
!if $(TCL_COMPILE_DEBUG)
-OPTDEFINES = $(OPTDEFINES) -DTCL_COMPILE_DEBUG -DTCL_COMPILE_STATS
+OPTDEFINES = $(OPTDEFINES) /DTCL_COMPILE_DEBUG /DTCL_COMPILE_STATS
!endif
-!if $(TCL_THREADS) && $(TCL_VERSION) < 86
-OPTDEFINES = $(OPTDEFINES) -DTCL_THREADS=1
-!if $(USE_THREAD_ALLOC)
-OPTDEFINES = $(OPTDEFINES) -DUSE_THREAD_ALLOC=1
+!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
+OPTDEFINES = $(OPTDEFINES) /DSTATIC_BUILD
!endif
!if $(TCL_NO_DEPRECATED)
-OPTDEFINES = $(OPTDEFINES) -DTCL_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
+USE_STUBS_DEFS = /DUSE_TCL_STUBS /DUSE_TCLOO_STUBS
!if $(NEED_TK)
-USE_STUBS_DEFS = $(USE_STUBS_DEFS) -DUSE_TK_STUBS
+USE_STUBS_DEFS = $(USE_STUBS_DEFS) /DUSE_TK_STUBS
!endif
!endif
!endif # USE_STUBS
!if !$(DEBUG)
-OPTDEFINES = $(OPTDEFINES) -DNDEBUG
+OPTDEFINES = $(OPTDEFINES) /DNDEBUG
!if $(OPTIMIZING)
-OPTDEFINES = $(OPTDEFINES) -DTCL_CFG_OPTIMIZED
+OPTDEFINES = $(OPTDEFINES) /DTCL_CFG_OPTIMIZED
!endif
!endif
!if $(PROFILE)
-OPTDEFINES = $(OPTDEFINES) -DTCL_CFG_PROFILED
+OPTDEFINES = $(OPTDEFINES) /DTCL_CFG_PROFILED
!endif
!if "$(MACHINE)" == "AMD64"
-OPTDEFINES = $(OPTDEFINES) -DTCL_CFG_DO64BIT
+OPTDEFINES = $(OPTDEFINES) /DTCL_CFG_DO64BIT
!endif
!if $(VCVERSION) < 1300
-OPTDEFINES = $(OPTDEFINES) -DNO_STRTOI64
+OPTDEFINES = $(OPTDEFINES) /DNO_STRTOI64
!endif
-# _ATL_XP_TARGETING - Newer SDK's need this to build for XP
-COMPILERFLAGS = /D_ATL_XP_TARGETING
-
-# Following is primarily for the benefit of extensions. Tcl 8.5 builds
-# Tcl without /DUNICODE, while 8.6 builds with it defined. When building
-# an extension, it is advisable (but not mandated) to use the same Windows
-# API as the Tcl build. This is accordingly defaulted below. A particular
-# extension can override this by pre-definining USE_WIDECHAR_API.
-!ifndef USE_WIDECHAR_API
-!if $(TCL_VERSION) > 85
-USE_WIDECHAR_API = 1
-!else
-USE_WIDECHAR_API = 0
+!if "$(_USE_64BIT_TIME_T)" == "1"
+OPTDEFINES = $(OPTDEFINES) /D_USE_64BIT_TIME_T
!endif
+!if "$(TCL_UTF_MAX)" == "6"
+OPTDEFINES = $(OPTDEFINES) /DTCL_UTF_MAX=6
!endif
-!if $(USE_WIDECHAR_API)
-COMPILERFLAGS = $(COMPILERFLAGS) /DUNICODE /D_UNICODE
-!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
+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
@@ -1357,7 +1380,7 @@ cwarn = $(cwarn) -wd4311 -wd4312 ### Common compiler options that are architecture specific
!if "$(MACHINE)" == "ARM"
-carch = -D_ARM_WINAPI_PARTITION_DESKTOP_SDK_AVAILABLE
+carch = /D_ARM_WINAPI_PARTITION_DESKTOP_SDK_AVAILABLE
!else
carch =
!endif
@@ -1369,7 +1392,7 @@ cwarn = $(cwarn) -WX INCLUDES = $(TCL_INCLUDES) $(TK_INCLUDES) $(PRJ_INCLUDES)
!if !$(DOING_TCL) && !$(DOING_TK)
-INCLUDES = $(INCLUDES) -I"$(GENERICDIR)" -I"$(WINDIR)" -I"$(COMPATDIR)"
+INCLUDES = $(INCLUDES) -I"$(GENERICDIR)" -I"$(WIN_DIR)" -I"$(COMPATDIR)"
!endif
# These flags are defined roughly in the order of the pre-reform
@@ -1385,13 +1408,13 @@ cflags = -nologo -c $(COMPILERFLAGS) $(carch) $(cwarn) -Fp$(TMP_DIR)^\ $(cdebug) # BUILD_$(PROJECT) macro which should be defined only for the shared
# library *implementation* and not for its caller interface
-appcflags = $(cflags) $(crt) $(INCLUDES) $(TCL_DEFINES) $(PRJ_DEFINES) $(OPTDEFINES) $(USE_STUBS_DEFS)
appcflags_nostubs = $(cflags) $(crt) $(INCLUDES) $(TCL_DEFINES) $(PRJ_DEFINES) $(OPTDEFINES)
-pkgcflags = $(appcflags) $(PKGNAMEFLAGS) -DBUILD_$(PROJECT)
-pkgcflags_nostubs = $(appcflags_nostubs) $(PKGNAMEFLAGS) -DBUILD_$(PROJECT)
+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
+# 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.
@@ -1401,7 +1424,7 @@ pkgcflags_nostubs = $(appcflags_nostubs) $(PKGNAMEFLAGS) -DBUILD_$(PROJECT) # 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)
+stubscflags = $(cflags) $(PKGNAMEFLAGS) $(PRJ_DEFINES) $(OPTDEFINES) -Zl /DSTATIC_BUILD $(INCLUDES) $(USE_STUBS_DEFS)
# Link flags
@@ -1466,13 +1489,13 @@ 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)\"
+ /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)
@@ -1480,9 +1503,15 @@ DEFAULT_BUILD_TARGET = $(PROJECT) default-target: $(DEFAULT_BUILD_TARGET)
+!if $(MULTIPLATFORM_INSTALL)
+default-pkgindex:
+ @echo package ifneeded $(PRJ_PACKAGE_TCLNAME) $(DOTVERSION) \
+ [list load [file join $$dir $(PLATFORM_IDENTIFY) $(PRJLIBNAME)]] > $(OUT_DIR)\pkgIndex.tcl
+!else
default-pkgindex:
@echo package ifneeded $(PRJ_PACKAGE_TCLNAME) $(DOTVERSION) \
[list load [file join $$dir $(PRJLIBNAME)]] > $(OUT_DIR)\pkgIndex.tcl
+!endif
default-pkgindex-tea:
@if exist $(ROOT)\pkgIndex.tcl.in nmakehlp -s << $(ROOT)\pkgIndex.tcl.in > $(OUT_DIR)\pkgIndex.tcl
@@ -1492,15 +1521,26 @@ default-pkgindex-tea: @PKG_LIB_FILE@ $(PRJLIBNAME)
<<
-
default-install: default-install-binaries default-install-libraries
+!if $(SYMBOLS)
+default-install: default-install-pdbs
+!endif
+# Again to deal with historical brokenness, there is some confusion
+# in terminlogy. For extensions, the "install-binaries" was used to
+# locate target directory for *binary shared libraries* and thus
+# the appropriate macro is LIB_INSTALL_DIR since BIN_INSTALL_DIR is
+# for executables (exes). On the other hand the "install-libraries"
+# target is for *scripts* and should have been called "install-scripts".
default-install-binaries: $(PRJLIB)
- @echo Installing binaries to '$(SCRIPT_INSTALL_DIR)'
- @if not exist "$(SCRIPT_INSTALL_DIR)" mkdir "$(SCRIPT_INSTALL_DIR)"
- @$(CPY) $(PRJLIB) "$(SCRIPT_INSTALL_DIR)" >NUL
+ @echo Installing binaries to '$(LIB_INSTALL_DIR)'
+ @if not exist "$(LIB_INSTALL_DIR)" mkdir "$(LIB_INSTALL_DIR)"
+ @$(CPY) $(PRJLIB) "$(LIB_INSTALL_DIR)" >NUL
-default-install-libraries: $(OUT_DIR)\pkgIndex.tcl
+# Alias for default-install-scripts
+default-install-libraries: default-install-scripts
+
+default-install-scripts: $(OUT_DIR)\pkgIndex.tcl
@echo Installing libraries to '$(SCRIPT_INSTALL_DIR)'
@if exist $(LIBDIR) $(CPY) $(LIBDIR)\*.tcl "$(SCRIPT_INSTALL_DIR)"
@echo Installing package index in '$(SCRIPT_INSTALL_DIR)'
@@ -1511,6 +1551,11 @@ default-install-stubs: @if not exist "$(SCRIPT_INSTALL_DIR)" mkdir "$(SCRIPT_INSTALL_DIR)"
@$(CPY) $(PRJSTUBLIB) "$(SCRIPT_INSTALL_DIR)" >NUL
+default-install-pdbs:
+ @echo Installing PDBs to '$(LIB_INSTALL_DIR)'
+ @if not exist "$(LIB_INSTALL_DIR)" mkdir "$(LIB_INSTALL_DIR)"
+ @$(CPY) "$(OUT_DIR)\*.pdb" "$(LIB_INSTALL_DIR)\"
+
default-install-docs-html:
@echo Installing documentation files to '$(DOC_INSTALL_DIR)'
@if not exist "$(DOC_INSTALL_DIR)" mkdir "$(DOC_INSTALL_DIR)"
@@ -1529,20 +1574,20 @@ default-install-demos: default-clean:
@echo Cleaning $(TMP_DIR)\* ...
@if exist $(TMP_DIR)\nul $(RMDIR) $(TMP_DIR)
- @echo Cleaning $(WINDIR)\nmakehlp.obj, nmakehlp.exe ...
- @if exist $(WINDIR)\nmakehlp.obj del $(WINDIR)\nmakehlp.obj
- @if exist $(WINDIR)\nmakehlp.exe del $(WINDIR)\nmakehlp.exe
- @if exist $(WINDIR)\nmakehlp.out del $(WINDIR)\nmakehlp.out
- @echo Cleaning $(WINDIR)\nmhlp-out.txt ...
- @if exist $(WINDIR)\nmhlp-out.txt del $(WINDIR)\nmhlp-out.txt
- @echo Cleaning $(WINDIR)\_junk.pch ...
- @if exist $(WINDIR)\_junk.pch del $(WINDIR)\_junk.pch
- @echo Cleaning $(WINDIR)\vercl.x, vercl.i ...
- @if exist $(WINDIR)\vercl.x del $(WINDIR)\vercl.x
- @if exist $(WINDIR)\vercl.i del $(WINDIR)\vercl.i
- @echo Cleaning $(WINDIR)\versions.vc, version.vc ...
- @if exist $(WINDIR)\versions.vc del $(WINDIR)\versions.vc
- @if exist $(WINDIR)\version.vc del $(WINDIR)\version.vc
+ @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)\* ...
@@ -1634,7 +1679,7 @@ DISABLE_IMPLICIT_RULES = 0 $<
<<
-{$(WINDIR)}.c{$(TMP_DIR)}.obj::
+{$(WIN_DIR)}.c{$(TMP_DIR)}.obj::
$(CCPKGCMD) @<<
$<
<<
@@ -1652,7 +1697,7 @@ $< {$(RCDIR)}.rc{$(TMP_DIR)}.res:
$(RESCMD) $<
-{$(WINDIR)}.rc{$(TMP_DIR)}.res:
+{$(WIN_DIR)}.rc{$(TMP_DIR)}.res:
$(RESCMD) $<
{$(TMP_DIR)}.rc{$(TMP_DIR)}.res:
@@ -1687,6 +1732,9 @@ TCLNMAKECONFIG = "$(OUT_DIR)\tcl.nmake" !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
diff --git a/win/targets.vc b/win/targets.vc index 7f1d388..6bfebc7 100644 --- a/win/targets.vc +++ b/win/targets.vc @@ -4,7 +4,7 @@ # Part of the nmake based build system for Tcl and its extensions.
# This file defines some standard targets for the convenience of extensions
# and can be optionally included by the extension makefile.
-# See TIP 477 (https://core.tcl.tk/tips/doc/trunk/tip/477.md) for docs.
+# See TIP 477 (https://core.tcl-lang.org/tips/doc/trunk/tip/477.md) for docs.
$(PROJECT): setup pkgindex $(PRJLIB)
diff --git a/win/tcl.dsp b/win/tcl.dsp index bdec59e..065d598 100644 --- a/win/tcl.dsp +++ b/win/tcl.dsp @@ -148,10 +148,6 @@ SOURCE=..\compat\dlfcn.h # End Source File
# Begin Source File
-SOURCE=..\compat\fixstrtod.c
-# End Source File
-# Begin Source File
-
SOURCE=..\compat\gettod.c
# End Source File
# Begin Source File
@@ -188,10 +184,6 @@ SOURCE=..\compat\strstr.c # End Source File
# Begin Source File
-SOURCE=..\compat\strtod.c
-# End Source File
-# Begin Source File
-
SOURCE=..\compat\strtol.c
# End Source File
# Begin Source File
@@ -204,10 +196,6 @@ SOURCE=..\compat\tclErrno.h # End Source File
# Begin Source File
-SOURCE=..\compat\unistd.h
-# End Source File
-# Begin Source File
-
SOURCE=..\compat\waitpid.c
# End Source File
# End Group
@@ -685,7 +685,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ CFLAGS_DEBUG=-g CFLAGS_OPTIMIZE="-O2 -fomit-frame-pointer" - CFLAGS_WARNING="-Wall -Wwrite-strings -Wsign-compare -Wdeclaration-after-statement" + CFLAGS_WARNING="-Wall -Wwrite-strings -Wsign-compare -Wdeclaration-after-statement -Wpointer-arith" LDFLAGS_DEBUG= LDFLAGS_OPTIMIZE= @@ -948,6 +948,8 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ [Defined when cygwin/mingw ignores VOID define in winnt.h]) fi + AC_CHECK_HEADER(stdbool.h, [AC_DEFINE(HAVE_STDBOOL_H, 1, [Do we have <stdbool.h>?])],) + # See if the compiler supports casting to a union type. # This is used to stop gcc from printing a compiler # warning when initializing a union member. @@ -968,6 +970,8 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ fi fi + AC_DEFINE(MP_32BIT, 1, [Use 'MP_32BIT' for libtommath]) + # DL_LIBS is empty, but then we match the Unix version AC_SUBST(DL_LIBS) AC_SUBST(CFLAGS_DEBUG) @@ -1267,18 +1271,18 @@ AC_DEFUN([SC_ZIPFS_SUPPORT], [ done ]) if test -f "$ac_cv_path_zip" ; then - ZIP_PROG="$ac_cv_path_zip " + ZIP_PROG="$ac_cv_path_zip" AC_MSG_RESULT([$ZIP_PROG]) ZIP_PROG_OPTIONS="-rq" - ZIP_PROG_VFSSEARCH="." + ZIP_PROG_VFSSEARCH="*" AC_MSG_RESULT([Found INFO Zip in environment]) # Use standard arguments for zip else # It is not an error if an installed version of Zip can't be located. # We can use the locally distributed minizip instead - ZIP_PROG="../minizip${EXEEXT_FOR_BUILD}" + ZIP_PROG="./minizip${EXEEXT_FOR_BUILD}" ZIP_PROG_OPTIONS="-o -r" - ZIP_PROG_VFSSEARCH="." + ZIP_PROG_VFSSEARCH="*" ZIP_INSTALL_OBJS="minizip${EXEEXT_FOR_BUILD}" AC_MSG_RESULT([No zip found on PATH building minizip]) fi diff --git a/win/tclWin32Dll.c b/win/tclWin32Dll.c index dca6875..2fed58b 100644 --- a/win/tclWin32Dll.c +++ b/win/tclWin32Dll.c @@ -46,8 +46,8 @@ BOOL APIENTRY DllMain(HINSTANCE hInst, DWORD reason, */ typedef struct MountPointMap { - TCHAR *volumeName; /* Native wide string volume name. */ - TCHAR driveLetter; /* Drive letter corresponding to the volume + WCHAR *volumeName; /* Native wide string volume name. */ + WCHAR driveLetter; /* Drive letter corresponding to the volume * name. */ struct MountPointMap *nextPtr; /* Pointer to next structure in list, or @@ -286,11 +286,11 @@ TclWinEncodingsCleanup(void) char TclWinDriveLetterForVolMountPoint( - const TCHAR *mountPoint) + const WCHAR *mountPoint) { MountPointMap *dlIter, *dlPtr2; - TCHAR Target[55]; /* Target of mount at mount point */ - TCHAR drive[4] = TEXT("A:\\"); + WCHAR Target[55]; /* Target of mount at mount point */ + WCHAR drive[4] = L"A:\\"; /* * Detect the volume mounted there. Unfortunately, there is no simple way @@ -301,22 +301,22 @@ TclWinDriveLetterForVolMountPoint( Tcl_MutexLock(&mountPointMap); dlIter = driveLetterLookup; while (dlIter != NULL) { - if (_tcscmp(dlIter->volumeName, mountPoint) == 0) { + if (wcscmp(dlIter->volumeName, mountPoint) == 0) { /* * We need to check whether this information is still valid, since * either the user or various programs could have adjusted the * mount points on the fly. */ - drive[0] = (TCHAR) dlIter->driveLetter; + drive[0] = (WCHAR) dlIter->driveLetter; /* * Try to read the volume mount point and see where it points. */ - if (GetVolumeNameForVolumeMountPoint(drive, + if (GetVolumeNameForVolumeMountPointW(drive, Target, 55) != 0) { - if (_tcscmp(dlIter->volumeName, Target) == 0) { + if (wcscmp(dlIter->volumeName, Target) == 0) { /* * Nothing has changed. */ @@ -368,18 +368,18 @@ TclWinDriveLetterForVolMountPoint( * We couldn't find it, so we must iterate over the letters. */ - for (drive[0] = L'A'; drive[0] <= L'Z'; drive[0]++) { + for (drive[0] = 'A'; drive[0] <= 'Z'; drive[0]++) { /* * Try to read the volume mount point and see where it points. */ - if (GetVolumeNameForVolumeMountPoint(drive, + if (GetVolumeNameForVolumeMountPointW(drive, Target, 55) != 0) { int alreadyStored = 0; for (dlIter = driveLetterLookup; dlIter != NULL; dlIter = dlIter->nextPtr) { - if (_tcscmp(dlIter->volumeName, Target) == 0) { + if (wcscmp(dlIter->volumeName, Target) == 0) { alreadyStored = 1; break; } @@ -400,7 +400,7 @@ TclWinDriveLetterForVolMountPoint( for (dlIter = driveLetterLookup; dlIter != NULL; dlIter = dlIter->nextPtr) { - if (_tcscmp(dlIter->volumeName, mountPoint) == 0) { + if (wcscmp(dlIter->volumeName, mountPoint) == 0) { Tcl_MutexUnlock(&mountPointMap); return (char) dlIter->driveLetter; } @@ -447,7 +447,7 @@ TclWinDriveLetterForVolMountPoint( * nativeBuffer <- UtfToExternal(encoding, utfBuffer); * Tcl_FreeEncoding(encoding); * - * By convention, in Windows a TCHAR is a Unicode character. If you plan + * By convention, in Windows a WCHAR is a Unicode character. If you plan * on targeting a Unicode interface when running on Windows, these * functions should be used. If you plan on targetting a "char" oriented * function on Windows, use Tcl_UtfToExternal() with an encoding of NULL. @@ -463,6 +463,8 @@ TclWinDriveLetterForVolMountPoint( *--------------------------------------------------------------------------- */ +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 +#undef Tcl_WinUtfToTChar TCHAR * Tcl_WinUtfToTChar( const char *string, /* Source string in UTF-8. */ @@ -472,12 +474,9 @@ Tcl_WinUtfToTChar( * converted string is stored. */ { Tcl_DStringInit(dsPtr); - if (!string) { - return NULL; - } - return Tcl_UtfToUniCharDString(string, len, dsPtr); + return (TCHAR *)Tcl_UtfToWCharDString(string, len, dsPtr); } - +#undef Tcl_WinTCharToUtf char * Tcl_WinTCharToUtf( const TCHAR *string, /* Source string in Unicode. */ @@ -487,16 +486,9 @@ Tcl_WinTCharToUtf( * converted string is stored. */ { Tcl_DStringInit(dsPtr); - if (!string) { - return NULL; - } - if (len < 0) { - len = wcslen(string); - } else { - len /= 2; - } - return Tcl_UniCharToUtfDString(string, len, dsPtr); + return Tcl_WCharToUtfDString((WCHAR *)string, len >> 1, dsPtr); } +#endif /* !defined(TCL_NO_DEPRECATED) */ /* *------------------------------------------------------------------------ diff --git a/win/tclWinChan.c b/win/tclWinChan.c index 8c47be6..d300269 100644 --- a/win/tclWinChan.c +++ b/win/tclWinChan.c @@ -96,7 +96,7 @@ static void FileThreadActionProc(ClientData instanceData, static int FileTruncateProc(ClientData instanceData, Tcl_WideInt length); static DWORD FileGetType(HANDLE handle); -static int NativeIsComPort(const TCHAR *nativeName); +static int NativeIsComPort(const WCHAR *nativeName); /* * This structure describes the channel type structure for file based IO. @@ -849,7 +849,7 @@ TclpOpenFileChannel( Tcl_Channel channel = 0; int channelPermissions = 0; DWORD accessMode = 0, createMode, shareMode, flags; - const TCHAR *nativeName; + const WCHAR *nativeName; HANDLE handle; char channelName[16 + TCL_INTEGER_SPACE]; TclFile readFile = NULL, writeFile = NULL; @@ -946,7 +946,7 @@ TclpOpenFileChannel( flags = FILE_ATTRIBUTE_READONLY; } } else { - flags = GetFileAttributes(nativeName); + flags = GetFileAttributesW(nativeName); if (flags == 0xFFFFFFFF) { flags = 0; } @@ -962,7 +962,7 @@ TclpOpenFileChannel( * Now we get to create the file. */ - handle = CreateFile(nativeName, accessMode, shareMode, + handle = CreateFileW(nativeName, accessMode, shareMode, NULL, createMode, flags, (HANDLE) NULL); if (handle == INVALID_HANDLE_VALUE) { @@ -1557,7 +1557,7 @@ FileGetType( static int NativeIsComPort( - const TCHAR *nativePath) /* Path of file to access, native encoding. */ + const WCHAR *nativePath) /* Path of file to access, native encoding. */ { const WCHAR *p = (const WCHAR *) nativePath; int i, len = wcslen(p); @@ -1571,7 +1571,7 @@ NativeIsComPort( * The 4th character must be a digit 1..9 */ - if ((p[3] < L'1') || (p[3] > L'9')) { + if ((p[3] < '1') || (p[3] > '9')) { return 0; } return 1; diff --git a/win/tclWinConsole.c b/win/tclWinConsole.c index f8b67a3..09262c0 100644 --- a/win/tclWinConsole.c +++ b/win/tclWinConsole.c @@ -31,8 +31,10 @@ TCL_DECLARE_MUTEX(consoleMutex) * Bit masks used in the flags field of the ConsoleInfo structure below. */ -#define CONSOLE_PENDING (1<<0) /* Message is pending in the queue. */ -#define CONSOLE_ASYNC (1<<1) /* Channel is non-blocking. */ +#define CONSOLE_PENDING (1<<0) /* Message is pending in the queue. */ +#define CONSOLE_ASYNC (1<<1) /* Channel is non-blocking. */ +#define CONSOLE_READ_OPS (1<<4) /* Channel supports read-related ops. */ +#define CONSOLE_RESET (1<<5) /* Console mode needs to be reset. */ /* * Bit masks used in the sharedFlags field of the ConsoleInfo structure below. @@ -102,6 +104,7 @@ typedef struct ConsoleInfo { * readable object. */ int bytesRead; /* Number of bytes in the buffer. */ int offset; /* Number of bytes read out of the buffer. */ + DWORD initMode; /* Initial console mode. */ char buffer[CONSOLE_BUFFER_SIZE]; /* Data consumed by reader thread. */ } ConsoleInfo; @@ -144,12 +147,18 @@ static int ConsoleEventProc(Tcl_Event *evPtr, int flags); static void ConsoleExitHandler(ClientData clientData); static int ConsoleGetHandleProc(ClientData instanceData, int direction, ClientData *handlePtr); +static int ConsoleGetOptionProc(ClientData instanceData, + Tcl_Interp *interp, const char *optionName, + Tcl_DString *dsPtr); static void ConsoleInit(void); static int ConsoleInputProc(ClientData instanceData, char *buf, int toRead, int *errorCode); static int ConsoleOutputProc(ClientData instanceData, const char *buf, int toWrite, int *errorCode); static DWORD WINAPI ConsoleReaderThread(LPVOID arg); +static int ConsoleSetOptionProc(ClientData instanceData, + Tcl_Interp *interp, const char *optionName, + const char *value); static void ConsoleSetupProc(ClientData clientData, int flags); static void ConsoleWatchProc(ClientData instanceData, int mask); static DWORD WINAPI ConsoleWriterThread(LPVOID arg); @@ -175,8 +184,8 @@ static const Tcl_ChannelType consoleChannelType = { ConsoleInputProc, /* Input proc. */ ConsoleOutputProc, /* Output proc. */ NULL, /* Seek proc. */ - NULL, /* Set option proc. */ - NULL, /* Get option proc. */ + ConsoleSetOptionProc, /* Set option proc. */ + ConsoleGetOptionProc, /* Get option proc. */ ConsoleWatchProc, /* Set up notifier to watch the channel. */ ConsoleGetHandleProc, /* Get an OS handle from channel. */ NULL, /* close2proc. */ @@ -193,8 +202,8 @@ static const Tcl_ChannelType consoleChannelType = { * * ReadConsoleBytes, WriteConsoleBytes -- * - * Wrapper for ReadConsole{A,W}, that takes and returns number of bytes - * instead of number of TCHARS. + * Wrapper for ReadConsoleW, that takes and returns number of bytes + * instead of number of WCHARS. * *---------------------------------------------------------------------- */ @@ -208,7 +217,6 @@ ReadConsoleBytes( { DWORD ntchars; BOOL result; - int tcharsize = sizeof(TCHAR); /* * If user types a Ctrl-Break or Ctrl-C, ReadConsole will return @@ -221,11 +229,11 @@ ReadConsoleBytes( * will run and take whatever action it deems appropriate. */ do { - result = ReadConsole(hConsole, lpBuffer, nbytes / tcharsize, &ntchars, + result = ReadConsoleW(hConsole, lpBuffer, nbytes / sizeof(WCHAR), &ntchars, NULL); } while (result && ntchars == 0 && GetLastError() == ERROR_OPERATION_ABORTED); if (nbytesread != NULL) { - *nbytesread = ntchars * tcharsize; + *nbytesread = ntchars * sizeof(WCHAR); } return result; } @@ -239,12 +247,11 @@ WriteConsoleBytes( { DWORD ntchars; BOOL result; - int tcharsize = sizeof(TCHAR); - result = WriteConsole(hConsole, lpBuffer, nbytes / tcharsize, &ntchars, + result = WriteConsoleW(hConsole, lpBuffer, nbytes / sizeof(WCHAR), &ntchars, NULL); if (nbyteswritten != NULL) { - *nbyteswritten = ntchars * tcharsize; + *nbyteswritten = ntchars * sizeof(WCHAR); } return result; } @@ -569,6 +576,17 @@ ConsoleCloseProc( consolePtr->validMask &= ~TCL_WRITABLE; /* + * If the user has been tinkering with the mode, reset it now. We ignore + * any errors from this; we're quite possibly about to close or exit + * anyway. + */ + + if ((consolePtr->flags & CONSOLE_READ_OPS) && + (consolePtr->flags & CONSOLE_RESET)) { + SetConsoleMode(consolePtr->handle, consolePtr->initMode); + } + + /* * Don't close the Win32 handle if the handle is a standard channel during * the thread exit process. Otherwise, one thread may kill the stdio of * another. @@ -590,7 +608,7 @@ ConsoleCloseProc( * Remove the file from the list of watched files. */ - for (nextPtrPtr = &(tsdPtr->firstConsolePtr), infoPtr = *nextPtrPtr; + for (nextPtrPtr = &tsdPtr->firstConsolePtr, infoPtr = *nextPtrPtr; infoPtr != NULL; nextPtrPtr = &infoPtr->nextPtr, infoPtr = *nextPtrPtr) { if (infoPtr == (ConsoleInfo *) consolePtr) { @@ -660,11 +678,11 @@ ConsoleInputProc( */ if (bufSize < (infoPtr->bytesRead - infoPtr->offset)) { - memcpy(buf, &infoPtr->buffer[infoPtr->offset], (size_t) bufSize); + memcpy(buf, &infoPtr->buffer[infoPtr->offset], bufSize); bytesRead = bufSize; infoPtr->offset += bufSize; } else { - memcpy(buf, &infoPtr->buffer[infoPtr->offset], (size_t) bufSize); + memcpy(buf, &infoPtr->buffer[infoPtr->offset], bufSize); bytesRead = infoPtr->bytesRead - infoPtr->offset; /* @@ -771,7 +789,7 @@ ConsoleOutputProc( infoPtr->writeBufLen = toWrite; infoPtr->writeBuf = ckalloc(toWrite); } - memcpy(infoPtr->writeBuf, buf, (size_t) toWrite); + memcpy(infoPtr->writeBuf, buf, toWrite); infoPtr->toWrite = toWrite; ResetEvent(threadInfo->readyEvent); TclPipeThreadSignal(&threadInfo->TI); @@ -1037,7 +1055,7 @@ WaitForRead( return 1; } - if (PeekConsoleInput(handle, &input, 1, &count) == FALSE) { + if (PeekConsoleInputW(handle, &input, 1, &count) == FALSE) { /* * Check to see if the peek failed because of EOF. */ @@ -1332,12 +1350,14 @@ TclWinOpenConsoleChannel( * we only want to catch when complete lines are ready for reading. */ - GetConsoleMode(infoPtr->handle, &modes); + infoPtr->flags |= CONSOLE_READ_OPS; + GetConsoleMode(infoPtr->handle, &infoPtr->initMode); + modes = infoPtr->initMode; modes &= ~(ENABLE_WINDOW_INPUT | ENABLE_MOUSE_INPUT); modes |= ENABLE_LINE_INPUT; SetConsoleMode(infoPtr->handle, modes); - infoPtr->reader.readyEvent = CreateEvent(NULL, TRUE, TRUE, NULL); + infoPtr->reader.readyEvent = CreateEventW(NULL, TRUE, TRUE, NULL); infoPtr->reader.thread = CreateThread(NULL, 256, ConsoleReaderThread, TclPipeThreadCreateTI(&infoPtr->reader.TI, infoPtr, infoPtr->reader.readyEvent), 0, NULL); @@ -1346,7 +1366,7 @@ TclWinOpenConsoleChannel( if (permissions & TCL_WRITABLE) { - infoPtr->writer.readyEvent = CreateEvent(NULL, TRUE, TRUE, NULL); + 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); @@ -1415,6 +1435,213 @@ ConsoleThreadActionProc( } /* + *---------------------------------------------------------------------- + * + * ConsoleSetOptionProc -- + * + * Sets an option on a channel. + * + * Results: + * A standard Tcl result. Also sets the interp's result on error if + * interp is not NULL. + * + * Side effects: + * May modify an option on a console. Sets Error message if needed (by + * calling Tcl_BadChannelOption). + * + *---------------------------------------------------------------------- + */ + +static int +ConsoleSetOptionProc( + ClientData instanceData, /* File state. */ + Tcl_Interp *interp, /* For error reporting - can be NULL. */ + const char *optionName, /* Which option to set? */ + const char *value) /* New value for option. */ +{ + ConsoleInfo *infoPtr = instanceData; + int len = strlen(optionName); + int vlen = strlen(value); + + /* + * Option -inputmode normal|password|raw + */ + + if ((infoPtr->flags & CONSOLE_READ_OPS) && (len > 1) && + (strncmp(optionName, "-inputmode", len) == 0)) { + DWORD mode; + + if (GetConsoleMode(infoPtr->handle, &mode) == 0) { + TclWinConvertError(GetLastError()); + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't read console mode: %s", + Tcl_PosixError(interp))); + } + return TCL_ERROR; + } + if (Tcl_UtfNcasecmp(value, "NORMAL", vlen) == 0) { + mode |= ENABLE_ECHO_INPUT | ENABLE_LINE_INPUT; + } else if (Tcl_UtfNcasecmp(value, "PASSWORD", vlen) == 0) { + mode |= ENABLE_LINE_INPUT; + mode &= ~ENABLE_ECHO_INPUT; + } else if (Tcl_UtfNcasecmp(value, "RAW", vlen) == 0) { + mode &= ~(ENABLE_ECHO_INPUT | ENABLE_LINE_INPUT); + } else if (Tcl_UtfNcasecmp(value, "RESET", vlen) == 0) { + /* + * Reset to the initial mode, whatever that is. + */ + + mode = infoPtr->initMode; + } else { + if (interp) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad mode \"%s\" for -inputmode: must be" + " normal, password, raw, or reset", value)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE", + "VALUE", NULL); + } + return TCL_ERROR; + } + if (SetConsoleMode(infoPtr->handle, mode) == 0) { + TclWinConvertError(GetLastError()); + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't set console mode: %s", + Tcl_PosixError(interp))); + } + return TCL_ERROR; + } + + /* + * If we've changed the mode from default, schedule a reset later. + */ + + if (mode == infoPtr->initMode) { + infoPtr->flags &= ~CONSOLE_RESET; + } else { + infoPtr->flags |= CONSOLE_RESET; + } + return TCL_OK; + } + + if (infoPtr->flags & CONSOLE_READ_OPS) { + return Tcl_BadChannelOption(interp, optionName, "inputmode"); + } else { + return Tcl_BadChannelOption(interp, optionName, ""); + } +} + +/* + *---------------------------------------------------------------------- + * + * ConsoleGetOptionProc -- + * + * Gets a mode associated with an IO channel. If the optionName arg is + * non-NULL, retrieves the value of that option. If the optionName arg is + * NULL, retrieves a list of alternating option names and values for the + * given channel. + * + * Results: + * A standard Tcl result. Also sets the supplied DString to the string + * value of the option(s) returned. Sets error message if needed + * (by calling Tcl_BadChannelOption). + * + *---------------------------------------------------------------------- + */ + +static int +ConsoleGetOptionProc( + ClientData instanceData, /* File state. */ + Tcl_Interp *interp, /* For error reporting - can be NULL. */ + const char *optionName, /* Option to get. */ + Tcl_DString *dsPtr) /* Where to store value(s). */ +{ + ConsoleInfo *infoPtr = instanceData; + int valid = 0; /* Flag if valid option parsed. */ + unsigned int len; + char buf[TCL_INTEGER_SPACE]; + + if (optionName == NULL) { + len = 0; + } else { + len = strlen(optionName); + } + + /* + * Get option -inputmode + * + * This is a great simplification of the underlying reality, but actually + * represents what almost all scripts really want to know. + */ + + if (infoPtr->flags & CONSOLE_READ_OPS) { + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-inputmode"); + } + if (len==0 || (len>1 && strncmp(optionName, "-inputmode", len)==0)) { + DWORD mode; + + valid = 1; + if (GetConsoleMode(infoPtr->handle, &mode) == 0) { + TclWinConvertError(GetLastError()); + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't read console mode: %s", + Tcl_PosixError(interp))); + } + return TCL_ERROR; + } + if (mode & ENABLE_LINE_INPUT) { + if (mode & ENABLE_ECHO_INPUT) { + Tcl_DStringAppendElement(dsPtr, "normal"); + } else { + Tcl_DStringAppendElement(dsPtr, "password"); + } + } else { + Tcl_DStringAppendElement(dsPtr, "raw"); + } + } + } + + /* + * Get option -winsize + * Option is readonly and returned by [fconfigure chan -winsize] but not + * returned by [fconfigure chan] without explicit option name. + */ + + if ((len > 1) && (strncmp(optionName, "-winsize", len) == 0)) { + CONSOLE_SCREEN_BUFFER_INFO consoleInfo; + + valid = 1; + if (!GetConsoleScreenBufferInfo(infoPtr->handle, &consoleInfo)) { + TclWinConvertError(GetLastError()); + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't read console size: %s", + Tcl_PosixError(interp))); + } + return TCL_ERROR; + } + sprintf(buf, "%d", + consoleInfo.srWindow.Right - consoleInfo.srWindow.Left + 1); + Tcl_DStringAppendElement(dsPtr, buf); + sprintf(buf, "%d", + consoleInfo.srWindow.Bottom - consoleInfo.srWindow.Top + 1); + Tcl_DStringAppendElement(dsPtr, buf); + } + + if (valid) { + return TCL_OK; + } + if (infoPtr->flags & CONSOLE_READ_OPS) { + return Tcl_BadChannelOption(interp, optionName, "inputmode winsize"); + } else { + return Tcl_BadChannelOption(interp, optionName, ""); + } +} + +/* * Local Variables: * mode: c * c-basic-offset: 4 diff --git a/win/tclWinDde.c b/win/tclWinDde.c index 38f1d88..267ee6e 100644 --- a/win/tclWinDde.c +++ b/win/tclWinDde.c @@ -34,7 +34,7 @@ typedef struct RegisteredInterp { struct RegisteredInterp *nextPtr; /* The next interp this application knows * about. */ - TCHAR *name; /* Interpreter's name (malloc-ed). */ + WCHAR *name; /* Interpreter's name (malloc-ed). */ Tcl_Obj *handlerPtr; /* The server handler command */ Tcl_Interp *interp; /* The interpreter attached to this name. */ } RegisteredInterp; @@ -79,10 +79,10 @@ 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_VERSION "1.4.2" #define TCL_DDE_PACKAGE_NAME "dde" -#define TCL_DDE_SERVICE_NAME TEXT("TclEval") -#define TCL_DDE_EXECUTE_RESULT TEXT("$TCLEVAL$EXECUTE$RESULT") +#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 @@ -99,27 +99,61 @@ static LRESULT CALLBACK DdeClientWindowProc(HWND hwnd, UINT uMsg, static int DdeCreateClient(DdeEnumServices *es); static BOOL CALLBACK DdeEnumWindowsCallback(HWND hwndTarget, LPARAM lParam); -static void DdeExitProc(ClientData clientData); +static void DdeExitProc(void *clientData); static int DdeGetServicesList(Tcl_Interp *interp, - const TCHAR *serviceName, const TCHAR *topicName); + 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(ClientData clientData); +static void DeleteProc(void *clientData); static Tcl_Obj * ExecuteRemoteObject(RegisteredInterp *riPtr, Tcl_Obj *ddeObjectPtr); static int MakeDdeConnection(Tcl_Interp *interp, - const TCHAR *name, HCONV *ddeConvPtr); + const WCHAR *name, HCONV *ddeConvPtr); static void SetDdeError(Tcl_Interp *interp); -static int DdeObjCmd(ClientData clientData, +static int DdeObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); +#if (TCL_MAJOR_VERSION < 9) && (TCL_MINOR_VERSION < 7) +# if TCL_UTF_MAX > 3 +# define Tcl_WCharToUtfDString(a,b,c) Tcl_WinTCharToUtf((TCHAR *)(a),(b)*sizeof(WCHAR),c) +# define Tcl_UtfToWCharDString(a,b,c) (WCHAR *)Tcl_WinUtfToTChar(a,b,c) +# else +# define Tcl_WCharToUtfDString Tcl_UniCharToUtfDString +# define Tcl_UtfToWCharDString Tcl_UtfToUniCharDString +# endif +#endif + +static unsigned char * +getByteArrayFromObj( + Tcl_Obj *objPtr, + size_t *lengthPtr +) { + int length; + unsigned char *result = Tcl_GetByteArrayFromObj(objPtr, &length); +#if TCL_MAJOR_VERSION > 8 + if (sizeof(TCL_HASH_TYPE) > sizeof(int)) { + /* 64-bit and TIP #494 situation: */ + *lengthPtr = *(TCL_HASH_TYPE *) objPtr->internalRep.twoPtrValue.ptr1; + } else +#endif + /* 32-bit or without TIP #494 */ + *lengthPtr = (size_t) (unsigned) length; + return result; +} + +#ifdef __cplusplus +extern "C" { +#endif DLLEXPORT int Dde_Init(Tcl_Interp *interp); DLLEXPORT int Dde_SafeInit(Tcl_Interp *interp); +#ifdef __cplusplus +} +#endif /* *---------------------------------------------------------------------- @@ -141,13 +175,13 @@ int Dde_Init( Tcl_Interp *interp) { - if (!Tcl_InitStubs(interp, "8.1", 0)) { + if (!Tcl_InitStubs(interp, "8.5", 0)) { return TCL_ERROR; } Tcl_CreateObjCommand(interp, "dde", DdeObjCmd, NULL, NULL); Tcl_CreateExitHandler(DdeExitProc, NULL); - return Tcl_PkgProvide(interp, TCL_DDE_PACKAGE_NAME, TCL_DDE_VERSION); + return Tcl_PkgProvideEx(interp, TCL_DDE_PACKAGE_NAME, TCL_DDE_VERSION, NULL); } /* @@ -217,7 +251,7 @@ Initialize(void) if (ddeInstance == 0) { Tcl_MutexLock(&ddeMutex); if (ddeInstance == 0) { - if (DdeInitialize(&ddeInstance, (PFNCALLBACK) DdeServerProc, + if (DdeInitializeW(&ddeInstance, (PFNCALLBACK) DdeServerProc, CBF_SKIP_REGISTRATIONS | CBF_SKIP_UNREGISTRATIONS | CBF_FAIL_POKES, 0) != DMLERR_NO_ERROR) { ddeInstance = 0; @@ -230,7 +264,7 @@ Initialize(void) if ((ddeServiceGlobal == 0) && (nameFound != 0)) { ddeIsServer = 1; Tcl_CreateExitHandler(DdeExitProc, NULL); - ddeServiceGlobal = DdeCreateStringHandle(ddeInstance, + ddeServiceGlobal = DdeCreateStringHandleW(ddeInstance, TCL_DDE_SERVICE_NAME, CP_WINUNICODE); DdeNameService(ddeInstance, ddeServiceGlobal, 0L, DNS_REGISTER); } else { @@ -265,10 +299,10 @@ Initialize(void) *---------------------------------------------------------------------- */ -static const TCHAR * +static const WCHAR * DdeSetServerName( Tcl_Interp *interp, - const TCHAR *name, /* The name that will be used to refer to the + 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 */ @@ -278,7 +312,7 @@ DdeSetServerName( int suffix, offset; RegisteredInterp *riPtr, *prevPtr; Tcl_DString dString; - const TCHAR *actualName; + const WCHAR *actualName; Tcl_Obj *srvListPtr = NULL, **srvPtrPtr = NULL; int n, srvCount = 0, lastSuffix, r = TCL_OK; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); @@ -316,7 +350,7 @@ DdeSetServerName( * current interp, but it doesn't have a name. */ - return TEXT(""); + return L""; } /* @@ -337,8 +371,8 @@ DdeSetServerName( &srvPtrPtr); } if (r != TCL_OK) { - Tcl_WinUtfToTChar(Tcl_GetStringResult(interp), -1, &dString); - OutputDebugString((TCHAR *) Tcl_DStringValue(&dString)); + Tcl_DStringInit(&dString); + OutputDebugStringW(Tcl_UtfToWCharDString(Tcl_GetString(Tcl_GetObjResult(interp)), -1, &dString)); Tcl_DStringFree(&dString); return NULL; } @@ -356,14 +390,14 @@ DdeSetServerName( lastSuffix = suffix; if (suffix > 1) { if (suffix == 2) { - Tcl_DStringAppend(&dString, (char *)name, _tcslen(name) * sizeof(TCHAR)); - Tcl_DStringAppend(&dString, (char *)TEXT(" #"), 2 * sizeof(TCHAR)); + 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(TCHAR) * TCL_INTEGER_SPACE); - actualName = (TCHAR *) Tcl_DStringValue(&dString); + Tcl_DStringSetLength(&dString, offset + sizeof(WCHAR) * TCL_INTEGER_SPACE); + actualName = (WCHAR *) Tcl_DStringValue(&dString); } - _sntprintf((TCHAR *) (Tcl_DStringValue(&dString) + offset), - TCL_INTEGER_SPACE, TEXT("%d"), suffix); + _snwprintf((WCHAR *) (Tcl_DStringValue(&dString) + offset), + TCL_INTEGER_SPACE, L"%d", suffix); } /* @@ -375,8 +409,9 @@ DdeSetServerName( Tcl_DString ds; Tcl_ListObjIndex(interp, srvPtrPtr[n], 1, &namePtr); - Tcl_WinUtfToTChar(Tcl_GetString(namePtr), -1, &ds); - if (_tcscmp(actualName, (TCHAR *)Tcl_DStringValue(&ds)) == 0) { + Tcl_DStringInit(&ds); + Tcl_UtfToWCharDString(Tcl_GetString(namePtr), -1, &ds); + if (wcscmp(actualName, (WCHAR *)Tcl_DStringValue(&ds)) == 0) { suffix++; Tcl_DStringFree(&ds); break; @@ -392,14 +427,14 @@ DdeSetServerName( riPtr = (RegisteredInterp *) Tcl_Alloc(sizeof(RegisteredInterp)); riPtr->interp = interp; - riPtr->name = (TCHAR *) Tcl_Alloc((_tcslen(actualName) + 1) * sizeof(TCHAR)); + 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; - _tcscpy(riPtr->name, actualName); + wcscpy(riPtr->name, actualName); if (Tcl_IsSafe(interp)) { Tcl_ExposeCommand(interp, "dde", "dde"); @@ -471,8 +506,7 @@ DdeGetRegistrationPtr( static void DeleteProc( - ClientData clientData) /* The interp we are deleting passed as - * ClientData. */ + void *clientData) /* The interp we are deleting. */ { RegisteredInterp *riPtr = (RegisteredInterp *) clientData; RegisteredInterp *searchPtr, *prevPtr; @@ -609,18 +643,20 @@ DdeServerProc( HSZ ddeTopic, HSZ ddeItem, /* String handles. Transaction-type * dependent. */ HDDEDATA hData, /* DDE data. Transaction-type dependent. */ - DWORD dwData1, DWORD dwData2) + DWORD unused1, DWORD unused2) /* Transaction-dependent data. */ { Tcl_DString dString; size_t len; DWORD dlen; - TCHAR *utilString; + 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: @@ -629,16 +665,16 @@ DdeServerProc( * sure we have a valid topic. */ - len = DdeQueryString(ddeInstance, ddeTopic, NULL, 0, CP_WINUNICODE); + len = DdeQueryStringW(ddeInstance, ddeTopic, NULL, 0, CP_WINUNICODE); Tcl_DStringInit(&dString); - Tcl_DStringSetLength(&dString, (len + 1) * sizeof(TCHAR) - 1); - utilString = (TCHAR *) Tcl_DStringValue(&dString); - DdeQueryString(ddeInstance, ddeTopic, utilString, (DWORD) len + 1, + 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 (_tcsicmp(utilString, riPtr->name) == 0) { + if (_wcsicmp(utilString, riPtr->name) == 0) { Tcl_DStringFree(&dString); return (HDDEDATA) TRUE; } @@ -654,15 +690,15 @@ DdeServerProc( * result to return in an XTYP_REQUEST. */ - len = DdeQueryString(ddeInstance, ddeTopic, NULL, 0, CP_WINUNICODE); + len = DdeQueryStringW(ddeInstance, ddeTopic, NULL, 0, CP_WINUNICODE); Tcl_DStringInit(&dString); - Tcl_DStringSetLength(&dString, (len + 1) * sizeof(TCHAR) - 1); - utilString = (TCHAR *) Tcl_DStringValue(&dString); - DdeQueryString(ddeInstance, ddeTopic, utilString, (DWORD) len + 1, + 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 (_tcsicmp(riPtr->name, utilString) == 0) { + if (_wcsicmp(riPtr->name, utilString) == 0) { convPtr = (Conversation *) Tcl_Alloc(sizeof(Conversation)); convPtr->nextPtr = tsdPtr->currentConversations; convPtr->returnPackagePtr = NULL; @@ -722,21 +758,22 @@ DdeServerProc( Tcl_DString dsBuf; char *returnString; - len = DdeQueryString(ddeInstance, ddeItem, NULL, 0, CP_WINUNICODE); + len = DdeQueryStringW(ddeInstance, ddeItem, NULL, 0, CP_WINUNICODE); Tcl_DStringInit(&dString); Tcl_DStringInit(&dsBuf); - Tcl_DStringSetLength(&dString, (len + 1) * sizeof(TCHAR) - 1); - utilString = (TCHAR *) Tcl_DStringValue(&dString); - DdeQueryString(ddeInstance, ddeItem, utilString, (DWORD) len + 1, + Tcl_DStringSetLength(&dString, (len + 1) * sizeof(WCHAR) - 1); + utilString = (WCHAR *) Tcl_DStringValue(&dString); + DdeQueryStringW(ddeInstance, ddeItem, utilString, (DWORD) len + 1, CP_WINUNICODE); - if (_tcsicmp(utilString, TCL_DDE_EXECUTE_RESULT) == 0) { + if (_wcsicmp(utilString, TCL_DDE_EXECUTE_RESULT) == 0) { returnString = Tcl_GetString(convPtr->returnPackagePtr); len = convPtr->returnPackagePtr->length; if (uFmt != CF_TEXT) { - Tcl_WinUtfToTChar(returnString, len, &dsBuf); + Tcl_DStringInit(&dsBuf); + Tcl_UtfToWCharDString(returnString, len, &dsBuf); returnString = Tcl_DStringValue(&dsBuf); - len = Tcl_DStringLength(&dsBuf) + sizeof(TCHAR) - 1; + len = Tcl_DStringLength(&dsBuf) + sizeof(WCHAR) - 1; } ddeReturn = DdeCreateDataHandle(ddeInstance, (BYTE *)returnString, (DWORD) len+1, 0, ddeItem, uFmt, 0); @@ -747,7 +784,8 @@ DdeServerProc( Tcl_DString ds; Tcl_Obj *variableObjPtr; - Tcl_WinTCharToUtf(utilString, -1, &ds); + Tcl_DStringInit(&ds); + Tcl_WCharToUtfDString(utilString, wcslen(utilString), &ds); variableObjPtr = Tcl_GetVar2Ex( convPtr->riPtr->interp, Tcl_DStringValue(&ds), NULL, TCL_GLOBAL_ONLY); @@ -755,9 +793,10 @@ DdeServerProc( returnString = Tcl_GetString(variableObjPtr); len = variableObjPtr->length; if (uFmt != CF_TEXT) { - Tcl_WinUtfToTChar(returnString, len, &dsBuf); + Tcl_DStringInit(&dsBuf); + Tcl_UtfToWCharDString(returnString, len, &dsBuf); returnString = Tcl_DStringValue(&dsBuf); - len = Tcl_DStringLength(&dsBuf) + sizeof(TCHAR) - 1; + len = Tcl_DStringLength(&dsBuf) + sizeof(WCHAR) - 1; } ddeReturn = DdeCreateDataHandle(ddeInstance, (BYTE *)returnString, (DWORD) len+1, 0, ddeItem, @@ -799,17 +838,19 @@ DdeServerProc( Tcl_DStringInit(&dString); Tcl_DStringInit(&ds2); - len = DdeQueryString(ddeInstance, ddeItem, NULL, 0, CP_WINUNICODE); - Tcl_DStringSetLength(&dString, (len + 1) * sizeof(TCHAR) - 1); - utilString = (TCHAR *) Tcl_DStringValue(&dString); - DdeQueryString(ddeInstance, ddeItem, utilString, (DWORD) len + 1, + 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_WinTCharToUtf(utilString, -1, &ds); - utilString = (TCHAR *) DdeAccessData(hData, &len2); + Tcl_DStringInit(&ds); + Tcl_WCharToUtfDString(utilString, wcslen(utilString), &ds); + utilString = (WCHAR *) DdeAccessData(hData, &len2); len = len2; if (uFmt != CF_TEXT) { - Tcl_WinTCharToUtf(utilString, -1, &ds2); - utilString = (TCHAR *) Tcl_DStringValue(&ds2); + Tcl_DStringInit(&ds2); + Tcl_WCharToUtfDString(utilString, wcslen(utilString), &ds2); + utilString = (WCHAR *) Tcl_DStringValue(&ds2); } variableObjPtr = Tcl_NewStringObj((char *)utilString, -1); @@ -844,7 +885,7 @@ DdeServerProc( return (HDDEDATA) DDE_FNOTPROCESSED; } - utilString = (TCHAR *) DdeAccessData(hData, &dlen); + utilString = (WCHAR *) DdeAccessData(hData, &dlen); string = (char *) utilString; if (!dlen) { /* Empty binary array. */ @@ -859,7 +900,8 @@ DdeServerProc( /* unicode */ Tcl_DString dsBuf; - Tcl_WinTCharToUtf(utilString, dlen - sizeof(TCHAR), &dsBuf); + Tcl_DStringInit(&dsBuf); + Tcl_WCharToUtfDString(utilString, (dlen>>1) - 1, &dsBuf); ddeObjectPtr = Tcl_NewStringObj(Tcl_DStringValue(&dsBuf), Tcl_DStringLength(&dsBuf)); Tcl_DStringFree(&dsBuf); @@ -914,9 +956,9 @@ DdeServerProc( len = dlen; for (i = 0, riPtr = tsdPtr->interpListPtr; i < numItems; i++, riPtr = riPtr->nextPtr) { - returnPtr[i].hszSvc = DdeCreateStringHandle(ddeInstance, + returnPtr[i].hszSvc = DdeCreateStringHandleW(ddeInstance, TCL_DDE_SERVICE_NAME, CP_WINUNICODE); - returnPtr[i].hszTopic = DdeCreateStringHandle(ddeInstance, + returnPtr[i].hszTopic = DdeCreateStringHandleW(ddeInstance, riPtr->name, CP_WINUNICODE); } returnPtr[i].hszSvc = NULL; @@ -948,8 +990,9 @@ DdeServerProc( static void DdeExitProc( - ClientData clientData) /* Not used in this handler. */ + void *dummy) /* Not used. */ { + (void)dummy; DdeNameService(ddeInstance, NULL, 0, DNS_UNREGISTER); DdeUninitialize(ddeInstance); ddeInstance = 0; @@ -975,14 +1018,14 @@ DdeExitProc( static int MakeDdeConnection( Tcl_Interp *interp, /* Used to report errors. */ - const TCHAR *name, /* The connection to use. */ + const WCHAR *name, /* The connection to use. */ HCONV *ddeConvPtr) { HSZ ddeTopic, ddeService; HCONV ddeConv; - ddeService = DdeCreateStringHandle(ddeInstance, TCL_DDE_SERVICE_NAME, CP_WINUNICODE); - ddeTopic = DdeCreateStringHandle(ddeInstance, name, CP_WINUNICODE); + ddeService = DdeCreateStringHandleW(ddeInstance, TCL_DDE_SERVICE_NAME, CP_WINUNICODE); + ddeTopic = DdeCreateStringHandleW(ddeInstance, name, CP_WINUNICODE); ddeConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL); DdeFreeStringHandle(ddeInstance, ddeService); @@ -992,7 +1035,8 @@ MakeDdeConnection( if (interp != NULL) { Tcl_DString dString; - Tcl_WinTCharToUtf(name, -1, &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); @@ -1029,9 +1073,9 @@ static int DdeCreateClient( DdeEnumServices *es) { - WNDCLASSEX wc; - static const TCHAR *szDdeClientClassName = TEXT("TclEval client class"); - static const TCHAR *szDdeClientWindowName = TEXT("TclEval client window"); + 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); @@ -1043,8 +1087,8 @@ DdeCreateClient( * Register and create the callback window. */ - RegisterClassEx(&wc); - es->hwnd = CreateWindowEx(0, szDdeClientClassName, szDdeClientWindowName, + RegisterClassExW(&wc); + es->hwnd = CreateWindowExW(0, szDdeClientClassName, szDdeClientWindowName, WS_POPUP, 0, 0, 0, 0, NULL, NULL, NULL, (LPVOID)es); return TCL_OK; } @@ -1063,16 +1107,16 @@ DdeClientWindowProc( (DdeEnumServices *) lpcs->lpCreateParams; #ifdef _WIN64 - SetWindowLongPtr(hwnd, GWLP_USERDATA, (LONG_PTR) es); + SetWindowLongPtrW(hwnd, GWLP_USERDATA, (LONG_PTR) es); #else - SetWindowLong(hwnd, GWL_USERDATA, (LONG) es); + SetWindowLongW(hwnd, GWL_USERDATA, (LONG) es); #endif return (LRESULT) 0L; } case WM_DDE_ACK: return DdeServicesOnAck(hwnd, wParam, lParam); default: - return DefWindowProc(hwnd, uMsg, wParam, lParam); + return DefWindowProcW(hwnd, uMsg, wParam, lParam); } } @@ -1086,13 +1130,13 @@ DdeServicesOnAck( ATOM service = (ATOM)LOWORD(lParam); ATOM topic = (ATOM)HIWORD(lParam); DdeEnumServices *es; - TCHAR sz[255]; + WCHAR sz[255]; Tcl_DString dString; #ifdef _WIN64 - es = (DdeEnumServices *) GetWindowLongPtr(hwnd, GWLP_USERDATA); + es = (DdeEnumServices *) GetWindowLongPtrW(hwnd, GWLP_USERDATA); #else - es = (DdeEnumServices *) GetWindowLong(hwnd, GWL_USERDATA); + es = (DdeEnumServices *) GetWindowLongW(hwnd, GWL_USERDATA); #endif if (((es->service == (ATOM)0) || (es->service == service)) @@ -1100,12 +1144,14 @@ DdeServicesOnAck( Tcl_Obj *matchPtr = Tcl_NewListObj(0, NULL); Tcl_Obj *resultPtr = Tcl_GetObjResult(es->interp); - GlobalGetAtomName(service, sz, 255); - Tcl_WinTCharToUtf(sz, -1, &dString); + 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); - GlobalGetAtomName(topic, sz, 255); - Tcl_WinTCharToUtf(sz, -1, &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); @@ -1133,7 +1179,7 @@ DdeServicesOnAck( * Tell the server we are no longer interested. */ - PostMessage(hwndRemote, WM_DDE_TERMINATE, (WPARAM)hwnd, 0L); + PostMessageW(hwndRemote, WM_DDE_TERMINATE, (WPARAM)hwnd, 0L); return 0L; } @@ -1145,7 +1191,7 @@ DdeEnumWindowsCallback( DWORD_PTR dwResult = 0; DdeEnumServices *es = (DdeEnumServices *) lParam; - SendMessageTimeout(hwndTarget, WM_DDE_INITIATE, (WPARAM)es->hwnd, + SendMessageTimeoutW(hwndTarget, WM_DDE_INITIATE, (WPARAM)es->hwnd, MAKELONG(es->service, es->topic), SMTO_ABORTIFHUNG, 1000, &dwResult); return TRUE; @@ -1154,16 +1200,16 @@ DdeEnumWindowsCallback( static int DdeGetServicesList( Tcl_Interp *interp, - const TCHAR *serviceName, - const TCHAR *topicName) + const WCHAR *serviceName, + const WCHAR *topicName) { DdeEnumServices es; es.interp = interp; es.result = TCL_OK; es.service = (serviceName == NULL) - ? (ATOM)0 : GlobalAddAtom(serviceName); - es.topic = (topicName == NULL) ? (ATOM)0 : GlobalAddAtom(topicName); + ? (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); @@ -1247,7 +1293,7 @@ SetDdeError( static int DdeObjCmd( - ClientData clientData, /* Used only for deletion */ + void *dummy, /* Not used. */ Tcl_Interp *interp, /* The interp we are sending from */ int objc, /* Number of arguments */ Tcl_Obj *const *objv) /* The arguments */ @@ -1279,16 +1325,17 @@ DdeObjCmd( }; int index, i, argIndex; - int length; + size_t length; int flags = 0, result = TCL_OK, firstArg = 0; HSZ ddeService = NULL, ddeTopic = NULL, ddeItem = NULL, ddeCookie = NULL; HDDEDATA ddeData = NULL, ddeItemData = NULL, ddeReturn; HCONV hConv = NULL; - const TCHAR *serviceName = NULL, *topicName = NULL; + const 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 @@ -1444,9 +1491,10 @@ DdeObjCmd( const char *src = Tcl_GetString(objv[firstArg]); length = objv[firstArg]->length; - Tcl_WinUtfToTChar(src, length, &serviceBuf); - serviceName = (TCHAR *) Tcl_DStringValue(&serviceBuf); - length = Tcl_DStringLength(&serviceBuf) / sizeof(TCHAR); + Tcl_DStringInit(&serviceBuf); + Tcl_UtfToWCharDString(src, length, &serviceBuf); + serviceName = (WCHAR *) Tcl_DStringValue(&serviceBuf); + length = Tcl_DStringLength(&serviceBuf) / sizeof(WCHAR); } else { length = 0; } @@ -1454,7 +1502,7 @@ DdeObjCmd( if (length == 0) { serviceName = NULL; } else if ((index != DDE_SERVERNAME) && (index != DDE_EVAL)) { - ddeService = DdeCreateStringHandle(ddeInstance, (void *) serviceName, + ddeService = DdeCreateStringHandleW(ddeInstance, serviceName, CP_WINUNICODE); } @@ -1462,12 +1510,13 @@ DdeObjCmd( const char *src = Tcl_GetString(objv[firstArg + 1]); length = objv[firstArg + 1]->length; - topicName = Tcl_WinUtfToTChar(src, length, &topicBuf); - length = Tcl_DStringLength(&topicBuf) / sizeof(TCHAR); + Tcl_DStringInit(&topicBuf); + topicName = Tcl_UtfToWCharDString(src, length, &topicBuf); + length = Tcl_DStringLength(&topicBuf) / sizeof(WCHAR); if (length == 0) { topicName = NULL; } else { - ddeTopic = DdeCreateStringHandle(ddeInstance, (void *) topicName, + ddeTopic = DdeCreateStringHandleW(ddeInstance, topicName, CP_WINUNICODE); } } @@ -1479,7 +1528,8 @@ DdeObjCmd( if (serviceName != NULL) { Tcl_DString dsBuf; - Tcl_WinTCharToUtf(serviceName, -1, &dsBuf); + Tcl_DStringInit(&dsBuf); + Tcl_WCharToUtfDString(serviceName, wcslen(serviceName), &dsBuf); Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_DStringValue(&dsBuf), Tcl_DStringLength(&dsBuf))); Tcl_DStringFree(&dsBuf); @@ -1489,22 +1539,23 @@ DdeObjCmd( break; case DDE_EXECUTE: { - int dataLength; + size_t dataLength; const void *dataString; Tcl_DString dsBuf; Tcl_DStringInit(&dsBuf); if (flags & DDE_FLAG_BINARY) { dataString = - Tcl_GetByteArrayFromObj(objv[firstArg + 2], &dataLength); + getByteArrayFromObj(objv[firstArg + 2], &dataLength); } else { const char *src; src = Tcl_GetString(objv[firstArg + 2]); dataLength = objv[firstArg + 2]->length; - dataString = (const TCHAR *) - Tcl_WinUtfToTChar(src, dataLength, &dsBuf); - dataLength = Tcl_DStringLength(&dsBuf) + sizeof(TCHAR); + Tcl_DStringInit(&dsBuf); + dataString = + Tcl_UtfToWCharDString(src, dataLength, &dsBuf); + dataLength = Tcl_DStringLength(&dsBuf) + sizeof(WCHAR); } if (dataLength + 1 < 2) { @@ -1550,13 +1601,14 @@ DdeObjCmd( break; } case DDE_REQUEST: { - const TCHAR *itemString; + const WCHAR *itemString; const char *src; src = Tcl_GetString(objv[firstArg + 2]); length = objv[firstArg + 2]->length; - itemString = Tcl_WinUtfToTChar(src, length, &itemBuf); - length = Tcl_DStringLength(&itemBuf) / sizeof(TCHAR); + Tcl_DStringInit(&itemBuf); + itemString = Tcl_UtfToWCharDString(src, length, &itemBuf); + length = Tcl_DStringLength(&itemBuf) / sizeof(WCHAR); if (length == 0) { Tcl_SetObjResult(interp, @@ -1574,7 +1626,7 @@ DdeObjCmd( result = TCL_ERROR; } else { Tcl_Obj *returnObjPtr; - ddeItem = DdeCreateStringHandle(ddeInstance, (void *) itemString, + ddeItem = DdeCreateStringHandleW(ddeInstance, itemString, CP_WINUNICODE); if (ddeItem != NULL) { ddeData = DdeClientTransaction(NULL, 0, hConv, ddeItem, @@ -1584,7 +1636,7 @@ DdeObjCmd( result = TCL_ERROR; } else { DWORD tmp; - TCHAR *dataString = (TCHAR *) DdeAccessData(ddeData, &tmp); + WCHAR *dataString = (WCHAR *) DdeAccessData(ddeData, &tmp); if (flags & DDE_FLAG_BINARY) { returnObjPtr = @@ -1592,11 +1644,12 @@ DdeObjCmd( } else { Tcl_DString dsBuf; - if ((tmp >= sizeof(TCHAR)) - && !dataString[tmp / sizeof(TCHAR) - 1]) { - tmp -= sizeof(TCHAR); + if ((tmp >= sizeof(WCHAR)) + && !dataString[tmp / sizeof(WCHAR) - 1]) { + tmp -= sizeof(WCHAR); } - Tcl_WinTCharToUtf(dataString, tmp, &dsBuf); + Tcl_DStringInit(&dsBuf); + Tcl_WCharToUtfDString(dataString, tmp>>1, &dsBuf); returnObjPtr = Tcl_NewStringObj(Tcl_DStringValue(&dsBuf), Tcl_DStringLength(&dsBuf)); @@ -1615,14 +1668,15 @@ DdeObjCmd( } case DDE_POKE: { Tcl_DString dsBuf; - const TCHAR *itemString; + const WCHAR *itemString; BYTE *dataString; const char *src; src = Tcl_GetString(objv[firstArg + 2]); length = objv[firstArg + 2]->length; - itemString = Tcl_WinUtfToTChar(src, length, &itemBuf); - length = Tcl_DStringLength(&itemBuf) / sizeof(TCHAR); + 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)); @@ -1633,14 +1687,15 @@ DdeObjCmd( Tcl_DStringInit(&dsBuf); if (flags & DDE_FLAG_BINARY) { dataString = (BYTE *) - Tcl_GetByteArrayFromObj(objv[firstArg + 3], &length); + 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_WinUtfToTChar(data, length, &dsBuf); - length = Tcl_DStringLength(&dsBuf) + sizeof(TCHAR); + Tcl_UtfToWCharDString(data, length, &dsBuf); + length = Tcl_DStringLength(&dsBuf) + sizeof(WCHAR); } hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL); @@ -1651,7 +1706,7 @@ DdeObjCmd( SetDdeError(interp); result = TCL_ERROR; } else { - ddeItem = DdeCreateStringHandle(ddeInstance, (void *) itemString, + ddeItem = DdeCreateStringHandleW(ddeInstance, itemString, CP_WINUNICODE); if (ddeItem != NULL) { ddeData = DdeClientTransaction(dataString, (DWORD) length, @@ -1699,7 +1754,7 @@ DdeObjCmd( for (riPtr = tsdPtr->interpListPtr; riPtr != NULL; riPtr = riPtr->nextPtr) { - if (_tcsicmp(serviceName, riPtr->name) == 0) { + if (_wcsicmp(serviceName, riPtr->name) == 0) { break; } } @@ -1802,9 +1857,10 @@ DdeObjCmd( objPtr = Tcl_ConcatObj(objc, objv); string = Tcl_GetString(objPtr); length = objPtr->length; - Tcl_WinUtfToTChar(string, length, &dsBuf); + Tcl_DStringInit(&dsBuf); + Tcl_UtfToWCharDString(string, length, &dsBuf); string = Tcl_DStringValue(&dsBuf); - length = Tcl_DStringLength(&dsBuf) + sizeof(TCHAR); + length = Tcl_DStringLength(&dsBuf) + sizeof(WCHAR); ddeItemData = DdeCreateDataHandle(ddeInstance, (BYTE *) string, (DWORD) length, 0, 0, CF_UNICODETEXT, 0); Tcl_DStringFree(&dsBuf); @@ -1819,7 +1875,7 @@ DdeObjCmd( 0xFFFFFFFF, hConv, 0, CF_UNICODETEXT, XTYP_EXECUTE, 30000, NULL); if (ddeData != 0) { - ddeCookie = DdeCreateStringHandle(ddeInstance, + ddeCookie = DdeCreateStringHandleW(ddeInstance, TCL_DDE_EXECUTE_RESULT, CP_WINUNICODE); ddeData = DdeClientTransaction(NULL, 0, hConv, ddeCookie, CF_UNICODETEXT, XTYP_REQUEST, 30000, NULL); @@ -1836,7 +1892,7 @@ DdeObjCmd( if (!(flags & DDE_FLAG_ASYNC)) { Tcl_Obj *resultPtr; - TCHAR *ddeDataString; + WCHAR *ddeDataString; /* * The return handle has a two or four element list in it. The @@ -1848,12 +1904,13 @@ DdeObjCmd( */ length = DdeGetData(ddeData, NULL, 0, 0); - ddeDataString = (TCHAR *) Tcl_Alloc(length); + ddeDataString = (WCHAR *) Tcl_Alloc(length); DdeGetData(ddeData, (BYTE *) ddeDataString, (DWORD) length, 0); - if (length > sizeof(TCHAR)) { - length -= sizeof(TCHAR); + if (length > sizeof(WCHAR)) { + length -= sizeof(WCHAR); } - Tcl_WinTCharToUtf(ddeDataString, length, &dsBuf); + Tcl_DStringInit(&dsBuf); + Tcl_WCharToUtfDString(ddeDataString, length>>1, &dsBuf); resultPtr = Tcl_NewStringObj(Tcl_DStringValue(&dsBuf), Tcl_DStringLength(&dsBuf)); Tcl_DStringFree(&dsBuf); diff --git a/win/tclWinError.c b/win/tclWinError.c index bce81fa..18f290f 100644 --- a/win/tclWinError.c +++ b/win/tclWinError.c @@ -394,14 +394,14 @@ tclWinDebugPanic( char buf[TCL_MAX_WARN_LEN * 3]; vsnprintf(buf, sizeof(buf), format, argList); - msgString[TCL_MAX_WARN_LEN-1] = L'\0'; + msgString[TCL_MAX_WARN_LEN-1] = '\0'; MultiByteToWideChar(CP_UTF8, 0, buf, -1, msgString, TCL_MAX_WARN_LEN); /* * Truncate MessageBox string if it is too long to not overflow the buffer. */ - if (msgString[TCL_MAX_WARN_LEN-1] != L'\0') { + if (msgString[TCL_MAX_WARN_LEN-1] != '\0') { memcpy(msgString + (TCL_MAX_WARN_LEN - 5), L" ...", 5 * sizeof(WCHAR)); } OutputDebugStringW(msgString); diff --git a/win/tclWinFCmd.c b/win/tclWinFCmd.c index c3ced34..8885e33 100644 --- a/win/tclWinFCmd.c +++ b/win/tclWinFCmd.c @@ -71,7 +71,7 @@ const TclFileAttrProcs tclpFileAttrProcs[] = { * Prototype for the TraverseWinTree callback function. */ -typedef int (TraversalProc)(const TCHAR *srcPtr, const TCHAR *dstPtr, +typedef int (TraversalProc)(const WCHAR *srcPtr, const WCHAR *dstPtr, int type, Tcl_DString *errorPtr); /* @@ -82,18 +82,18 @@ static void StatError(Tcl_Interp *interp, Tcl_Obj *fileName); static int ConvertFileNameFormat(Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, int longShort, Tcl_Obj **attributePtrPtr); -static int DoCopyFile(const TCHAR *srcPtr, const TCHAR *dstPtr); -static int DoCreateDirectory(const TCHAR *pathPtr); -static int DoRemoveJustDirectory(const TCHAR *nativeSrc, +static int DoCopyFile(const WCHAR *srcPtr, const WCHAR *dstPtr); +static int DoCreateDirectory(const WCHAR *pathPtr); +static int DoRemoveJustDirectory(const WCHAR *nativeSrc, int ignoreError, Tcl_DString *errorPtr); static int DoRemoveDirectory(Tcl_DString *pathPtr, int recursive, Tcl_DString *errorPtr); -static int DoRenameFile(const TCHAR *nativeSrc, - const TCHAR *dstPtr); -static int TraversalCopy(const TCHAR *srcPtr, const TCHAR *dstPtr, +static int DoRenameFile(const WCHAR *nativeSrc, + const WCHAR *dstPtr); +static int TraversalCopy(const WCHAR *srcPtr, const WCHAR *dstPtr, int type, Tcl_DString *errorPtr); -static int TraversalDelete(const TCHAR *srcPtr, - const TCHAR *dstPtr, int type, +static int TraversalDelete(const WCHAR *srcPtr, + const WCHAR *dstPtr, int type, Tcl_DString *errorPtr); static int TraverseWinTree(TraversalProc *traverseProc, Tcl_DString *sourcePtr, Tcl_DString *dstPtr, @@ -151,9 +151,9 @@ TclpObjRenameFile( static int DoRenameFile( - const TCHAR *nativeSrc, /* Pathname of file or dir to be renamed + const WCHAR *nativeSrc, /* Pathname of file or dir to be renamed * (native). */ - const TCHAR *nativeDst) /* New pathname for file or directory + const WCHAR *nativeDst) /* New pathname for file or directory * (native). */ { #if defined(HAVE_NO_SEH) && !defined(_WIN64) @@ -214,12 +214,12 @@ DoRenameFile( "movl %%edx, %%fs:0" "\n\t" /* - * Call MoveFile(nativeSrc, nativeDst) + * Call MoveFileW(nativeSrc, nativeDst) */ "pushl %%ebx" "\n\t" "pushl %%ecx" "\n\t" - "movl %[moveFile], %%eax" "\n\t" + "movl %[moveFileW], %%eax" "\n\t" "call *%%eax" "\n\t" /* @@ -256,7 +256,7 @@ DoRenameFile( [registration] "m" (registration), [nativeDst] "m" (nativeDst), [nativeSrc] "m" (nativeSrc), - [moveFile] "r" (MoveFile) + [moveFileW] "r" (MoveFileW) : "%eax", "%ebx", "%ecx", "%edx", "memory" ); @@ -267,7 +267,7 @@ DoRenameFile( #ifndef HAVE_NO_SEH __try { #endif - if ((*MoveFile)(nativeSrc, nativeDst) != FALSE) { + if ((*MoveFileW)(nativeSrc, nativeDst) != FALSE) { retval = TCL_OK; } #ifndef HAVE_NO_SEH @@ -281,10 +281,10 @@ DoRenameFile( TclWinConvertError(GetLastError()); - srcAttr = GetFileAttributes(nativeSrc); - dstAttr = GetFileAttributes(nativeDst); + srcAttr = GetFileAttributesW(nativeSrc); + dstAttr = GetFileAttributesW(nativeDst); if (srcAttr == 0xffffffff) { - if (GetFullPathName(nativeSrc, 0, NULL, + if (GetFullPathNameW(nativeSrc, 0, NULL, NULL) >= MAX_PATH) { errno = ENAMETOOLONG; return TCL_ERROR; @@ -292,7 +292,7 @@ DoRenameFile( srcAttr = 0; } if (dstAttr == 0xffffffff) { - if (GetFullPathName(nativeDst, 0, NULL, + if (GetFullPathNameW(nativeDst, 0, NULL, NULL) >= MAX_PATH) { errno = ENAMETOOLONG; return TCL_ERROR; @@ -307,29 +307,31 @@ DoRenameFile( if (errno == EACCES) { decode: if (srcAttr & FILE_ATTRIBUTE_DIRECTORY) { - TCHAR *nativeSrcRest, *nativeDstRest; + WCHAR *nativeSrcRest, *nativeDstRest; const char **srcArgv, **dstArgv; int size, srcArgc, dstArgc; - TCHAR nativeSrcPath[MAX_PATH]; - TCHAR nativeDstPath[MAX_PATH]; + WCHAR nativeSrcPath[MAX_PATH]; + WCHAR nativeDstPath[MAX_PATH]; Tcl_DString srcString, dstString; const char *src, *dst; - size = GetFullPathName(nativeSrc, MAX_PATH, + size = GetFullPathNameW(nativeSrc, MAX_PATH, nativeSrcPath, &nativeSrcRest); if ((size == 0) || (size > MAX_PATH)) { return TCL_ERROR; } - size = GetFullPathName(nativeDst, MAX_PATH, + size = GetFullPathNameW(nativeDst, MAX_PATH, nativeDstPath, &nativeDstRest); if ((size == 0) || (size > MAX_PATH)) { return TCL_ERROR; } - CharLower(nativeSrcPath); - CharLower(nativeDstPath); + CharLowerW(nativeSrcPath); + CharLowerW(nativeDstPath); - src = Tcl_WinTCharToUtf(nativeSrcPath, -1, &srcString); - dst = Tcl_WinTCharToUtf(nativeDstPath, -1, &dstString); + 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 @@ -408,7 +410,7 @@ DoRenameFile( * directory back, for completeness. */ - if (MoveFile(nativeSrc, + if (MoveFileW(nativeSrc, nativeDst) != FALSE) { return TCL_OK; } @@ -419,8 +421,8 @@ DoRenameFile( */ TclWinConvertError(GetLastError()); - CreateDirectory(nativeDst, NULL); - SetFileAttributes(nativeDst, dstAttr); + CreateDirectoryW(nativeDst, NULL); + SetFileAttributesW(nativeDst, dstAttr); if (Tcl_GetErrno() == EACCES) { /* * Decode the EACCES to a more meaningful error. @@ -445,21 +447,21 @@ DoRenameFile( * back to old name. */ - TCHAR *nativeRest, *nativeTmp, *nativePrefix; + WCHAR *nativeRest, *nativeTmp, *nativePrefix; int result, size; - TCHAR tempBuf[MAX_PATH]; + WCHAR tempBuf[MAX_PATH]; - size = GetFullPathName(nativeDst, MAX_PATH, + size = GetFullPathNameW(nativeDst, MAX_PATH, tempBuf, &nativeRest); if ((size == 0) || (size > MAX_PATH) || (nativeRest == NULL)) { return TCL_ERROR; } - nativeTmp = (TCHAR *) tempBuf; - nativeRest[0] = L'\0'; + nativeTmp = (WCHAR *) tempBuf; + nativeRest[0] = '\0'; result = TCL_ERROR; - nativePrefix = (TCHAR *) L"tclr"; - if (GetTempFileName(nativeTmp, nativePrefix, + nativePrefix = (WCHAR *)L"tclr"; + if (GetTempFileNameW(nativeTmp, nativePrefix, 0, tempBuf) != 0) { /* * Strictly speaking, need the following DeleteFile and @@ -469,15 +471,15 @@ DoRenameFile( */ nativeTmp = tempBuf; - DeleteFile(nativeTmp); - if (MoveFile(nativeDst, nativeTmp) != FALSE) { - if (MoveFile(nativeSrc, nativeDst) != FALSE) { - SetFileAttributes(nativeTmp, FILE_ATTRIBUTE_NORMAL); - DeleteFile(nativeTmp); + DeleteFileW(nativeTmp); + if (MoveFileW(nativeDst, nativeTmp) != FALSE) { + if (MoveFileW(nativeSrc, nativeDst) != FALSE) { + SetFileAttributesW(nativeTmp, FILE_ATTRIBUTE_NORMAL); + DeleteFileW(nativeTmp); return TCL_OK; } else { - DeleteFile(nativeDst); - MoveFile(nativeTmp, nativeDst); + DeleteFileW(nativeDst); + MoveFileW(nativeTmp, nativeDst); } } @@ -540,8 +542,8 @@ TclpObjCopyFile( static int DoCopyFile( - const TCHAR *nativeSrc, /* Pathname of file to be copied (native). */ - const TCHAR *nativeDst) /* Pathname of file to copy to (native). */ + const WCHAR *nativeSrc, /* Pathname of file to be copied (native). */ + const WCHAR *nativeDst) /* Pathname of file to copy to (native). */ { #if defined(HAVE_NO_SEH) && !defined(_WIN64) TCLEXCEPTION_REGISTRATION registration; @@ -601,10 +603,10 @@ DoCopyFile( "movl %%edx, %%fs:0" "\n\t" /* - * Call CopyFile(nativeSrc, nativeDst, 0) + * Call CopyFileW(nativeSrc, nativeDst, 0) */ - "movl %[copyFile], %%eax" "\n\t" + "movl %[copyFileW], %%eax" "\n\t" "pushl $0" "\n\t" "pushl %%ebx" "\n\t" "pushl %%ecx" "\n\t" @@ -644,7 +646,7 @@ DoCopyFile( [registration] "m" (registration), [nativeDst] "m" (nativeDst), [nativeSrc] "m" (nativeSrc), - [copyFile] "r" (CopyFile) + [copyFileW] "r" (CopyFileW) : "%eax", "%ebx", "%ecx", "%edx", "memory" ); @@ -655,7 +657,7 @@ DoCopyFile( #ifndef HAVE_NO_SEH __try { #endif - if (CopyFile(nativeSrc, nativeDst, 0) != FALSE) { + if (CopyFileW(nativeSrc, nativeDst, 0) != FALSE) { retval = TCL_OK; } #ifndef HAVE_NO_SEH @@ -675,8 +677,8 @@ DoCopyFile( if (Tcl_GetErrno() == EACCES) { DWORD srcAttr, dstAttr; - srcAttr = GetFileAttributes(nativeSrc); - dstAttr = GetFileAttributes(nativeDst); + srcAttr = GetFileAttributesW(nativeSrc); + dstAttr = GetFileAttributesW(nativeDst); if (srcAttr != 0xffffffff) { if (dstAttr == 0xffffffff) { dstAttr = 0; @@ -692,9 +694,9 @@ DoCopyFile( Tcl_SetErrno(EISDIR); } if (dstAttr & FILE_ATTRIBUTE_READONLY) { - SetFileAttributes(nativeDst, + SetFileAttributesW(nativeDst, dstAttr & ~((DWORD)FILE_ATTRIBUTE_READONLY)); - if (CopyFile(nativeSrc, nativeDst, + if (CopyFileW(nativeSrc, nativeDst, 0) != FALSE) { return TCL_OK; } @@ -705,7 +707,7 @@ DoCopyFile( */ TclWinConvertError(GetLastError()); - SetFileAttributes(nativeDst, dstAttr); + SetFileAttributesW(nativeDst, dstAttr); } } } @@ -749,7 +751,7 @@ TclpDeleteFile( const void *nativePath) /* Pathname of file to be removed (native). */ { DWORD attr; - const TCHAR *path = nativePath; + const WCHAR *path = nativePath; /* * The DeleteFile API acts differently under Win95/98 and NT WRT NULL and @@ -761,13 +763,13 @@ TclpDeleteFile( return TCL_ERROR; } - if (DeleteFile(path) != FALSE) { + if (DeleteFileW(path) != FALSE) { return TCL_OK; } TclWinConvertError(GetLastError()); if (Tcl_GetErrno() == EACCES) { - attr = GetFileAttributes(path); + attr = GetFileAttributesW(path); if (attr != 0xffffffff) { if (attr & FILE_ATTRIBUTE_DIRECTORY) { if (attr & FILE_ATTRIBUTE_REPARSE_POINT) { @@ -788,21 +790,21 @@ TclpDeleteFile( Tcl_SetErrno(EISDIR); } else if (attr & FILE_ATTRIBUTE_READONLY) { - int res = SetFileAttributes(path, + int res = SetFileAttributesW(path, attr & ~((DWORD) FILE_ATTRIBUTE_READONLY)); if ((res != 0) && - (DeleteFile(path) != FALSE)) { + (DeleteFileW(path) != FALSE)) { return TCL_OK; } TclWinConvertError(GetLastError()); if (res != 0) { - SetFileAttributes(path, attr); + SetFileAttributesW(path, attr); } } } } else if (Tcl_GetErrno() == ENOENT) { - attr = GetFileAttributes(path); + attr = GetFileAttributesW(path); if (attr != 0xffffffff) { if (attr & FILE_ATTRIBUTE_DIRECTORY) { /* @@ -859,9 +861,9 @@ TclpObjCreateDirectory( static int DoCreateDirectory( - const TCHAR *nativePath) /* Pathname of directory to create (native). */ + const WCHAR *nativePath) /* Pathname of directory to create (native). */ { - if (CreateDirectory(nativePath, NULL) == 0) { + if (CreateDirectoryW(nativePath, NULL) == 0) { DWORD error = GetLastError(); TclWinConvertError(error); @@ -911,8 +913,10 @@ TclpObjCopyDirectory( return TCL_ERROR; } - Tcl_WinUtfToTChar(Tcl_GetString(normSrcPtr), -1, &srcString); - Tcl_WinUtfToTChar(Tcl_GetString(normDestPtr), -1, &dstString); + Tcl_DStringInit(&srcString); + Tcl_DStringInit(&dstString); + Tcl_UtfToWCharDString(Tcl_GetString(normSrcPtr), -1, &srcString); + Tcl_UtfToWCharDString(Tcl_GetString(normDestPtr), -1, &dstString); ret = TraverseWinTree(TraversalCopy, &srcString, &dstString, &ds); @@ -984,7 +988,8 @@ TclpObjRemoveDirectory( if (normPtr == NULL) { return TCL_ERROR; } - Tcl_WinUtfToTChar(Tcl_GetString(normPtr), -1, &native); + Tcl_DStringInit(&native); + Tcl_UtfToWCharDString(Tcl_GetString(normPtr), -1, &native); ret = DoRemoveDirectory(&native, recursive, &ds); Tcl_DStringFree(&native); } else { @@ -1009,7 +1014,7 @@ TclpObjRemoveDirectory( static int DoRemoveJustDirectory( - const TCHAR *nativePath, /* Pathname of directory to be removed + const WCHAR *nativePath, /* Pathname of directory to be removed * (native). */ int ignoreError, /* If non-zero, don't initialize the errorPtr * under some circumstances on return. */ @@ -1030,7 +1035,7 @@ DoRemoveJustDirectory( return TCL_ERROR; } - attr = GetFileAttributes(nativePath); + attr = GetFileAttributesW(nativePath); if (attr & FILE_ATTRIBUTE_REPARSE_POINT) { /* @@ -1044,7 +1049,7 @@ DoRemoveJustDirectory( * Ordinary directory. */ - if (RemoveDirectory(nativePath) != FALSE) { + if (RemoveDirectoryW(nativePath) != FALSE) { return TCL_OK; } } @@ -1052,7 +1057,7 @@ DoRemoveJustDirectory( TclWinConvertError(GetLastError()); if (Tcl_GetErrno() == EACCES) { - attr = GetFileAttributes(nativePath); + attr = GetFileAttributesW(nativePath); if (attr != 0xffffffff) { if ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0) { /* @@ -1076,15 +1081,15 @@ DoRemoveJustDirectory( if (attr & FILE_ATTRIBUTE_READONLY) { attr &= ~FILE_ATTRIBUTE_READONLY; - if (SetFileAttributes(nativePath, + if (SetFileAttributesW(nativePath, attr) == FALSE) { goto end; } - if (RemoveDirectory(nativePath) != FALSE) { + if (RemoveDirectoryW(nativePath) != FALSE) { return TCL_OK; } TclWinConvertError(GetLastError()); - SetFileAttributes(nativePath, + SetFileAttributesW(nativePath, attr | FILE_ATTRIBUTE_READONLY); } } @@ -1109,7 +1114,10 @@ DoRemoveJustDirectory( end: if (errorPtr != NULL) { - char *p = Tcl_WinTCharToUtf(nativePath, -1, errorPtr); + char *p; + + Tcl_DStringInit(errorPtr); + p = Tcl_WCharToUtfDString(nativePath, -1, errorPtr); for (; *p; ++p) { if (*p == '\\') *p = '/'; } @@ -1129,7 +1137,7 @@ DoRemoveDirectory( * filled with UTF-8 name of file causing * error. */ { - int res = DoRemoveJustDirectory((const TCHAR *)Tcl_DStringValue(pathPtr), recursive, + int res = DoRemoveJustDirectory((const WCHAR *)Tcl_DStringValue(pathPtr), recursive, errorPtr); if ((res == TCL_ERROR) && (recursive != 0) && (Tcl_GetErrno() == EEXIST)) { @@ -1180,21 +1188,21 @@ TraverseWinTree( * error. */ { DWORD sourceAttr; - TCHAR *nativeSource, *nativeTarget, *nativeErrfile; + WCHAR *nativeSource, *nativeTarget, *nativeErrfile; int result, found, sourceLen, targetLen = 0, oldSourceLen, oldTargetLen; HANDLE handle; - WIN32_FIND_DATA data; + WIN32_FIND_DATAW data; nativeErrfile = NULL; result = TCL_OK; oldTargetLen = 0; /* lint. */ - nativeSource = (TCHAR *) Tcl_DStringValue(sourcePtr); - nativeTarget = (TCHAR *) + nativeSource = (WCHAR *) Tcl_DStringValue(sourcePtr); + nativeTarget = (WCHAR *) (targetPtr == NULL ? NULL : Tcl_DStringValue(targetPtr)); oldSourceLen = Tcl_DStringLength(sourcePtr); - sourceAttr = GetFileAttributes(nativeSource); + sourceAttr = GetFileAttributesW(nativeSource); if (sourceAttr == 0xffffffff) { nativeErrfile = nativeSource; goto end; @@ -1217,11 +1225,11 @@ TraverseWinTree( return traverseProc(nativeSource, nativeTarget, DOTREE_F, errorPtr); } - Tcl_DStringAppend(sourcePtr, (char *) TEXT("\\*.*"), 4 * sizeof(TCHAR) + 1); + Tcl_DStringAppend(sourcePtr, (char *) L"\\*.*", 4 * sizeof(WCHAR) + 1); Tcl_DStringSetLength(sourcePtr, Tcl_DStringLength(sourcePtr) - 1); - nativeSource = (TCHAR *) Tcl_DStringValue(sourcePtr); - handle = FindFirstFile(nativeSource, &data); + nativeSource = (WCHAR *) Tcl_DStringValue(sourcePtr); + handle = FindFirstFileW(nativeSource, &data); if (handle == INVALID_HANDLE_VALUE) { /* * Can't read directory. @@ -1241,24 +1249,24 @@ TraverseWinTree( return result; } - sourceLen = oldSourceLen + sizeof(TCHAR); - Tcl_DStringAppend(sourcePtr, (char *) TEXT("\\"), sizeof(TCHAR) + 1); + sourceLen = oldSourceLen + sizeof(WCHAR); + Tcl_DStringAppend(sourcePtr, (char *) L"\\", sizeof(WCHAR) + 1); Tcl_DStringSetLength(sourcePtr, sourceLen); if (targetPtr != NULL) { oldTargetLen = Tcl_DStringLength(targetPtr); targetLen = oldTargetLen; - targetLen += sizeof(TCHAR); - Tcl_DStringAppend(targetPtr, (char *) TEXT("\\"), sizeof(TCHAR) + 1); + targetLen += sizeof(WCHAR); + Tcl_DStringAppend(targetPtr, (char *) L"\\", sizeof(WCHAR) + 1); Tcl_DStringSetLength(targetPtr, targetLen); } found = 1; - for (; found; found = FindNextFile(handle, &data)) { - TCHAR *nativeName; + for (; found; found = FindNextFileW(handle, &data)) { + WCHAR *nativeName; int len; - TCHAR *wp = data.cFileName; + WCHAR *wp = data.cFileName; if (*wp == '.') { wp++; if (*wp == '.') { @@ -1268,8 +1276,8 @@ TraverseWinTree( continue; } } - nativeName = (TCHAR *) data.cFileName; - len = _tcslen(data.cFileName) * sizeof(TCHAR); + nativeName = (WCHAR *) data.cFileName; + len = wcslen(data.cFileName) * sizeof(WCHAR); /* * Append name after slash, and recurse on the file. @@ -1314,8 +1322,8 @@ TraverseWinTree( * files in that directory. */ - result = traverseProc((const TCHAR *)Tcl_DStringValue(sourcePtr), - (const TCHAR *)(targetPtr == NULL ? NULL : Tcl_DStringValue(targetPtr)), + result = traverseProc((const WCHAR *)Tcl_DStringValue(sourcePtr), + (const WCHAR *)(targetPtr == NULL ? NULL : Tcl_DStringValue(targetPtr)), DOTREE_POSTD, errorPtr); } @@ -1323,7 +1331,8 @@ TraverseWinTree( if (nativeErrfile != NULL) { TclWinConvertError(GetLastError()); if (errorPtr != NULL) { - Tcl_WinTCharToUtf(nativeErrfile, -1, errorPtr); + Tcl_DStringInit(errorPtr); + Tcl_WCharToUtfDString(nativeErrfile, -1, errorPtr); } result = TCL_ERROR; } @@ -1350,8 +1359,8 @@ TraverseWinTree( static int TraversalCopy( - const TCHAR *nativeSrc, /* Source pathname to copy. */ - const TCHAR *nativeDst, /* Destination pathname of copy. */ + const WCHAR *nativeSrc, /* Source pathname to copy. */ + const WCHAR *nativeDst, /* Destination pathname of copy. */ int type, /* Reason for call - see TraverseWinTree() */ Tcl_DString *errorPtr) /* If non-NULL, initialized DString filled * with UTF-8 name of file causing error. */ @@ -1369,9 +1378,9 @@ TraversalCopy( break; case DOTREE_PRED: if (DoCreateDirectory(nativeDst) == TCL_OK) { - DWORD attr = GetFileAttributes(nativeSrc); + DWORD attr = GetFileAttributesW(nativeSrc); - if (SetFileAttributes(nativeDst, + if (SetFileAttributesW(nativeDst, attr) != FALSE) { return TCL_OK; } @@ -1388,7 +1397,8 @@ TraversalCopy( */ if (errorPtr != NULL) { - Tcl_WinTCharToUtf(nativeDst, -1, errorPtr); + Tcl_DStringInit(errorPtr); + Tcl_WCharToUtfDString(nativeDst, -1, errorPtr); } return TCL_ERROR; } @@ -1416,8 +1426,8 @@ TraversalCopy( static int TraversalDelete( - const TCHAR *nativeSrc, /* Source pathname to delete. */ - const TCHAR *dstPtr, /* Not used. */ + const WCHAR *nativeSrc, /* Source pathname to delete. */ + const WCHAR *dstPtr, /* Not used. */ int type, /* Reason for call - see TraverseWinTree() */ Tcl_DString *errorPtr) /* If non-NULL, initialized DString filled * with UTF-8 name of file causing error. */ @@ -1443,7 +1453,8 @@ TraversalDelete( } if (errorPtr != NULL) { - Tcl_WinTCharToUtf(nativeSrc, -1, errorPtr); + Tcl_DStringInit(errorPtr); + Tcl_WCharToUtfDString(nativeSrc, -1, errorPtr); } return TCL_ERROR; } @@ -1503,11 +1514,11 @@ GetWinFileAttributes( Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */ { DWORD result; - const TCHAR *nativeName; + const WCHAR *nativeName; int attr; nativeName = Tcl_FSGetNativePath(fileName); - result = GetFileAttributes(nativeName); + result = GetFileAttributesW(nativeName); if (result == 0xffffffff) { StatError(interp, fileName); @@ -1524,8 +1535,8 @@ GetWinFileAttributes( * We test for, and fix that case, here. */ - const char *str = TclGetString(fileName); - size_t len = fileName->length; + int len; + const char *str = TclGetStringFromObj(fileName, &len); if (len < 4) { if (len == 0) { @@ -1549,7 +1560,7 @@ GetWinFileAttributes( } } - *attributePtrPtr = Tcl_NewBooleanObj(attr); + *attributePtrPtr = Tcl_NewWideIntObj(attr != 0); return TCL_OK; } @@ -1610,11 +1621,12 @@ ConvertFileNameFormat( for (i = 0; i < pathc; i++) { Tcl_Obj *elt; char *pathv; + int length; Tcl_ListObjIndex(NULL, splitPath, i, &elt); - pathv = TclGetString(elt); - if ((pathv[0] == '/') || ((elt->length == 3) && (pathv[1] == ':')) + pathv = TclGetStringFromObj(elt, &length); + if ((pathv[0] == '/') || ((length == 3) && (pathv[1] == ':')) || (strcmp(pathv, ".") == 0) || (strcmp(pathv, "..") == 0)) { /* * Handle "/", "//machine/export", "c:/", "." or ".." by just @@ -1635,9 +1647,9 @@ ConvertFileNameFormat( Tcl_Obj *tempPath; Tcl_DString ds; Tcl_DString dsTemp; - const TCHAR *nativeName; + const WCHAR *nativeName; const char *tempString; - WIN32_FIND_DATA data; + WIN32_FIND_DATAW data; HANDLE handle; DWORD attr; @@ -1649,19 +1661,20 @@ ConvertFileNameFormat( * likely to lead to infinite loops. */ - tempString = TclGetString(tempPath); - nativeName = Tcl_WinUtfToTChar(tempString, tempPath->length, &ds); + tempString = TclGetStringFromObj(tempPath, &length); + Tcl_DStringInit(&ds); + nativeName = Tcl_UtfToWCharDString(tempString, length, &ds); Tcl_DecrRefCount(tempPath); - handle = FindFirstFile(nativeName, &data); + handle = FindFirstFileW(nativeName, &data); if (handle == INVALID_HANDLE_VALUE) { /* - * FindFirstFile() doesn't like root directories. We would + * 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 = GetFileAttributes(nativeName); + attr = GetFileAttributesW(nativeName); if ((attr!=0xFFFFFFFF) && (attr & FILE_ATTRIBUTE_DIRECTORY)) { Tcl_DStringFree(&ds); goto simple; @@ -1682,12 +1695,12 @@ ConvertFileNameFormat( } } else { if (data.cAlternateFileName[0] == '\0') { - nativeName = (TCHAR *) data.cFileName; + nativeName = (WCHAR *) data.cFileName; } } /* - * Purify reports a extraneous UMR in Tcl_WinTCharToUtf() trying + * 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 @@ -1699,7 +1712,7 @@ ConvertFileNameFormat( */ Tcl_DStringInit(&dsTemp); - Tcl_WinTCharToUtf(nativeName, -1, &dsTemp); + Tcl_WCharToUtfDString(nativeName, -1, &dsTemp); Tcl_DStringFree(&ds); /* @@ -1828,10 +1841,10 @@ SetWinFileAttributes( { DWORD fileAttributes, old; int yesNo, result; - const TCHAR *nativeName; + const WCHAR *nativeName; nativeName = Tcl_FSGetNativePath(fileName); - fileAttributes = old = GetFileAttributes(nativeName); + fileAttributes = old = GetFileAttributesW(nativeName); if (fileAttributes == 0xffffffff) { StatError(interp, fileName); @@ -1850,7 +1863,7 @@ SetWinFileAttributes( } if ((fileAttributes != old) - && !SetFileAttributes(nativeName, fileAttributes)) { + && !SetFileAttributesW(nativeName, fileAttributes)) { StatError(interp, fileName); return TCL_ERROR; } @@ -1923,10 +1936,10 @@ TclpObjListVolumes(void) if (GetLogicalDriveStringsA(sizeof(buf), buf) == 0) { /* - * GetVolumeInformation() will detects all drives, but causes + * 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 GetVolumeInformation() to + * 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. */ @@ -1956,6 +1969,121 @@ TclpObjListVolumes(void) } /* + *---------------------------------------------------------------------- + * + * TclpCreateTemporaryDirectory -- + * + * Creates a temporary directory, possibly based on the supplied bits and + * pieces of template supplied in the arguments. + * + * Results: + * An object (refcount 0) containing the name of the newly-created + * directory, or NULL on failure. + * + * Side effects: + * Accesses the native filesystem. Makes a directory. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclpCreateTemporaryDirectory( + Tcl_Obj *dirObj, + Tcl_Obj *basenameObj) +{ + Tcl_DString base, name; /* Contains WCHARs */ + int baseLen; + DWORD error; + WCHAR tempBuf[MAX_PATH + 1]; + DWORD len = GetTempPathW(MAX_PATH, tempBuf); + + /* + * Build the path in writable memory from the user-supplied pieces and + * some defaults. First, the parent temporary directory. + */ + + if (dirObj) { + Tcl_GetString(dirObj); + if (dirObj->length < 1) { + goto useSystemTemp; + } + Tcl_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. + */ + + baseLen = Tcl_DStringLength(&base); + do { + char tempbuf[SUFFIX_LENGTH + 1]; + int i; + static const char randChars[] = + "QWERTYUIOPASDFGHJKLZXCVBNM1234567890"; + static const int numRandChars = sizeof(randChars) - 1; + + /* + * Put a random suffix on the end. + */ + + error = ERROR_SUCCESS; + tempbuf[SUFFIX_LENGTH] = '\0'; + for (i = 0 ; i < SUFFIX_LENGTH; i++) { + tempbuf[i] = randChars[(int) (rand() % numRandChars)]; + } + Tcl_DStringSetLength(&base, baseLen); + 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 diff --git a/win/tclWinFile.c b/win/tclWinFile.c index dfeeef1..7699f7d 100644 --- a/win/tclWinFile.c +++ b/win/tclWinFile.c @@ -156,27 +156,27 @@ static void FromCTime(time_t posixTime, FILETIME *fileTime); * Declarations for local functions defined in this file: */ -static int NativeAccess(const TCHAR *path, int mode); -static int NativeDev(const TCHAR *path); -static int NativeStat(const TCHAR *path, Tcl_StatBuf *statPtr, +static int NativeAccess(const WCHAR *path, int mode); +static int NativeDev(const WCHAR *path); +static int NativeStat(const WCHAR *path, Tcl_StatBuf *statPtr, int checkLinks); static unsigned short NativeStatMode(DWORD attr, int checkLinks, int isExec); -static int NativeIsExec(const TCHAR *path); -static int NativeReadReparse(const TCHAR *LinkDirectory, +static int NativeIsExec(const WCHAR *path); +static int NativeReadReparse(const WCHAR *LinkDirectory, REPARSE_DATA_BUFFER *buffer, DWORD desiredAccess); -static int NativeWriteReparse(const TCHAR *LinkDirectory, +static int NativeWriteReparse(const WCHAR *LinkDirectory, REPARSE_DATA_BUFFER *buffer); static int NativeMatchType(int isDrive, DWORD attr, - const TCHAR *nativeName, Tcl_GlobTypeData *types); + const WCHAR *nativeName, Tcl_GlobTypeData *types); static int WinIsDrive(const char *name, size_t nameLen); static int WinIsReserved(const char *path); -static Tcl_Obj * WinReadLink(const TCHAR *LinkSource); -static Tcl_Obj * WinReadLinkDirectory(const TCHAR *LinkDirectory); -static int WinLink(const TCHAR *LinkSource, - const TCHAR *LinkTarget, int linkAction); -static int WinSymLinkDirectory(const TCHAR *LinkDirectory, - const TCHAR *LinkTarget); +static Tcl_Obj * WinReadLink(const WCHAR *LinkSource); +static Tcl_Obj * WinReadLinkDirectory(const WCHAR *LinkDirectory); +static int WinLink(const WCHAR *LinkSource, + const WCHAR *LinkTarget, int linkAction); +static int WinSymLinkDirectory(const WCHAR *LinkDirectory, + const WCHAR *LinkTarget); MODULE_SCOPE TCL_NORETURN void tclWinDebugPanic(const char *format, ...); /* @@ -191,19 +191,19 @@ MODULE_SCOPE TCL_NORETURN void tclWinDebugPanic(const char *format, ...); static int WinLink( - const TCHAR *linkSourcePath, - const TCHAR *linkTargetPath, + const WCHAR *linkSourcePath, + const WCHAR *linkTargetPath, int linkAction) { - TCHAR tempFileName[MAX_PATH]; - TCHAR *tempFilePart; + WCHAR tempFileName[MAX_PATH]; + WCHAR *tempFilePart; DWORD attr; /* * Get the full path referenced by the target. */ - if (!GetFullPathName(linkTargetPath, MAX_PATH, tempFileName, + if (!GetFullPathNameW(linkTargetPath, MAX_PATH, tempFileName, &tempFilePart)) { /* * Invalid file. @@ -217,7 +217,7 @@ WinLink( * Make sure source file doesn't exist. */ - attr = GetFileAttributes(linkSourcePath); + attr = GetFileAttributesW(linkSourcePath); if (attr != INVALID_FILE_ATTRIBUTES) { Tcl_SetErrno(EEXIST); return -1; @@ -227,7 +227,7 @@ WinLink( * Get the full path referenced by the source file/directory. */ - if (!GetFullPathName(linkSourcePath, MAX_PATH, tempFileName, + if (!GetFullPathNameW(linkSourcePath, MAX_PATH, tempFileName, &tempFilePart)) { /* * Invalid file. @@ -241,7 +241,7 @@ WinLink( * Check the target. */ - attr = GetFileAttributes(linkTargetPath); + attr = GetFileAttributesW(linkTargetPath); if (attr == INVALID_FILE_ATTRIBUTES) { /* * The target doesn't exist. @@ -254,7 +254,7 @@ WinLink( */ if (linkAction & TCL_CREATE_HARD_LINK) { - if (CreateHardLink(linkSourcePath, linkTargetPath, NULL)) { + if (CreateHardLinkW(linkSourcePath, linkTargetPath, NULL)) { /* * Success! */ @@ -306,17 +306,17 @@ WinLink( static Tcl_Obj * WinReadLink( - const TCHAR *linkSourcePath) + const WCHAR *linkSourcePath) { - TCHAR tempFileName[MAX_PATH]; - TCHAR *tempFilePart; + WCHAR tempFileName[MAX_PATH]; + WCHAR *tempFilePart; DWORD attr; /* * Get the full path referenced by the target. */ - if (!GetFullPathName(linkSourcePath, MAX_PATH, tempFileName, + if (!GetFullPathNameW(linkSourcePath, MAX_PATH, tempFileName, &tempFilePart)) { /* * Invalid file. @@ -330,7 +330,7 @@ WinReadLink( * Make sure source file does exist. */ - attr = GetFileAttributes(linkSourcePath); + attr = GetFileAttributesW(linkSourcePath); if (attr == INVALID_FILE_ATTRIBUTES) { /* * The source doesn't exist. @@ -370,8 +370,8 @@ WinReadLink( static int WinSymLinkDirectory( - const TCHAR *linkDirPath, - const TCHAR *linkTargetPath) + const WCHAR *linkDirPath, + const WCHAR *linkTargetPath) { DUMMY_REPARSE_BUFFER dummy; REPARSE_DATA_BUFFER *reparseBuffer = (REPARSE_DATA_BUFFER *) &dummy; @@ -395,11 +395,11 @@ WinSymLinkDirectory( */ for (loop = nativeTarget; *loop != 0; loop++) { - if (*loop == L'/') { - *loop = L'\\'; + if (*loop == '/') { + *loop = '\\'; } } - if ((nativeTarget[len-1] == L'\\') && (nativeTarget[len-2] != L':')) { + if ((nativeTarget[len-1] == '\\') && (nativeTarget[len-2] != ':')) { nativeTarget[len-1] = 0; } @@ -442,8 +442,8 @@ WinSymLinkDirectory( int TclWinSymLinkCopyDirectory( - const TCHAR *linkOrigPath, /* Existing junction - reparse point */ - const TCHAR *linkCopyPath) /* Will become a duplicate junction */ + const WCHAR *linkOrigPath, /* Existing junction - reparse point */ + const WCHAR *linkCopyPath) /* Will become a duplicate junction */ { DUMMY_REPARSE_BUFFER dummy; REPARSE_DATA_BUFFER *reparseBuffer = (REPARSE_DATA_BUFFER *) &dummy; @@ -473,7 +473,7 @@ TclWinSymLinkCopyDirectory( int TclWinSymLinkDelete( - const TCHAR *linkOrigPath, + const WCHAR *linkOrigPath, int linkOnly) { /* @@ -487,7 +487,7 @@ TclWinSymLinkDelete( memset(reparseBuffer, 0, sizeof(DUMMY_REPARSE_BUFFER)); reparseBuffer->ReparseTag = IO_REPARSE_TAG_MOUNT_POINT; - hFile = CreateFile(linkOrigPath, GENERIC_WRITE, 0, NULL, OPEN_EXISTING, + hFile = CreateFileW(linkOrigPath, GENERIC_WRITE, 0, NULL, OPEN_EXISTING, FILE_FLAG_OPEN_REPARSE_POINT | FILE_FLAG_BACKUP_SEMANTICS, NULL); if (hFile != INVALID_HANDLE_VALUE) { @@ -502,7 +502,7 @@ TclWinSymLinkDelete( } else { CloseHandle(hFile); if (!linkOnly) { - RemoveDirectory(linkOrigPath); + RemoveDirectoryW(linkOrigPath); } return 0; } @@ -531,9 +531,14 @@ TclWinSymLinkDelete( *-------------------------------------------------------------------- */ +#if defined (__clang__) || ((__GNUC__) && ((__GNUC__ > 4) || ((__GNUC__ == 4) && (__GNUC_MINOR__ > 5)))) +#pragma GCC diagnostic push +#pragma GCC diagnostic ignored "-Warray-bounds" +#endif + static Tcl_Obj * WinReadLinkDirectory( - const TCHAR *linkDirPath) + const WCHAR *linkDirPath) { int attr, len, offset; DUMMY_REPARSE_BUFFER dummy; @@ -542,7 +547,7 @@ WinReadLinkDirectory( Tcl_DString ds; const char *copy; - attr = GetFileAttributes(linkDirPath); + attr = GetFileAttributesW(linkDirPath); if (!(attr & FILE_ATTRIBUTE_REPARSE_POINT)) { goto invalidError; } @@ -567,7 +572,7 @@ WinReadLinkDirectory( */ offset = 0; - if (reparseBuffer->MountPointReparseBuffer.PathBuffer[0] == L'\\') { + if (reparseBuffer->MountPointReparseBuffer.PathBuffer[0] == '\\') { /* * Check whether this is a mounted volume. */ @@ -581,7 +586,7 @@ WinReadLinkDirectory( * to fix here. It doesn't seem very well documented. */ - reparseBuffer->MountPointReparseBuffer.PathBuffer[1]=L'\\'; + reparseBuffer->MountPointReparseBuffer.PathBuffer[1] = '\\'; /* * Check if a corresponding drive letter exists, and use that @@ -629,10 +634,11 @@ WinReadLinkDirectory( } } - Tcl_WinTCharToUtf((const TCHAR *) + Tcl_DStringInit(&ds); + Tcl_WCharToUtfDString( reparseBuffer->MountPointReparseBuffer.PathBuffer, - (int) reparseBuffer->MountPointReparseBuffer - .SubstituteNameLength, &ds); + reparseBuffer->MountPointReparseBuffer + .SubstituteNameLength>>1, &ds); copy = Tcl_DStringValue(&ds)+offset; len = Tcl_DStringLength(&ds)-offset; @@ -646,6 +652,10 @@ WinReadLinkDirectory( Tcl_SetErrno(EINVAL); return NULL; } + +#if defined (__clang__) || ((__GNUC__) && ((__GNUC__ > 4) || ((__GNUC__ == 4) && (__GNUC_MINOR__ > 5)))) +#pragma GCC diagnostic pop +#endif /* *-------------------------------------------------------------------- @@ -664,14 +674,15 @@ WinReadLinkDirectory( static int NativeReadReparse( - const TCHAR *linkDirPath, /* The junction to read */ + const WCHAR *linkDirPath, /* The junction to read */ REPARSE_DATA_BUFFER *buffer,/* Pointer to buffer. Cannot be NULL */ DWORD desiredAccess) { HANDLE hFile; DWORD returnedLength; - hFile = CreateFile(linkDirPath, desiredAccess, FILE_SHARE_READ, NULL, OPEN_EXISTING, + 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) { @@ -720,7 +731,7 @@ NativeReadReparse( static int NativeWriteReparse( - const TCHAR *linkDirPath, + const WCHAR *linkDirPath, REPARSE_DATA_BUFFER *buffer) { HANDLE hFile; @@ -730,7 +741,7 @@ NativeWriteReparse( * Create the directory - it must not already exist. */ - if (CreateDirectory(linkDirPath, NULL) == 0) { + if (CreateDirectoryW(linkDirPath, NULL) == 0) { /* * Error creating directory. */ @@ -738,7 +749,7 @@ NativeWriteReparse( TclWinConvertError(GetLastError()); return -1; } - hFile = CreateFile(linkDirPath, GENERIC_WRITE, 0, NULL, + hFile = CreateFileW(linkDirPath, GENERIC_WRITE, 0, NULL, OPEN_EXISTING, FILE_FLAG_OPEN_REPARSE_POINT | FILE_FLAG_BACKUP_SEMANTICS, NULL); if (hFile == INVALID_HANDLE_VALUE) { @@ -763,7 +774,7 @@ NativeWriteReparse( TclWinConvertError(GetLastError()); CloseHandle(hFile); - RemoveDirectory(linkDirPath); + RemoveDirectoryW(linkDirPath); return -1; } CloseHandle(hFile); @@ -804,7 +815,7 @@ tclWinDebugPanic( va_start(argList, format); vsnprintf(buf, sizeof(buf), format, argList); - msgString[TCL_MAX_WARN_LEN-1] = L'\0'; + msgString[TCL_MAX_WARN_LEN-1] = '\0'; MultiByteToWideChar(CP_UTF8, 0, buf, -1, msgString, TCL_MAX_WARN_LEN); /* @@ -812,7 +823,7 @@ tclWinDebugPanic( * and cause possible oversized window error. */ - if (msgString[TCL_MAX_WARN_LEN-1] != L'\0') { + if (msgString[TCL_MAX_WARN_LEN-1] != '\0') { memcpy(msgString + (TCL_MAX_WARN_LEN - 5), L" ...", 5 * sizeof(WCHAR)); } if (IsDebuggerPresent()) { @@ -833,7 +844,7 @@ tclWinDebugPanic( #endif abort(); } - + /* *--------------------------------------------------------------------------- * @@ -904,7 +915,7 @@ TclpMatchInDirectory( * May be NULL. In particular the directory * flag is very important. */ { - const TCHAR *native; + const WCHAR *native; if (types != NULL && types->type == TCL_GLOB_TYPE_MOUNT) { /* @@ -922,19 +933,20 @@ TclpMatchInDirectory( * Match a single file directly. */ + int len; DWORD attr; WIN32_FILE_ATTRIBUTE_DATA data; - const char *str = TclGetString(norm); + const char *str = TclGetStringFromObj(norm, &len); native = Tcl_FSGetNativePath(pathPtr); - if (GetFileAttributesEx(native, + if (GetFileAttributesExW(native, GetFileExInfoStandard, &data) != TRUE) { return TCL_OK; } attr = data.dwFileAttributes; - if (NativeMatchType(WinIsDrive(str,norm->length), attr, native, types)) { + if (NativeMatchType(WinIsDrive(str,len), attr, native, types)) { Tcl_ListObjAppendElement(interp, resultPtr, pathPtr); } } @@ -942,10 +954,10 @@ TclpMatchInDirectory( } else { DWORD attr; HANDLE handle; - WIN32_FIND_DATA data; + WIN32_FIND_DATAW data; const char *dirName; /* UTF-8 dir name, later with pattern * appended. */ - size_t dirLength; + int dirLength; int matchSpecialDots; Tcl_DString ds; /* Native encoding of dir, also used * temporarily for other things. */ @@ -971,7 +983,7 @@ TclpMatchInDirectory( if (native == NULL) { return TCL_OK; } - attr = GetFileAttributes(native); + attr = GetFileAttributesW(native); if ((attr == INVALID_FILE_ATTRIBUTES) || ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0)) { @@ -984,8 +996,7 @@ TclpMatchInDirectory( */ Tcl_DStringInit(&dsOrig); - dirName = TclGetString(fileNamePtr); - dirLength = fileNamePtr->length; + dirName = TclGetStringFromObj(fileNamePtr, &dirLength); Tcl_DStringAppend(&dsOrig, dirName, dirLength); lastChar = dirName[dirLength -1]; @@ -1013,15 +1024,16 @@ TclpMatchInDirectory( dirName = TclDStringAppendLiteral(&dsOrig, "*.*"); } - native = Tcl_WinUtfToTChar(dirName, -1, &ds); + Tcl_DStringInit(&ds); + native = Tcl_UtfToWCharDString(dirName, -1, &ds); if ((types == NULL) || (types->type != TCL_GLOB_TYPE_DIR)) { - handle = FindFirstFile(native, &data); + handle = FindFirstFileW(native, &data); } else { /* * We can be more efficient, for pure directory requests. */ - handle = FindFirstFileEx(native, + handle = FindFirstFileExW(native, FindExInfoStandard, &data, FindExSearchLimitToDirectories, NULL, 0); } @@ -1086,7 +1098,8 @@ TclpMatchInDirectory( native = data.cFileName; attr = data.dwFileAttributes; - utfname = Tcl_WinTCharToUtf(native, -1, &ds); + Tcl_DStringInit(&ds); + utfname = Tcl_WCharToUtfDString(native, -1, &ds); if (!matchSpecialDots) { /* @@ -1146,7 +1159,7 @@ TclpMatchInDirectory( */ Tcl_DStringFree(&ds); - } while (FindNextFile(handle, &data) == TRUE); + } while (FindNextFileW(handle, &data) == TRUE); FindClose(handle); Tcl_DStringFree(&dsOrig); @@ -1304,7 +1317,7 @@ NativeMatchType( int isDrive, /* Is this a drive. */ DWORD attr, /* We already know the attributes for the * file. */ - const TCHAR *nativeName, /* Native path to check. */ + const WCHAR *nativeName, /* Native path to check. */ Tcl_GlobTypeData *types) /* Type description to match against. */ { /* @@ -1441,11 +1454,16 @@ TclpGetUserHome( if (domain == NULL) { const char *ptr; - /* no domain - firstly check it's the current user */ - if ( (ptr = TclpGetUserName(&ds)) != NULL - && strcasecmp(name, ptr) == 0 - ) { - /* try safest and fastest way to get current user home */ + /* + * No domain. Firstly check it's the current user + */ + + ptr = TclpGetUserName(&ds); + if (ptr != NULL && strcasecmp(name, ptr) == 0) { + /* + * Try safest and fastest way to get current user home + */ + ptr = TclGetEnv("HOME", &ds); if (ptr != NULL) { Tcl_JoinPath(1, &ptr, bufferPtr); @@ -1456,46 +1474,63 @@ TclpGetUserHome( Tcl_DStringFree(&ds); } else { Tcl_DStringInit(&ds); - wName = Tcl_UtfToUniCharDString(domain + 1, -1, &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_UtfToUniCharDString(name, nameLen, &ds); + wName = Tcl_UtfToWCharDString(name, nameLen, &ds); while (NetUserGetInfo(wDomain, wName, 1, (LPBYTE *) &uiPtr) != 0) { /* - * user does not exists - if domain was not specified, - * try again using current domain. + * User does not exist; if domain was not specified, try again + * using current domain. */ + rc = 1; - if (domain != NULL) break; - /* get current domain */ + if (domain != NULL) { + break; + } + + /* + * Get current domain + */ + rc = NetGetDCName(NULL, NULL, (LPBYTE *) &wDomain); - if (rc != 0) break; + if (rc != 0) { + break; + } domain = INT2PTR(-1); /* repeat once */ } if (rc == 0) { DWORD i, size = MAX_PATH; + wHomeDir = uiPtr->usri1_home_dir; - if ((wHomeDir != NULL) && (wHomeDir[0] != L'\0')) { + if ((wHomeDir != NULL) && (wHomeDir[0] != '\0')) { size = lstrlenW(wHomeDir); - Tcl_UniCharToUtfDString(wHomeDir, size, bufferPtr); + Tcl_WCharToUtfDString(wHomeDir, size, bufferPtr); } else { /* * User exists but has no home dir. Return * "{GetProfilesDirectory}/<user>". */ + GetProfilesDirectoryW(buf, &size); - Tcl_UniCharToUtfDString(buf, size-1, bufferPtr); + Tcl_WCharToUtfDString(buf, size-1, bufferPtr); Tcl_DStringAppend(bufferPtr, "/", 1); Tcl_DStringAppend(bufferPtr, name, nameLen); } result = Tcl_DStringValue(bufferPtr); - /* be sure we returns normalized path */ - for (i = 0; i < size; ++i){ - if (result[i] == '\\') result[i] = '/'; + + /* + * Be sure we return normalized path + */ + + for (i = 0; i < size; ++i) { + if (result[i] == '\\') { + result[i] = '/'; + } } NetApiBufferFree((void *) uiPtr); } @@ -1553,12 +1588,12 @@ TclpGetUserHome( static int NativeAccess( - const TCHAR *nativePath, /* Path of file to access, native encoding. */ + const WCHAR *nativePath, /* Path of file to access, native encoding. */ int mode) /* Permission setting. */ { DWORD attr; - attr = GetFileAttributes(nativePath); + attr = GetFileAttributesW(nativePath); if (attr == INVALID_FILE_ATTRIBUTES) { /* @@ -1583,48 +1618,72 @@ NativeAccess( /* * If it's not a directory (assume file), do several fast checks: */ + if (!(attr & FILE_ATTRIBUTE_DIRECTORY)) { /* * If the attributes say this is not writable at all. The file is a * regular file (i.e., not a directory), then the file is not - * writable, full stop. For directories, the read-only bit is + * writable, full stop. For directories, the read-only bit is * (mostly) ignored by Windows, so we can't ascertain anything about * directory access from the attrib data. However, if we have the - * advanced 'getFileSecurityProc', then more robust ACL checks - * will be done below. + * advanced 'getFileSecurityProc', then more robust ACL checks will be + * done below. */ + if ((mode & W_OK) && (attr & FILE_ATTRIBUTE_READONLY)) { Tcl_SetErrno(EACCES); return -1; } - /* If doesn't have the correct extension, it can't be executable */ + /* + * If doesn't have the correct extension, it can't be executable + */ + if ((mode & X_OK) && !NativeIsExec(nativePath)) { Tcl_SetErrno(EACCES); return -1; } - /* Special case for read/write/executable check on file */ + + /* + * Special case for read/write/executable check on file + */ + if ((mode & (R_OK|W_OK|X_OK)) && !(mode & ~(R_OK|W_OK|X_OK))) { DWORD mask = 0; HANDLE hFile; - if (mode & R_OK) { mask |= GENERIC_READ; } - if (mode & W_OK) { mask |= GENERIC_WRITE; } - if (mode & X_OK) { mask |= GENERIC_EXECUTE; } - hFile = CreateFile(nativePath, mask, - FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE, NULL, - OPEN_EXISTING, FILE_FLAG_NO_BUFFERING, NULL); + if (mode & R_OK) { + mask |= GENERIC_READ; + } + 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; } - /* fast exit if access was denied */ + + /* + * Fast exit if access was denied + */ + if (GetLastError() == ERROR_ACCESS_DENIED) { Tcl_SetErrno(EACCES); return -1; } } - /* We cannnot verify the access fast, check it below using security info. */ + + /* + * We cannnot verify the access fast, check it below using security + * info. + */ } /* @@ -1653,7 +1712,7 @@ NativeAccess( */ size = 0; - GetFileSecurity(nativePath, + GetFileSecurityW(nativePath, OWNER_SECURITY_INFORMATION | GROUP_SECURITY_INFORMATION | DACL_SECURITY_INFORMATION | LABEL_SECURITY_INFORMATION, 0, 0, &size); @@ -1684,10 +1743,10 @@ NativeAccess( } /* - * Call GetFileSecurity() for real. + * Call GetFileSecurityW() for real. */ - if (!GetFileSecurity(nativePath, + if (!GetFileSecurityW(nativePath, OWNER_SECURITY_INFORMATION | GROUP_SECURITY_INFORMATION | DACL_SECURITY_INFORMATION | LABEL_SECURITY_INFORMATION, sdPtr, size, &size)) { @@ -1815,9 +1874,9 @@ NativeAccess( static int NativeIsExec( - const TCHAR *path) + const WCHAR *path) { - int len = _tcslen(path); + int len = wcslen(path); if (len < 5) { return 0; @@ -1828,11 +1887,11 @@ NativeIsExec( } path += len-3; - if ((_tcsicmp(path, TEXT("exe")) == 0) - || (_tcsicmp(path, TEXT("com")) == 0) - || (_tcsicmp(path, TEXT("cmd")) == 0) - || (_tcsicmp(path, TEXT("cmd")) == 0) - || (_tcsicmp(path, TEXT("bat")) == 0)) { + 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; @@ -1859,14 +1918,14 @@ TclpObjChdir( Tcl_Obj *pathPtr) /* Path to new working directory. */ { int result; - const TCHAR *nativePath; + const WCHAR *nativePath; nativePath = Tcl_FSGetNativePath(pathPtr); if (!nativePath) { return -1; } - result = SetCurrentDirectory(nativePath); + result = SetCurrentDirectoryW(nativePath); if (result == 0) { TclWinConvertError(GetLastError()); @@ -1903,11 +1962,11 @@ TclpGetCwd( Tcl_DString *bufferPtr) /* Uninitialized or free DString filled with * name of current directory. */ { - TCHAR buffer[MAX_PATH]; + WCHAR buffer[MAX_PATH]; char *p; WCHAR *native; - if (GetCurrentDirectory(MAX_PATH, buffer) == 0) { + if (GetCurrentDirectoryW(MAX_PATH, buffer) == 0) { TclWinConvertError(GetLastError()); if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -1926,7 +1985,8 @@ TclpGetCwd( && (native[2] == '\\') && (native[3] == '\\')) { native += 2; } - Tcl_WinTCharToUtf((TCHAR *) native, -1, bufferPtr); + Tcl_DStringInit(bufferPtr); + Tcl_WCharToUtfDString(native, -1, bufferPtr); /* * Convert to forward slashes for easier use in scripts. @@ -1981,7 +2041,7 @@ TclpObjStat( static int NativeStat( - const TCHAR *nativePath, /* Path of file to stat */ + const WCHAR *nativePath, /* Path of file to stat */ Tcl_StatBuf *statPtr, /* Filled with results of stat call. */ int checkLinks) /* If non-zero, behave like 'lstat' */ { @@ -1999,16 +2059,15 @@ NativeStat( * 'getFileAttributesExProc', and if that isn't available, then on even * simpler routines. * - * Special consideration must be given to Windows hardcoded names - * like CON, NULL, COM1, LPT1 etc. For these, we still need to - * do the CreateFile as some may not exist (e.g. there is no CON - * in wish by default). However the subsequent GetFileInformationByHandle - * will fail. We do a WinIsReserved to see if it is one of the special - * names, and if successful, mock up a BY_HANDLE_FILE_INFORMATION - * structure. + * Special consideration must be given to Windows hardcoded names like + * CON, NULL, COM1, LPT1 etc. For these, we still need to do the + * CreateFile as some may not exist (e.g. there is no CON in wish by + * default). However the subsequent GetFileInformationByHandle will + * fail. We do a WinIsReserved to see if it is one of the special names, + * and if successful, mock up a BY_HANDLE_FILE_INFORMATION structure. */ - fileHandle = CreateFile(nativePath, GENERIC_READ, + 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); @@ -2023,7 +2082,11 @@ NativeStat( Tcl_SetErrno(ENOENT); return -1; } - /* Mock up the expected structure */ + + /* + * Mock up the expected structure + */ + memset(&data, 0, sizeof(data)); statPtr->st_atime = 0; statPtr->st_mtime = 0; @@ -2062,17 +2125,17 @@ NativeStat( WIN32_FILE_ATTRIBUTE_DATA data; - if (GetFileAttributesEx(nativePath, + if (GetFileAttributesExW(nativePath, GetFileExInfoStandard, &data) != TRUE) { HANDLE hFind; - WIN32_FIND_DATA ffd; + WIN32_FIND_DATAW ffd; DWORD lasterror = GetLastError(); if (lasterror != ERROR_SHARING_VIOLATION) { TclWinConvertError(lasterror); return -1; } - hFind = FindFirstFile(nativePath, &ffd); + hFind = FindFirstFileW(nativePath, &ffd); if (hFind == INVALID_HANDLE_VALUE) { TclWinConvertError(GetLastError()); return -1; @@ -2122,21 +2185,22 @@ NativeStat( static int NativeDev( - const TCHAR *nativePath) /* Full path of file to stat */ + const WCHAR *nativePath) /* Full path of file to stat */ { int dev; Tcl_DString ds; - TCHAR nativeFullPath[MAX_PATH]; - TCHAR *nativePart; + WCHAR nativeFullPath[MAX_PATH]; + WCHAR *nativePart; const char *fullPath; - GetFullPathName(nativePath, MAX_PATH, nativeFullPath, &nativePart); - fullPath = Tcl_WinTCharToUtf(nativeFullPath, -1, &ds); + 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 TCHAR *nativeVol; + const WCHAR *nativeVol; Tcl_DString volString; p = strchr(fullPath + 2, '\\'); @@ -2152,13 +2216,14 @@ NativeDev( } else { p++; } - nativeVol = Tcl_WinUtfToTChar(fullPath, p - fullPath, &volString); + Tcl_DStringInit(&volString); + nativeVol = Tcl_UtfToWCharDString(fullPath, p - fullPath, &volString); dw = (DWORD) -1; - GetVolumeInformation(nativeVol, NULL, 0, &dw, NULL, NULL, NULL, 0); + GetVolumeInformationW(nativeVol, NULL, 0, &dw, NULL, NULL, NULL, 0); /* - * GetFullPathName() turns special devices like "NUL" into "\\.\NUL", - * but GetVolumeInformation() returns failure for "\\.\NUL". This will + * 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. @@ -2298,15 +2363,15 @@ ClientData TclpGetNativeCwd( ClientData clientData) { - TCHAR buffer[MAX_PATH]; + WCHAR buffer[MAX_PATH]; - if (GetCurrentDirectory(MAX_PATH, buffer) == 0) { + if (GetCurrentDirectoryW(MAX_PATH, buffer) == 0) { TclWinConvertError(GetLastError()); return NULL; } if (clientData != NULL) { - if (_tcscmp((const TCHAR*)clientData, buffer) == 0) { + if (wcscmp((const WCHAR *) clientData, buffer) == 0) { return clientData; } } @@ -2347,8 +2412,8 @@ TclpObjLink( { if (toPtr != NULL) { int res; - const TCHAR *LinkTarget; - const TCHAR *LinkSource = Tcl_FSGetNativePath(pathPtr); + const WCHAR *LinkTarget; + const WCHAR *LinkSource = Tcl_FSGetNativePath(pathPtr); Tcl_Obj *normalizedToPtr = Tcl_FSGetNormalizedPath(NULL, toPtr); if (normalizedToPtr == NULL) { @@ -2367,7 +2432,7 @@ TclpObjLink( return NULL; } } else { - const TCHAR *LinkSource = Tcl_FSGetNativePath(pathPtr); + const WCHAR *LinkSource = Tcl_FSGetNativePath(pathPtr); if (LinkSource == NULL) { return NULL; @@ -2401,7 +2466,7 @@ TclpFilesystemPathType( { #define VOL_BUF_SIZE 32 int found; - TCHAR volType[VOL_BUF_SIZE]; + WCHAR volType[VOL_BUF_SIZE]; char *firstSeparator; const char *path; Tcl_Obj *normPath = Tcl_FSGetNormalizedPath(NULL, pathPtr); @@ -2416,13 +2481,13 @@ TclpFilesystemPathType( firstSeparator = strchr(path, '/'); if (firstSeparator == NULL) { - found = GetVolumeInformation(Tcl_FSGetNativePath(pathPtr), + 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 = GetVolumeInformation(Tcl_FSGetNativePath(driveName), + found = GetVolumeInformationW(Tcl_FSGetNativePath(driveName), NULL, 0, NULL, NULL, NULL, volType, VOL_BUF_SIZE); Tcl_DecrRefCount(driveName); } @@ -2432,7 +2497,8 @@ TclpFilesystemPathType( } else { Tcl_DString ds; - Tcl_WinTCharToUtf(volType, -1, &ds); + Tcl_DStringInit(&ds); + Tcl_WCharToUtfDString(volType, -1, &ds); return TclDStringToObj(&ds); } #undef VOL_BUF_SIZE @@ -2476,8 +2542,9 @@ TclpFilesystemPathType( int TclpObjNormalizePath( Tcl_Interp *interp, - Tcl_Obj *pathPtr, - int nextCheckpoint) + Tcl_Obj *pathPtr, /* An unshared object containing the path to + * normalize */ + int nextCheckpoint) /* offset to start at in pathPtr */ { char *lastValidPathEnd = NULL; Tcl_DString dsNorm; /* This will hold the normalized string. */ @@ -2502,10 +2569,13 @@ TclpObjNormalizePath( */ WIN32_FILE_ATTRIBUTE_DATA data; - const TCHAR *nativePath = Tcl_WinUtfToTChar(path, + const WCHAR *nativePath; + + Tcl_DStringInit(&ds); + nativePath = Tcl_UtfToWCharDString(path, currentPathEndPosition - path, &ds); - if (GetFileAttributesEx(nativePath, + if (GetFileAttributesExW(nativePath, GetFileExInfoStandard, &data) != TRUE) { /* * File doesn't exist. @@ -2524,8 +2594,8 @@ TclpObjNormalizePath( for (i=0 ; i<len ; i++) { WCHAR wc = ((WCHAR *) nativePath)[i]; - if (wc >= L'a') { - wc -= (L'a' - L'A'); + if (wc >= 'a') { + wc -= ('a' - 'A'); ((WCHAR *) nativePath)[i] = wc; } } @@ -2534,10 +2604,12 @@ TclpObjNormalizePath( (int)(sizeof(WCHAR) * len)); lastValidPathEnd = currentPathEndPosition; } else if (nextCheckpoint == 0) { - /* Path starts with a drive designation - * that's not actually on the system. - * We still must normalize up past the - * first separator. [Bug 3603434] */ + /* + * Path starts with a drive designation that's not + * actually on the system. We still must normalize up + * past the first separator. [Bug 3603434] + */ + currentPathEndPosition++; } } @@ -2552,11 +2624,10 @@ TclpObjNormalizePath( */ /* - * Check for symlinks, except at last component of path (we - * don't follow final symlinks). Also a drive (C:/) for - * example, may sometimes have the reparse flag set for some - * reason I don't understand. We therefore don't perform this - * check for drives. + * Check for symlinks, except at last component of path (we don't + * follow final symlinks). Also a drive (C:/) for example, may + * sometimes have the reparse flag set for some reason I don't + * understand. We therefore don't perform this check for drives. */ if (cur != 0 && !isDrive && @@ -2565,8 +2636,8 @@ TclpObjNormalizePath( if (to != NULL) { /* - * Read the reparse point ok. Now, reparse points need - * not be normalized, otherwise we could use: + * Read the reparse point ok. Now, reparse points need not + * be normalized, otherwise we could use: * * Tcl_GetStringFromObj(to, &pathLen); * nextCheckpoint = pathLen; @@ -2606,16 +2677,16 @@ TclpObjNormalizePath( #ifndef TclNORM_LONG_PATH /* - * Now we convert the tail of the current path to its 'long - * form', and append it to 'dsNorm' which holds the current - * normalized path + * Now we convert the tail of the current path to its 'long form', + * and append it to 'dsNorm' which holds the current normalized + * path */ if (isDrive) { WCHAR drive = ((WCHAR *) nativePath)[0]; - if (drive >= L'a') { - drive -= (L'a' - L'A'); + if (drive >= 'a') { + drive -= ('a' - 'A'); ((WCHAR *) nativePath)[0] = drive; } Tcl_DStringAppend(&dsNorm, (const char *)nativePath, @@ -2637,16 +2708,16 @@ TclpObjNormalizePath( int dotLen = currentPathEndPosition-lastValidPathEnd; /* - * Path is just dots. We shouldn't really ever see a - * path like that. However, to be nice we at least - * don't mangle the path - we just add the dots as a - * path segment and continue. + * Path is just dots. We shouldn't really ever see a path + * like that. However, to be nice we at least don't mangle + * the path - we just add the dots as a path segment and + * continue. */ Tcl_DStringAppend(&dsNorm, ((const char *)nativePath) + Tcl_DStringLength(&ds) - - (dotLen * sizeof(TCHAR)), - (int)(dotLen * sizeof(TCHAR))); + - (dotLen * sizeof(WCHAR)), + dotLen * sizeof(WCHAR)); } else { /* * Normal path. @@ -2658,8 +2729,7 @@ TclpObjNormalizePath( handle = FindFirstFileW((WCHAR *) nativePath, &fData); if (handle == INVALID_HANDLE_VALUE) { /* - * This is usually the '/' in 'c:/' at end of - * string. + * This is usually the '/' in 'c:/' at end of string. */ Tcl_DStringAppend(&dsNorm, (const char *) L"/", @@ -2689,8 +2759,8 @@ TclpObjNormalizePath( } /* - * If we get here, we've got past one directory delimiter, so - * we know it is no longer a drive. + * If we get here, we've got past one directory delimiter, so we + * know it is no longer a drive. */ isDrive = 0; @@ -2704,17 +2774,20 @@ TclpObjNormalizePath( if (1) { WCHAR wpath[MAX_PATH]; - const TCHAR *nativePath = - Tcl_WinUtfToTChar(path, lastValidPathEnd - path, &ds); - DWORD wpathlen = GetLongPathNameProc(nativePath, - (TCHAR *) 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] >= L'a') { - wpath[0] -= (L'a' - L'A'); + if (wpath[0] >= 'a') { + wpath[0] -= ('a' - 'A'); } Tcl_DStringAppend(&dsNorm, (const char *) wpath, wpathlen * sizeof(WCHAR)); @@ -2735,22 +2808,24 @@ TclpObjNormalizePath( * native encoding, so we have to convert it to Utf. */ - Tcl_WinTCharToUtf((const TCHAR *) Tcl_DStringValue(&dsNorm), - Tcl_DStringLength(&dsNorm), &ds); + Tcl_DStringInit(&ds); + Tcl_WCharToUtfDString((const WCHAR *) Tcl_DStringValue(&dsNorm), + Tcl_DStringLength(&dsNorm)>>1, &ds); nextCheckpoint = Tcl_DStringLength(&ds); if (*lastValidPathEnd != 0) { /* * Not the end of the string. */ + int len; char *path; Tcl_Obj *tmpPathPtr; tmpPathPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), nextCheckpoint); Tcl_AppendToObj(tmpPathPtr, lastValidPathEnd, -1); - path = TclGetString(tmpPathPtr); - Tcl_SetStringObj(pathPtr, path, tmpPathPtr->length); + path = TclGetStringFromObj(tmpPathPtr, &len); + Tcl_SetStringObj(pathPtr, path, len); Tcl_DecrRefCount(tmpPathPtr); } else { /* @@ -2833,8 +2908,8 @@ TclWinVolumeRelativeNormalize( * also on drive C. */ - const char *drive = TclGetString(useThisCwd); - size_t cwdLen = useThisCwd->length; + int cwdLen; + const char *drive = TclGetStringFromObj(useThisCwd, &cwdLen); char drive_cur = path[0]; if (drive_cur >= 'a') { @@ -2910,7 +2985,8 @@ TclpNativeToNormalized( int len; char *copy, *p; - Tcl_WinTCharToUtf((const TCHAR *) clientData, -1, &ds); + Tcl_DStringInit(&ds); + Tcl_WCharToUtfDString((const WCHAR *) clientData, -1, &ds); copy = Tcl_DStringValue(&ds); len = Tcl_DStringLength(&ds); @@ -2957,7 +3033,7 @@ TclpNativeToNormalized( * The nativePath representation. * * Side effects: - * Memory will be allocated. The path may need to be normalized. + * Memory will be allocated. The path might be normalized. * *--------------------------------------------------------------------------- */ @@ -2969,7 +3045,7 @@ TclNativeCreateNativeRep( WCHAR *nativePathPtr = NULL; const char *str; Tcl_Obj *validPathPtr; - size_t len; + int len; WCHAR *wp; if (TclFSCwdIsNative()) { @@ -2983,7 +3059,11 @@ TclNativeCreateNativeRep( if (validPathPtr == NULL) { return NULL; } - /* refCount of validPathPtr was already incremented in Tcl_FSGetTranslatedPath */ + + /* + * refCount of validPathPtr was already incremented in + * Tcl_FSGetTranslatedPath + */ } else { /* * Make sure the normalized path is set. @@ -2993,73 +3073,100 @@ TclNativeCreateNativeRep( if (validPathPtr == NULL) { return NULL; } - /* validPathPtr returned from Tcl_FSGetNormalizedPath is owned by Tcl, so incr refCount here */ + + /* + * validPathPtr returned from Tcl_FSGetNormalizedPath is owned by Tcl, + * so incr refCount here + */ + Tcl_IncrRefCount(validPathPtr); } - str = Tcl_GetString(validPathPtr); - len = validPathPtr->length; + str = Tcl_GetStringFromObj(validPathPtr, &len); + + if (strlen(str) != (size_t) len) { + /* + * String contains NUL-bytes. This is invalid. + */ - if (strlen(str)!=(unsigned int)len) { - /* String contains NUL-bytes. This is invalid. */ goto done; } - /* For a reserved device, strip a possible postfix ':' */ + + /* + * For a reserved device, strip a possible postfix ':' + */ + len = WinIsReserved(str); if (len == 0) { - /* Let MultiByteToWideChar check for other invalid sequences, like - * 0xC0 0x80 (== overlong NUL). See bug [3118489]: NUL in filenames */ + /* + * Let MultiByteToWideChar check for other invalid sequences, like + * 0xC0 0x80 (== overlong NUL). See bug [3118489]: NUL in filenames + */ + len = MultiByteToWideChar(CP_UTF8, MB_ERR_INVALID_CHARS, str, -1, 0, 0); if (len==0) { goto done; } } - /* Overallocate 6 chars, making some room for extended paths */ - wp = nativePathPtr = ckalloc( (len+6) * sizeof(WCHAR) ); + + /* + * Overallocate 6 chars, making some room for extended paths + */ + + wp = nativePathPtr = ckalloc((len + 6) * sizeof(WCHAR)); if (nativePathPtr==0) { goto done; } - MultiByteToWideChar(CP_UTF8, MB_ERR_INVALID_CHARS, str, -1, nativePathPtr, len+1); + MultiByteToWideChar(CP_UTF8, MB_ERR_INVALID_CHARS, str, -1, nativePathPtr, + len + 1); + /* - ** If path starts with "//?/" or "\\?\" (extended path), translate - ** any slashes to backslashes but leave the '?' intact - */ - if ((str[0]=='\\' || str[0]=='/') && (str[1]=='\\' || str[1]=='/') - && str[2]=='?' && (str[3]=='\\' || str[3]=='/')) { + * If path starts with "//?/" or "\\?\" (extended path), translate any + * slashes to backslashes but leave the '?' intact + */ + + if ((str[0] == '\\' || str[0] == '/') && (str[1] == '\\' || str[1] == '/') + && str[2] == '?' && (str[3] == '\\' || str[3] == '/')) { wp[0] = wp[1] = wp[3] = '\\'; str += 4; wp += 4; } + /* - ** If there is no "\\?\" prefix but there is a drive or UNC - ** path prefix and the path is larger than MAX_PATH chars, - ** no Win32 API function can handle that unless it is - ** prefixed with the extended path prefix. See: - ** <http://msdn.microsoft.com/en-us/library/aa365247(VS.85).aspx#maxpath> - **/ - if (((str[0]>='A'&&str[0]<='Z') || (str[0]>='a'&&str[0]<='z')) - && str[1]==':') { - if (wp==nativePathPtr && len>MAX_PATH && (str[2]=='\\' || str[2]=='/')) { - memmove(wp+4, wp, len*sizeof(WCHAR)); - memcpy(wp, L"\\\\?\\", 4*sizeof(WCHAR)); + * If there is no "\\?\" prefix but there is a drive or UNC path prefix + * and the path is larger than MAX_PATH chars, no Win32 API function can + * handle that unless it is prefixed with the extended path prefix. See: + * <http://msdn.microsoft.com/en-us/library/aa365247(VS.85).aspx#maxpath> + */ + + if (((str[0] >= 'A' && str[0] <= 'Z') || (str[0] >= 'a' && str[0] <= 'z')) + && str[1] == ':') { + if (wp == nativePathPtr && len > MAX_PATH + && (str[2] == '\\' || str[2] == '/')) { + memmove(wp + 4, wp, len * sizeof(WCHAR)); + memcpy(wp, L"\\\\?\\", 4 * sizeof(WCHAR)); wp += 4; } + /* - ** If (remainder of) path starts with "<drive>:", - ** leave the ':' intact. + * If (remainder of) path starts with "<drive>:", leave the ':' + * intact. */ + wp += 2; - } else if (wp==nativePathPtr && len>MAX_PATH - && (str[0]=='\\' || str[0]=='/') - && (str[1]=='\\' || str[1]=='/') && str[2]!='?') { - memmove(wp+6, wp, len*sizeof(WCHAR)); - memcpy(wp, L"\\\\?\\UNC", 7*sizeof(WCHAR)); + } else if (wp == nativePathPtr && len > MAX_PATH + && (str[0] == '\\' || str[0] == '/') + && (str[1] == '\\' || str[1] == '/') && str[2] != '?') { + memmove(wp + 6, wp, len * sizeof(WCHAR)); + memcpy(wp, L"\\\\?\\UNC", 7 * sizeof(WCHAR)); wp += 7; } + /* - ** In the remainder of the path, translate invalid characters to - ** characters in the Unicode private use area. - */ + * In the remainder of the path, translate invalid characters to + * characters in the Unicode private use area. + */ + while (*wp != '\0') { if ((*wp < ' ') || wcschr(L"\"*:<>?|", *wp)) { *wp |= 0xF000; @@ -3070,7 +3177,6 @@ TclNativeCreateNativeRep( } done: - TclDecrRefCount(validPathPtr); return nativePathPtr; } @@ -3103,7 +3209,7 @@ TclNativeDupInternalRep( return NULL; } - len = sizeof(TCHAR) * (_tcslen((const TCHAR *) clientData) + 1); + len = sizeof(WCHAR) * (wcslen((const WCHAR *) clientData) + 1); copy = ckalloc(len); memcpy(copy, clientData, len); @@ -3134,7 +3240,7 @@ TclpUtime( { int res = 0; HANDLE fileHandle; - const TCHAR *native; + const WCHAR *native; DWORD attr = 0; DWORD flags = FILE_ATTRIBUTE_NORMAL; FILETIME lastAccessTime, lastModTime; @@ -3144,7 +3250,7 @@ TclpUtime( native = Tcl_FSGetNativePath(pathPtr); - attr = GetFileAttributes(native); + attr = GetFileAttributesW(native); if (attr != INVALID_FILE_ATTRIBUTES && attr & FILE_ATTRIBUTE_DIRECTORY) { flags = FILE_FLAG_BACKUP_SEMANTICS; @@ -3155,7 +3261,7 @@ TclpUtime( * savings complications that utime gets wrong. */ - fileHandle = CreateFile(native, FILE_WRITE_ATTRIBUTES, 0, NULL, + fileHandle = CreateFileW(native, FILE_WRITE_ATTRIBUTES, 0, NULL, OPEN_EXISTING, flags, NULL); if (fileHandle == INVALID_HANDLE_VALUE || @@ -3185,7 +3291,7 @@ int TclWinFileOwned( Tcl_Obj *pathPtr) /* File whose ownership is to be checked */ { - const TCHAR *native; + const WCHAR *native; PSID ownerSid = NULL; PSECURITY_DESCRIPTOR secd = NULL; HANDLE token; @@ -3195,22 +3301,29 @@ TclWinFileOwned( native = Tcl_FSGetNativePath(pathPtr); - if (GetNamedSecurityInfo((LPTSTR) native, SE_FILE_OBJECT, - OWNER_SECURITY_INFORMATION, &ownerSid, - NULL, NULL, NULL, &secd) != ERROR_SUCCESS) { - /* Either not a file, or we do not have access to it in which - case we are in all likelihood not the owner */ + 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. + */ + return 0; } /* - * Getting the current process SID is a multi-step process. - * We make the assumption that if a call fails, this process is - * so underprivileged it could not possibly own anything. Normally - * a process can *always* look up its own token. + * Getting the current process SID is a multi-step process. We make the + * assumption that if a call fails, this process is so underprivileged it + * could not possibly own anything. Normally a process can *always* look + * up its own token. */ + if (OpenProcessToken(GetCurrentProcess(), TOKEN_QUERY, &token)) { - /* Find out how big the buffer needs to be */ + /* + * Find out how big the buffer needs to be. + */ + bufsz = 0; GetTokenInformation(token, TokenUser, NULL, 0, &bufsz); if (bufsz) { @@ -3222,15 +3335,20 @@ TclWinFileOwned( CloseHandle(token); } - /* Free allocations and be done */ - if (secd) + /* + * Free allocations and be done. + */ + + if (secd) { LocalFree(secd); /* Also frees ownerSid */ - if (buf) + } + if (buf) { ckfree(buf); + } return (owned != 0); /* Convert non-0 to 1 */ } - + /* * Local Variables: * mode: c diff --git a/win/tclWinInit.c b/win/tclWinInit.c index 2ce19ce..0d37d1a 100644 --- a/win/tclWinInit.c +++ b/win/tclWinInit.c @@ -17,7 +17,7 @@ #include <lmcons.h> /* - * GetUserName() is found in advapi32.dll + * GetUserNameW() is found in advapi32.dll */ #ifdef _MSC_VER # pragma comment(lib, "advapi32.lib") @@ -113,7 +113,7 @@ static void AppendEnvironment(Tcl_Obj *listPtr, const char *lib); * * TclpInitPlatform -- * - * Initialize all the platform-dependant things like signals, + * Initialize all the platform-dependent things like signals, * floating-point error handling and sockets. * * Called at process initialization time. @@ -149,13 +149,13 @@ TclpInitPlatform(void) * invoked. */ - TclWinInit(GetModuleHandle(NULL)); + TclWinInit(GetModuleHandleW(NULL)); #endif /* * Fill available functions depending on windows version */ - handle = GetModuleHandle(TEXT("KERNEL32")); + handle = GetModuleHandleW(L"KERNEL32"); tclWinProcs.cancelSynchronousIo = (BOOL (WINAPI *)(HANDLE)) GetProcAddress(handle, "CancelSynchronousIo"); @@ -188,6 +188,7 @@ TclpInitLibraryPath( Tcl_Obj *pathPtr; char installLib[LIBRARY_SIZE]; const char *bytes; + int length; pathPtr = Tcl_NewObj(); @@ -223,10 +224,10 @@ TclpInitLibraryPath( TclGetProcessGlobalValue(&sourceLibraryDir)); *encodingPtr = NULL; - bytes = TclGetString(pathPtr); - *lengthPtr = pathPtr->length; - *valuePtr = ckalloc(*lengthPtr + 1); - memcpy(*valuePtr, bytes, *lengthPtr + 1); + bytes = TclGetStringFromObj(pathPtr, &length); + *lengthPtr = length++; + *valuePtr = ckalloc(length); + memcpy(*valuePtr, bytes, length); Tcl_DecrRefCount(pathPtr); } @@ -269,7 +270,7 @@ AppendEnvironment( for (shortlib = (char *) &lib[strlen(lib)-1]; shortlib>lib ; shortlib--) { if (*shortlib == '/') { - if ((unsigned)(shortlib - lib) == strlen(lib) - 1) { + if ((size_t)(shortlib - lib) == strlen(lib) - 1) { Tcl_Panic("last character in lib cannot be '/'"); } shortlib++; @@ -296,7 +297,7 @@ AppendEnvironment( Tcl_SplitPath(buf, &pathc, &pathv); /* - * The lstrcmpi() will work even if pathv[pathc-1] is random UTF-8 + * The lstrcmpiA() will work even if pathv[pathc-1] is random UTF-8 * chars because I know shortlib is ascii. */ @@ -468,15 +469,15 @@ TclpGetUserName( Tcl_DStringInit(bufferPtr); if (TclGetEnv("USERNAME", bufferPtr) == NULL) { - TCHAR szUserName[UNLEN+1]; + WCHAR szUserName[UNLEN+1]; DWORD cchUserNameLen = UNLEN; - if (!GetUserName(szUserName, &cchUserNameLen)) { + if (!GetUserNameW(szUserName, &cchUserNameLen)) { return NULL; } cchUserNameLen--; - cchUserNameLen *= sizeof(TCHAR); - Tcl_WinTCharToUtf(szUserName, cchUserNameLen, bufferPtr); + Tcl_DStringInit(bufferPtr); + Tcl_WCharToUtfDString(szUserName, cchUserNameLen, bufferPtr); } return Tcl_DStringValue(bufferPtr); } @@ -516,7 +517,7 @@ TclpSetVariables( TclGetProcessGlobalValue(&defaultLibraryDir), TCL_GLOBAL_ONLY); if (!osInfoInitialized) { - HMODULE handle = GetModuleHandle(TEXT("NTDLL")); + HMODULE handle = GetModuleHandleW(L"NTDLL"); int(__stdcall *getversion)(void *) = (int(__stdcall *)(void *)) GetProcAddress(handle, "RtlGetVersion"); osInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFOW); @@ -542,7 +543,7 @@ TclpSetVariables( TCL_GLOBAL_ONLY); } -#ifdef _DEBUG +#ifndef NDEBUG /* * The existence of the "debug" element of the tcl_platform array * indicates that this particular Tcl shell has been compiled with debug @@ -627,7 +628,7 @@ TclpFindVariable( * searches). */ { int i, length, result = -1; - register const char *env, *p1, *p2; + const char *env, *p1, *p2; char *envUpper, *nameUpper; Tcl_DString envString; @@ -637,7 +638,7 @@ TclpFindVariable( length = strlen(name); nameUpper = ckalloc(length + 1); - memcpy(nameUpper, name, (size_t) length+1); + memcpy(nameUpper, name, length+1); Tcl_UtfToUpper(nameUpper); Tcl_DStringInit(&envString); diff --git a/win/tclWinInt.h b/win/tclWinInt.h index 63835bf..07c1b9e 100644 --- a/win/tclWinInt.h +++ b/win/tclWinInt.h @@ -46,7 +46,7 @@ MODULE_SCOPE TclWinProcs tclWinProcs; */ MODULE_SCOPE char TclWinDriveLetterForVolMountPoint( - const TCHAR *mountPoint); + const WCHAR *mountPoint); MODULE_SCOPE void TclWinEncodingsCleanup(); MODULE_SCOPE void TclWinInit(HINSTANCE hInst); MODULE_SCOPE TclFile TclWinMakeFile(HANDLE handle); @@ -56,11 +56,11 @@ MODULE_SCOPE Tcl_Channel TclWinOpenFileChannel(HANDLE handle, char *channelName, int permissions, int appendMode); MODULE_SCOPE Tcl_Channel TclWinOpenSerialChannel(HANDLE handle, char *channelName, int permissions); -MODULE_SCOPE HANDLE TclWinSerialOpen(HANDLE handle, const TCHAR *name, +MODULE_SCOPE HANDLE TclWinSerialOpen(HANDLE handle, const WCHAR *name, DWORD access); -MODULE_SCOPE int TclWinSymLinkCopyDirectory(const TCHAR *LinkOriginal, - const TCHAR *LinkCopy); -MODULE_SCOPE int TclWinSymLinkDelete(const TCHAR *LinkOriginal, +MODULE_SCOPE int TclWinSymLinkCopyDirectory(const WCHAR *LinkOriginal, + const WCHAR *LinkCopy); +MODULE_SCOPE int TclWinSymLinkDelete(const WCHAR *LinkOriginal, int linkOnly); MODULE_SCOPE int TclWinFileOwned(Tcl_Obj *); diff --git a/win/tclWinLoad.c b/win/tclWinLoad.c index 69263e9..b79a4ca 100644 --- a/win/tclWinLoad.c +++ b/win/tclWinLoad.c @@ -64,7 +64,7 @@ TclpDlopen( int flags) { HINSTANCE hInstance = NULL; - const TCHAR *nativeName; + const WCHAR *nativeName; Tcl_LoadHandle handlePtr; DWORD firstError; @@ -76,7 +76,7 @@ TclpDlopen( nativeName = Tcl_FSGetNativePath(pathPtr); if (nativeName != NULL) { - hInstance = LoadLibraryEx(nativeName, NULL, + hInstance = LoadLibraryExW(nativeName, NULL, LOAD_WITH_ALTERED_SEARCH_PATH); } if (hInstance == NULL) { @@ -95,8 +95,9 @@ TclpDlopen( firstError = (nativeName == NULL) ? ERROR_MOD_NOT_FOUND : GetLastError(); - nativeName = Tcl_WinUtfToTChar(Tcl_GetString(pathPtr), -1, &ds); - hInstance = LoadLibraryEx(nativeName, NULL, + Tcl_DStringInit(&ds); + nativeName = Tcl_UtfToWCharDString(Tcl_GetString(pathPtr), -1, &ds); + hInstance = LoadLibraryExW(nativeName, NULL, LOAD_WITH_ALTERED_SEARCH_PATH); Tcl_DStringFree(&ds); } diff --git a/win/tclWinNotify.c b/win/tclWinNotify.c index b34fc4f..2ab4efa 100644 --- a/win/tclWinNotify.c +++ b/win/tclWinNotify.c @@ -49,7 +49,7 @@ static Tcl_ThreadDataKey dataKey; */ static int notifierCount = 0; -static const TCHAR className[] = TEXT("TclNotifier"); +static const WCHAR className[] = L"TclNotifier"; static int initialized = 0; static CRITICAL_SECTION notifierMutex; @@ -83,7 +83,6 @@ Tcl_InitNotifier(void) return tclNotifierHooks.initNotifierProc(); } else { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - WNDCLASS class; TclpMasterLock(); if (!initialized) { @@ -99,18 +98,20 @@ Tcl_InitNotifier(void) EnterCriticalSection(¬ifierMutex); if (notifierCount == 0) { - class.style = 0; - class.cbClsExtra = 0; - class.cbWndExtra = 0; - class.hInstance = TclWinGetTclInstance(); - class.hbrBackground = NULL; - class.lpszMenuName = NULL; - class.lpszClassName = className; - class.lpfnWndProc = NotifierProc; - class.hIcon = NULL; - class.hCursor = NULL; - - if (!RegisterClass(&class)) { + 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"); } } @@ -124,7 +125,7 @@ Tcl_InitNotifier(void) tsdPtr->hwnd = NULL; tsdPtr->thread = GetCurrentThreadId(); - tsdPtr->event = CreateEvent(NULL, TRUE /* manual */, + tsdPtr->event = CreateEventW(NULL, TRUE /* manual */, FALSE /* !signaled */, NULL); return tsdPtr; @@ -194,7 +195,7 @@ Tcl_FinalizeNotifier( if (notifierCount) { notifierCount--; if (notifierCount == 0) { - UnregisterClass(className, TclWinGetTclInstance()); + UnregisterClassW(className, TclWinGetTclInstance()); } } LeaveCriticalSection(¬ifierMutex); @@ -246,7 +247,7 @@ Tcl_AlertNotifier( EnterCriticalSection(&tsdPtr->crit); if (!tsdPtr->pending) { - PostMessage(tsdPtr->hwnd, WM_WAKEUP, 0, 0); + PostMessageW(tsdPtr->hwnd, WM_WAKEUP, 0, 0); } tsdPtr->pending = 1; LeaveCriticalSection(&tsdPtr->crit); @@ -358,7 +359,7 @@ Tcl_ServiceModeHook( */ if (mode == TCL_SERVICE_ALL && !tsdPtr->hwnd) { - tsdPtr->hwnd = CreateWindow(className, className, + tsdPtr->hwnd = CreateWindowW(className, className, WS_TILED, 0, 0, 0, 0, NULL, NULL, TclWinGetTclInstance(), NULL); @@ -406,7 +407,7 @@ NotifierProc( tsdPtr->pending = 0; LeaveCriticalSection(&tsdPtr->crit); } else if (message != WM_TIMER) { - return DefWindowProc(hwnd, message, wParam, lParam); + return DefWindowProcW(hwnd, message, wParam, lParam); } /* @@ -478,7 +479,7 @@ Tcl_WaitForEvent( * events currently sitting in the queue. */ - if (!PeekMessage(&msg, NULL, 0, 0, PM_NOREMOVE)) { + 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 @@ -500,12 +501,12 @@ Tcl_WaitForEvent( * Check to see if there are any messages to process. */ - if (PeekMessage(&msg, NULL, 0, 0, PM_NOREMOVE)) { + if (PeekMessageW(&msg, NULL, 0, 0, PM_NOREMOVE)) { /* * Retrieve and dispatch the first message. */ - result = GetMessage(&msg, NULL, 0, 0); + result = GetMessageW(&msg, NULL, 0, 0); if (result == 0) { /* * We received a request to exit this thread (WM_QUIT), so @@ -523,7 +524,7 @@ Tcl_WaitForEvent( status = -1; } else { TranslateMessage(&msg); - DispatchMessage(&msg); + DispatchMessageW(&msg); status = 1; } } else { diff --git a/win/tclWinPanic.c b/win/tclWinPanic.c index a71f506..fbd3e46 100644 --- a/win/tclWinPanic.c +++ b/win/tclWinPanic.c @@ -42,14 +42,14 @@ Tcl_ConsolePanic( va_start(argList, format); vsnprintf(buf+3, sizeof(buf)-3, format, argList); buf[sizeof(buf)-1] = 0; - msgString[TCL_MAX_WARN_LEN-1] = L'\0'; + msgString[TCL_MAX_WARN_LEN-1] = '\0'; MultiByteToWideChar(CP_UTF8, 0, buf+3, -1, msgString, TCL_MAX_WARN_LEN); /* * Truncate MessageBox string if it is too long to not overflow the buffer. */ - if (msgString[TCL_MAX_WARN_LEN-1] != L'\0') { + if (msgString[TCL_MAX_WARN_LEN-1] != '\0') { memcpy(msgString + (TCL_MAX_WARN_LEN - 5), L" ...", 5 * sizeof(WCHAR)); } @@ -58,7 +58,7 @@ Tcl_ConsolePanic( } else if (_isatty(2)) { WriteConsoleW(handle, msgString, wcslen(msgString), &dummy, 0); } else { - buf[0] = 0xEF; buf[1] = 0xBB; buf[2] = 0xBF; /* UTF-8 bom */ + buf[0] = '\xEF'; buf[1] = '\xBB'; buf[2] = '\xBF'; /* UTF-8 bom */ WriteFile(handle, buf, strlen(buf), &dummy, 0); WriteFile(handle, "\n", 1, &dummy, 0); FlushFileBuffers(handle); diff --git a/win/tclWinPipe.c b/win/tclWinPipe.c index bd95ea4..23ede6e 100644 --- a/win/tclWinPipe.c +++ b/win/tclWinPipe.c @@ -124,8 +124,7 @@ typedef struct PipeInfo { * write. Set to 0 if no error has been * detected. This word is shared with the * writer thread so access must be - * synchronized with the writable object. - */ + * synchronized with the writable object. */ char *writeBuf; /* Current background output buffer. Access is * synchronized with the writable object. */ int writeBufLen; /* Size of write buffer. Access is @@ -191,7 +190,7 @@ static DWORD WINAPI PipeReaderThread(LPVOID arg); static void PipeSetupProc(ClientData clientData, int flags); static void PipeWatchProc(ClientData instanceData, int mask); static DWORD WINAPI PipeWriterThread(LPVOID arg); -static int TempFileName(TCHAR name[MAX_PATH]); +static int TempFileName(WCHAR name[MAX_PATH]); static int WaitForRead(PipeInfo *infoPtr, int blocking); static void PipeThreadActionProc(ClientData instanceData, int action); @@ -218,7 +217,7 @@ static const Tcl_ChannelType pipeChannelType = { NULL, /* handler proc. */ NULL, /* wide seek proc */ PipeThreadActionProc, /* thread action proc */ - NULL /* truncate */ + NULL /* truncate */ }; /* @@ -463,18 +462,18 @@ TclWinMakeFile( static int TempFileName( - TCHAR name[MAX_PATH]) /* Buffer in which name for temporary file + WCHAR name[MAX_PATH]) /* Buffer in which name for temporary file * gets stored. */ { - const TCHAR *prefix = TEXT("TCL"); - if (GetTempPath(MAX_PATH, name) != 0) { - if (GetTempFileName(name, prefix, 0, name) != 0) { + 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 GetTempFileName(name, prefix, 0, name); + return GetTempFileNameW(name, prefix, 0, name); } /* @@ -533,7 +532,7 @@ TclpOpenFile( HANDLE handle; DWORD accessMode, createMode, shareMode, flags; Tcl_DString ds; - const TCHAR *nativePath; + const WCHAR *nativePath; /* * Map the access bits to the NT access mode. @@ -578,7 +577,8 @@ TclpOpenFile( break; } - nativePath = Tcl_WinUtfToTChar(path, -1, &ds); + Tcl_DStringInit(&ds); + nativePath = Tcl_UtfToWCharDString(path, -1, &ds); /* * If the file is not being created, use the existing file attributes. @@ -586,7 +586,7 @@ TclpOpenFile( flags = 0; if (!(mode & O_CREAT)) { - flags = GetFileAttributes(nativePath); + flags = GetFileAttributesW(nativePath); if (flags == 0xFFFFFFFF) { flags = 0; } @@ -602,7 +602,7 @@ TclpOpenFile( * Now we get to create the file. */ - handle = CreateFile(nativePath, accessMode, shareMode, + handle = CreateFileW(nativePath, accessMode, shareMode, NULL, createMode, flags, NULL); Tcl_DStringFree(&ds); @@ -650,7 +650,7 @@ TclFile TclpCreateTempFile( const char *contents) /* String to write into temp file, or NULL. */ { - TCHAR name[MAX_PATH]; + WCHAR name[MAX_PATH]; const char *native; Tcl_DString dstring; HANDLE handle; @@ -659,7 +659,7 @@ TclpCreateTempFile( return NULL; } - handle = CreateFile(name, + 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) { @@ -721,7 +721,7 @@ TclpCreateTempFile( TclWinConvertError(GetLastError()); CloseHandle(handle); - DeleteFile(name); + DeleteFileW(name); return NULL; } @@ -744,7 +744,7 @@ TclpCreateTempFile( Tcl_Obj * TclpTempFileName(void) { - TCHAR fileName[MAX_PATH]; + WCHAR fileName[MAX_PATH]; if (TempFileName(fileName) == 0) { return NULL; @@ -936,8 +936,8 @@ TclpCreateProcess( * process. */ { int result, applType, createFlags; - Tcl_DString cmdLine; /* Complete command line (TCHAR). */ - STARTUPINFO startInfo; + Tcl_DString cmdLine; /* Complete command line (WCHAR). */ + STARTUPINFOW startInfo; PROCESS_INFORMATION procInfo; SECURITY_ATTRIBUTES secAtts; HANDLE hProcess, h, inputHandle, outputHandle, errorHandle; @@ -1048,7 +1048,7 @@ TclpCreateProcess( * sink. */ - startInfo.hStdOutput = CreateFile(TEXT("NUL:"), GENERIC_WRITE, 0, + startInfo.hStdOutput = CreateFileW(L"NUL:", GENERIC_WRITE, 0, &secAtts, OPEN_ALWAYS, FILE_ATTRIBUTE_NORMAL, NULL); } else { DuplicateHandle(hProcess, outputHandle, hProcess, @@ -1068,7 +1068,7 @@ TclpCreateProcess( * sink. */ - startInfo.hStdError = CreateFile(TEXT("NUL:"), GENERIC_WRITE, 0, + startInfo.hStdError = CreateFileW(L"NUL:", GENERIC_WRITE, 0, &secAtts, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL); } else { DuplicateHandle(hProcess, errorHandle, hProcess, &startInfo.hStdError, @@ -1134,7 +1134,7 @@ TclpCreateProcess( BuildCommandLine(execPath, argc, argv, &cmdLine); - if (CreateProcess(NULL, (TCHAR *) Tcl_DStringValue(&cmdLine), + if (CreateProcessW(NULL, (WCHAR *) Tcl_DStringValue(&cmdLine), NULL, NULL, TRUE, (DWORD) createFlags, NULL, NULL, &startInfo, &procInfo) == 0) { TclWinConvertError(GetLastError()); @@ -1156,7 +1156,7 @@ TclpCreateProcess( * 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 - * CreateProcess() and CloseHandle(), the problem does not occur." PSS ID + * CreateProcessW() and CloseHandle(), the problem does not occur." PSS ID * Number: Q124121 */ @@ -1205,7 +1205,7 @@ HasConsole(void) { HANDLE handle; - handle = CreateFileA("CONOUT$", GENERIC_WRITE, FILE_SHARE_WRITE, + handle = CreateFileW(L"CONOUT$", GENERIC_WRITE, FILE_SHARE_WRITE, NULL, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL); if (handle != INVALID_HANDLE_VALUE) { @@ -1260,14 +1260,14 @@ ApplicationType( { int applType, i, nameLen, found; HANDLE hFile; - TCHAR *rest; + WCHAR *rest; char *ext; char buf[2]; DWORD attr, read; IMAGE_DOS_HEADER header; Tcl_DString nameBuf, ds; - const TCHAR *nativeName; - TCHAR nativeFullPath[MAX_PATH]; + const WCHAR *nativeName; + WCHAR nativeFullPath[MAX_PATH]; static const char extensions[][5] = {"", ".com", ".exe", ".bat", ".cmd"}; /* @@ -1275,7 +1275,7 @@ ApplicationType( * is, then try adding .com, .exe, .bat and .cmd, in that order, to the name, * looking for an executable. * - * Using the raw SearchPath() function doesn't do quite what is necessary. + * 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 @@ -1291,9 +1291,10 @@ ApplicationType( for (i = 0; i < (int) (sizeof(extensions) / sizeof(extensions[0])); i++) { Tcl_DStringSetLength(&nameBuf, nameLen); Tcl_DStringAppend(&nameBuf, extensions[i], -1); - nativeName = Tcl_WinUtfToTChar(Tcl_DStringValue(&nameBuf), + Tcl_DStringInit(&ds); + nativeName = Tcl_UtfToWCharDString(Tcl_DStringValue(&nameBuf), Tcl_DStringLength(&nameBuf), &ds); - found = SearchPath(NULL, nativeName, NULL, MAX_PATH, + found = SearchPathW(NULL, nativeName, NULL, MAX_PATH, nativeFullPath, &rest); Tcl_DStringFree(&ds); if (found == 0) { @@ -1305,11 +1306,12 @@ ApplicationType( * known type. */ - attr = GetFileAttributes(nativeFullPath); + attr = GetFileAttributesW(nativeFullPath); if ((attr == 0xffffffff) || (attr & FILE_ATTRIBUTE_DIRECTORY)) { continue; } - strcpy(fullName, Tcl_WinTCharToUtf(nativeFullPath, -1, &ds)); + Tcl_DStringInit(&ds); + strcpy(fullName, Tcl_WCharToUtfDString(nativeFullPath, -1, &ds)); Tcl_DStringFree(&ds); ext = strrchr(fullName, '.'); @@ -1319,7 +1321,7 @@ ApplicationType( break; } - hFile = CreateFile(nativeFullPath, + hFile = CreateFileW(nativeFullPath, GENERIC_READ, FILE_SHARE_READ, NULL, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL); if (hFile == INVALID_HANDLE_VALUE) { @@ -1399,8 +1401,9 @@ ApplicationType( * application name from the arguments. */ - GetShortPathName(nativeFullPath, nativeFullPath, MAX_PATH); - strcpy(fullName, Tcl_WinTCharToUtf(nativeFullPath, -1, &ds)); + GetShortPathNameW(nativeFullPath, nativeFullPath, MAX_PATH); + Tcl_DStringInit(&ds); + strcpy(fullName, Tcl_WCharToUtfDString(nativeFullPath, -1, &ds)); Tcl_DStringFree(&ds); } return applType; @@ -1412,7 +1415,7 @@ ApplicationType( * BuildCommandLine -- * * The command line arguments are stored in linePtr separated by spaces, - * in a form that CreateProcess() understands. Special characters in + * in a form that CreateProcessW() understands. Special characters in * individual arguments from argv[] must be quoted when being stored in * cmdLine. * @@ -1428,9 +1431,12 @@ ApplicationType( static const char * BuildCmdLineBypassBS( const char *current, - const char **bspos -) { - /* mark first backslash possition */ + const char **bspos) +{ + /* + * Mark first backslash position. + */ + if (!*bspos) { *bspos = current; } @@ -1445,14 +1451,14 @@ QuoteCmdLineBackslash( Tcl_DString *dsPtr, const char *start, const char *current, - const char *bspos -) { + const char *bspos) +{ if (!bspos) { - if (current > start) { /* part before current (special) */ + if (current > start) { /* part before current (special) */ Tcl_DStringAppend(dsPtr, start, (int) (current - start)); } } else { - if (bspos > start) { /* part before first backslash */ + if (bspos > start) { /* part before first backslash */ Tcl_DStringAppend(dsPtr, start, (int) (bspos - start)); } while (bspos++ < current) { /* each backslash twice */ @@ -1467,38 +1473,59 @@ QuoteCmdLinePart( const char *start, const char *special, const char *specMetaChars, - const char **bspos -) { + const char **bspos) +{ if (!*bspos) { - /* rest before special (before quote) */ + /* + * Rest before special (before quote). + */ + QuoteCmdLineBackslash(dsPtr, start, special, NULL); start = special; } else { - /* rest before first backslash and backslashes into new quoted block */ + /* + * Rest before first backslash and backslashes into new quoted block. + */ + QuoteCmdLineBackslash(dsPtr, start, *bspos, NULL); start = *bspos; } + /* - * escape all special chars enclosed in quotes like `"..."`, note that here we - * don't must escape `\` (with `\`), because it's outside of the main quotes, - * so `\` remains `\`, but important - not at end of part, because results as - * before the quote, so `%\%\` should be escaped as `"%\%"\\`). + * escape all special chars enclosed in quotes like `"..."`, note that + * here we don't must escape `\` (with `\`), because it's outside of the + * main quotes, so `\` remains `\`, but important - not at end of part, + * because results as before the quote, so `%\%\` should be escaped as + * `"%\%"\\`). */ + TclDStringAppendLiteral(dsPtr, "\""); /* opening escape quote-char */ do { *bspos = NULL; special++; if (*special == '\\') { - /* bypass backslashes (and mark first backslash possition)*/ + /* + * Bypass backslashes (and mark first backslash position). + */ + special = BuildCmdLineBypassBS(special, bspos); - if (*special == '\0') break; + if (*special == '\0') { + break; + } } } while (*special && strchr(specMetaChars, *special)); if (!*bspos) { - /* unescaped rest before quote */ + /* + * Unescaped rest before quote. + */ + QuoteCmdLineBackslash(dsPtr, start, special, NULL); } else { - /* unescaped rest before first backslash (rather belongs to the main block) */ + /* + * Unescaped rest before first backslash (rather belongs to the main + * block). + */ + QuoteCmdLineBackslash(dsPtr, start, *bspos, NULL); } TclDStringAppendLiteral(dsPtr, "\""); /* closing escape quote-char */ @@ -1512,18 +1539,19 @@ BuildCommandLine( int argc, /* Number of arguments. */ const char **argv, /* Argument strings in UTF. */ Tcl_DString *linePtr) /* Initialized Tcl_DString that receives the - * command line (TCHAR). */ + * command line (WCHAR). */ { const char *arg, *start, *special, *bspos; int quote = 0, i; Tcl_DString ds; - - /* characters to enclose in quotes if unpaired quote flag set */ - const static char *specMetaChars = "&|^<>!()%"; - /* characters to enclose in quotes in any case (regardless unpaired-flag) */ - const static char *specMetaChars2 = "%"; - - /* Quote flags: + static const char specMetaChars[] = "&|^<>!()%"; + /* Characters to enclose in quotes if unpaired + * quote flag set. */ + static const char specMetaChars2[] = "%"; + /* Character to enclose in quotes in any case + * (regardless of unpaired-flag). */ + /* + * Quote flags: * CL_ESCAPE - escape argument; * CL_QUOTE - enclose in quotes; * CL_UNPAIRED - previous arguments chain contains unpaired quote-char; @@ -1554,34 +1582,32 @@ BuildCommandLine( if (arg[0] == '\0') { quote = CL_QUOTE; } else { - int count; - Tcl_UniChar ch; for (start = arg; - *start != '\0' && - (quote & (CL_ESCAPE|CL_QUOTE)) != (CL_ESCAPE|CL_QUOTE); - start += count - ) { - count = Tcl_UtfToUniChar(start, &ch); - if (count > 1) continue; - if (Tcl_UniCharIsSpace(ch)) { - quote |= CL_QUOTE; /* quote only */ - if (bspos) { /* if backslash found - escape & quote */ + *start != '\0' && + (quote & (CL_ESCAPE|CL_QUOTE)) != (CL_ESCAPE|CL_QUOTE); + start++) { + if (*start & 0x80) { + continue; + } + if (TclIsSpaceProc(*start)) { + quote |= CL_QUOTE; /* quote only */ + if (bspos) { /* if backslash found, escape & quote */ quote |= CL_ESCAPE; break; } continue; } if (strchr(specMetaChars, *start)) { - quote |= (CL_ESCAPE|CL_QUOTE); /*escape & quote */ + quote |= (CL_ESCAPE|CL_QUOTE); /* escape & quote */ break; } if (*start == '"') { - quote |= CL_ESCAPE; /* escape only */ + quote |= CL_ESCAPE; /* escape only */ continue; } if (*start == '\\') { bspos = start; - if (quote & CL_QUOTE) { /* if quote - escape & quote */ + if (quote & CL_QUOTE) { /* if quote, escape & quote */ quote |= CL_ESCAPE; break; } @@ -1591,61 +1617,122 @@ BuildCommandLine( bspos = NULL; } if (quote & CL_QUOTE) { - /* start of argument (main opening quote-char) */ + /* + * Start of argument (main opening quote-char). + */ + TclDStringAppendLiteral(&ds, "\""); } if (!(quote & CL_ESCAPE)) { - /* nothing to escape */ + /* + * Nothing to escape. + */ + Tcl_DStringAppend(&ds, arg, -1); } else { start = arg; for (special = arg; *special != '\0'; ) { - /* position of `\` is important before quote or at end (equal `\"` because quoted) */ + /* + * Position of `\` is important before quote or at end (equal + * `\"` because quoted). + */ + if (*special == '\\') { - /* bypass backslashes (and mark first backslash possition)*/ + /* + * Bypass backslashes (and mark first backslash position) + */ + special = BuildCmdLineBypassBS(special, &bspos); - if (*special == '\0') break; + if (*special == '\0') { + break; + } } /* ["] */ if (*special == '"') { - quote ^= CL_UNPAIRED; /* invert unpaired flag - observe unpaired quotes */ - /* add part before (and escape backslashes before quote) */ + /* + * Invert the unpaired flag - observe unpaired quotes + */ + + quote ^= CL_UNPAIRED; + + /* + * Add part before (and escape backslashes before quote). + */ + QuoteCmdLineBackslash(&ds, start, special, bspos); bspos = NULL; - /* escape using backslash */ + + /* + * Escape using backslash + */ + TclDStringAppendLiteral(&ds, "\\\""); start = ++special; continue; } - /* unpaired (escaped) quote causes special handling on meta-chars */ + + /* + * Unpaired (escaped) quote causes special handling on + * meta-chars + */ + if ((quote & CL_UNPAIRED) && strchr(specMetaChars, *special)) { - special = QuoteCmdLinePart(&ds, start, special, specMetaChars, &bspos); - /* start to current or first backslash */ + special = QuoteCmdLinePart(&ds, start, special, + specMetaChars, &bspos); + + /* + * Start to current or first backslash + */ + start = !bspos ? special : bspos; continue; } - /* special case for % - should be enclosed always (paired also) */ + + /* + * Special case for % - should be enclosed always (paired + * also) + */ + if (strchr(specMetaChars2, *special)) { - special = QuoteCmdLinePart(&ds, start, special, specMetaChars2, &bspos); - /* start to current or first backslash */ + special = QuoteCmdLinePart(&ds, start, special, + specMetaChars2, &bspos); + + /* + * Start to current or first backslash. + */ + start = !bspos ? special : bspos; continue; } - /* other not special (and not meta) character */ - bspos = NULL; /* reset last backslash possition (not interesting) */ + + /* + * Other not special (and not meta) character + */ + + bspos = NULL; /* reset last backslash position (not + * interesting) */ special++; } - /* rest of argument (and escape backslashes before closing main quote) */ + + /* + * Rest of argument (and escape backslashes before closing main + * quote) + */ + QuoteCmdLineBackslash(&ds, start, special, - (quote & CL_QUOTE) ? bspos : NULL); + (quote & CL_QUOTE) ? bspos : NULL); } if (quote & CL_QUOTE) { - /* end of argument (main closing quote-char) */ + /* + * End of argument (main closing quote-char) + */ + TclDStringAppendLiteral(&ds, "\""); } } Tcl_DStringFree(linePtr); - Tcl_WinUtfToTChar(Tcl_DStringValue(&ds), Tcl_DStringLength(&ds), linePtr); + Tcl_DStringInit(linePtr); + Tcl_UtfToWCharDString(Tcl_DStringValue(&ds), Tcl_DStringLength(&ds), linePtr); Tcl_DStringFree(&ds); } @@ -1702,7 +1789,7 @@ TclpCreateCommandChannel( * Start the background reader thread. */ - infoPtr->readable = CreateEvent(NULL, TRUE, TRUE, NULL); + infoPtr->readable = CreateEventW(NULL, TRUE, TRUE, NULL); infoPtr->readThread = CreateThread(NULL, 256, PipeReaderThread, TclPipeThreadCreateTI(&infoPtr->readTI, infoPtr, infoPtr->readable), 0, NULL); @@ -1717,7 +1804,7 @@ TclpCreateCommandChannel( * Start the background writer thread. */ - infoPtr->writable = CreateEvent(NULL, TRUE, TRUE, NULL); + infoPtr->writable = CreateEventW(NULL, TRUE, TRUE, NULL); infoPtr->writeThread = CreateThread(NULL, 256, PipeWriterThread, TclPipeThreadCreateTI(&infoPtr->writeTI, infoPtr, infoPtr->writable), 0, NULL); @@ -2178,8 +2265,9 @@ PipeOutputProc( *errorCode = 0; /* avoid blocking if pipe-thread exited */ - timeout = ((infoPtr->flags & PIPE_ASYNC) || !TclPipeThreadIsAlive(&infoPtr->writeTI) - || TclInExit() || TclInThreadExit()) ? 0 : INFINITE; + timeout = ((infoPtr->flags & PIPE_ASYNC) + || !TclPipeThreadIsAlive(&infoPtr->writeTI) + || TclInExit() || TclInThreadExit()) ? 0 : INFINITE; if (WaitForSingleObject(infoPtr->writable, timeout) == WAIT_TIMEOUT) { /* * The writer thread is blocked waiting for a write to complete and @@ -2217,7 +2305,7 @@ PipeOutputProc( infoPtr->writeBufLen = toWrite; infoPtr->writeBuf = ckalloc(toWrite); } - memcpy(infoPtr->writeBuf, buf, (size_t) toWrite); + memcpy(infoPtr->writeBuf, buf, toWrite); infoPtr->toWrite = toWrite; ResetEvent(infoPtr->writable); TclPipeThreadSignal(&infoPtr->writeTI); @@ -2365,6 +2453,7 @@ PipeWatchProc( infoPtr->watchMask = mask & infoPtr->validMask; if (infoPtr->watchMask) { Tcl_Time blockTime = { 0, 0 }; + if (!oldMask) { infoPtr->nextPtr = tsdPtr->firstPipePtr; tsdPtr->firstPipePtr = infoPtr; @@ -2834,7 +2923,7 @@ static DWORD WINAPI PipeReaderThread( LPVOID arg) { - TclPipeThreadInfo *pipeTI = (TclPipeThreadInfo *)arg; + TclPipeThreadInfo *pipeTI = (TclPipeThreadInfo *) arg; PipeInfo *infoPtr = NULL; /* access info only after success init/wait */ HANDLE handle = NULL; DWORD count, err; @@ -2845,13 +2934,14 @@ PipeReaderThread( * Wait for the main thread to signal before attempting to wait on the * pipe becoming readable. */ + if (!TclPipeThreadWaitForSignal(&pipeTI)) { /* exit */ break; } if (!infoPtr) { - infoPtr = (PipeInfo *)pipeTI->clientData; + infoPtr = (PipeInfo *) pipeTI->clientData; handle = ((WinFile *) infoPtr->readFile)->handle; } @@ -3104,7 +3194,7 @@ TclpOpenTemporaryFile( Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj) { - TCHAR name[MAX_PATH]; + WCHAR name[MAX_PATH]; char *namePtr; HANDLE handle; DWORD flags = FILE_ATTRIBUTE_TEMPORARY; @@ -3116,21 +3206,22 @@ TclpOpenTemporaryFile( } namePtr = (char *) name; - length = GetTempPath(MAX_PATH, name); + length = GetTempPathW(MAX_PATH, name); if (length == 0) { goto gotError; } - namePtr += length * sizeof(TCHAR); + namePtr += length * sizeof(WCHAR); if (basenameObj) { - const char *string = Tcl_GetString(basenameObj); + const char *string = TclGetStringFromObj(basenameObj, &length); - Tcl_WinUtfToTChar(string, basenameObj->length, &buf); + 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 TCHAR *baseStr = TEXT("TCL"); - int length = 3 * sizeof(TCHAR); + const WCHAR *baseStr = L"TCL"; + length = 3 * sizeof(WCHAR); memcpy(namePtr, baseStr, length); namePtr += length; @@ -3144,12 +3235,13 @@ TclpOpenTemporaryFile( sprintf(number, "%d.TMP", counter); counter = (unsigned short) (counter + 1); - Tcl_WinUtfToTChar(number, strlen(number), &buf); + 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 = CreateFile(name, + handle = CreateFileW(name, GENERIC_READ|GENERIC_WRITE, 0, NULL, CREATE_NEW, flags, NULL); } while (handle == INVALID_HANDLE_VALUE && --counter2 > 0 @@ -3197,8 +3289,8 @@ TclPipeThreadCreateTI( pipeTI = malloc(sizeof(TclPipeThreadInfo)); #else pipeTI = ckalloc(sizeof(TclPipeThreadInfo)); -#endif - pipeTI->evControl = CreateEvent(NULL, FALSE, FALSE, NULL); +#endif /* !_PTI_USE_CKALLOC */ + pipeTI->evControl = CreateEventW(NULL, FALSE, FALSE, NULL); pipeTI->state = PTI_STATE_IDLE; pipeTI->clientData = clientData; pipeTI->evWakeUp = wakeEvent; @@ -3236,40 +3328,64 @@ TclPipeThreadWaitForSignal( } wakeEvent = pipeTI->evWakeUp; + /* * Wait for the main thread to signal before attempting to do the work. */ - /* reset work state of thread (idle/waiting) */ - if ((state = InterlockedCompareExchange(&pipeTI->state, - PTI_STATE_IDLE, PTI_STATE_WORK)) & (PTI_STATE_STOP|PTI_STATE_END)) { - /* end of work, check the owner of structure */ + /* + * Reset work state of thread (idle/waiting) + */ + + state = InterlockedCompareExchange(&pipeTI->state, PTI_STATE_IDLE, + PTI_STATE_WORK); + if (state & (PTI_STATE_STOP|PTI_STATE_END)) { + /* + * End of work, check the owner of structure. + */ + goto end; } - /* entering wait */ - waitResult = WaitForSingleObject(pipeTI->evControl, INFINITE); - if (waitResult != WAIT_OBJECT_0) { + /* + * Entering wait + */ + waitResult = WaitForSingleObject(pipeTI->evControl, INFINITE); + if (waitResult != WAIT_OBJECT_0) { /* * The control event was not signaled, so end of work (unexpected * behaviour, main thread can be dead?). */ + goto end; } - /* try to set work state of thread */ - if ((state = InterlockedCompareExchange(&pipeTI->state, - PTI_STATE_WORK, PTI_STATE_IDLE)) & (PTI_STATE_STOP|PTI_STATE_END)) { - /* end of work */ + /* + * Try to set work state of thread + */ + + state = InterlockedCompareExchange(&pipeTI->state, PTI_STATE_WORK, + PTI_STATE_IDLE); + if (state & (PTI_STATE_STOP|PTI_STATE_END)) { + /* + * End of work + */ + goto end; } - /* signaled to work */ + /* + * Signaled to work. + */ + return 1; -end: - /* end of work, check the owner of the TI structure */ + end: + /* + * End of work, check the owner of the TI structure. + */ + if (state != PTI_STATE_STOP) { *pipeTIPtr = NULL; } else { @@ -3299,7 +3415,8 @@ end: int TclPipeThreadStopSignal( - TclPipeThreadInfo **pipeTIPtr, HANDLE wakeEvent) + TclPipeThreadInfo **pipeTIPtr, + HANDLE wakeEvent) { TclPipeThreadInfo *pipeTI = *pipeTIPtr; HANDLE evControl; @@ -3310,28 +3427,28 @@ TclPipeThreadStopSignal( } evControl = pipeTI->evControl; pipeTI->evWakeUp = wakeEvent; - switch ( - (state = InterlockedCompareExchange(&pipeTI->state, - PTI_STATE_STOP, PTI_STATE_IDLE)) - ) { - - case PTI_STATE_IDLE: - - /* Thread was idle/waiting, notify it goes teardown */ - SetEvent(evControl); - - *pipeTIPtr = NULL; - - case PTI_STATE_DOWN: + state = InterlockedCompareExchange(&pipeTI->state, PTI_STATE_STOP, + PTI_STATE_IDLE); + switch (state) { + case PTI_STATE_IDLE: + /* + * Thread was idle/waiting, notify it goes teardown + */ + SetEvent(evControl); + *pipeTIPtr = NULL; + /* 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 thread) - */ - InterlockedExchange(&pipeTI->state, PTI_STATE_END); + default: + /* + * Thread works currently, we should try to end it, own the TI + * structure (because of possible sharing the joint structures with + * thread) + */ + + InterlockedExchange(&pipeTI->state, PTI_STATE_END); break; } @@ -3374,46 +3491,63 @@ TclPipeThreadStop( pipeTI = *pipeTIPtr; evControl = pipeTI->evControl; pipeTI->evWakeUp = NULL; + /* * Try to sane stop the pipe worker, corresponding its current state */ - switch ( - (state = InterlockedCompareExchange(&pipeTI->state, - PTI_STATE_STOP, PTI_STATE_IDLE)) - ) { - case PTI_STATE_IDLE: + state = InterlockedCompareExchange(&pipeTI->state, PTI_STATE_STOP, + PTI_STATE_IDLE); + switch (state) { + case PTI_STATE_IDLE: + /* + * Thread was idle/waiting, notify it goes teardown + */ - /* Thread was idle/waiting, notify it goes teardown */ - SetEvent(evControl); + SetEvent(evControl); - /* we don't need to wait for it at all, thread frees himself (owns the TI structure) */ - pipeTI = NULL; + /* + * We don't need to wait for it at all, thread frees himself (owns the + * TI structure) + */ + + pipeTI = NULL; break; - case PTI_STATE_STOP: - /* already stopped, thread frees himself (owns the TI structure) */ - pipeTI = NULL; + case PTI_STATE_STOP: + /* + * Already stopped, thread frees himself (owns the TI structure) + */ + + pipeTI = NULL; break; - case PTI_STATE_DOWN: - /* Thread already down (?), do nothing */ + case PTI_STATE_DOWN: + /* + * Thread already down (?), do nothing + */ - /* we don't need to wait for it, but we should free pipeTI */ - hThread = NULL; + /* + * We don't need to wait for it, but we should free pipeTI + */ + hThread = NULL; break; /* case PTI_STATE_WORK: */ - default: + default: + /* + * Thread works currently, we should try to end it, own the TI + * structure (because of possible sharing the joint structures with + * thread) + */ + + state = InterlockedCompareExchange(&pipeTI->state, PTI_STATE_END, + PTI_STATE_WORK); + if (state == PTI_STATE_DOWN) { /* - * Thread works currently, we should try to end it, own the TI structure - * (because of possible sharing the joint structures with thread) + * We don't need to wait for it, but we should free pipeTI */ - if ((state = InterlockedCompareExchange(&pipeTI->state, - PTI_STATE_END, PTI_STATE_WORK)) == PTI_STATE_DOWN - ) { - /* we don't need to wait for it, but we should free pipeTI */ - hThread = NULL; - }; + hThread = NULL; + } break; } @@ -3428,8 +3562,8 @@ TclPipeThreadStop( GetExitCodeThread(hThread, &exitCode); if (exitCode == STILL_ACTIVE) { - int inExit = (TclInExit() || TclInThreadExit()); + /* * Set the stop event so that if the pipe thread is blocked * somewhere, it may hereafter sane exit cleanly. @@ -3440,59 +3574,69 @@ TclPipeThreadStop( /* * Cancel all sync-IO of this thread (may be blocked there). */ + if (tclWinProcs.cancelSynchronousIo) { tclWinProcs.cancelSynchronousIo(hThread); } /* - * Wait at most 20 milliseconds for the reader thread to - * close (regarding TIP#398-fast-exit). + * Wait at most 20 milliseconds for the reader thread to close + * (regarding TIP#398-fast-exit). */ - /* if we want TIP#398-fast-exit. */ - if (WaitForSingleObject(hThread, inExit ? 0 : 20) == WAIT_TIMEOUT) { + /* + * If we want TIP#398-fast-exit. + */ + if (WaitForSingleObject(hThread, inExit ? 0 : 20) == WAIT_TIMEOUT) { /* - * The thread must be blocked waiting for the pipe to - * become readable in ReadFile(). There isn't a clean way - * to exit the thread from this condition. We should - * terminate the child process instead to get the reader - * thread to fall out of ReadFile with a FALSE. (below) is - * not the correct way to do this, but will stay here - * until a better solution is found. + * The thread must be blocked waiting for the pipe to become + * readable in ReadFile(). There isn't a clean way to exit the + * thread from this condition. We should terminate the child + * process instead to get the reader thread to fall out of + * ReadFile with a FALSE. (below) is not the correct way to do + * this, but will stay here until a better solution is found. * - * Note that we need to guard against terminating the - * thread while it is in the middle of Tcl_ThreadAlert - * because it won't be able to release the notifier lock. + * Note that we need to guard against terminating the thread + * while it is in the middle of Tcl_ThreadAlert because it + * won't be able to release the notifier lock. * - * Also note that terminating threads during their initialization or teardown phase - * may result in ntdll.dll's LoaderLock to remain locked indefinitely. - * This causes ntdll.dll's LdrpInitializeThread() to deadlock trying to acquire LoaderLock. - * LdrpInitializeThread() is executed within new threads to perform - * initialization and to execute DllMain() of all loaded dlls. - * As a result, all new threads are deadlocked in their initialization phase and never execute, - * even though CreateThread() reports successful thread creation. - * This results in a very weird process-wide behavior, which is extremely hard to debug. + * Also note that terminating threads during their + * initialization or teardown phase may result in ntdll.dll's + * LoaderLock to remain locked indefinitely. This causes + * ntdll.dll's LdrpInitializeThread() to deadlock trying to + * acquire LoaderLock. LdrpInitializeThread() is executed + * within new threads to perform initialization and to execute + * DllMain() of all loaded dlls. As a result, all new threads + * are deadlocked in their initialization phase and never + * execute, even though CreateThread() reports successful + * thread creation. This results in a very weird process-wide + * behavior, which is extremely hard to debug. * * THREADS SHOULD NEVER BE TERMINATED. Period. * - * But for now, check if thread is exiting, and if so, let it die peacefully. + * But for now, check if thread is exiting, and if so, let it + * die peacefully. * - * Also don't terminate if in exit (otherwise deadlocked in ntdll.dll's). + * Also don't terminate if in exit (otherwise deadlocked in + * ntdll.dll's). */ - if ( pipeTI->state != PTI_STATE_DOWN - && WaitForSingleObject(hThread, - inExit ? 50 : 5000) != WAIT_OBJECT_0 - ) { + if (pipeTI->state != PTI_STATE_DOWN + && WaitForSingleObject(hThread, + inExit ? 50 : 5000) != WAIT_OBJECT_0) { /* BUG: this leaks memory */ if (inExit || !TerminateThread(hThread, 0)) { - /* in exit or terminate fails, just give thread a chance to exit */ + /* + * in exit or terminate fails, just give thread a + * chance to exit + */ + if (InterlockedExchange(&pipeTI->state, PTI_STATE_STOP) != PTI_STATE_DOWN) { pipeTI = NULL; } - }; + } } } } @@ -3504,11 +3648,11 @@ TclPipeThreadStop( SetEvent(pipeTI->evWakeUp); } CloseHandle(pipeTI->evControl); -# ifndef _PTI_USE_CKALLOC +#ifndef _PTI_USE_CKALLOC free(pipeTI); -# else +#else ckfree(pipeTI); -# endif +#endif /* !_PTI_USE_CKALLOC */ } } @@ -3537,28 +3681,30 @@ TclPipeThreadExit( { LONG state; TclPipeThreadInfo *pipeTI = *pipeTIPtr; + /* * If state of thread was set to stop (exactly), we can sane free its info * structure, otherwise it is shared with main thread, so main thread will * own it. */ + if (!pipeTI) { return; } *pipeTIPtr = NULL; - if ((state = InterlockedExchange(&pipeTI->state, - PTI_STATE_DOWN)) == PTI_STATE_STOP) { + state = InterlockedExchange(&pipeTI->state, PTI_STATE_DOWN); + if (state == PTI_STATE_STOP) { CloseHandle(pipeTI->evControl); if (pipeTI->evWakeUp) { SetEvent(pipeTI->evWakeUp); } -# ifndef _PTI_USE_CKALLOC +#ifndef _PTI_USE_CKALLOC free(pipeTI); -# else +#else ckfree(pipeTI); /* be sure all subsystems used are finalized */ Tcl_FinalizeThread(); -# endif +#endif /* !_PTI_USE_CKALLOC */ } } diff --git a/win/tclWinPort.h b/win/tclWinPort.h index 21344ec..774a0a4 100644 --- a/win/tclWinPort.h +++ b/win/tclWinPort.h @@ -14,9 +14,10 @@ #ifndef _TCLWINPORT #define _TCLWINPORT -#if !defined(_WIN64) && defined(BUILD_tcl) + +#if !defined(_WIN64) && !defined(__MINGW_USE_VC2005_COMPAT) /* See [Bug 3354324]: file mtime sets wrong time */ -# define _USE_32BIT_TIME_T +# define __MINGW_USE_VC2005_COMPAT #endif /* @@ -52,15 +53,6 @@ typedef DWORD_PTR * PDWORD_PTR; # include <wspiapi.h> #endif -#ifdef CHECK_UNICODE_CALLS -# define _UNICODE -# define UNICODE -# define __TCHAR_DEFINED - typedef float *_TCHAR; -# define _TCHAR_DEFINED - typedef float *TCHAR; -#endif /* CHECK_UNICODE_CALLS */ - /* * Pull in the typedef of TCHAR for windows. */ @@ -91,7 +83,13 @@ typedef DWORD_PTR * PDWORD_PTR; #include <malloc.h> #include <process.h> #include <signal.h> +#if HAVE_INTTYPES_H +# include <inttypes.h> +#endif #include <limits.h> +#ifdef HAVE_STDINT_H +# include <stdint.h> +#endif #ifndef __GNUC__ # define strncasecmp _strnicmp @@ -480,10 +478,13 @@ typedef DWORD_PTR * PDWORD_PTR; * including the *printf family and others. Tell it to shut up. * (_MSC_VER is 1200 for VC6, 1300 or 1310 for vc7.net, 1400 for 8.0) */ -#if defined(_MSC_VER) && (_MSC_VER >= 1400) +#if defined(_MSC_VER) +# pragma warning(disable:4146) # pragma warning(disable:4244) -# pragma warning(disable:4267) -# pragma warning(disable:4996) +# if _MSC_VER >= 1400 +# pragma warning(disable:4267) +# pragma warning(disable:4996) +# endif #endif /* diff --git a/win/tclWinReg.c b/win/tclWinReg.c index 0d2cd94..2c1b8a5 100644 --- a/win/tclWinReg.c +++ b/win/tclWinReg.c @@ -94,7 +94,7 @@ 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(ClientData clientData); +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, @@ -116,16 +116,51 @@ static int ParseKeyName(Tcl_Interp *interp, char *name, char **hostNamePtr, HKEY *rootKeyPtr, char **keyNamePtr); static DWORD RecursiveDeleteKey(HKEY hStartKey, - const TCHAR * pKeyName, REGSAM mode); -static int RegistryObjCmd(ClientData clientData, + const WCHAR * pKeyName, REGSAM mode); +static int RegistryObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int SetValue(Tcl_Interp *interp, Tcl_Obj *keyNameObj, Tcl_Obj *valueNameObj, Tcl_Obj *dataObj, Tcl_Obj *typeObj, REGSAM mode); +#if (TCL_MAJOR_VERSION < 9) && (TCL_MINOR_VERSION < 7) +# if TCL_UTF_MAX > 3 +# define Tcl_WCharToUtfDString(a,b,c) Tcl_WinTCharToUtf((TCHAR *)(a),(b)*sizeof(WCHAR),c) +# define Tcl_UtfToWCharDString(a,b,c) (WCHAR *)Tcl_WinUtfToTChar(a,b,c) +# else +# define Tcl_WCharToUtfDString Tcl_UniCharToUtfDString +# define Tcl_UtfToWCharDString Tcl_UtfToUniCharDString +# endif +#endif + +static unsigned char * +getByteArrayFromObj( + Tcl_Obj *objPtr, + size_t *lengthPtr +) { + int length; + + unsigned char *result = Tcl_GetByteArrayFromObj(objPtr, &length); +#if TCL_MAJOR_VERSION > 8 + if (sizeof(TCL_HASH_TYPE) > sizeof(int)) { + /* 64-bit and TIP #494 situation: */ + *lengthPtr = *(TCL_HASH_TYPE *) objPtr->internalRep.twoPtrValue.ptr1; + } else +#endif + /* 32-bit or without TIP #494 */ + *lengthPtr = (size_t) (unsigned) length; + return result; +} + +#ifdef __cplusplus +extern "C" { +#endif DLLEXPORT int Registry_Init(Tcl_Interp *interp); DLLEXPORT int Registry_Unload(Tcl_Interp *interp, int flags); +#ifdef __cplusplus +} +#endif /* *---------------------------------------------------------------------- @@ -156,7 +191,7 @@ Registry_Init( cmd = Tcl_CreateObjCommand(interp, "registry", RegistryObjCmd, interp, DeleteCmd); Tcl_SetAssocData(interp, REGISTRY_ASSOC_KEY, NULL, cmd); - return Tcl_PkgProvide(interp, "registry", "1.3.3"); + return Tcl_PkgProvideEx(interp, "registry", "1.3.4", NULL); } /* @@ -182,6 +217,7 @@ Registry_Unload( { Tcl_Command cmd; Tcl_Obj *objv[3]; + (void)flags; /* * Unregister the registry package. There is no Tcl_PkgForget() @@ -196,7 +232,7 @@ Registry_Unload( * Delete the originally registered command. */ - cmd = Tcl_GetAssocData(interp, REGISTRY_ASSOC_KEY, NULL); + cmd = (Tcl_Command)Tcl_GetAssocData(interp, REGISTRY_ASSOC_KEY, NULL); if (cmd != NULL) { Tcl_DeleteCommandFromToken(interp, cmd); } @@ -223,9 +259,9 @@ Registry_Unload( static void DeleteCmd( - ClientData clientData) + void *clientData) { - Tcl_Interp *interp = clientData; + Tcl_Interp *interp = (Tcl_Interp *)clientData; Tcl_SetAssocData(interp, REGISTRY_ASSOC_KEY, NULL, NULL); } @@ -248,7 +284,7 @@ DeleteCmd( static int RegistryObjCmd( - ClientData clientData, /* Not used. */ + void *dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument values. */ @@ -267,6 +303,7 @@ RegistryObjCmd( static const char *const modes[] = { "-32bit", "-64bit", NULL }; + (void)dummy; if (objc < 2) { wrongArgs: @@ -396,7 +433,7 @@ DeleteKey( REGSAM mode) /* Mode flags to pass. */ { char *tail, *buffer, *hostName, *keyName; - const TCHAR *nativeTail; + const WCHAR *nativeTail; HKEY rootKey, subkey; DWORD result; Tcl_DString buf; @@ -449,7 +486,8 @@ DeleteKey( * Now we recursively delete the key and everything below it. */ - nativeTail = Tcl_WinUtfToTChar(tail, -1, &buf); + Tcl_DStringInit(&buf); + nativeTail = Tcl_UtfToWCharDString(tail, -1, &buf); result = RecursiveDeleteKey(subkey, nativeTail, saveMode); Tcl_DStringFree(&buf); @@ -505,8 +543,9 @@ DeleteValue( } valueName = Tcl_GetString(valueNameObj); - Tcl_WinUtfToTChar(valueName, valueNameObj->length, &ds); - result = RegDeleteValue(key, (const TCHAR *)Tcl_DStringValue(&ds)); + 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( @@ -549,7 +588,7 @@ GetKeyNames( { const char *pattern; /* Pattern being matched against subkeys */ HKEY key; /* Handle to the key being examined */ - TCHAR buffer[MAX_KEY_LENGTH]; + WCHAR buffer[MAX_KEY_LENGTH]; /* Buffer to hold the subkey name */ DWORD bufSize; /* Size of the buffer */ DWORD index; /* Position of the current subkey */ @@ -580,7 +619,7 @@ GetKeyNames( resultPtr = Tcl_NewObj(); for (index = 0;; ++index) { bufSize = MAX_KEY_LENGTH; - result = RegEnumKeyEx(key, index, buffer, &bufSize, + result = RegEnumKeyExW(key, index, buffer, &bufSize, NULL, NULL, NULL, NULL); if (result != ERROR_SUCCESS) { if (result == ERROR_NO_MORE_ITEMS) { @@ -594,7 +633,8 @@ GetKeyNames( } break; } - name = Tcl_WinTCharToUtf(buffer, bufSize * sizeof(TCHAR), &ds); + Tcl_DStringInit(&ds); + name = Tcl_WCharToUtfDString(buffer, bufSize, &ds); if (pattern && !Tcl_StringMatch(name, pattern)) { Tcl_DStringFree(&ds); continue; @@ -644,7 +684,7 @@ GetType( DWORD result, type; Tcl_DString ds; const char *valueName; - const TCHAR *nativeValue; + const WCHAR *nativeValue; /* * Attempt to open the key for reading. @@ -660,8 +700,9 @@ GetType( */ valueName = Tcl_GetString(valueNameObj); - nativeValue = Tcl_WinUtfToTChar(valueName, valueNameObj->length, &ds); - result = RegQueryValueEx(key, nativeValue, NULL, &type, + Tcl_DStringInit(&ds); + nativeValue = Tcl_UtfToWCharDString(valueName, valueNameObj->length, &ds); + result = RegQueryValueExW(key, nativeValue, NULL, &type, NULL, NULL); Tcl_DStringFree(&ds); RegCloseKey(key); @@ -713,7 +754,7 @@ GetValue( { HKEY key; const char *valueName; - const TCHAR *nativeValue; + const WCHAR *nativeValue; DWORD result, length, type; Tcl_DString data, buf; @@ -738,12 +779,13 @@ GetValue( Tcl_DStringInit(&data); Tcl_DStringSetLength(&data, TCL_DSTRING_STATIC_SIZE - 1); - length = TCL_DSTRING_STATIC_SIZE/sizeof(TCHAR) - 1; + length = TCL_DSTRING_STATIC_SIZE/sizeof(WCHAR) - 1; valueName = Tcl_GetString(valueNameObj); - nativeValue = Tcl_WinUtfToTChar(valueName, valueNameObj->length, &buf); + Tcl_DStringInit(&buf); + nativeValue = Tcl_UtfToWCharDString(valueName, valueNameObj->length, &buf); - result = RegQueryValueEx(key, nativeValue, NULL, &type, + result = RegQueryValueExW(key, nativeValue, NULL, &type, (BYTE *) Tcl_DStringValue(&data), &length); while (result == ERROR_MORE_DATA) { /* @@ -752,9 +794,9 @@ GetValue( * HKEY_PERFORMANCE_DATA */ - length = Tcl_DStringLength(&data) * (2 / sizeof(TCHAR)); - Tcl_DStringSetLength(&data, (int) length * sizeof(TCHAR)); - result = RegQueryValueEx(key, nativeValue, + 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); @@ -790,13 +832,13 @@ GetValue( */ while ((p < end) && *((WCHAR *) p) != 0) { - WCHAR *wp; + WCHAR *wp = (WCHAR *) p; - Tcl_WinTCharToUtf((TCHAR *) p, -1, &buf); + Tcl_DStringInit(&buf); + Tcl_WCharToUtfDString(wp, wcslen(wp), &buf); Tcl_ListObjAppendElement(interp, resultPtr, Tcl_NewStringObj(Tcl_DStringValue(&buf), Tcl_DStringLength(&buf))); - wp = (WCHAR *) p; while (*wp++ != 0) {/* empty body */} p = (char *) wp; @@ -804,7 +846,9 @@ GetValue( } Tcl_SetObjResult(interp, resultPtr); } else if ((type == REG_SZ) || (type == REG_EXPAND_SZ)) { - Tcl_WinTCharToUtf((TCHAR *) Tcl_DStringValue(&data), -1, &buf); + WCHAR *wp = (WCHAR *) Tcl_DStringValue(&data); + Tcl_DStringInit(&buf); + Tcl_WCharToUtfDString((const WCHAR *)Tcl_DStringValue(&data), wcslen(wp), &buf); Tcl_DStringResult(interp, &buf); } else { /* @@ -861,7 +905,7 @@ GetValueNames( resultPtr = Tcl_NewObj(); Tcl_DStringInit(&buffer); - Tcl_DStringSetLength(&buffer, (int) (MAX_KEY_LENGTH * sizeof(TCHAR))); + Tcl_DStringSetLength(&buffer, (int) (MAX_KEY_LENGTH * sizeof(WCHAR))); index = 0; result = TCL_OK; @@ -878,12 +922,11 @@ GetValueNames( */ size = MAX_KEY_LENGTH; - while (RegEnumValue(key,index, (TCHAR *)Tcl_DStringValue(&buffer), + while (RegEnumValueW(key,index, (WCHAR *)Tcl_DStringValue(&buffer), &size, NULL, NULL, NULL, NULL) == ERROR_SUCCESS) { - size *= sizeof(TCHAR); - Tcl_WinTCharToUtf((TCHAR *) Tcl_DStringValue(&buffer), (int) size, - &ds); + 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, @@ -989,8 +1032,9 @@ OpenSubKey( */ if (hostName) { - hostName = (char *) Tcl_WinUtfToTChar(hostName, -1, &buf); - result = RegConnectRegistry((TCHAR *)hostName, rootKey, + Tcl_DStringInit(&buf); + hostName = (char *) Tcl_UtfToWCharDString(hostName, -1, &buf); + result = RegConnectRegistryW((WCHAR *)hostName, rootKey, &rootKey); Tcl_DStringFree(&buf); if (result != ERROR_SUCCESS) { @@ -1004,12 +1048,13 @@ OpenSubKey( */ if (keyName) { - keyName = (char *) Tcl_WinUtfToTChar(keyName, -1, &buf); + Tcl_DStringInit(&buf); + keyName = (char *) Tcl_UtfToWCharDString(keyName, -1, &buf); } if (flags & REG_CREATE) { DWORD create; - result = RegCreateKeyEx(rootKey, (TCHAR *)keyName, 0, NULL, + result = RegCreateKeyExW(rootKey, (WCHAR *)keyName, 0, NULL, REG_OPTION_NON_VOLATILE, mode, NULL, keyPtr, &create); } else if (rootKey == HKEY_PERFORMANCE_DATA) { /* @@ -1020,7 +1065,7 @@ OpenSubKey( *keyPtr = HKEY_PERFORMANCE_DATA; result = ERROR_SUCCESS; } else { - result = RegOpenKeyEx(rootKey, (TCHAR *)keyName, 0, mode, + result = RegOpenKeyExW(rootKey, (WCHAR *)keyName, 0, mode, keyPtr); } if (keyName) { @@ -1140,7 +1185,7 @@ ParseKeyName( static DWORD RecursiveDeleteKey( HKEY startKey, /* Parent of key to be deleted. */ - const TCHAR *keyName, /* Name of key to be deleted in external + const WCHAR *keyName, /* Name of key to be deleted in external * encoding, not UTF. */ REGSAM mode) /* Mode flags to pass. */ { @@ -1149,7 +1194,7 @@ RecursiveDeleteKey( HKEY hKey; REGSAM saveMode = mode; static int checkExProc = 0; - static FARPROC regDeleteKeyExProc = NULL; + static LONG (* regDeleteKeyExProc) (HKEY, LPCWSTR, REGSAM, DWORD) = (LONG (*) (HKEY, LPCWSTR, REGSAM, DWORD)) NULL; /* * Do not allow NULL or empty key name. @@ -1160,13 +1205,13 @@ RecursiveDeleteKey( } mode |= KEY_ENUMERATE_SUB_KEYS | DELETE | KEY_QUERY_VALUE; - result = RegOpenKeyEx(startKey, keyName, 0, mode, &hKey); + result = RegOpenKeyExW(startKey, keyName, 0, mode, &hKey); if (result != ERROR_SUCCESS) { return result; } Tcl_DStringInit(&subkey); - Tcl_DStringSetLength(&subkey, (int) (MAX_KEY_LENGTH * sizeof(TCHAR))); + Tcl_DStringSetLength(&subkey, (int) (MAX_KEY_LENGTH * sizeof(WCHAR))); mode = saveMode; while (result == ERROR_SUCCESS) { @@ -1175,7 +1220,7 @@ RecursiveDeleteKey( */ size = MAX_KEY_LENGTH; - result = RegEnumKeyEx(hKey, 0, (TCHAR *)Tcl_DStringValue(&subkey), + result = RegEnumKeyExW(hKey, 0, (WCHAR *)Tcl_DStringValue(&subkey), &size, NULL, NULL, NULL, NULL); if (result == ERROR_NO_MORE_ITEMS) { /* @@ -1188,19 +1233,19 @@ RecursiveDeleteKey( HMODULE handle; checkExProc = 1; - handle = GetModuleHandle(TEXT("ADVAPI32")); - regDeleteKeyExProc = (FARPROC) + handle = GetModuleHandleW(L"ADVAPI32"); + regDeleteKeyExProc = (LONG (*) (HKEY, LPCWSTR, REGSAM, DWORD)) GetProcAddress(handle, "RegDeleteKeyExW"); } if (mode && regDeleteKeyExProc) { result = regDeleteKeyExProc(startKey, keyName, mode, 0); } else { - result = RegDeleteKey(startKey, keyName); + result = RegDeleteKeyW(startKey, keyName); } break; } else if (result == ERROR_SUCCESS) { result = RecursiveDeleteKey(hKey, - (const TCHAR *) Tcl_DStringValue(&subkey), mode); + (const WCHAR *) Tcl_DStringValue(&subkey), mode); } } Tcl_DStringFree(&subkey); @@ -1256,7 +1301,8 @@ SetValue( } valueName = Tcl_GetString(valueNameObj); - valueName = (char *) Tcl_WinUtfToTChar(valueName, valueNameObj->length, &nameBuf); + Tcl_DStringInit(&nameBuf); + valueName = (char *) Tcl_UtfToWCharDString(valueName, valueNameObj->length, &nameBuf); if (type == REG_DWORD || type == REG_DWORD_BIG_ENDIAN) { int value; @@ -1268,7 +1314,7 @@ SetValue( } value = ConvertDWORD((DWORD) type, (DWORD) value); - result = RegSetValueEx(key, (TCHAR *) valueName, 0, + result = RegSetValueExW(key, (WCHAR *) valueName, 0, (DWORD) type, (BYTE *) &value, sizeof(DWORD)); } else if (type == REG_MULTI_SZ) { Tcl_DString data, buf; @@ -1300,9 +1346,10 @@ SetValue( Tcl_DStringAppend(&data, "", 1); /* NUL-terminated string */ } - Tcl_WinUtfToTChar(Tcl_DStringValue(&data), Tcl_DStringLength(&data)+1, + Tcl_DStringInit(&buf); + Tcl_UtfToWCharDString(Tcl_DStringValue(&data), Tcl_DStringLength(&data)+1, &buf); - result = RegSetValueEx(key, (TCHAR *) valueName, 0, + result = RegSetValueExW(key, (WCHAR *) valueName, 0, (DWORD) type, (BYTE *) Tcl_DStringValue(&buf), (DWORD) Tcl_DStringLength(&buf)); Tcl_DStringFree(&data); @@ -1311,7 +1358,8 @@ SetValue( Tcl_DString buf; const char *data = Tcl_GetString(dataObj); - data = (char *) Tcl_WinUtfToTChar(data, dataObj->length, &buf); + Tcl_DStringInit(&buf); + data = (char *) Tcl_UtfToWCharDString(data, dataObj->length, &buf); /* * Include the null in the length, padding if needed for WCHAR. @@ -1319,19 +1367,19 @@ SetValue( Tcl_DStringSetLength(&buf, Tcl_DStringLength(&buf)+1); - result = RegSetValueEx(key, (TCHAR *) valueName, 0, + result = RegSetValueExW(key, (WCHAR *) valueName, 0, (DWORD) type, (BYTE *) data, (DWORD) Tcl_DStringLength(&buf) + 1); Tcl_DStringFree(&buf); } else { BYTE *data; - int bytelength; + size_t bytelength; /* * Store binary data in the registry. */ - data = (BYTE *) Tcl_GetByteArrayFromObj(dataObj, &bytelength); - result = RegSetValueEx(key, (TCHAR *) valueName, 0, + data = (BYTE *) getByteArrayFromObj(dataObj, &bytelength); + result = RegSetValueExW(key, (WCHAR *) valueName, 0, (DWORD) type, data, (DWORD) bytelength); } @@ -1391,7 +1439,8 @@ BroadcastValue( } str = Tcl_GetString(objv[0]); - wstr = (WCHAR *) Tcl_WinUtfToTChar(str, objv[0]->length, &ds); + Tcl_DStringInit(&ds); + wstr = Tcl_UtfToWCharDString(str, objv[0]->length, &ds); if (Tcl_DStringLength(&ds) == 0) { wstr = NULL; } @@ -1400,7 +1449,7 @@ BroadcastValue( * Use the ignore the result. */ - result = SendMessageTimeout(HWND_BROADCAST, WM_SETTINGCHANGE, + result = SendMessageTimeoutW(HWND_BROADCAST, WM_SETTINGCHANGE, (WPARAM) 0, (LPARAM) wstr, SMTO_ABORTIFHUNG, (UINT) timeout, &sendResult); Tcl_DStringFree(&ds); @@ -1435,7 +1484,7 @@ AppendSystemError( DWORD error) /* Result code from error. */ { int length; - TCHAR *tMsgPtr, **tMsgPtrPtr = &tMsgPtr; + WCHAR *tMsgPtr, **tMsgPtrPtr = &tMsgPtr; const char *msg; char id[TCL_INTEGER_SPACE], msgBuf[24 + TCL_INTEGER_SPACE]; Tcl_DString ds; @@ -1444,9 +1493,9 @@ AppendSystemError( if (Tcl_IsShared(resultPtr)) { resultPtr = Tcl_DuplicateObj(resultPtr); } - length = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM + length = FormatMessageW(FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_ALLOCATE_BUFFER, NULL, error, - MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), (TCHAR *) tMsgPtrPtr, + MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), (WCHAR *) tMsgPtrPtr, 0, NULL); if (length == 0) { sprintf(msgBuf, "unknown error: %ld", error); @@ -1454,7 +1503,8 @@ AppendSystemError( } else { char *msgPtr; - Tcl_WinTCharToUtf(tMsgPtr, -1, &ds); + Tcl_DStringInit(&ds); + Tcl_WCharToUtfDString(tMsgPtr, wcslen(tMsgPtr), &ds); LocalFree(tMsgPtr); msgPtr = Tcl_DStringValue(&ds); diff --git a/win/tclWinSerial.c b/win/tclWinSerial.c index d77a609..65af10f 100644 --- a/win/tclWinSerial.c +++ b/win/tclWinSerial.c @@ -44,6 +44,15 @@ TCL_DECLARE_MUTEX(serialMutex) #define SERIAL_ERROR (1<<4) /* + * Bit masks used for noting whether to drain or discard output on close. They + * are disjoint from each other; at most one may be set at a time. + */ + +#define SERIAL_CLOSE_DRAIN (1<<6) /* Drain all output on close. */ +#define SERIAL_CLOSE_DISCARD (1<<7) /* Discard all output on close. */ +#define SERIAL_CLOSE_MASK (3<<6) /* Both two bits above. */ + +/* * Default time to block between checking status on the serial port. */ @@ -604,7 +613,6 @@ SerialCloseProc( serialPtr->validMask &= ~TCL_READABLE; if (serialPtr->writeThread) { - TclPipeThreadStop(&serialPtr->writeTI, serialPtr->writeThread); CloseHandle(serialPtr->osWrite.hEvent); @@ -1024,7 +1032,7 @@ SerialOutputProc( infoPtr->writeBufLen = toWrite; infoPtr->writeBuf = ckalloc(toWrite); } - memcpy(infoPtr->writeBuf, buf, (size_t) toWrite); + memcpy(infoPtr->writeBuf, buf, toWrite); infoPtr->toWrite = toWrite; ResetEvent(infoPtr->evWritable); TclPipeThreadSignal(&infoPtr->writeTI); @@ -1278,12 +1286,12 @@ SerialWriterThread( /* exit */ break; } - infoPtr = (SerialInfo *)pipeTI->clientData; + infoPtr = (SerialInfo *) pipeTI->clientData; buf = infoPtr->writeBuf; toWrite = infoPtr->toWrite; - myWrite.hEvent = CreateEvent(NULL, TRUE, FALSE, NULL); + myWrite.hEvent = CreateEventW(NULL, TRUE, FALSE, NULL); /* * Loop until all of the bytes are written or an error occurs. @@ -1342,7 +1350,25 @@ SerialWriterThread( Tcl_MutexUnlock(&serialMutex); } - /* Worker exit, so inform the main thread or free TI-structure (if owned) */ + /* + * We're about to close, so do any drain or discard required. + */ + + if (infoPtr) { + switch (infoPtr->flags & SERIAL_CLOSE_MASK) { + case SERIAL_CLOSE_DRAIN: + FlushFileBuffers(infoPtr->handle); + break; + case SERIAL_CLOSE_DISCARD: + PurgeComm(infoPtr->handle, PURGE_TXABORT | PURGE_TXCLEAR); + break; + } + } + + /* + * Worker exit, so inform the main thread or free TI-structure (if owned). + */ + TclPipeThreadExit(&pipeTI); return 0; @@ -1368,7 +1394,7 @@ SerialWriterThread( HANDLE TclWinSerialOpen( HANDLE handle, - const TCHAR *name, + const WCHAR *name, DWORD access) { SerialInit(); @@ -1377,7 +1403,7 @@ TclWinSerialOpen( * If an open channel is specified, close it */ - if ( handle != INVALID_HANDLE_VALUE && CloseHandle(handle) == FALSE) { + if (handle != INVALID_HANDLE_VALUE && CloseHandle(handle) == FALSE) { return INVALID_HANDLE_VALUE; } @@ -1387,7 +1413,7 @@ TclWinSerialOpen( * finished */ - handle = CreateFile(name, access, 0, 0, OPEN_EXISTING, + handle = CreateFileW(name, access, 0, 0, OPEN_EXISTING, FILE_FLAG_OVERLAPPED, 0); return handle; @@ -1460,15 +1486,15 @@ TclWinOpenSerialChannel( InitializeCriticalSection(&infoPtr->csWrite); if (permissions & TCL_READABLE) { - infoPtr->osRead.hEvent = CreateEvent(NULL, TRUE, FALSE, NULL); + 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 = CreateEvent(NULL, TRUE, FALSE, NULL); - infoPtr->evWritable = CreateEvent(NULL, TRUE, TRUE, NULL); + 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); @@ -1595,7 +1621,7 @@ SerialSetOptionProc( BOOL result, flag; size_t len, vlen; Tcl_DString ds; - const TCHAR *native; + const WCHAR *native; int argc; const char **argv; @@ -1610,6 +1636,32 @@ SerialSetOptionProc( vlen = strlen(value); /* + * Option -closemode drain|discard|default + */ + + if ((len > 2) && (strncmp(optionName, "-closemode", len) == 0)) { + if (Tcl_UtfNcasecmp(value, "DEFAULT", vlen) == 0) { + infoPtr->flags &= ~SERIAL_CLOSE_MASK; + } else if (Tcl_UtfNcasecmp(value, "DRAIN", vlen) == 0) { + infoPtr->flags &= ~SERIAL_CLOSE_MASK; + infoPtr->flags |= SERIAL_CLOSE_DRAIN; + } else if (Tcl_UtfNcasecmp(value, "DISCARD", vlen) == 0) { + infoPtr->flags &= ~SERIAL_CLOSE_MASK; + infoPtr->flags |= SERIAL_CLOSE_DISCARD; + } else { + if (interp) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad mode \"%s\" for -closemode: must be" + " default, discard, or drain", value)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE", + "VALUE", NULL); + } + return TCL_ERROR; + } + return TCL_OK; + } + + /* * Option -mode baud,parity,databits,stopbits */ @@ -1617,8 +1669,9 @@ SerialSetOptionProc( if (!GetCommState(infoPtr->handle, &dcb)) { goto getStateFailed; } - native = Tcl_WinUtfToTChar(value, -1, &ds); - result = BuildCommDCB(native, &dcb); + Tcl_DStringInit(&ds); + native = Tcl_UtfToWCharDString(value, -1, &ds); + result = BuildCommDCBW(native, &dcb); Tcl_DStringFree(&ds); if (result == FALSE) { @@ -1718,7 +1771,7 @@ SerialSetOptionProc( if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "bad value for -xchar: should be a list of" - " two elements with each a single character", -1)); + " two elements with each a single 8-bit character", -1)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "XCHAR", NULL); } ckfree(argv); @@ -1742,12 +1795,12 @@ SerialSetOptionProc( int charLen; charLen = Tcl_UtfToUniChar(argv[0], &character); - if (argv[0][charLen]) { + if ((character > 0xFF) || argv[0][charLen]) { goto badXchar; } dcb.XonChar = (char) character; charLen = Tcl_UtfToUniChar(argv[1], &character); - if (argv[1][charLen]) { + if ((character > 0xFF) || argv[1][charLen]) { goto badXchar; } dcb.XoffChar = (char) character; @@ -1849,7 +1902,7 @@ SerialSetOptionProc( * -sysbuffer 4096 or -sysbuffer {64536 4096} */ - size_t inSize = (size_t) -1, outSize = (size_t) -1; + int inSize = -1, outSize = -1; if (Tcl_SplitList(interp, value, &argc, &argv) == TCL_ERROR) { return TCL_ERROR; @@ -1938,7 +1991,8 @@ SerialSetOptionProc( } return Tcl_BadChannelOption(interp, optionName, - "mode handshake pollinterval sysbuffer timeout ttycontrol xchar"); + "closemode mode handshake pollinterval sysbuffer timeout " + "ttycontrol xchar"); getStateFailed: if (interp != NULL) { @@ -1999,6 +2053,27 @@ SerialGetOptionProc( } /* + * Get option -closemode + */ + + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-closemode"); + } + if (len==0 || (len>1 && strncmp(optionName, "-closemode", len)==0)) { + switch (infoPtr->flags & SERIAL_CLOSE_MASK) { + case SERIAL_CLOSE_DRAIN: + Tcl_DStringAppendElement(dsPtr, "drain"); + break; + case SERIAL_CLOSE_DISCARD: + Tcl_DStringAppendElement(dsPtr, "discard"); + break; + default: + Tcl_DStringAppendElement(dsPtr, "default"); + break; + } + } + + /* * Get option -mode */ @@ -2077,7 +2152,7 @@ SerialGetOptionProc( Tcl_DStringStartSublist(dsPtr); } if (len==0 || (len>1 && strncmp(optionName, "-xchar", len) == 0)) { - char buf[4]; + char buf[TCL_UTF_MAX]; valid = 1; if (!GetCommState(infoPtr->handle, &dcb)) { @@ -2088,9 +2163,9 @@ SerialGetOptionProc( } return TCL_ERROR; } - sprintf(buf, "%c", dcb.XonChar); + buf[Tcl_UniCharToUtf(UCHAR(dcb.XonChar), buf)] = '\0'; Tcl_DStringAppendElement(dsPtr, buf); - sprintf(buf, "%c", dcb.XoffChar); + buf[Tcl_UniCharToUtf(UCHAR(dcb.XoffChar), buf)] = '\0'; Tcl_DStringAppendElement(dsPtr, buf); } if (len == 0) { @@ -2174,7 +2249,8 @@ SerialGetOptionProc( return TCL_OK; } return Tcl_BadChannelOption(interp, optionName, - "mode pollinterval lasterror queue sysbuffer ttystatus xchar"); + "closemode mode pollinterval lasterror queue sysbuffer ttystatus " + "xchar"); } /* diff --git a/win/tclWinSock.c b/win/tclWinSock.c index b18c763..7b51805 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -82,7 +82,7 @@ */ static int initialized = 0; -static const TCHAR className[] = TEXT("TclSocket"); +static const WCHAR className[] = L"TclSocket"; TCL_DECLARE_MUTEX(socketMutex) /* @@ -235,7 +235,7 @@ typedef struct { } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; -static WNDCLASS windowClass; +static WNDCLASSW windowClass; /* * Static routines for this file: @@ -363,19 +363,19 @@ InitializeHostName( unsigned int *lengthPtr, Tcl_Encoding *encodingPtr) { - TCHAR tbuf[MAX_COMPUTERNAME_LENGTH + 1]; + WCHAR wbuf[MAX_COMPUTERNAME_LENGTH + 1]; DWORD length = MAX_COMPUTERNAME_LENGTH + 1; Tcl_DString ds; - if (GetComputerName(tbuf, &length) != 0) { + Tcl_DStringInit(&ds); + if (GetComputerNameW(wbuf, &length) != 0) { /* * Convert string from native to UTF then change to lowercase. */ - Tcl_UtfToLower(Tcl_WinTCharToUtf(tbuf, -1, &ds)); + Tcl_UtfToLower(Tcl_WCharToUtfDString(wbuf, -1, &ds)); } else { - Tcl_DStringInit(&ds); if (TclpHasSockets(NULL) == TCL_OK) { /* * The buffer size of 256 is recommended by the MSDN page that @@ -2528,7 +2528,7 @@ InitSockets(void) windowClass.hIcon = NULL; windowClass.hCursor = NULL; - if (!RegisterClass(&windowClass)) { + if (!RegisterClassW(&windowClass)) { TclWinConvertError(GetLastError()); goto initFailure; } @@ -2653,7 +2653,7 @@ SocketExitHandler( */ TclpFinalizeSockets(); - UnregisterClass(className, TclWinGetTclInstance()); + UnregisterClassW(className, TclWinGetTclInstance()); initialized = 0; Tcl_MutexUnlock(&socketMutex); } @@ -3200,7 +3200,7 @@ SocketThread( * Create a dummy window receiving socket events. */ - tsdPtr->hwnd = CreateWindow(className, className, WS_TILED, 0, 0, 0, 0, + tsdPtr->hwnd = CreateWindowW(className, className, WS_TILED, 0, 0, 0, 0, NULL, NULL, windowClass.hInstance, arg); /* @@ -3223,8 +3223,8 @@ SocketThread( * PostMessage(SOCKET_TERMINATE) in TclpFinalizeSockets(). */ - while (GetMessage(&msg, NULL, 0, 0) > 0) { - DispatchMessage(&msg); + while (GetMessageW(&msg, NULL, 0, 0) > 0) { + DispatchMessageW(&msg); } /* @@ -3269,14 +3269,14 @@ SocketProc( TcpFdList *fds = NULL; ThreadSpecificData *tsdPtr = (ThreadSpecificData *) #ifdef _WIN64 - GetWindowLongPtr(hwnd, GWLP_USERDATA); + GetWindowLongPtrW(hwnd, GWLP_USERDATA); #else - GetWindowLong(hwnd, GWL_USERDATA); + GetWindowLongW(hwnd, GWL_USERDATA); #endif switch (message) { default: - return DefWindowProc(hwnd, message, wParam, lParam); + return DefWindowProcW(hwnd, message, wParam, lParam); break; case WM_CREATE: @@ -3289,7 +3289,7 @@ SocketProc( SetWindowLongPtr(hwnd, GWLP_USERDATA, (LONG_PTR) ((LPCREATESTRUCT)lParam)->lpCreateParams); #else - SetWindowLong(hwnd, GWL_USERDATA, + SetWindowLongW(hwnd, GWL_USERDATA, (LONG) ((LPCREATESTRUCT)lParam)->lpCreateParams); #endif break; diff --git a/win/tclWinTest.c b/win/tclWinTest.c index b3ad626..cd0e07f 100644 --- a/win/tclWinTest.c +++ b/win/tclWinTest.c @@ -41,6 +41,8 @@ static int TestwinclockCmd(ClientData dummy, Tcl_Interp* interp, int objc, Tcl_Obj *const objv[]); static int TestwinsleepCmd(ClientData dummy, Tcl_Interp* interp, int objc, Tcl_Obj *const objv[]); +static int TestSizeCmd(ClientData dummy, Tcl_Interp* interp, + int objc, Tcl_Obj *const objv[]); static Tcl_ObjCmdProc TestExceptionCmd; static int TestplatformChmod(const char *nativePath, int pmode); static int TestchmodCmd(ClientData dummy, Tcl_Interp* interp, @@ -78,6 +80,7 @@ TclplatformtestInit( Tcl_CreateObjCommand(interp, "testwinclock", TestwinclockCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testwinsleep", TestwinsleepCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testexcept", TestExceptionCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "testsize", TestSizeCmd, NULL, NULL); return TCL_OK; } @@ -136,7 +139,7 @@ TesteventloopCmd( while (!done) { MSG msg; - if (!GetMessage(&msg, NULL, 0, 0)) { + if (!GetMessageW(&msg, NULL, 0, 0)) { /* * The application is exiting, so repost the quit message and * start unwinding. @@ -146,7 +149,7 @@ TesteventloopCmd( break; } TranslateMessage(&msg); - DispatchMessage(&msg); + DispatchMessageW(&msg); } (void) Tcl_SetServiceMode(oldMode); framePtr = oldFramePtr; @@ -276,11 +279,11 @@ TestwinclockCmd( result = Tcl_NewObj(); Tcl_ListObjAppendElement(interp, result, - Tcl_NewIntObj((int) (t2.QuadPart / 10000000))); + Tcl_NewWideIntObj(t2.QuadPart / 10000000)); Tcl_ListObjAppendElement(interp, result, - Tcl_NewIntObj((int) ((t2.QuadPart / 10) % 1000000))); - Tcl_ListObjAppendElement(interp, result, Tcl_NewIntObj(tclTime.sec)); - Tcl_ListObjAppendElement(interp, result, Tcl_NewIntObj(tclTime.usec)); + Tcl_NewWideIntObj((t2.QuadPart / 10) % 1000000)); + Tcl_ListObjAppendElement(interp, result, Tcl_NewWideIntObj(tclTime.sec)); + Tcl_ListObjAppendElement(interp, result, Tcl_NewWideIntObj(tclTime.usec)); Tcl_ListObjAppendElement(interp, result, Tcl_NewWideIntObj(p1.QuadPart)); Tcl_ListObjAppendElement(interp, result, Tcl_NewWideIntObj(p2.QuadPart)); @@ -310,6 +313,31 @@ TestwinsleepCmd( return TCL_OK; } +static int +TestSizeCmd( + ClientData clientData, /* Unused */ + Tcl_Interp* interp, /* Tcl interpreter */ + int objc, /* Parameter count */ + Tcl_Obj *const * objv) /* Parameter vector */ +{ + if (objc != 2) { + goto syntax; + } + if (strcmp(Tcl_GetString(objv[1]), "time_t") == 0) { + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(sizeof(time_t))); + return TCL_OK; + } + if (strcmp(Tcl_GetString(objv[1]), "st_mtime") == 0) { + Tcl_StatBuf *statPtr; + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(sizeof(statPtr->st_mtime))); + return TCL_OK; + } + +syntax: + Tcl_WrongNumArgs(interp, 1, objv, "time_t|st_mtime"); + return TCL_ERROR; +} + /* *---------------------------------------------------------------------- * @@ -399,9 +427,11 @@ TestplatformChmod( { static const SECURITY_INFORMATION infoBits = OWNER_SECURITY_INFORMATION | GROUP_SECURITY_INFORMATION | DACL_SECURITY_INFORMATION; + /* don't reset change permissions mask (WRITE_DAC, allow test-cases restore it to cleanup) */ static const DWORD readOnlyMask = FILE_DELETE_CHILD | FILE_ADD_FILE | FILE_ADD_SUBDIRECTORY | FILE_WRITE_EA | FILE_APPEND_DATA - | FILE_WRITE_DATA | DELETE; + | FILE_WRITE_DATA + | DELETE; /* * References to security functions (only available on NT and later). @@ -565,11 +595,13 @@ TestplatformChmod( } /* - * Apply the new ACL. + * Apply the new ACL. Note PROTECTED_DACL_SECURITY_INFORMATION can be used + * to remove inherited ACL (we need to overwrite the default ACL's in this case) */ if (set_readOnly == acl_readOnly_found || SetNamedSecurityInfoA( - (LPSTR) nativePath, SE_FILE_OBJECT, DACL_SECURITY_INFORMATION, + (LPSTR) nativePath, SE_FILE_OBJECT, + DACL_SECURITY_INFORMATION /*| PROTECTED_DACL_SECURITY_INFORMATION*/, NULL, NULL, newAcl, NULL) == ERROR_SUCCESS) { res = 0; } diff --git a/win/tclWinThrd.c b/win/tclWinThrd.c index d169ebb..d649310 100644 --- a/win/tclWinThrd.c +++ b/win/tclWinThrd.c @@ -682,7 +682,7 @@ Tcl_ConditionWait( */ if (tsdPtr->flags == WIN_THREAD_UNINIT) { - tsdPtr->condEvent = CreateEvent(NULL, TRUE /* manual reset */, + tsdPtr->condEvent = CreateEventW(NULL, TRUE /* manual reset */, FALSE /* non signaled */, NULL); tsdPtr->nextPtr = NULL; tsdPtr->prevPtr = NULL; diff --git a/win/tclWinTime.c b/win/tclWinTime.c index 18702e7..f18d63e 100644 --- a/win/tclWinTime.c +++ b/win/tclWinTime.c @@ -53,6 +53,7 @@ typedef struct { * initialized. */ int perfCounterAvailable; /* Flag == 1 if the hardware has a performance * counter. */ + DWORD calibrationInterv; /* Calibration interval in seconds (start 1 sec) */ HANDLE calibrationThread; /* Handle to the thread that keeps the virtual * clock calibrated. */ HANDLE readyEvent; /* System event used to trigger the requesting @@ -63,7 +64,6 @@ typedef struct { LARGE_INTEGER nominalFreq; /* Nominal frequency of the system performance * counter, that is, the value returned from * QueryPerformanceFrequency. */ - /* * The following values are used for calculating virtual time. Virtual * time is always equal to: @@ -76,6 +76,8 @@ typedef struct { ULARGE_INTEGER fileTimeLastCall; LARGE_INTEGER perfCounterLastCall; LARGE_INTEGER curCounterFreq; + LARGE_INTEGER posixEpoch; /* Posix epoch expressed as 100-ns ticks since + * the windows epoch. */ /* * Data used in developing the estimate of performance counter frequency @@ -92,6 +94,7 @@ static TimeInfo timeInfo = { { NULL, 0, 0, NULL, NULL, 0 }, 0, 0, + 1, (HANDLE) NULL, (HANDLE) NULL, (HANDLE) NULL, @@ -100,11 +103,13 @@ static TimeInfo timeInfo = { (ULARGE_INTEGER) (DWORDLONG) 0, (LARGE_INTEGER) (Tcl_WideInt) 0, (LARGE_INTEGER) (Tcl_WideInt) 0, + (LARGE_INTEGER) (Tcl_WideInt) 0, #else - 0, - 0, - 0, - 0, + {0, 0}, + {0, 0}, + {0, 0}, + {0, 0}, + {0, 0}, #endif { 0 }, { 0 }, @@ -112,6 +117,17 @@ static TimeInfo timeInfo = { }; /* + * Scale to convert wide click values from the TclpGetWideClicks native + * resolution to microsecond resolution and back. + */ +static struct { + int initialized; /* 1 if initialized, 0 otherwise */ + int perfCounter; /* 1 if performance counter usable for wide clicks */ + double microsecsScale; /* Denominator scale between clock / microsecs */ +} wideClick = {0, 0, 0.0}; + + +/* * Declarations for functions defined later in this file. */ @@ -127,6 +143,7 @@ static Tcl_WideInt AccumulateSample(Tcl_WideInt perfCounter, Tcl_WideUInt fileTime); static void NativeScaleTime(Tcl_Time* timebuf, ClientData clientData); +static Tcl_WideInt NativeGetMicroseconds(void); static void NativeGetTime(Tcl_Time* timebuf, ClientData clientData); @@ -158,10 +175,19 @@ ClientData tclTimeClientData = NULL; unsigned long TclpGetSeconds(void) { - Tcl_Time t; + Tcl_WideInt usecSincePosixEpoch; - tclGetTimeProcPtr(&t, tclTimeClientData); /* Tcl_GetTime inlined. */ - return t.sec; + /* Try to use high resolution timer */ + if ( tclGetTimeProcPtr == NativeGetTime + && (usecSincePosixEpoch = NativeGetMicroseconds()) + ) { + return usecSincePosixEpoch / 1000000; + } else { + Tcl_Time t; + + tclGetTimeProcPtr(&t, tclTimeClientData); /* Tcl_GetTime inlined. */ + return t.sec; + } } /* @@ -172,7 +198,7 @@ TclpGetSeconds(void) * 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 dependant. + * start time is also system dependent. * * Results: * Number of clicks from some start time. @@ -186,19 +212,147 @@ TclpGetSeconds(void) unsigned long TclpGetClicks(void) { - /* - * Use the Tcl_GetTime abstraction to get the time in microseconds, as - * nearly as we can, and return it. - */ + Tcl_WideInt usecSincePosixEpoch; - Tcl_Time now; /* Current Tcl time */ - unsigned long retval; /* Value to return */ + /* Try to use high resolution timer */ + if ( tclGetTimeProcPtr == NativeGetTime + && (usecSincePosixEpoch = NativeGetMicroseconds()) + ) { + return (unsigned long)usecSincePosixEpoch; + } else { + /* + * Use the Tcl_GetTime abstraction to get the time in microseconds, as + * nearly as we can, and return it. + */ - tclGetTimeProcPtr(&now, tclTimeClientData); /* Tcl_GetTime inlined */ + Tcl_Time now; /* Current Tcl time */ - retval = (now.sec * 1000000) + now.usec; - return retval; + tclGetTimeProcPtr(&now, tclTimeClientData); /* Tcl_GetTime inlined */ + return (unsigned long)(now.sec * 1000000) + now.usec; + } +} + +/* + *---------------------------------------------------------------------- + * + * TclpGetWideClicks -- + * + * This procedure returns a WideInt value that represents the highest + * resolution clock in microseconds available on the system. + * + * Results: + * Number of microseconds (from some start time). + * + * Side effects: + * This should be used for time-delta resp. for measurement purposes + * only, because on some platforms can return microseconds from some + * start time (not from the epoch). + * + *---------------------------------------------------------------------- + */ + +Tcl_WideInt +TclpGetWideClicks(void) +{ + LARGE_INTEGER curCounter; + + if (!wideClick.initialized) { + LARGE_INTEGER perfCounterFreq; + + /* + * The frequency of the performance counter is fixed at system boot and + * is consistent across all processors. Therefore, the frequency need + * only be queried upon application initialization. + */ + if (QueryPerformanceFrequency(&perfCounterFreq)) { + wideClick.perfCounter = 1; + wideClick.microsecsScale = 1000000.0 / perfCounterFreq.QuadPart; + } else { + /* fallback using microseconds */ + wideClick.perfCounter = 0; + wideClick.microsecsScale = 1; + } + wideClick.initialized = 1; + } + if (wideClick.perfCounter) { + if (QueryPerformanceCounter(&curCounter)) { + return (Tcl_WideInt)curCounter.QuadPart; + } + /* fallback using microseconds */ + wideClick.perfCounter = 0; + wideClick.microsecsScale = 1; + return TclpGetMicroseconds(); + } else { + return TclpGetMicroseconds(); + } +} + +/* + *---------------------------------------------------------------------- + * + * TclpWideClickInMicrosec -- + * + * This procedure return scale to convert wide click values from the + * TclpGetWideClicks native resolution to microsecond resolution + * and back. + * + * Results: + * 1 click in microseconds as double. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +double +TclpWideClickInMicrosec(void) +{ + if (!wideClick.initialized) { + (void)TclpGetWideClicks(); /* initialize */ + } + return wideClick.microsecsScale; +} + +/* + *---------------------------------------------------------------------- + * + * TclpGetMicroseconds -- + * + * This procedure returns a WideInt value that represents the highest + * resolution clock in microseconds available on the system. + * + * Results: + * Number of microseconds (from the epoch). + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_WideInt +TclpGetMicroseconds(void) +{ + Tcl_WideInt usecSincePosixEpoch; + + /* Try to use high resolution timer */ + if ( tclGetTimeProcPtr == NativeGetTime + && (usecSincePosixEpoch = NativeGetMicroseconds()) + ) { + return usecSincePosixEpoch; + } else { + /* + * Use the Tcl_GetTime abstraction to get the time in microseconds, as + * nearly as we can, and return it. + */ + + Tcl_Time now; + + tclGetTimeProcPtr(&now, tclTimeClientData); /* Tcl_GetTime inlined */ + return (((Tcl_WideInt)now.sec) * 1000000) + now.usec; + } } /* @@ -227,7 +381,17 @@ void Tcl_GetTime( Tcl_Time *timePtr) /* Location to store time information. */ { - tclGetTimeProcPtr(timePtr, tclTimeClientData); + Tcl_WideInt usecSincePosixEpoch; + + /* Try to use high resolution timer */ + if ( tclGetTimeProcPtr == NativeGetTime + && (usecSincePosixEpoch = NativeGetMicroseconds()) + ) { + timePtr->sec = (long) (usecSincePosixEpoch / 1000000); + timePtr->usec = (unsigned long) (usecSincePosixEpoch % 1000000); + } else { + tclGetTimeProcPtr(timePtr, tclTimeClientData); + } } /* @@ -260,13 +424,14 @@ NativeScaleTime( /* *---------------------------------------------------------------------- * - * NativeGetTime -- + * NativeGetMicroseconds -- * - * TIP #233: Gets the current system time in seconds and microseconds - * since the beginning of the epoch: 00:00 UCT, January 1, 1970. + * Gets the current system time in microseconds since the beginning + * of the epoch: 00:00 UCT, January 1, 1970. * * Results: - * Returns the current time in timePtr. + * Returns the wide integer with number of microseconds from the epoch, or + * 0 if high resolution timer is not available. * * Side effects: * On the first call, initializes a set of static variables to keep track @@ -279,13 +444,20 @@ NativeScaleTime( *---------------------------------------------------------------------- */ -static void -NativeGetTime( - Tcl_Time *timePtr, - ClientData clientData) -{ - struct _timeb t; +static inline Tcl_WideInt +NativeCalc100NsTicks( + ULONGLONG fileTimeLastCall, + LONGLONG perfCounterLastCall, + LONGLONG curCounterFreq, + LONGLONG curCounter +) { + return fileTimeLastCall + + ((curCounter - perfCounterLastCall) * 10000000 / curCounterFreq); +} +static Tcl_WideInt +NativeGetMicroseconds(void) +{ /* * Initialize static storage on the first trip through. * @@ -296,6 +468,10 @@ NativeGetTime( if (!timeInfo.initialized) { TclpInitLock(); if (!timeInfo.initialized) { + + timeInfo.posixEpoch.LowPart = 0xD53E8000; + timeInfo.posixEpoch.HighPart = 0x019DB1DE; + timeInfo.perfCounterAvailable = QueryPerformanceFrequency(&timeInfo.nominalFreq); @@ -372,8 +548,8 @@ NativeGetTime( DWORD id; InitializeCriticalSection(&timeInfo.cs); - timeInfo.readyEvent = CreateEvent(NULL, FALSE, FALSE, NULL); - timeInfo.exitEvent = CreateEvent(NULL, FALSE, FALSE, NULL); + 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, @@ -400,22 +576,12 @@ NativeGetTime( * time. */ - ULARGE_INTEGER fileTimeLastCall; - LARGE_INTEGER perfCounterLastCall, curCounterFreq; + ULONGLONG fileTimeLastCall; + LONGLONG perfCounterLastCall, curCounterFreq; /* Copy with current data of calibration cycle */ LARGE_INTEGER curCounter; /* Current performance counter. */ - Tcl_WideInt curFileTime;/* Current estimated time, expressed as 100-ns - * ticks since the Windows epoch. */ - static LARGE_INTEGER posixEpoch; - /* Posix epoch expressed as 100-ns ticks since - * the windows epoch. */ - Tcl_WideInt usecSincePosixEpoch; - /* Current microseconds since Posix epoch. */ - - posixEpoch.LowPart = 0xD53E8000; - posixEpoch.HighPart = 0x019DB1DE; QueryPerformanceCounter(&curCounter); @@ -424,21 +590,18 @@ NativeGetTime( */ EnterCriticalSection(&timeInfo.cs); - fileTimeLastCall.QuadPart = timeInfo.fileTimeLastCall.QuadPart; - perfCounterLastCall.QuadPart = timeInfo.perfCounterLastCall.QuadPart; - curCounterFreq.QuadPart = timeInfo.curCounterFreq.QuadPart; + fileTimeLastCall = timeInfo.fileTimeLastCall.QuadPart; + perfCounterLastCall = timeInfo.perfCounterLastCall.QuadPart; + curCounterFreq = timeInfo.curCounterFreq.QuadPart; LeaveCriticalSection(&timeInfo.cs); /* * If calibration cycle occurred after we get curCounter */ - if (curCounter.QuadPart <= perfCounterLastCall.QuadPart) { - usecSincePosixEpoch = - (fileTimeLastCall.QuadPart - posixEpoch.QuadPart) / 10; - timePtr->sec = (long) (usecSincePosixEpoch / 1000000); - timePtr->usec = (unsigned long) (usecSincePosixEpoch % 1000000); - return; + if (curCounter.QuadPart <= perfCounterLastCall) { + /* Calibrated file-time is saved from posix in 100-ns ticks */ + return fileTimeLastCall / 10; } /* @@ -451,27 +614,62 @@ NativeGetTime( * loop should recover. */ - if (curCounter.QuadPart - perfCounterLastCall.QuadPart < - 11 * curCounterFreq.QuadPart / 10 + if (curCounter.QuadPart - perfCounterLastCall < + 11 * curCounterFreq * timeInfo.calibrationInterv / 10 ) { - curFileTime = fileTimeLastCall.QuadPart + - ((curCounter.QuadPart - perfCounterLastCall.QuadPart) - * 10000000 / curCounterFreq.QuadPart); - - usecSincePosixEpoch = (curFileTime - posixEpoch.QuadPart) / 10; - timePtr->sec = (long) (usecSincePosixEpoch / 1000000); - timePtr->usec = (unsigned long) (usecSincePosixEpoch % 1000000); - return; + /* Calibrated file-time is saved from posix in 100-ns ticks */ + return NativeCalc100NsTicks(fileTimeLastCall, + perfCounterLastCall, curCounterFreq, curCounter.QuadPart) / 10; } } /* - * High resolution timer is not available. Just use ftime. + * High resolution timer is not available. + */ + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * NativeGetTime -- + * + * TIP #233: Gets the current system time in seconds and microseconds + * since the beginning of the epoch: 00:00 UCT, January 1, 1970. + * + * Results: + * Returns the current time in timePtr. + * + * Side effects: + * See NativeGetMicroseconds for more information. + * + *---------------------------------------------------------------------- + */ + +static void +NativeGetTime( + Tcl_Time *timePtr, + ClientData clientData) +{ + Tcl_WideInt usecSincePosixEpoch; + + /* + * Try to use high resolution timer. */ + if ( (usecSincePosixEpoch = NativeGetMicroseconds()) ) { + timePtr->sec = (long) (usecSincePosixEpoch / 1000000); + timePtr->usec = (unsigned long) (usecSincePosixEpoch % 1000000); + } else { + /* + * High resolution timer is not available. Just use ftime. + */ - _ftime(&t); - timePtr->sec = (long)t.time; - timePtr->usec = t.millitm * 1000; + struct _timeb t; + + _ftime(&t); + timePtr->sec = (long)t.time; + timePtr->usec = t.millitm * 1000; + } } /* @@ -492,6 +690,8 @@ NativeGetTime( *---------------------------------------------------------------------- */ +void TclWinResetTimerResolution(void); + static void StopCalibration( ClientData unused) /* Client data is unused */ @@ -534,8 +734,18 @@ TclpGetDate( { struct tm *tmPtr; time_t time; +#if defined(_WIN64) || (defined(_USE_64BIT_TIME_T) || (defined(_MSC_VER) && _MSC_VER < 1400)) +# define t2 *t /* no need to cripple time to 32-bit */ +#else + time_t t2 = *(__time32_t *)t; +#endif if (!useGMT) { +#if defined(_MSC_VER) && (_MSC_VER >= 1900) +# undef timezone /* prevent conflict with timezone() function */ + long timezone = 0; +#endif + tzset(); /* @@ -561,11 +771,15 @@ TclpGetDate( #define LOCALTIME_VALIDITY_BOUNDARY 0 #endif - if (*t >= LOCALTIME_VALIDITY_BOUNDARY) { - return TclpLocaltime(t); + if (t2 >= LOCALTIME_VALIDITY_BOUNDARY) { + return TclpLocaltime(&t2); } - time = *t - timezone; +#if defined(_MSC_VER) && (_MSC_VER >= 1900) + _get_timezone(&timezone); +#endif + + time = t2 - timezone; /* * If we aren't near to overflowing the long, just add the bias and @@ -573,10 +787,10 @@ TclpGetDate( * result at the end. */ - if (*t < (LONG_MAX - 2*SECSPERDAY) && *t > (LONG_MIN + 2*SECSPERDAY)) { + if (t2 < (LONG_MAX - 2*SECSPERDAY) && t2 > (LONG_MIN + 2*SECSPERDAY)) { tmPtr = ComputeGMT(&time); } else { - tmPtr = ComputeGMT(t); + tmPtr = ComputeGMT(&t2); tzset(); @@ -612,7 +826,7 @@ TclpGetDate( tmPtr->tm_wday = (tmPtr->tm_wday + (int)time) % 7; } } else { - tmPtr = ComputeGMT(t); + tmPtr = ComputeGMT(&t2); } return tmPtr; } @@ -773,6 +987,8 @@ CalibrationThread( QueryPerformanceFrequency(&timeInfo.curCounterFreq); timeInfo.fileTimeLastCall.LowPart = curFileTime.dwLowDateTime; timeInfo.fileTimeLastCall.HighPart = curFileTime.dwHighDateTime; + /* Calibrated file-time will be saved from posix in 100-ns ticks */ + timeInfo.fileTimeLastCall.QuadPart -= timeInfo.posixEpoch.QuadPart; ResetCounterSamples(timeInfo.fileTimeLastCall.QuadPart, timeInfo.perfCounterLastCall.QuadPart, @@ -832,6 +1048,7 @@ UpdateTimeEachSecond(void) /* Current value returned from * QueryPerformanceCounter. */ FILETIME curSysTime; /* Current system time. */ + static LARGE_INTEGER lastFileTime; /* File time of the previous calibration */ LARGE_INTEGER curFileTime; /* File time at the time this callback was * scheduled. */ Tcl_WideInt estFreq; /* Estimated perf counter frequency. */ @@ -843,15 +1060,24 @@ UpdateTimeEachSecond(void) * step over 1 second. */ /* - * Sample performance counter and system time. + * Sample performance counter and system time (from posix epoch). */ - QueryPerformanceCounter(&curPerfCounter); GetSystemTimeAsFileTime(&curSysTime); curFileTime.LowPart = curSysTime.dwLowDateTime; curFileTime.HighPart = curSysTime.dwHighDateTime; + curFileTime.QuadPart -= timeInfo.posixEpoch.QuadPart; + /* If calibration still not needed (check for possible time switch) */ + if ( curFileTime.QuadPart > lastFileTime.QuadPart + && curFileTime.QuadPart < lastFileTime.QuadPart + + (timeInfo.calibrationInterv * 10000000) + ) { + /* again in next one second */ + return; + } + QueryPerformanceCounter(&curPerfCounter); - EnterCriticalSection(&timeInfo.cs); + lastFileTime.QuadPart = curFileTime.QuadPart; /* * We devide by timeInfo.curCounterFreq.QuadPart in several places. That @@ -863,7 +1089,6 @@ UpdateTimeEachSecond(void) */ if (timeInfo.curCounterFreq.QuadPart == 0){ - LeaveCriticalSection(&timeInfo.cs); timeInfo.perfCounterAvailable = 0; return; } @@ -902,12 +1127,9 @@ UpdateTimeEachSecond(void) * is estFreq * 20000000 / (vt1 - vt0) */ - vt0 = 10000000 * (curPerfCounter.QuadPart - - timeInfo.perfCounterLastCall.QuadPart) - / timeInfo.curCounterFreq.QuadPart - + timeInfo.fileTimeLastCall.QuadPart; - vt1 = 20000000 + curFileTime.QuadPart; - + vt0 = NativeCalc100NsTicks(timeInfo.fileTimeLastCall.QuadPart, + timeInfo.perfCounterLastCall.QuadPart, timeInfo.curCounterFreq.QuadPart, + curPerfCounter.QuadPart); /* * If we've gotten more than a second away from system time, then drifting * the clock is going to be pretty hopeless. Just let it jump. Otherwise, @@ -916,21 +1138,75 @@ UpdateTimeEachSecond(void) tdiff = vt0 - curFileTime.QuadPart; if (tdiff > 10000000 || tdiff < -10000000) { - timeInfo.fileTimeLastCall.QuadPart = curFileTime.QuadPart; - timeInfo.curCounterFreq.QuadPart = estFreq; + /* jump to current system time, use curent estimated frequency */ + vt0 = curFileTime.QuadPart; } else { - driftFreq = estFreq * 20000000 / (vt1 - vt0); + /* calculate new frequency and estimate drift to the next second */ + vt1 = 20000000 + curFileTime.QuadPart; + driftFreq = (estFreq * 20000000 / (vt1 - vt0)); + /* + * Avoid too large drifts (only half of the current difference), + * that allows also be more accurate (aspire to the smallest tdiff), + * so then we can prolong calibration interval by tdiff < 100000 + */ + driftFreq = timeInfo.curCounterFreq.QuadPart + + (driftFreq - timeInfo.curCounterFreq.QuadPart) / 2; + + /* + * Average between estimated, 2 current and 5 drifted frequencies, + * (do the soft drifting as possible) + */ + estFreq = (estFreq + 2 * timeInfo.curCounterFreq.QuadPart + 5 * driftFreq) / 8; + } - if (driftFreq > 1003*estFreq/1000) { - driftFreq = 1003*estFreq/1000; - } else if (driftFreq < 997*estFreq/1000) { - driftFreq = 997*estFreq/1000; + /* Avoid too large discrepancy from nominal frequency */ + if (estFreq > 1003*timeInfo.nominalFreq.QuadPart/1000) { + estFreq = 1003*timeInfo.nominalFreq.QuadPart/1000; + vt0 = curFileTime.QuadPart; + } else if (estFreq < 997*timeInfo.nominalFreq.QuadPart/1000) { + estFreq = 997*timeInfo.nominalFreq.QuadPart/1000; + vt0 = curFileTime.QuadPart; + } else if (vt0 != curFileTime.QuadPart) { + /* + * Be sure the clock ticks never backwards (avoid it by negative drifting) + * just compare native time (in 100-ns) before and hereafter using + * new calibrated values) and do a small adjustment (short time freeze) + */ + LARGE_INTEGER newPerfCounter; + Tcl_WideInt nt0, nt1; + + QueryPerformanceCounter(&newPerfCounter); + nt0 = NativeCalc100NsTicks(timeInfo.fileTimeLastCall.QuadPart, + timeInfo.perfCounterLastCall.QuadPart, timeInfo.curCounterFreq.QuadPart, + newPerfCounter.QuadPart); + nt1 = NativeCalc100NsTicks(vt0, + curPerfCounter.QuadPart, estFreq, + newPerfCounter.QuadPart); + if (nt0 > nt1) { /* drifted backwards, try to compensate with new base */ + /* first adjust with a micro jump (short frozen time is acceptable) */ + vt0 += nt0 - nt1; + /* if drift unavoidable (e. g. we had a time switch), then reset it */ + vt1 = vt0 - curFileTime.QuadPart; + if (vt1 > 10000000 || vt1 < -10000000) { + /* larger jump resp. shift relative new file-time */ + vt0 = curFileTime.QuadPart; + } } + } + + /* In lock commit new values to timeInfo (hold lock as short as possible) */ + EnterCriticalSection(&timeInfo.cs); - timeInfo.fileTimeLastCall.QuadPart = vt0; - timeInfo.curCounterFreq.QuadPart = driftFreq; + /* grow calibration interval up to 10 seconds (if still precise enough) */ + if (tdiff < -100000 || tdiff > 100000) { + /* too long drift - reset calibration interval to 1000 second */ + timeInfo.calibrationInterv = 1; + } else if (timeInfo.calibrationInterv < 10) { + timeInfo.calibrationInterv++; } + timeInfo.fileTimeLastCall.QuadPart = vt0; + timeInfo.curCounterFreq.QuadPart = estFreq; timeInfo.perfCounterLastCall.QuadPart = curPerfCounter.QuadPart; LeaveCriticalSection(&timeInfo.cs); @@ -1086,7 +1362,11 @@ TclpGmtime( * Posix gmtime_r function. */ +#if defined(_WIN64) || defined(_USE_64BIT_TIME_T) || (defined(_MSC_VER) && _MSC_VER < 1400) return gmtime(timePtr); +#else + return _gmtime32((CONST __time32_t *)timePtr); +#endif } /* @@ -1117,7 +1397,11 @@ TclpLocaltime( * provide a Posix localtime_r function. */ +#if defined(_WIN64) || defined(_USE_64BIT_TIME_T) || (defined(_MSC_VER) && _MSC_VER < 1400) return localtime(timePtr); +#else + return _localtime32((CONST __time32_t *)timePtr); +#endif } #endif /* TCL_NO_DEPRECATED */ |