summaryrefslogtreecommitdiffstats
path: root/win
diff options
context:
space:
mode:
Diffstat (limited to 'win')
-rw-r--r--win/Makefile.in381
-rw-r--r--win/README8
-rw-r--r--win/buildall.vc.bat10
-rw-r--r--win/cat.c9
-rwxr-xr-xwin/configure454
-rw-r--r--win/configure.in134
-rw-r--r--win/makefile.bc93
-rw-r--r--win/makefile.vc253
-rw-r--r--win/rules.vc31
-rw-r--r--win/stub16.c195
-rw-r--r--win/tcl.dsp16
-rw-r--r--win/tcl.hpj.in4
-rw-r--r--win/tcl.m482
-rw-r--r--win/tclAppInit.c182
-rw-r--r--win/tclWin32Dll.c566
-rw-r--r--win/tclWinChan.c181
-rw-r--r--win/tclWinConsole.c496
-rw-r--r--win/tclWinDde.c442
-rw-r--r--win/tclWinError.c59
-rw-r--r--win/tclWinFCmd.c387
-rwxr-xr-xwin/tclWinFile.c1523
-rw-r--r--win/tclWinInit.c101
-rw-r--r--win/tclWinInt.h132
-rw-r--r--win/tclWinLoad.c299
-rw-r--r--win/tclWinNotify.c451
-rw-r--r--win/tclWinPipe.c454
-rw-r--r--win/tclWinPort.h308
-rw-r--r--win/tclWinReg.c656
-rw-r--r--win/tclWinSerial.c200
-rw-r--r--win/tclWinSock.c3493
-rw-r--r--win/tclWinTest.c202
-rw-r--r--win/tclWinThrd.c84
-rw-r--r--win/tclWinThrd.h19
-rw-r--r--win/tclWinTime.c133
-rw-r--r--win/tclooConfig.sh19
-rw-r--r--win/tclsh.icobin3630 -> 57022 bytes
36 files changed, 6384 insertions, 5673 deletions
diff --git a/win/Makefile.in b/win/Makefile.in
index 6376470..066e6b1 100644
--- a/win/Makefile.in
+++ b/win/Makefile.in
@@ -81,7 +81,12 @@ CFLAGS_OPTIMIZE = @CFLAGS_OPTIMIZE@
#CFLAGS = $(CFLAGS_DEBUG)
#CFLAGS = $(CFLAGS_OPTIMIZE)
#CFLAGS = $(CFLAGS_DEBUG) $(CFLAGS_OPTIMIZE)
-CFLAGS = @CFLAGS@ @CFLAGS_DEFAULT@ -D_ATL_XP_TARGETING
+CFLAGS = @CFLAGS@ @CFLAGS_DEFAULT@ -DUNICODE -D_UNICODE -D_ATL_XP_TARGETING
+
+# To compile without backward compatibility and deprecated code uncomment the
+# following
+NO_DEPRECATED_FLAGS =
+#NO_DEPRECATED_FLAGS = -DTCL_NO_DEPRECATED
# To enable compilation debugging reverse the comment characters on one of the
# following lines.
@@ -89,15 +94,15 @@ COMPILE_DEBUG_FLAGS =
#COMPILE_DEBUG_FLAGS = -DTCL_COMPILE_DEBUG
#COMPILE_DEBUG_FLAGS = -DTCL_COMPILE_DEBUG -DTCL_COMPILE_STATS
-# Special compiler flags to use when building man2tcl on Windows.
-MAN2TCLFLAGS = @MAN2TCLFLAGS@
-
SRC_DIR = @srcdir@
ROOT_DIR = @srcdir@/..
-GENERIC_DIR = @srcdir@/../generic
-TOMMATH_DIR = @srcdir@/../libtommath
-WIN_DIR = @srcdir@
-COMPAT_DIR = @srcdir@/../compat
+TOP_DIR = $(shell cd @srcdir@/..; pwd -P)
+GENERIC_DIR = $(TOP_DIR)/generic
+TOMMATH_DIR = $(TOP_DIR)/libtommath
+WIN_DIR = $(TOP_DIR)/win
+COMPAT_DIR = $(TOP_DIR)/compat
+PKGS_DIR = $(TOP_DIR)/pkgs
+ZLIB_DIR = $(COMPAT_DIR)/zlib
# Converts a POSIX path to a Windows native path.
CYGPATH = @CYGPATH@
@@ -111,6 +116,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)')
+ZLIB_DIR_NATIVE = $(shell $(CYGPATH) '$(ZLIB_DIR)')
#GENERIC_DIR_NATIVE = $(GENERIC_DIR)
#TOMMATH_DIR_NATIVE = $(TOMMATH_DIR)
#WIN_DIR_NATIVE = $(WIN_DIR)
@@ -118,7 +124,7 @@ ROOT_DIR_NATIVE = $(shell $(CYGPATH) '$(ROOT_DIR)')
# Fully qualify library path so that `make test`
# does not depend on the current directory.
-LIBRARY_DIR1 = $(shell cd '$(ROOT_DIR_NATIVE)/library' ; pwd)
+LIBRARY_DIR1 = $(shell cd '$(ROOT_DIR_NATIVE)/library' ; pwd -P)
LIBRARY_DIR = $(shell $(CYGPATH) '$(LIBRARY_DIR1)')
DLLSUFFIX = @DLLSUFFIX@
LIBSUFFIX = @LIBSUFFIX@
@@ -135,37 +141,33 @@ TCL_STUB_LIB_FILE = @TCL_STUB_LIB_FILE@
TCL_DLL_FILE = @TCL_DLL_FILE@
TCL_LIB_FILE = @TCL_LIB_FILE@
DDE_DLL_FILE = tcldde$(DDEVER)${DLLSUFFIX}
-DDE_LIB_FILE = tcldde$(DDEVER)${LIBSUFFIX}
+DDE_LIB_FILE = @LIBPREFIX@tcldde$(DDEVER)${LIBSUFFIX}
REG_DLL_FILE = tclreg$(REGVER)${DLLSUFFIX}
-REG_LIB_FILE = tclreg$(REGVER)${LIBSUFFIX}
-PIPE_DLL_FILE = tclpip$(VER)${DLLSUFFIX}
-
-SHARED_LIBRARIES = $(TCL_DLL_FILE) $(TCL_STUB_LIB_FILE) \
- $(DDE_DLL_FILE) $(REG_DLL_FILE) $(PIPE_DLL_FILE)
-STATIC_LIBRARIES = $(TCL_LIB_FILE) $(REG_LIB_FILE) $(DDE_LIB_FILE)
-
-# To compile without backward compatibility and deprecated code
-# uncomment the following
-NO_DEPRECATED_FLAGS =
-#NO_DEPRECATED_FLAGS = -DTCL_NO_DEPRECATED
+REG_LIB_FILE = @LIBPREFIX@tclreg$(REGVER)${LIBSUFFIX}
+TEST_DLL_FILE = tcltest$(VER)${DLLSUFFIX}
+TEST_LIB_FILE = @LIBPREFIX@tcltest$(VER)${LIBSUFFIX}
+ZLIB_DLL_FILE = zlib1.dll
-# TCL_EXE is the name of a tclsh executable that is available *BEFORE* running
-# make for the first time. Certain build targets (make genstubs) need it to be
-# available on the PATH. This executable should *NOT* be required just to do a
-# normal build although it can be required to run make dist.
-TCL_EXE = tclsh
+SHARED_LIBRARIES = $(TCL_DLL_FILE) @ZLIB_DLL_FILE@
+STATIC_LIBRARIES = $(TCL_LIB_FILE)
TCLSH = tclsh$(VER)${EXESUFFIX}
-TCLTEST = tcltest${EXEEXT}
CAT32 = cat32$(EXEEXT)
MAN2TCL = man2tcl$(EXEEXT)
+# For cross-compiled builds, TCL_EXE is the name of a tclsh executable that is
+# available *BEFORE* running make for the first time. Certain build targets
+# (make genstubs, make install) need it to be available on the PATH. This
+# executable should *NOT* be required just to do a normal build although
+# it can be required to run make dist.
+TCL_EXE = @TCL_EXE@
+
@SET_MAKE@
# Setting the VPATH variable to a list of paths will cause the Makefile to
# look into these paths when resolving .c to .obj dependencies.
-VPATH = $(GENERIC_DIR):$(TOMMATH_DIR):$(WIN_DIR):$(COMPAT_DIR)
+VPATH = $(GENERIC_DIR):$(TOMMATH_DIR):$(WIN_DIR):$(COMPAT_DIR):$(ZLIB_DIR)
AR = @AR@
RANLIB = @RANLIB@
@@ -183,10 +185,10 @@ EXEEXT = @EXEEXT@
OBJEXT = @OBJEXT@
STLIB_LD = @STLIB_LD@
SHLIB_LD = @SHLIB_LD@
-SHLIB_LD_LIBS = @SHLIB_LD_LIBS@ $(LIBS)
+SHLIB_LD_LIBS = @SHLIB_LD_LIBS@
SHLIB_CFLAGS = @SHLIB_CFLAGS@
SHLIB_SUFFIX = @SHLIB_SUFFIX@
-LIBS = @LIBS@
+LIBS = @LIBS@ $(shell $(CYGPATH) '@ZLIB_LIBS@')
RMDIR = rm -rf
MKDIR = mkdir -p
@@ -195,9 +197,9 @@ RM = rm -f
COPY = cp
CC_SWITCHES = ${CFLAGS} ${CFLAGS_WARNING} ${TCL_SHLIB_CFLAGS} \
--I"${GENERIC_DIR_NATIVE}" -DTCL_TOMMATH -DMP_PREC=4 -I"${TOMMATH_DIR_NATIVE}" \
--I"${WIN_DIR_NATIVE}" ${AC_FLAGS} \
-${COMPILE_DEBUG_FLAGS} ${NO_DEPRECATED_FLAGS}
+-I"${ZLIB_DIR_NATIVE}" -I"${GENERIC_DIR_NATIVE}" -DTCL_TOMMATH \
+-DMP_PREC=4 -I"${TOMMATH_DIR_NATIVE}" -I"${WIN_DIR_NATIVE}" \
+${AC_FLAGS} ${COMPILE_DEBUG_FLAGS} ${NO_DEPRECATED_FLAGS}
CC_OBJNAME = @CC_OBJNAME@
CC_EXENAME = @CC_EXENAME@
@@ -212,8 +214,7 @@ TCLTEST_OBJS = \
tclTestObj.$(OBJEXT) \
tclTestProcBodyObj.$(OBJEXT) \
tclThreadTest.$(OBJEXT) \
- tclWinTest.$(OBJEXT) \
- testMain.$(OBJEXT)
+ tclWinTest.$(OBJEXT)
GENERIC_OBJS = \
regcomp.$(OBJEXT) \
@@ -221,6 +222,7 @@ GENERIC_OBJS = \
regfree.$(OBJEXT) \
regerror.$(OBJEXT) \
tclAlloc.$(OBJEXT) \
+ tclAssembly.$(OBJEXT) \
tclAsync.$(OBJEXT) \
tclBasic.$(OBJEXT) \
tclBinary.$(OBJEXT) \
@@ -230,12 +232,16 @@ GENERIC_OBJS = \
tclCmdIL.$(OBJEXT) \
tclCmdMZ.$(OBJEXT) \
tclCompCmds.$(OBJEXT) \
+ tclCompCmdsGR.$(OBJEXT) \
+ tclCompCmdsSZ.$(OBJEXT) \
tclCompExpr.$(OBJEXT) \
tclCompile.$(OBJEXT) \
tclConfig.$(OBJEXT) \
tclDate.$(OBJEXT) \
tclDictObj.$(OBJEXT) \
+ tclDisassemble.$(OBJEXT) \
tclEncoding.$(OBJEXT) \
+ tclEnsemble.$(OBJEXT) \
tclEnv.$(OBJEXT) \
tclEvent.$(OBJEXT) \
tclExecute.$(OBJEXT) \
@@ -250,6 +256,7 @@ GENERIC_OBJS = \
tclIOCmd.$(OBJEXT) \
tclIOGT.$(OBJEXT) \
tclIORChan.$(OBJEXT) \
+ tclIORTrans.$(OBJEXT) \
tclIOSock.$(OBJEXT) \
tclIOUtil.$(OBJEXT) \
tclLink.$(OBJEXT) \
@@ -257,9 +264,18 @@ GENERIC_OBJS = \
tclListObj.$(OBJEXT) \
tclLoad.$(OBJEXT) \
tclMain.$(OBJEXT) \
+ tclMain2.$(OBJEXT) \
tclNamesp.$(OBJEXT) \
tclNotify.$(OBJEXT) \
+ tclOO.$(OBJEXT) \
+ tclOOBasic.$(OBJEXT) \
+ tclOOCall.$(OBJEXT) \
+ tclOODefineCmds.$(OBJEXT) \
+ tclOOInfo.$(OBJEXT) \
+ tclOOMethod.$(OBJEXT) \
+ tclOOStubInit.$(OBJEXT) \
tclObj.$(OBJEXT) \
+ tclOptimize.$(OBJEXT) \
tclPanic.$(OBJEXT) \
tclParse.$(OBJEXT) \
tclPathObj.$(OBJEXT) \
@@ -276,7 +292,6 @@ GENERIC_OBJS = \
tclStringObj.$(OBJEXT) \
tclStrToD.$(OBJEXT) \
tclStubInit.$(OBJEXT) \
- tclStubLib.$(OBJEXT) \
tclThread.$(OBJEXT) \
tclThreadAlloc.$(OBJEXT) \
tclThreadJoin.$(OBJEXT) \
@@ -286,7 +301,8 @@ GENERIC_OBJS = \
tclTrace.$(OBJEXT) \
tclUtf.$(OBJEXT) \
tclUtil.$(OBJEXT) \
- tclVar.$(OBJEXT)
+ tclVar.$(OBJEXT) \
+ tclZlib.$(OBJEXT)
TOMMATH_OBJS = \
bncore.${OBJEXT} \
@@ -371,47 +387,48 @@ WIN_OBJS = \
tclWinThrd.$(OBJEXT) \
tclWinTime.$(OBJEXT)
-PIPE_OBJS = stub16.$(OBJEXT)
-
DDE_OBJS = tclWinDde.$(OBJEXT)
REG_OBJS = tclWinReg.$(OBJEXT)
-STUB_OBJS = tclStubLib.$(OBJEXT)
+STUB_OBJS = \
+ tclStubLib.$(OBJEXT) \
+ tclTomMathStubLib.$(OBJEXT) \
+ tclOOStubLib.$(OBJEXT)
TCLSH_OBJS = tclAppInit.$(OBJEXT)
-TCL_OBJS = ${GENERIC_OBJS} $(TOMMATH_OBJS) ${WIN_OBJS}
+ZLIB_OBJS = \
+ adler32.$(OBJEXT) \
+ compress.$(OBJEXT) \
+ crc32.$(OBJEXT) \
+ deflate.$(OBJEXT) \
+ infback.$(OBJEXT) \
+ inffast.$(OBJEXT) \
+ inflate.$(OBJEXT) \
+ inftrees.$(OBJEXT) \
+ trees.$(OBJEXT) \
+ uncompr.$(OBJEXT) \
+ zutil.$(OBJEXT)
+
+TCL_OBJS = ${GENERIC_OBJS} $(TOMMATH_OBJS) ${WIN_OBJS} @ZLIB_OBJS@
TCL_DOCS = "$(ROOT_DIR_NATIVE)"/doc/*.[13n]
-all: binaries libraries doc
+all: binaries libraries doc packages
-tcltest: $(TCLTEST)
+tcltest: $(TCLSH) $(TEST_DLL_FILE)
-binaries: @LIBRARIES@ $(TCLSH)
-
-libraries:
-
-doc:
-
-winhelp: $(ROOT_DIR)/tools/man2help.tcl $(MAN2TCL)
- TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \
- ./$(TCLSH) "$(ROOT_DIR_NATIVE)"/tools/man2help.tcl tcl "$(VER)" $(TCL_DOCS)
- hcw /c /e tcl.hpj
+binaries: $(TCL_STUB_LIB_FILE) @LIBRARIES@ winextensions $(TCLSH)
winextensions: ${DDE_DLL_FILE} ${REG_DLL_FILE}
-$(MAN2TCL): $(ROOT_DIR)/tools/man2tcl.c
- $(CC) $(CFLAGS_OPTIMIZE) $(MAN2TCLFLAGS) -o $(MAN2TCL) "$(ROOT_DIR_NATIVE)"/tools/man2tcl.c
+libraries:
-$(TCLSH): $(TCL_LIB_FILE) $(TCL_STUB_LIB_FILE) $(TCLSH_OBJS) tclsh.$(RES)
- $(CC) $(CFLAGS) $(TCLSH_OBJS) $(TCL_LIB_FILE) $(LIBS) \
- tclsh.$(RES) $(CC_EXENAME) $(LDFLAGS_CONSOLE)
- @VC_MANIFEST_EMBED_EXE@
+doc:
-$(TCLTEST): $(TCL_LIB_FILE) $(TCLTEST_OBJS) $(CAT32) tclsh.$(RES)
- $(CC) $(CFLAGS) $(TCLTEST_OBJS) $(TCL_LIB_FILE) $(LIBS) \
+$(TCLSH): $(TCLSH_OBJS) @LIBRARIES@ $(TCL_STUB_LIB_FILE) tclsh.$(RES)
+ $(CC) $(CFLAGS) $(TCLSH_OBJS) $(TCL_LIB_FILE) $(TCL_STUB_LIB_FILE) $(LIBS) \
tclsh.$(RES) $(CC_EXENAME) $(LDFLAGS_CONSOLE)
@VC_MANIFEST_EMBED_EXE@
@@ -429,37 +446,33 @@ ${TCL_STUB_LIB_FILE}: ${STUB_OBJS}
@MAKE_STUB_LIB@ ${STUB_OBJS}
@POST_MAKE_LIB@
-${TCL_DLL_FILE}: ${TCL_OBJS} tcl.$(RES)
- @$(RM) ${TCL_DLL_FILE}
+${TCL_DLL_FILE}: ${TCL_OBJS} tcl.$(RES) @ZLIB_DLL_FILE@
+ @$(RM) ${TCL_DLL_FILE} $(TCL_LIB_FILE)
@MAKE_DLL@ ${TCL_OBJS} tcl.$(RES) $(SHLIB_LD_LIBS)
@VC_MANIFEST_EMBED_DLL@
-${TCL_LIB_FILE}: ${TCL_OBJS}
+${TCL_LIB_FILE}: ${TCL_OBJS} ${DDE_OBJS} ${REG_OBJS}
@$(RM) ${TCL_LIB_FILE}
- @MAKE_LIB@ ${TCL_OBJS}
+ @MAKE_LIB@ ${TCL_OBJS} ${DDE_OBJS} ${REG_OBJS}
@POST_MAKE_LIB@
-${DDE_DLL_FILE}: ${DDE_OBJS} ${TCL_STUB_LIB_FILE}
- @$(RM) ${DDE_DLL_FILE}
+${DDE_DLL_FILE}: ${TCL_STUB_LIB_FILE} ${DDE_OBJS}
@MAKE_DLL@ ${DDE_OBJS} $(TCL_STUB_LIB_FILE) $(SHLIB_LD_LIBS)
-${DDE_LIB_FILE}: ${DDE_OBJS} ${TCL_LIB_FILE}
- @$(RM) ${DDE_LIB_FILE}
- @MAKE_LIB@ ${DDE_OBJS} ${TCL_LIB_FILE}
-
-${REG_DLL_FILE}: ${REG_OBJS} ${TCL_STUB_LIB_FILE}
- @$(RM) ${REG_DLL_FILE}
+${REG_DLL_FILE}: ${TCL_STUB_LIB_FILE} ${REG_OBJS}
@MAKE_DLL@ ${REG_OBJS} $(TCL_STUB_LIB_FILE) $(SHLIB_LD_LIBS)
-${REG_LIB_FILE}: ${REG_OBJS} ${TCL_LIB_FILE}
- @$(RM) ${REG_LIB_FILE}
- @MAKE_LIB@ ${REG_OBJS} ${TCL_LIB_FILE}
-
-# PIPE_DLL_FILE is actually an executable, don't build it like a DLL.
+${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)
-${PIPE_DLL_FILE}: ${PIPE_OBJS}
- @$(RM) ${PIPE_DLL_FILE}
- @MAKE_EXE@ $(CFLAGS) ${PIPE_OBJS} $(LIBS) $(LDFLAGS_CONSOLE)
+# use pre-built zlib1.dll
+${ZLIB_DLL_FILE}: ${TCL_STUB_LIB_FILE}
+ @if test "@ZLIB_LIBS@set" != "${ZLIB_DIR_NATIVE}/win32/zdll.libset" ; then \
+ $(COPY) $(ZLIB_DIR)/win64/${ZLIB_DLL_FILE} ${ZLIB_DLL_FILE}; \
+ else \
+ $(COPY) $(ZLIB_DIR)/win32/${ZLIB_DLL_FILE} ${ZLIB_DLL_FILE}; \
+ fi;
# Add the object extension to the implicit rules. By default .obj is not
# automatically added.
@@ -474,31 +487,13 @@ tclWinInit.${OBJEXT}: tclWinInit.c
$(CC) -c $(CC_SWITCHES) -DBUILD_tcl $(EXTFLAGS) @DEPARG@ $(CC_OBJNAME)
tclWinPipe.${OBJEXT}: tclWinPipe.c
- $(CC) -c $(CC_SWITCHES) -DBUILD_tcl -DTCL_PIPE_DLL=\"$(PIPE_DLL_FILE)\" \
- $(EXTFLAGS) @DEPARG@ $(CC_OBJNAME)
+ $(CC) -c $(CC_SWITCHES) -DBUILD_tcl $(EXTFLAGS) @DEPARG@ $(CC_OBJNAME)
testMain.${OBJEXT}: tclAppInit.c
$(CC) -c $(CC_SWITCHES) -DTCL_TEST @DEPARG@ $(CC_OBJNAME)
-tclTest.${OBJEXT}: tclTest.c
- $(CC) -c $(CC_SWITCHES) @DEPARG@ $(CC_OBJNAME)
-
-tclTestObj.${OBJEXT}: tclTestObj.c
- $(CC) -c $(CC_SWITCHES) @DEPARG@ $(CC_OBJNAME)
-
-tclWinTest.${OBJEXT}: tclWinTest.c
- $(CC) -c $(CC_SWITCHES) @DEPARG@ $(CC_OBJNAME)
-
-tclAppInit.${OBJEXT} : tclAppInit.c
- $(CC) -c $(CC_SWITCHES) @DEPARG@ $(CC_OBJNAME)
-
-# The following objects should be built using the stub interfaces
-
-tclWinReg.${OBJEXT} : tclWinReg.c
- $(CC) -c $(CC_SWITCHES) -DUSE_TCL_STUBS @DEPARG@ $(CC_OBJNAME)
-
-tclWinDde.${OBJEXT} : tclWinDde.c
- $(CC) -c $(CC_SWITCHES) -DUSE_TCL_STUBS @DEPARG@ $(CC_OBJNAME)
+tclMain2.${OBJEXT}: tclMain.c
+ $(CC) -c $(CC_SWITCHES) -DBUILD_tcl -DTCL_ASCII_MAIN @DEPARG@ $(CC_OBJNAME)
# TIP #59, embedding of configuration information into the binary library.
#
@@ -530,6 +525,11 @@ tclPkgConfig.${OBJEXT}: tclPkgConfig.c
tclStubLib.${OBJEXT}: tclStubLib.c
$(CC) -c $(CC_SWITCHES) -DSTATIC_BUILD @DEPARG@ $(CC_OBJNAME)
+tclTomMathStubLib.${OBJEXT}: tclTomMathStubLib.c
+ $(CC) -c $(CC_SWITCHES) -DSTATIC_BUILD @DEPARG@ $(CC_OBJNAME)
+
+tclOOStubLib.${OBJEXT}: tclOOStubLib.c
+ $(CC) -c $(CC_SWITCHES) -DSTATIC_BUILD @DEPARG@ $(CC_OBJNAME)
# Implicit rule for all object files that will end up in the Tcl library
@@ -555,11 +555,11 @@ gendate:
# run (and the results checked) after updating to a new release of libtommath.
gentommath_h:
- $(TCL_EXE) "$(ROOT_DIR_NATIVE)\tools\fix_tommath_h.tcl" \
- "$(TOMMATH_DIR_NATIVE)\tommath.h" \
- > "$(GENERIC_DIR_NATIVE)\tclTomMath.h"
+ $(TCL_EXE) "$(ROOT_DIR_NATIVE)/tools/fix_tommath_h.tcl" \
+ "$(TOMMATH_DIR_NATIVE)/tommath.h" \
+ > "$(GENERIC_DIR_NATIVE)/tclTomMath.h"
-install: all install-binaries install-libraries install-doc
+install: all install-binaries install-libraries install-doc install-packages
install-binaries: binaries
@for i in "$(LIB_INSTALL_DIR)" "$(BIN_INSTALL_DIR)" ; \
@@ -571,7 +571,7 @@ install-binaries: binaries
else true; \
fi; \
done;
- @for i in dde$(DDEDOTVER) reg$(REGDOTVER); \
+ @for i in dde${DDEDOTVER} reg${REGDOTVER}; \
do \
if [ ! -d $(LIB_INSTALL_DIR)/$$i ] ; then \
echo "Making directory $(LIB_INSTALL_DIR)/$$i"; \
@@ -579,14 +579,14 @@ install-binaries: binaries
else true; \
fi; \
done;
- @for i in $(TCL_DLL_FILE) $(TCLSH) $(PIPE_DLL_FILE); \
+ @for i in $(TCL_DLL_FILE) $(ZLIB_DLL_FILE) $(TCLSH); \
do \
if [ -f $$i ]; then \
echo "Installing $$i to $(BIN_INSTALL_DIR)/"; \
$(COPY) $$i "$(BIN_INSTALL_DIR)"; \
fi; \
done
- @for i in tclConfig.sh $(TCL_LIB_FILE) $(TCL_STUB_LIB_FILE); \
+ @for i in tclConfig.sh tclooConfig.sh $(TCL_LIB_FILE) $(TCL_STUB_LIB_FILE); \
do \
if [ -f $$i ]; then \
echo "Installing $$i to $(LIB_INSTALL_DIR)/"; \
@@ -595,27 +595,27 @@ install-binaries: binaries
done
@if [ -f $(DDE_DLL_FILE) ]; then \
echo Installing $(DDE_DLL_FILE); \
- $(COPY) $(DDE_DLL_FILE) $(LIB_INSTALL_DIR)/dde$(DDEDOTVER); \
+ $(COPY) $(DDE_DLL_FILE) $(LIB_INSTALL_DIR)/dde${DDEDOTVER}; \
$(COPY) $(ROOT_DIR)/library/dde/pkgIndex.tcl \
- $(LIB_INSTALL_DIR)/dde$(DDEDOTVER); \
+ $(LIB_INSTALL_DIR)/dde${DDEDOTVER}; \
fi
@if [ -f $(DDE_LIB_FILE) ]; then \
echo Installing $(DDE_LIB_FILE); \
- $(COPY) $(DDE_LIB_FILE) $(LIB_INSTALL_DIR)/dde$(DDEDOTVER); \
+ $(COPY) $(DDE_LIB_FILE) $(LIB_INSTALL_DIR)/dde${DDEDOTVER}; \
fi
@if [ -f $(REG_DLL_FILE) ]; then \
echo Installing $(REG_DLL_FILE); \
- $(COPY) $(REG_DLL_FILE) $(LIB_INSTALL_DIR)/reg$(REGDOTVER); \
+ $(COPY) $(REG_DLL_FILE) $(LIB_INSTALL_DIR)/reg${REGDOTVER}; \
$(COPY) $(ROOT_DIR)/library/reg/pkgIndex.tcl \
- $(LIB_INSTALL_DIR)/reg$(REGDOTVER); \
+ $(LIB_INSTALL_DIR)/reg${REGDOTVER}; \
fi
@if [ -f $(REG_LIB_FILE) ]; then \
echo Installing $(REG_LIB_FILE); \
- $(COPY) $(REG_LIB_FILE) $(LIB_INSTALL_DIR)/reg$(REGDOTVER); \
+ $(COPY) $(REG_LIB_FILE) $(LIB_INSTALL_DIR)/reg${REGDOTVER}; \
fi
install-libraries: libraries install-tzdata install-msgs
- @for i in $(prefix)/lib $(INCLUDE_INSTALL_DIR) \
+ @for i in "$$($(CYGPATH) $(prefix)/lib)" "$(INCLUDE_INSTALL_DIR)" \
$(SCRIPT_INSTALL_DIR); \
do \
if [ ! -d $$i ] ; then \
@@ -624,7 +624,7 @@ install-libraries: libraries install-tzdata install-msgs
else true; \
fi; \
done;
- @for i in http1.0 opt0.4 encoding ../tcl8 ../tcl8/8.4 ../tcl8/8.4/platform ../tcl8/8.5; \
+ @for i in http1.0 opt0.4 encoding ../tcl8 ../tcl8/8.4 ../tcl8/8.4/platform ../tcl8/8.5 ../tcl8/8.6; \
do \
if [ ! -d $(SCRIPT_INSTALL_DIR)/$$i ] ; then \
echo "Making directory $(SCRIPT_INSTALL_DIR)/$$i"; \
@@ -634,6 +634,7 @@ install-libraries: libraries install-tzdata install-msgs
done;
@echo "Installing header files";
@for i in "$(GENERIC_DIR)/tcl.h" "$(GENERIC_DIR)/tclDecls.h" \
+ "$(GENERIC_DIR)/tclOO.h" "$(GENERIC_DIR)/tclOODecls.h" \
"$(GENERIC_DIR)/tclPlatDecls.h" \
"$(GENERIC_DIR)/tclTomMath.h" \
"$(GENERIC_DIR)/tclTomMathDecls.h"; \
@@ -650,17 +651,17 @@ install-libraries: libraries install-tzdata install-msgs
do \
$(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/http1.0"; \
done;
- @echo "Installing package http 2.7.13 as a Tcl Module";
- @$(COPY) $(ROOT_DIR)/library/http/http.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.4/http-2.7.13.tm;
+ @echo "Installing package http 2.8.9 as a Tcl Module";
+ @$(COPY) $(ROOT_DIR)/library/http/http.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.6/http-2.8.9.tm;
@echo "Installing library opt0.4 directory";
@for j in $(ROOT_DIR)/library/opt/*.tcl; \
do \
$(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/opt0.4"; \
done;
- @echo "Installing package msgcat 1.5.2 as a Tcl Module";
- @$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/msgcat-1.5.2.tm;
- @echo "Installing package tcltest 2.3.8 as a Tcl Module";
- @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/tcltest-2.3.8.tm;
+ @echo "Installing package msgcat 1.6.0 as a Tcl Module";
+ @$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/msgcat-1.6.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;
@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";
@@ -672,14 +673,12 @@ install-libraries: libraries install-tzdata install-msgs
install-tzdata:
@echo "Installing time zone data"
- @TCL_LIBRARY="${LIBRARY_DIR}"; export TCL_LIBRARY; \
- ./$(TCLSH) "$(ROOT_DIR)/tools/installData.tcl" \
+ @$(TCL_EXE) "$(ROOT_DIR)/tools/installData.tcl" \
"$(ROOT_DIR)/library/tzdata" "$(SCRIPT_INSTALL_DIR)/tzdata"
install-msgs:
@echo "Installing message catalogs"
- @TCL_LIBRARY="${LIBRARY_DIR}"; export TCL_LIBRARY; \
- ./$(TCLSH) "$(ROOT_DIR)/tools/installData.tcl" \
+ @$(TCL_EXE) "$(ROOT_DIR)/tools/installData.tcl" \
"$(ROOT_DIR)/library/msgs" "$(SCRIPT_INSTALL_DIR)/msgs"
install-doc: doc
@@ -697,6 +696,7 @@ install-private-headers: libraries
@echo "Installing private header files";
@for i in "$(GENERIC_DIR)/tclInt.h" "$(GENERIC_DIR)/tclIntDecls.h" \
"$(GENERIC_DIR)/tclIntPlatDecls.h" "$(GENERIC_DIR)/tclPort.h" \
+ "$(GENERIC_DIR)/tclOOInt.h" "$(GENERIC_DIR)/tclOOIntDecls.h" \
"$(WIN_DIR)/tclWinPort.h" ; \
do \
$(COPY) "$$i" "$(PRIVATE_INCLUDE_INSTALL_DIR)"; \
@@ -706,17 +706,21 @@ install-private-headers: libraries
# tcltest, i.e.:
# % make test TESTFLAGS="-verbose bps -file fileName.test"
-test: binaries $(TCLTEST)
+test: test-tcl test-packages
+
+test-tcl: binaries $(TCLSH) $(CAT32) $(TEST_DLL_FILE)
TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \
- ./$(TCLTEST) "$(ROOT_DIR_NATIVE)/tests/all.tcl" $(TESTFLAGS) \
- -load "package ifneeded dde 1.3.3 [list load [file normalize ${DDE_DLL_FILE}] dde]; \
- package ifneeded registry 1.2.2 [list load [file normalize ${REG_DLL_FILE}] registry]" | ./$(CAT32)
+ ./$(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 dde 1.4.0 [list load [file normalize ${DDE_DLL_FILE}] dde]; \
+ package ifneeded registry 1.3.2 [list load [file normalize ${REG_DLL_FILE}] registry]" | ./$(CAT32)
-# Useful target to launch a built tcltest with the proper path,...
-runtest: binaries $(TCLTEST)
+# Useful target to launch a built tclsh with the proper path,...
+runtest: binaries $(TCLSH) $(TEST_DLL_FILE)
@TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \
- ./$(TCLTEST) $(TESTFLAGS) -load "package ifneeded dde 1.3.3 [list load [file normalize ${DDE_DLL_FILE}] dde]; \
- package ifneeded registry 1.2.2 [list load [file normalize ${REG_DLL_FILE}] registry]" $(SCRIPT)
+ ./$(TCLSH) $(TESTFLAGS) -load "package ifneeded Tcltest ${VERSION}@TCL_PATCH_LEVEL@ [list load [file normalize ${TEST_DLL_FILE}] Tcltest]; \
+ package ifneeded dde 1.4.0 [list load [file normalize ${DDE_DLL_FILE}] dde]; \
+ package ifneeded registry 1.3.2 [list load [file normalize ${REG_DLL_FILE}] registry]" $(SCRIPT)
# This target can be used to run tclsh from the build directory via
# `make shell SCRIPT=foo.tcl`
@@ -738,16 +742,94 @@ Makefile: $(SRC_DIR)/Makefile.in
cleanhelp:
$(RM) *.hlp *.cnt *.GID *.rtf man2tcl.exe
-clean: cleanhelp
+clean: cleanhelp clean-packages
$(RM) *.lib *.a *.exp *.dll *.$(RES) *.${OBJEXT} *~ \#* TAGS a.out
- $(RM) $(TCLSH) $(TCLTEST) $(CAT32)
+ $(RM) $(TCLSH) $(CAT32)
$(RM) *.pch *.ilk *.pdb
-distclean: clean
+distclean: distclean-packages clean
$(RM) Makefile config.status config.cache config.log tclConfig.sh \
tcl.hpj config.status.lineno
#
+# Bundled package targets
+#
+
+PKG_CFG_ARGS = @PKG_CFG_ARGS@
+PKG_DIR = ./pkgs
+
+packages:
+ @builddir=`$(CYGPATH) $$(pwd -P)`; \
+ for i in $(PKGS_DIR)/*; do \
+ if [ -d $$i ] ; then \
+ if [ -x $$i/configure ] ; then \
+ pkg=`basename $$i`; \
+ mkdir -p $(PKG_DIR)/$$pkg; \
+ if [ ! -f $(PKG_DIR)/$$pkg/Makefile ]; then \
+ ( cd $(PKG_DIR)/$$pkg; \
+ echo "Configuring package '$$i' wd = `$(CYGPATH) $$(pwd -P)`"; \
+ $$i/configure --with-tcl=$$builddir --with-tclinclude=$(GENERIC_DIR_NATIVE) $(PKG_CFG_ARGS) --enable-shared --enable-threads; ) \
+ fi ; \
+ echo "Building package '$$pkg'"; \
+ ( cd $(PKG_DIR)/$$pkg; $(MAKE); ) \
+ fi; \
+ fi; \
+ done; \
+ cd $$builddir
+
+install-packages: packages
+ @builddir=`pwd -P`; \
+ for i in $(PKGS_DIR)/*; do \
+ if [ -d $$i ]; then \
+ pkg=`basename $$i`; \
+ if [ -f $(PKG_DIR)/$$pkg/Makefile ]; then \
+ echo "Installing package '$$pkg'"; \
+ ( cd $(PKG_DIR)/$$pkg; $(MAKE) install "DESTDIR=$(INSTALL_ROOT)"; ) \
+ fi; \
+ fi; \
+ done; \
+ cd $$builddir
+
+test-packages: tcltest packages
+ @builddir=`pwd -P`; \
+ for i in $(PKGS_DIR)/*; do \
+ if [ -d $$i ]; then \
+ pkg=`basename $$i`; \
+ if [ -f $(PKG_DIR)/$$pkg/Makefile ]; then \
+ echo "Testing package '$$pkg'"; \
+ ( cd $(PKG_DIR)/$$pkg; $(MAKE) "LD_LIBRARY_PATH=$$builddir:${LD_LIBRARY_PATH}" "TCL_LIBRARY=${TCL_BUILDTIME_LIBRARY}" "TCLLIBPATH=$$builddir/pkgs" test "TCLSH_PROG=$$builddir/${TCLSH}"; ) \
+ fi; \
+ fi; \
+ done; \
+ cd $$builddir
+
+clean-packages:
+ @builddir=`pwd -P`; \
+ for i in $(PKGS_DIR)/*; do \
+ if [ -d $$i ]; then \
+ pkg=`basename $$i`; \
+ if [ -f $(PKG_DIR)/$$pkg/Makefile ]; then \
+ ( cd $(PKG_DIR)/$$pkg; $(MAKE) clean; ) \
+ fi; \
+ fi; \
+ done; \
+ cd $$builddir
+
+distclean-packages:
+ @builddir=`pwd -P`; \
+ for i in $(PKGS_DIR)/*; do \
+ if [ -d $$i ]; then \
+ pkg=`basename $$i`; \
+ if [ -f $(PKG_DIR)/$$pkg/Makefile ]; then \
+ ( cd $(PKG_DIR)/$$pkg; $(MAKE) distclean; ) \
+ fi; \
+ cd $$builddir; \
+ rm -rf $(PKG_DIR)/$$pkg; \
+ fi; \
+ done; \
+ rm -rf $(PKG_DIR)
+
+#
# Regenerate the stubs files.
#
@@ -761,8 +843,29 @@ genstubs:
$(TCL_EXE) "$(ROOT_DIR_NATIVE)/tools/genStubs.tcl" \
"$(GENERIC_DIR_NATIVE)" \
"$(GENERIC_DIR_NATIVE)/tcl.decls" \
- "$(GENERIC_DIR_NATIVE)/tclInt.decls" \
+ "$(GENERIC_DIR_NATIVE)/tclInt.decls" \
"$(GENERIC_DIR_NATIVE)/tclTomMath.decls"
+ $(TCL_EXE) "$(ROOT_DIR_NATIVE)/tools/genStubs.tcl" \
+ "$(GENERIC_DIR_NATIVE)" \
+ "$(GENERIC_DIR_NATIVE)/tclOO.decls"
+
+#
+# This target creates the HTML folder for Tcl & Tk and places it in
+# DISTDIR/html. It uses the tcltk-man2html.tcl tool from the Tcl group's tool
+# workspace. It depends on the Tcl & Tk being in directories called tcl8.* &
+# tk8.* up two directories from the TOOL_DIR.
+#
+
+TOOL_DIR=$(ROOT_DIR)/tools
+HTML_INSTALL_DIR=$(ROOT_DIR)/html
+html:
+ $(MAKE) shell SCRIPT="$(TOOL_DIR)/tcltk-man2html.tcl --htmldir=$(HTML_INSTALL_DIR) --srcdir=$(ROOT_DIR)/.. $(BUILD_HTML_FLAGS)"
+
+html-tcl: $(TCLSH)
+ $(MAKE) shell SCRIPT="$(TOOL_DIR)/tcltk-man2html.tcl --htmldir=$(HTML_INSTALL_DIR) --srcdir=$(ROOT_DIR)/.. $(BUILD_HTML_FLAGS) --tcl"
+
+html-tk: $(TCLSH)
+ $(MAKE) shell SCRIPT="$(TOOL_DIR)/tcltk-man2html.tcl --htmldir=$(HTML_INSTALL_DIR) --srcdir=$(ROOT_DIR)/.. $(BUILD_HTML_FLAGS) --tk"
#
# The list of all the targets that do not correspond to real files. This stops
diff --git a/win/README b/win/README
index 8288e3d..5e060ef 100644
--- a/win/README
+++ b/win/README
@@ -1,4 +1,4 @@
-Tcl 8.5 for Windows
+Tcl 8.6 for Windows
1. Introduction
---------------
@@ -16,7 +16,7 @@ The information in this file is maintained on the web at:
In order to compile Tcl for Windows, you need the following:
- Tcl 8.5 Source Distribution (plus any patches)
+ Tcl 8.6 Source Distribution (plus any patches)
and
@@ -79,9 +79,9 @@ Use the Makefile "install" target to install Tcl. It will install it
according to the prefix options you provided in the correct directory
structure.
-Note that in order to run tclsh85.exe, you must ensure that tcl85.dll is
+Note that in order to run tclsh86.exe, you must ensure that tcl86.dll is
on your path, in the system directory, or in the directory containing
-tclsh85.exe.
+tclsh86.exe.
Note: Tcl no longer provides support for Win32s.
diff --git a/win/buildall.vc.bat b/win/buildall.vc.bat
index 1a0f36d..deb9e39 100644
--- a/win/buildall.vc.bat
+++ b/win/buildall.vc.bat
@@ -59,15 +59,15 @@ if "%INSTALLDIR%" == "" set INSTALLDIR=C:\Program Files\Tcl
:: Build the normal stuff along with the help file.
::
-set OPTS=threads
-if not %SYMBOLS%.==. set OPTS=symbols,threads
-nmake -nologo -f makefile.vc release winhelp OPTS=%OPTS% %1
+set OPTS=none
+if not %SYMBOLS%.==. set OPTS=symbols
+nmake -nologo -f makefile.vc release htmlhelp OPTS=%OPTS% %1
if errorlevel 1 goto error
:: Build the static core and shell.
::
-set OPTS=static,msvcrt,threads
-if not %SYMBOLS%.==. set OPTS=symbols,static,msvcrt,threads
+set OPTS=static,msvcrt
+if not %SYMBOLS%.==. set OPTS=symbols,static,msvcrt
nmake -nologo -f makefile.vc shell OPTS=%OPTS% %1
if errorlevel 1 goto error
diff --git a/win/cat.c b/win/cat.c
index d413923..d49e37c 100644
--- a/win/cat.c
+++ b/win/cat.c
@@ -9,12 +9,19 @@
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
+#ifdef TCL_BROKEN_MAINARGS
+/* On mingw32 and cygwin this doesn't work */
+# undef UNICODE
+# undef _UNICODE
+#endif
+
#include <stdio.h>
#include <io.h>
#include <string.h>
+#include <tchar.h>
int
-main(void)
+_tmain(void)
{
char buf[1024];
int n;
diff --git a/win/configure b/win/configure
index 3fe89bf..e8e4b87 100755
--- a/win/configure
+++ b/win/configure
@@ -309,7 +309,7 @@ ac_includes_default="\
# include <unistd.h>
#endif"
-ac_subst_vars='SHELL PATH_SEPARATOR PACKAGE_NAME PACKAGE_TARNAME PACKAGE_VERSION PACKAGE_STRING PACKAGE_BUGREPORT exec_prefix prefix program_transform_name bindir sbindir libexecdir datadir sysconfdir sharedstatedir localstatedir libdir includedir oldincludedir infodir mandir build_alias host_alias target_alias DEFS ECHO_C ECHO_N ECHO_T LIBS CC CFLAGS LDFLAGS CPPFLAGS ac_ct_CC EXEEXT OBJEXT CPP EGREP AR ac_ct_AR RANLIB ac_ct_RANLIB RC ac_ct_RC SET_MAKE TCL_THREADS CYGPATH CELIB_DIR DL_LIBS CFLAGS_DEBUG CFLAGS_OPTIMIZE CFLAGS_WARNING CFLAGS_DEFAULT LDFLAGS_DEFAULT VC_MANIFEST_EMBED_DLL VC_MANIFEST_EMBED_EXE TCL_WIN_VERSION MACHINE TCL_VERSION TCL_MAJOR_VERSION TCL_MINOR_VERSION TCL_PATCH_LEVEL TCL_LIB_FILE TCL_LIB_FLAG TCL_LIB_SPEC TCL_STUB_LIB_FILE TCL_STUB_LIB_FLAG TCL_STUB_LIB_SPEC TCL_STUB_LIB_PATH TCL_INCLUDE_SPEC TCL_BUILD_STUB_LIB_SPEC TCL_BUILD_STUB_LIB_PATH TCL_DLL_FILE TCL_SRC_DIR TCL_BIN_DIR TCL_DBGX CFG_TCL_SHARED_LIB_SUFFIX CFG_TCL_UNSHARED_LIB_SUFFIX CFG_TCL_EXPORT_FILE_SUFFIX EXTRA_CFLAGS DEPARG CC_OBJNAME CC_EXENAME LDFLAGS_DEBUG LDFLAGS_OPTIMIZE LDFLAGS_CONSOLE LDFLAGS_WINDOW STLIB_LD SHLIB_LD SHLIB_LD_LIBS SHLIB_CFLAGS SHLIB_SUFFIX TCL_SHARED_BUILD LIBS_GUI DLLSUFFIX LIBPREFIX LIBSUFFIX EXESUFFIX LIBRARIES MAKE_LIB MAKE_STUB_LIB POST_MAKE_LIB MAKE_DLL MAKE_EXE TCL_BUILD_LIB_SPEC TCL_LD_SEARCH_FLAGS TCL_NEEDS_EXP_FILE TCL_BUILD_EXP_FILE TCL_EXP_FILE TCL_LIB_VERSIONS_OK TCL_PACKAGE_PATH TCL_DDE_VERSION TCL_DDE_MAJOR_VERSION TCL_DDE_MINOR_VERSION TCL_REG_VERSION TCL_REG_MAJOR_VERSION TCL_REG_MINOR_VERSION RC_OUT RC_TYPE RC_INCLUDE RC_DEFINE RC_DEFINES RES LIBOBJS LTLIBOBJS'
+ac_subst_vars='SHELL PATH_SEPARATOR PACKAGE_NAME PACKAGE_TARNAME PACKAGE_VERSION PACKAGE_STRING PACKAGE_BUGREPORT exec_prefix prefix program_transform_name bindir sbindir libexecdir datadir sysconfdir sharedstatedir localstatedir libdir includedir oldincludedir infodir mandir build_alias host_alias target_alias DEFS ECHO_C ECHO_N ECHO_T LIBS CC CFLAGS LDFLAGS CPPFLAGS ac_ct_CC EXEEXT OBJEXT CPP EGREP AR ac_ct_AR RANLIB ac_ct_RANLIB RC ac_ct_RC SET_MAKE TCL_THREADS CYGPATH CELIB_DIR DL_LIBS CFLAGS_DEBUG CFLAGS_OPTIMIZE CFLAGS_WARNING ZLIB_DLL_FILE ZLIB_LIBS ZLIB_OBJS CFLAGS_DEFAULT LDFLAGS_DEFAULT VC_MANIFEST_EMBED_DLL VC_MANIFEST_EMBED_EXE TCL_WIN_VERSION MACHINE TCL_VERSION TCL_MAJOR_VERSION TCL_MINOR_VERSION TCL_PATCH_LEVEL PKG_CFG_ARGS TCL_EXE TCL_LIB_FILE TCL_LIB_FLAG TCL_STATIC_LIB_FILE TCL_STATIC_LIB_FLAG TCL_IMPORT_LIB_FILE TCL_IMPORT_LIB_FLAG TCL_LIB_SPEC TCL_STUB_LIB_FILE TCL_STUB_LIB_FLAG TCL_STUB_LIB_SPEC TCL_STUB_LIB_PATH TCL_INCLUDE_SPEC TCL_BUILD_STUB_LIB_SPEC TCL_BUILD_STUB_LIB_PATH TCL_DLL_FILE TCL_SRC_DIR TCL_BIN_DIR TCL_DBGX CFG_TCL_SHARED_LIB_SUFFIX CFG_TCL_UNSHARED_LIB_SUFFIX CFG_TCL_EXPORT_FILE_SUFFIX EXTRA_CFLAGS DEPARG CC_OBJNAME CC_EXENAME LDFLAGS_DEBUG LDFLAGS_OPTIMIZE LDFLAGS_CONSOLE LDFLAGS_WINDOW STLIB_LD SHLIB_LD SHLIB_LD_LIBS SHLIB_CFLAGS SHLIB_SUFFIX TCL_SHARED_BUILD LIBS_GUI DLLSUFFIX LIBPREFIX LIBSUFFIX EXESUFFIX LIBRARIES MAKE_LIB MAKE_STUB_LIB POST_MAKE_LIB MAKE_DLL MAKE_EXE TCL_BUILD_LIB_SPEC TCL_LD_SEARCH_FLAGS TCL_NEEDS_EXP_FILE TCL_BUILD_EXP_FILE TCL_EXP_FILE TCL_LIB_VERSIONS_OK TCL_PACKAGE_PATH TCL_DDE_VERSION TCL_DDE_MAJOR_VERSION TCL_DDE_MINOR_VERSION TCL_REG_VERSION TCL_REG_MAJOR_VERSION TCL_REG_MINOR_VERSION RC_OUT RC_TYPE RC_INCLUDE RC_DEFINE RC_DEFINES RES LIBOBJS LTLIBOBJS'
ac_subst_files=''
# Initialize some variables set by options.
@@ -840,7 +840,7 @@ if test -n "$ac_init_help"; then
Optional Features:
--disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no)
--enable-FEATURE[=ARG] include FEATURE [ARG=yes]
- --enable-threads build with threads (default: off)
+ --enable-threads build with threads (default: on)
--enable-shared build and link with shared libraries (default: on)
--enable-64bit enable 64bit support (where applicable)
--enable-wince enable Win/CE support (where applicable)
@@ -1308,22 +1308,29 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu
# /bin/sh. The bash shell seems to suffer from some strange failures.
SHELL=/bin/sh
-TCL_VERSION=8.5
+TCL_VERSION=8.6
TCL_MAJOR_VERSION=8
-TCL_MINOR_VERSION=5
-TCL_PATCH_LEVEL=".19"
+TCL_MINOR_VERSION=6
+TCL_PATCH_LEVEL=".6"
VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION
-TCL_DDE_VERSION=1.3
+TCL_DDE_VERSION=1.4
TCL_DDE_MAJOR_VERSION=1
-TCL_DDE_MINOR_VERSION=3
+TCL_DDE_MINOR_VERSION=4
DDEVER=$TCL_DDE_MAJOR_VERSION$TCL_DDE_MINOR_VERSION
-TCL_REG_VERSION=1.2
+TCL_REG_VERSION=1.3
TCL_REG_MAJOR_VERSION=1
-TCL_REG_MINOR_VERSION=2
+TCL_REG_MINOR_VERSION=3
REGVER=$TCL_REG_MAJOR_VERSION$TCL_REG_MINOR_VERSION
+PKG_CFG_ARGS=$@
+
+#------------------------------------------------------------------------
+# Empty slate for bundled packages, to avoid stale configuration
+#------------------------------------------------------------------------
+rm -Rf pkgs
+
#------------------------------------------------------------------------
# Handle the --prefix=... option
#------------------------------------------------------------------------
@@ -3057,12 +3064,12 @@ if test "${enable_threads+set}" = set; then
enableval="$enable_threads"
tcl_ok=$enableval
else
- tcl_ok=no
+ tcl_ok=yes
fi;
if test "$tcl_ok" = "yes"; then
- echo "$as_me:$LINENO: result: yes" >&5
-echo "${ECHO_T}yes" >&6
+ echo "$as_me:$LINENO: result: yes (default)" >&5
+echo "${ECHO_T}yes (default)" >&6
TCL_THREADS=1
cat >>confdefs.h <<\_ACEOF
#define TCL_THREADS 1
@@ -3076,8 +3083,8 @@ _ACEOF
else
TCL_THREADS=0
- echo "$as_me:$LINENO: result: no (default)" >&5
-echo "${ECHO_T}no (default)" >&6
+ echo "$as_me:$LINENO: result: no" >&5
+echo "${ECHO_T}no" >&6
fi
@@ -3271,6 +3278,11 @@ echo "${ECHO_T}$CELIB_DIR" >&6
# Set some defaults (may get changed below)
EXTRA_CFLAGS=""
+cat >>confdefs.h <<\_ACEOF
+#define MODULE_SCOPE extern
+_ACEOF
+
+
# Extract the first word of "cygpath", so it can be a program name with args.
set dummy cygpath; ac_word=$2
echo "$as_me:$LINENO: checking for $ac_word" >&5
@@ -3328,7 +3340,7 @@ cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h. */
- #ifndef __WIN32__
+ #ifndef _WIN32
#error cross-compiler
#endif
@@ -3451,7 +3463,7 @@ cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h. */
- #ifdef __WIN32__
+ #ifdef _WIN32
#error win32
#endif
@@ -3502,14 +3514,80 @@ echo "${ECHO_T}$ac_cv_win32" >&6
echo "$as_me: error: ${CC} cannot produce win32 executables." >&2;}
{ (exit 1); exit 1; }; }
fi
+
+ hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -mwindows -municode -Dmain=xxmain"
+ echo "$as_me:$LINENO: checking for working -municode linker flag" >&5
+echo $ECHO_N "checking for working -municode linker flag... $ECHO_C" >&6
+if test "${ac_cv_municode+set}" = set; then
+ echo $ECHO_N "(cached) $ECHO_C" >&6
+else
+ cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h. */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h. */
+
+ #include <windows.h>
+ int APIENTRY wWinMain(HINSTANCE a, HINSTANCE b, LPWSTR c, int d) {return 0;}
+
+int
+main ()
+{
+
+ ;
+ return 0;
+}
+_ACEOF
+rm -f conftest.$ac_objext conftest$ac_exeext
+if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
+ (eval $ac_link) 2>conftest.er1
+ ac_status=$?
+ grep -v '^ *+' conftest.er1 >conftest.err
+ rm -f conftest.er1
+ cat conftest.err >&5
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); } &&
+ { ac_try='test -z "$ac_c_werror_flag"
+ || test ! -s conftest.err'
+ { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
+ (eval $ac_try) 2>&5
+ ac_status=$?
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); }; } &&
+ { ac_try='test -s conftest$ac_exeext'
+ { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
+ (eval $ac_try) 2>&5
+ ac_status=$?
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); }; }; then
+ ac_cv_municode=yes
+else
+ echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+ac_cv_municode=no
+fi
+rm -f conftest.err conftest.$ac_objext \
+ conftest$ac_exeext conftest.$ac_ext
+
+fi
+echo "$as_me:$LINENO: result: $ac_cv_municode" >&5
+echo "${ECHO_T}$ac_cv_municode" >&6
+ CFLAGS=$hold_cflags
+ if test "$ac_cv_municode" = "yes" ; then
+ extra_ldflags="$extra_ldflags -municode"
+ else
+ extra_cflags="$extra_cflags -DTCL_BROKEN_MAINARGS"
+ fi
fi
echo "$as_me:$LINENO: checking compiler flags" >&5
echo $ECHO_N "checking compiler flags... $ECHO_C" >&6
if test "${GCC}" = "yes" ; then
SHLIB_LD=""
- SHLIB_LD_LIBS=""
- LIBS="-lws2_32"
+ SHLIB_LD_LIBS='${LIBS}'
+ LIBS="-lnetapi32 -lkernel32 -luser32 -ladvapi32 -luserenv -lws2_32"
# mingw needs to link ole32 and oleaut32 for [send], but MSVC doesn't
LIBS_GUI="-lgdi32 -lcomdlg32 -limm32 -lcomctl32 -lshell32 -luuid -lole32 -loleaut32"
STLIB_LD='${AR} cr'
@@ -3529,9 +3607,6 @@ echo $ECHO_N "checking compiler flags... $ECHO_C" >&6
echo "$as_me:$LINENO: result: using static flags" >&5
echo "${ECHO_T}using static flags" >&6
runtime=
- MAKE_DLL="echo "
- LIBSUFFIX="s\${DBGX}.a"
- LIBFLAGSUFFIX="s\${DBGX}"
LIBRARIES="\${STATIC_LIBRARIES}"
EXESUFFIX="s\${DBGX}.exe"
else
@@ -3549,29 +3624,29 @@ echo "$as_me: error: ${CC} does not support the -shared option.
fi
runtime=
- # Link with gcc since ld does not link to default libs like
- # -luser32 and -lmsvcrt by default.
- SHLIB_LD='${CC} -shared'
- SHLIB_LD_LIBS='${LIBS}'
# Add SHLIB_LD_LIBS to the Make rule, not here.
- MAKE_DLL="\${SHLIB_LD} \$(LDFLAGS) -o \$@ ${extra_ldflags} \
- -Wl,--out-implib,\$(patsubst %.dll,lib%.a,\$@)"
- LIBSUFFIX="\${DBGX}.a"
- LIBFLAGSUFFIX="\${DBGX}"
EXESUFFIX="\${DBGX}.exe"
LIBRARIES="\${SHARED_LIBRARIES}"
fi
+ # Link with gcc since ld does not link to default libs like
+ # -luser32 and -lmsvcrt by default.
+ SHLIB_LD='${CC} -shared'
+ SHLIB_LD_LIBS='${LIBS}'
+ MAKE_DLL="\${SHLIB_LD} \$(LDFLAGS) -o \$@ ${extra_ldflags} \
+ -Wl,--out-implib,\$(patsubst %.dll,lib%.a,\$@)"
# DLLSUFFIX is separate because it is the building block for
# users of tclConfig.sh that may build shared or static.
DLLSUFFIX="\${DBGX}.dll"
+ LIBSUFFIX="\${DBGX}.a"
+ LIBFLAGSUFFIX="\${DBGX}"
SHLIB_SUFFIX=.dll
EXTRA_CFLAGS="${extra_cflags}"
CFLAGS_DEBUG=-g
CFLAGS_OPTIMIZE="-O2 -fomit-frame-pointer"
- CFLAGS_WARNING="-Wall"
+ CFLAGS_WARNING="-Wall -Wdeclaration-after-statement"
LDFLAGS_DEBUG=
LDFLAGS_OPTIMIZE=
@@ -3672,24 +3747,16 @@ echo "${ECHO_T} Using 64-bit $MACHINE mode" >&6
echo "$as_me:$LINENO: result: using static flags" >&5
echo "${ECHO_T}using static flags" >&6
runtime=-MT
- MAKE_DLL="echo "
- LIBSUFFIX="s\${DBGX}.lib"
- LIBFLAGSUFFIX="s\${DBGX}"
LIBRARIES="\${STATIC_LIBRARIES}"
EXESUFFIX="s\${DBGX}.exe"
- SHLIB_LD_LIBS=""
else
# dynamic
echo "$as_me:$LINENO: result: using shared flags" >&5
echo "${ECHO_T}using shared flags" >&6
runtime=-MD
# Add SHLIB_LD_LIBS to the Make rule, not here.
- MAKE_DLL="\${SHLIB_LD} \$(LDFLAGS) -out:\$@"
- LIBSUFFIX="\${DBGX}.lib"
- LIBFLAGSUFFIX="\${DBGX}"
- EXESUFFIX="\${DBGX}.exe"
LIBRARIES="\${SHARED_LIBRARIES}"
- SHLIB_LD_LIBS='${LIBS}'
+ EXESUFFIX="\${DBGX}.exe"
case "x`echo \${VisualStudioVersion}`" in
x1[4-9]*)
lflags="${lflags} -nodefaultlib:libucrt.lib"
@@ -3698,9 +3765,12 @@ echo "${ECHO_T}using shared flags" >&6
;;
esac
fi
+ MAKE_DLL="\${SHLIB_LD} \$(LDFLAGS) -out:\$@"
# DLLSUFFIX is separate because it is the building block for
# users of tclConfig.sh that may build shared or static.
DLLSUFFIX="\${DBGX}.dll"
+ LIBSUFFIX="\${DBGX}.lib"
+ LIBFLAGSUFFIX="\${DBGX}"
# This is a 2-stage check to make sure we have the 64-bit SDK
# We have to know where the SDK is installed.
@@ -3729,7 +3799,7 @@ echo "$as_me: WARNING: Could not find 64-bit $MACHINE SDK" >&2;}
echo "${ECHO_T} Using 64-bit $MACHINE mode" >&6
fi
- LIBS="user32.lib advapi32.lib ws2_32.lib"
+ LIBS="netapi32.lib kernel32.lib user32.lib advapi32.lib userenv.lib ws2_32.lib"
case "x`echo \${VisualStudioVersion}`" in
x1[4-9]*)
@@ -3936,6 +4006,7 @@ _ACEOF
fi
SHLIB_LD="${LINKBIN} -dll -incremental:no ${lflags}"
+ SHLIB_LD_LIBS='${LIBS}'
# link -lib only works when -lib is the first arg
STLIB_LD="${LINKBIN} -lib ${lflags}"
RC_OUT=-fo
@@ -4271,6 +4342,72 @@ _ACEOF
+# Cross-compiling
+case ${host_alias} in
+*mingw32*)
+ TCL_EXE="tclsh"
+ ;;
+*)
+ TCL_EXE="TCL_LIBRARY=\"\${LIBRARY_DIR}\"; export TCL_LIBRARY; ./\${TCLSH}"
+ ;;
+esac
+
+#------------------------------------------------------------------------
+# Add stuff for zlib; note that this is mostly done in the makefile now
+# as we just assume that the platform hasn't got a usable z.lib
+#------------------------------------------------------------------------
+
+if test "${enable_shared+set}" = "set"; then
+
+ enableval="$enable_shared"
+ tcl_ok=$enableval
+
+else
+
+ tcl_ok=yes
+
+fi
+
+if test "$tcl_ok" = "yes"; then
+
+ ZLIB_DLL_FILE=\${ZLIB_DLL_FILE}
+
+ if test "$do64bit" = "yes"; then
+
+ if test "$GCC" == "yes"; then
+
+ ZLIB_LIBS=\${ZLIB_DIR_NATIVE}/win64/libz.dll.a
+
+
+else
+
+ ZLIB_LIBS=\${ZLIB_DIR_NATIVE}/win64/zdll.lib
+
+
+fi
+
+
+else
+
+ ZLIB_LIBS=\${ZLIB_DIR_NATIVE}/win32/zdll.lib
+
+
+fi
+
+
+else
+
+ ZLIB_OBJS=\${ZLIB_OBJS}
+
+
+fi
+
+
+cat >>confdefs.h <<\_ACEOF
+#define HAVE_ZLIB 1
+_ACEOF
+
+
echo "$as_me:$LINENO: checking for intptr_t" >&5
echo $ECHO_N "checking for intptr_t... $ECHO_C" >&6
if test "${ac_cv_type_intptr_t+set}" = set; then
@@ -4542,6 +4679,7 @@ _ACEOF
fi
+
#--------------------------------------------------------------------
# Perform additinal compiler tests.
#--------------------------------------------------------------------
@@ -4619,6 +4757,217 @@ _ACEOF
fi
+# See if the compiler supports intrinsics.
+
+echo "$as_me:$LINENO: checking for intrinsics support in compiler" >&5
+echo $ECHO_N "checking for intrinsics support in compiler... $ECHO_C" >&6
+if test "${tcl_cv_intrinsics+set}" = set; then
+ echo $ECHO_N "(cached) $ECHO_C" >&6
+else
+ cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h. */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h. */
+
+#define WIN32_LEAN_AND_MEAN
+#include <windows.h>
+#undef WIN32_LEAN_AND_MEAN
+#include <intrin.h>
+
+int
+main ()
+{
+
+ __cpuidex(0,0,0);
+
+ ;
+ return 0;
+}
+_ACEOF
+rm -f conftest.$ac_objext conftest$ac_exeext
+if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
+ (eval $ac_link) 2>conftest.er1
+ ac_status=$?
+ grep -v '^ *+' conftest.er1 >conftest.err
+ rm -f conftest.er1
+ cat conftest.err >&5
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); } &&
+ { ac_try='test -z "$ac_c_werror_flag"
+ || test ! -s conftest.err'
+ { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
+ (eval $ac_try) 2>&5
+ ac_status=$?
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); }; } &&
+ { ac_try='test -s conftest$ac_exeext'
+ { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
+ (eval $ac_try) 2>&5
+ ac_status=$?
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); }; }; then
+ tcl_cv_intrinsics=yes
+else
+ echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+tcl_cv_intrinsics=no
+fi
+rm -f conftest.err conftest.$ac_objext \
+ conftest$ac_exeext conftest.$ac_ext
+
+fi
+echo "$as_me:$LINENO: result: $tcl_cv_intrinsics" >&5
+echo "${ECHO_T}$tcl_cv_intrinsics" >&6
+if test "$tcl_cv_intrinsics" = "yes"; then
+
+cat >>confdefs.h <<\_ACEOF
+#define HAVE_INTRIN_H 1
+_ACEOF
+
+fi
+
+# See if the <wspiapi.h> header file is present
+
+echo "$as_me:$LINENO: checking for wspiapi.h" >&5
+echo $ECHO_N "checking for wspiapi.h... $ECHO_C" >&6
+if test "${tcl_cv_wspiapi_h+set}" = set; then
+ echo $ECHO_N "(cached) $ECHO_C" >&6
+else
+ cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h. */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h. */
+
+#include <wspiapi.h>
+
+int
+main ()
+{
+
+ ;
+ return 0;
+}
+_ACEOF
+rm -f conftest.$ac_objext
+if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
+ (eval $ac_compile) 2>conftest.er1
+ ac_status=$?
+ grep -v '^ *+' conftest.er1 >conftest.err
+ rm -f conftest.er1
+ cat conftest.err >&5
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); } &&
+ { ac_try='test -z "$ac_c_werror_flag"
+ || test ! -s conftest.err'
+ { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
+ (eval $ac_try) 2>&5
+ ac_status=$?
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); }; } &&
+ { ac_try='test -s conftest.$ac_objext'
+ { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
+ (eval $ac_try) 2>&5
+ ac_status=$?
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); }; }; then
+ tcl_cv_wspiapi_h=yes
+else
+ echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+tcl_cv_wspiapi_h=no
+fi
+rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+
+fi
+echo "$as_me:$LINENO: result: $tcl_cv_wspiapi_h" >&5
+echo "${ECHO_T}$tcl_cv_wspiapi_h" >&6
+if test "$tcl_cv_wspiapi_h" = "yes"; then
+
+cat >>confdefs.h <<\_ACEOF
+#define HAVE_WSPIAPI_H 1
+_ACEOF
+
+fi
+
+# See if declarations like FINDEX_INFO_LEVELS are
+# missing from winbase.h. This is known to be
+# a problem with VC++ 5.2.
+
+echo "$as_me:$LINENO: checking for FINDEX_INFO_LEVELS in winbase.h" >&5
+echo $ECHO_N "checking for FINDEX_INFO_LEVELS in winbase.h... $ECHO_C" >&6
+if test "${tcl_cv_findex_enums+set}" = set; then
+ echo $ECHO_N "(cached) $ECHO_C" >&6
+else
+ cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h. */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h. */
+
+#define WIN32_LEAN_AND_MEAN
+#include <windows.h>
+#undef WIN32_LEAN_AND_MEAN
+
+int
+main ()
+{
+
+ FINDEX_INFO_LEVELS i;
+ FINDEX_SEARCH_OPS j;
+
+ ;
+ return 0;
+}
+_ACEOF
+rm -f conftest.$ac_objext
+if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
+ (eval $ac_compile) 2>conftest.er1
+ ac_status=$?
+ grep -v '^ *+' conftest.er1 >conftest.err
+ rm -f conftest.er1
+ cat conftest.err >&5
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); } &&
+ { ac_try='test -z "$ac_c_werror_flag"
+ || test ! -s conftest.err'
+ { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
+ (eval $ac_try) 2>&5
+ ac_status=$?
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); }; } &&
+ { ac_try='test -s conftest.$ac_objext'
+ { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
+ (eval $ac_try) 2>&5
+ ac_status=$?
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); }; }; then
+ tcl_cv_findex_enums=yes
+else
+ echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+tcl_cv_findex_enums=no
+fi
+rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+
+fi
+echo "$as_me:$LINENO: result: $tcl_cv_findex_enums" >&5
+echo "${ECHO_T}$tcl_cv_findex_enums" >&6
+if test "$tcl_cv_findex_enums" = "no"; then
+
+cat >>confdefs.h <<\_ACEOF
+#define HAVE_NO_FINDEX_ENUMS 1
+_ACEOF
+
+fi
+
#--------------------------------------------------------------------
# Set the default compiler switches based on the --enable-symbols
# option. This macro depends on C flags, and should be called
@@ -4775,12 +5124,6 @@ eval "TCL_SRC_DIR=\"`cd $srcdir/..; $CYGPATH $(pwd)`\""
eval "TCL_DLL_FILE=tcl${VER}${DLLSUFFIX}"
-eval "TCL_LIB_FILE=${LIBPREFIX}tcl$VER${LIBSUFFIX}"
-
-eval "TCL_LIB_FLAG=\"-ltcl${VER}${LIBFLAGSUFFIX}\""
-eval "TCL_BUILD_LIB_SPEC=\"-L`$CYGPATH $(pwd)` ${TCL_LIB_FLAG}\""
-eval "TCL_LIB_SPEC=\"-L${libdir} ${TCL_LIB_FLAG}\""
-
eval "TCL_STUB_LIB_FILE=\"${LIBPREFIX}tclstub${VER}${LIBSUFFIX}\""
eval "TCL_STUB_LIB_FLAG=\"-ltclstub${VER}${LIBFLAGSUFFIX}\""
eval "TCL_BUILD_STUB_LIB_SPEC=\"-L`$CYGPATH $(pwd)` ${TCL_STUB_LIB_FLAG}\""
@@ -4788,6 +5131,10 @@ eval "TCL_STUB_LIB_SPEC=\"-L${libdir} ${TCL_STUB_LIB_FLAG}\""
eval "TCL_BUILD_STUB_LIB_PATH=\"`$CYGPATH $(pwd)`/${TCL_STUB_LIB_FILE}\""
eval "TCL_STUB_LIB_PATH=\"${libdir}/${TCL_STUB_LIB_FILE}\""
+eval "TCL_LIB_FILE=\"${LIBPREFIX}tcl${VER}${LIBSUFFIX}\""
+eval "TCL_BUILD_LIB_SPEC=\"-L`$CYGPATH $(pwd)` -ltcl${VER}${FLAGSUFFIX}\""
+eval "TCL_LIB_SPEC=\"-L${libdir} -ltcl${VER}${FLAGSUFFIX}\""
+
# Install time header dir can be set via --includedir
eval "TCL_INCLUDE_SPEC=\"-I${includedir}\""
@@ -4853,6 +5200,12 @@ TCL_WIN_VERSION="$TCL_VERSION.$TCL_RELEASE_LEVEL.`echo $TCL_PATCH_LEVEL | tr -d
+
+
+
+
+
+
# empty on win
@@ -5595,6 +5948,9 @@ s,@DL_LIBS@,$DL_LIBS,;t t
s,@CFLAGS_DEBUG@,$CFLAGS_DEBUG,;t t
s,@CFLAGS_OPTIMIZE@,$CFLAGS_OPTIMIZE,;t t
s,@CFLAGS_WARNING@,$CFLAGS_WARNING,;t t
+s,@ZLIB_DLL_FILE@,$ZLIB_DLL_FILE,;t t
+s,@ZLIB_LIBS@,$ZLIB_LIBS,;t t
+s,@ZLIB_OBJS@,$ZLIB_OBJS,;t t
s,@CFLAGS_DEFAULT@,$CFLAGS_DEFAULT,;t t
s,@LDFLAGS_DEFAULT@,$LDFLAGS_DEFAULT,;t t
s,@VC_MANIFEST_EMBED_DLL@,$VC_MANIFEST_EMBED_DLL,;t t
@@ -5605,8 +5961,14 @@ s,@TCL_VERSION@,$TCL_VERSION,;t t
s,@TCL_MAJOR_VERSION@,$TCL_MAJOR_VERSION,;t t
s,@TCL_MINOR_VERSION@,$TCL_MINOR_VERSION,;t t
s,@TCL_PATCH_LEVEL@,$TCL_PATCH_LEVEL,;t t
+s,@PKG_CFG_ARGS@,$PKG_CFG_ARGS,;t t
+s,@TCL_EXE@,$TCL_EXE,;t t
s,@TCL_LIB_FILE@,$TCL_LIB_FILE,;t t
s,@TCL_LIB_FLAG@,$TCL_LIB_FLAG,;t t
+s,@TCL_STATIC_LIB_FILE@,$TCL_STATIC_LIB_FILE,;t t
+s,@TCL_STATIC_LIB_FLAG@,$TCL_STATIC_LIB_FLAG,;t t
+s,@TCL_IMPORT_LIB_FILE@,$TCL_IMPORT_LIB_FILE,;t t
+s,@TCL_IMPORT_LIB_FLAG@,$TCL_IMPORT_LIB_FLAG,;t t
s,@TCL_LIB_SPEC@,$TCL_LIB_SPEC,;t t
s,@TCL_STUB_LIB_FILE@,$TCL_STUB_LIB_FILE,;t t
s,@TCL_STUB_LIB_FLAG@,$TCL_STUB_LIB_FLAG,;t t
diff --git a/win/configure.in b/win/configure.in
index 8931a38..8bb9c48 100644
--- a/win/configure.in
+++ b/win/configure.in
@@ -11,22 +11,29 @@ AC_PREREQ(2.59)
# /bin/sh. The bash shell seems to suffer from some strange failures.
SHELL=/bin/sh
-TCL_VERSION=8.5
+TCL_VERSION=8.6
TCL_MAJOR_VERSION=8
-TCL_MINOR_VERSION=5
-TCL_PATCH_LEVEL=".19"
+TCL_MINOR_VERSION=6
+TCL_PATCH_LEVEL=".6"
VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION
-TCL_DDE_VERSION=1.3
+TCL_DDE_VERSION=1.4
TCL_DDE_MAJOR_VERSION=1
-TCL_DDE_MINOR_VERSION=3
+TCL_DDE_MINOR_VERSION=4
DDEVER=$TCL_DDE_MAJOR_VERSION$TCL_DDE_MINOR_VERSION
-TCL_REG_VERSION=1.2
+TCL_REG_VERSION=1.3
TCL_REG_MAJOR_VERSION=1
-TCL_REG_MINOR_VERSION=2
+TCL_REG_MINOR_VERSION=3
REGVER=$TCL_REG_MAJOR_VERSION$TCL_REG_MINOR_VERSION
+PKG_CFG_ARGS=$@
+
+#------------------------------------------------------------------------
+# Empty slate for bundled packages, to avoid stale configuration
+#------------------------------------------------------------------------
+rm -Rf pkgs
+
#------------------------------------------------------------------------
# Handle the --prefix=... option
#------------------------------------------------------------------------
@@ -98,6 +105,43 @@ SC_ENABLE_SHARED
SC_CONFIG_CFLAGS
+# Cross-compiling
+case ${host_alias} in
+*mingw32*)
+ TCL_EXE="tclsh"
+ ;;
+*)
+ TCL_EXE="TCL_LIBRARY=\"\${LIBRARY_DIR}\"; export TCL_LIBRARY; ./\${TCLSH}"
+ ;;
+esac
+
+#------------------------------------------------------------------------
+# Add stuff for zlib; note that this is mostly done in the makefile now
+# as we just assume that the platform hasn't got a usable z.lib
+#------------------------------------------------------------------------
+
+AS_IF([test "${enable_shared+set}" = "set"], [
+ enableval="$enable_shared"
+ tcl_ok=$enableval
+], [
+ tcl_ok=yes
+])
+AS_IF([test "$tcl_ok" = "yes"], [
+ AC_SUBST(ZLIB_DLL_FILE,[\${ZLIB_DLL_FILE}])
+ AS_IF([test "$do64bit" = "yes"], [
+ AS_IF([test "$GCC" == "yes"],[
+ AC_SUBST(ZLIB_LIBS,[\${ZLIB_DIR_NATIVE}/win64/libz.dll.a])
+ ], [
+ AC_SUBST(ZLIB_LIBS,[\${ZLIB_DIR_NATIVE}/win64/zdll.lib])
+ ])
+ ], [
+ AC_SUBST(ZLIB_LIBS,[\${ZLIB_DIR_NATIVE}/win32/zdll.lib])
+ ])
+], [
+ AC_SUBST(ZLIB_OBJS,[\${ZLIB_OBJS}])
+])
+AC_DEFINE(HAVE_ZLIB, 1, [Is there an installed zlib?])
+
AC_CHECK_TYPE([intptr_t], [
AC_DEFINE([HAVE_INTPTR_T], 1, [Do we have the intptr_t type?])], [
AC_CACHE_CHECK([for pointer-size signed integer type], tcl_cv_intptr_t, [
@@ -129,6 +173,7 @@ AC_CHECK_TYPE([uintptr_t], [
type wide enough to hold a pointer.])
fi
])
+
#--------------------------------------------------------------------
# Perform additinal compiler tests.
#--------------------------------------------------------------------
@@ -156,6 +201,65 @@ if test "$tcl_cv_findex_enums" = "no"; then
[Defined when enums are missing from winbase.h])
fi
+# See if the compiler supports intrinsics.
+
+AC_CACHE_CHECK(for intrinsics support in compiler,
+ tcl_cv_intrinsics,
+AC_TRY_LINK([
+#define WIN32_LEAN_AND_MEAN
+#include <windows.h>
+#undef WIN32_LEAN_AND_MEAN
+#include <intrin.h>
+],
+[
+ __cpuidex(0,0,0);
+],
+ tcl_cv_intrinsics=yes,
+ tcl_cv_intrinsics=no)
+)
+if test "$tcl_cv_intrinsics" = "yes"; then
+ AC_DEFINE(HAVE_INTRIN_H, 1,
+ [Defined when the compilers supports intrinsics])
+fi
+
+# See if the <wspiapi.h> header file is present
+
+AC_CACHE_CHECK(for wspiapi.h,
+ tcl_cv_wspiapi_h,
+AC_TRY_COMPILE([
+#include <wspiapi.h>
+], [],
+ tcl_cv_wspiapi_h=yes,
+ tcl_cv_wspiapi_h=no)
+)
+if test "$tcl_cv_wspiapi_h" = "yes"; then
+ AC_DEFINE(HAVE_WSPIAPI_H, 1,
+ [Defined when wspiapi.h exists])
+fi
+
+# See if declarations like FINDEX_INFO_LEVELS are
+# missing from winbase.h. This is known to be
+# a problem with VC++ 5.2.
+
+AC_CACHE_CHECK(for FINDEX_INFO_LEVELS in winbase.h,
+ tcl_cv_findex_enums,
+AC_TRY_COMPILE([
+#define WIN32_LEAN_AND_MEAN
+#include <windows.h>
+#undef WIN32_LEAN_AND_MEAN
+],
+[
+ FINDEX_INFO_LEVELS i;
+ FINDEX_SEARCH_OPS j;
+],
+ tcl_cv_findex_enums=yes,
+ tcl_cv_findex_enums=no)
+)
+if test "$tcl_cv_findex_enums" = "no"; then
+ AC_DEFINE(HAVE_NO_FINDEX_ENUMS, 1,
+ [Defined when enums are missing from winbase.h])
+fi
+
#--------------------------------------------------------------------
# Set the default compiler switches based on the --enable-symbols
# option. This macro depends on C flags, and should be called
@@ -190,12 +294,6 @@ eval "TCL_SRC_DIR=\"`cd $srcdir/..; $CYGPATH $(pwd)`\""
eval "TCL_DLL_FILE=tcl${VER}${DLLSUFFIX}"
-eval "TCL_LIB_FILE=${LIBPREFIX}tcl$VER${LIBSUFFIX}"
-
-eval "TCL_LIB_FLAG=\"-ltcl${VER}${LIBFLAGSUFFIX}\""
-eval "TCL_BUILD_LIB_SPEC=\"-L`$CYGPATH $(pwd)` ${TCL_LIB_FLAG}\""
-eval "TCL_LIB_SPEC=\"-L${libdir} ${TCL_LIB_FLAG}\""
-
eval "TCL_STUB_LIB_FILE=\"${LIBPREFIX}tclstub${VER}${LIBSUFFIX}\""
eval "TCL_STUB_LIB_FLAG=\"-ltclstub${VER}${LIBFLAGSUFFIX}\""
eval "TCL_BUILD_STUB_LIB_SPEC=\"-L`$CYGPATH $(pwd)` ${TCL_STUB_LIB_FLAG}\""
@@ -203,6 +301,10 @@ eval "TCL_STUB_LIB_SPEC=\"-L${libdir} ${TCL_STUB_LIB_FLAG}\""
eval "TCL_BUILD_STUB_LIB_PATH=\"`$CYGPATH $(pwd)`/${TCL_STUB_LIB_FILE}\""
eval "TCL_STUB_LIB_PATH=\"${libdir}/${TCL_STUB_LIB_FILE}\""
+eval "TCL_LIB_FILE=\"${LIBPREFIX}tcl${VER}${LIBSUFFIX}\""
+eval "TCL_BUILD_LIB_SPEC=\"-L`$CYGPATH $(pwd)` -ltcl${VER}${FLAGSUFFIX}\""
+eval "TCL_LIB_SPEC=\"-L${libdir} -ltcl${VER}${FLAGSUFFIX}\""
+
# Install time header dir can be set via --includedir
eval "TCL_INCLUDE_SPEC=\"-I${includedir}\""
@@ -265,9 +367,15 @@ AC_SUBST(TCL_VERSION)
AC_SUBST(TCL_MAJOR_VERSION)
AC_SUBST(TCL_MINOR_VERSION)
AC_SUBST(TCL_PATCH_LEVEL)
+AC_SUBST(PKG_CFG_ARGS)
+AC_SUBST(TCL_EXE)
AC_SUBST(TCL_LIB_FILE)
AC_SUBST(TCL_LIB_FLAG)
+AC_SUBST(TCL_STATIC_LIB_FILE)
+AC_SUBST(TCL_STATIC_LIB_FLAG)
+AC_SUBST(TCL_IMPORT_LIB_FILE)
+AC_SUBST(TCL_IMPORT_LIB_FLAG)
# empty on win
AC_SUBST(TCL_LIB_SPEC)
AC_SUBST(TCL_STUB_LIB_FILE)
diff --git a/win/makefile.bc b/win/makefile.bc
index 6421682..f5b5acc 100644
--- a/win/makefile.bc
+++ b/win/makefile.bc
@@ -50,7 +50,6 @@
#
# Not yet modified:
# - The 'plug-in-DLL' and the associated shell.
-# - The programs to create the windows help files.
#
# Suggestions and / or improvements are always welcome.
#
@@ -124,14 +123,14 @@ CFG_ENCODING = \"cp1252\"
NAMEPREFIX = tcl
STUBPREFIX = $(NAMEPREFIX)stub
-DOTVERSION = 8.5
-VERSION = 85
+DOTVERSION = 8.6
+VERSION = 86
-DDEVERSION = 13
-DDEDOTVERSION = 1.3
+DDEVERSION = 14
+DDEDOTVERSION = 1.4
-REGVERSION = 12
-REGDOTVERSION = 1.2
+REGVERSION = 13
+REGDOTVERSION = 1.3
BINROOT = ..
!IF "$(NODEBUG)" == "1"
@@ -160,8 +159,6 @@ TCLPLUGINDLLNAME = $(NAMEPREFIX)$(VERSION)p$(DBGX).dll
TCLPLUGINDLL = $(OUTDIR)\$(TCLPLUGINDLLNAME)
TCLSH = $(OUTDIR)\$(NAMEPREFIX)sh$(VERSION)$(DBGX).exe
TCLSHP = $(OUTDIR)\$(NAMEPREFIX)shp$(VERSION)$(DBGX).exe
-TCLPIPEDLLNAME = $(NAMEPREFIX)pip$(VERSION)$(DBGX).dll
-TCLPIPEDLL = $(OUTDIR)\$(TCLPIPEDLLNAME)
TCLREGDLLNAME = $(NAMEPREFIX)reg$(REGVERSION)$(DBGX).dll
TCLREGDLL = $(OUTDIR)\$(TCLREGDLLNAME)
TCLDDEDLLNAME = $(NAMEPREFIX)dde$(DDEVERSION)$(DBGX).dll
@@ -203,12 +200,16 @@ TCLOBJS = \
$(TMPDIR)\tclCmdIL.obj \
$(TMPDIR)\tclCmdMZ.obj \
$(TMPDIR)\tclCompCmds.obj \
+ $(TMPDIR)\tclCompCmdsGR.obj \
+ $(TMPDIR)\tclCompCmdsSZ.obj \
$(TMPDIR)\tclCompExpr.obj \
$(TMPDIR)\tclCompile.obj \
$(TMPDIR)\tclConfig.obj \
$(TMPDIR)\tclDate.obj \
$(TMPDIR)\tclDictObj.obj \
+ $(TMPDIR)\tclDisassemble.obj \
$(TMPDIR)\tclEncoding.obj \
+ $(TMPDIR)\tclEnsemble.obj \
$(TMPDIR)\tclEnv.obj \
$(TMPDIR)\tclEvent.obj \
$(TMPDIR)\tclExecute.obj \
@@ -231,7 +232,15 @@ TCLOBJS = \
$(TMPDIR)\tclMain.obj \
$(TMPDIR)\tclNamesp.obj \
$(TMPDIR)\tclNotify.obj \
+ $(TMPDIR)\tclOO.obj \
+ $(TMPDIR)\tclOOBasic.obj \
+ $(TMPDIR)\tclOOCall.obj \
+ $(TMPDIR)\tclOODefineCmds.obj \
+ $(TMPDIR)\tclOOInfo.obj \
+ $(TMPDIR)\tclOOMethod.obj \
+ $(TMPDIR)\tclOOStubInit.obj \
$(TMPDIR)\tclObj.obj \
+ $(TMPDIR)\tclOptimize.obj \
$(TMPDIR)\tclPanic.obj \
$(TMPDIR)\tclParse.obj \
$(TMPDIR)\tclPipe.obj \
@@ -246,7 +255,6 @@ TCLOBJS = \
$(TMPDIR)\tclScan.obj \
$(TMPDIR)\tclStringObj.obj \
$(TMPDIR)\tclStubInit.obj \
- $(TMPDIR)\tclStubLib.obj \
$(TMPDIR)\tclThread.obj \
$(TMPDIR)\tclThreadJoin.obj \
$(TMPDIR)\tclTimer.obj \
@@ -267,9 +275,13 @@ TCLOBJS = \
$(TMPDIR)\tclWinPipe.obj \
$(TMPDIR)\tclWinSock.obj \
$(TMPDIR)\tclWinThrd.obj \
- $(TMPDIR)\tclWinTime.obj
+ $(TMPDIR)\tclWinTime.obj \
+ $(TMPDIR)\tclZlib.obj
-TCLSTUBOBJS = $(TMPDIR)\tclStubLib.obj
+TCLSTUBOBJS = \
+ $(TMPDIR)\tclStubLib.obj \
+ $(TMPDIR)\tclTomMathStubLib.obj \
+ $(TMPDIR)\tclOOStubLib.obj
WINDIR = $(ROOT)\win
GENERICDIR = $(ROOT)\generic
@@ -278,6 +290,7 @@ TCL_INCLUDES = -I"$(WINDIR)" -I"$(GENERICDIR)"
TCL_DEFINES = $(DEBUGDEFINES) $(THREADDEFINES) $(SYMDEFINES) \
$(PROFDEFINES) $(OPTDEFINES) $(SIXFOURDEFINES) \
-DTCL_CFGVAL_ENCODING=${CFG_ENCODING}
+### TODO: Add -DHAVE_ZLIB=1
######################################################################
# Compiler flags
@@ -330,7 +343,7 @@ LNLIBS = import32 cw32mt
######################################################################
release: setup $(TCLSH) dlls
-dlls: setup $(TCLPIPEDLL) $(TCLREGDLL) $(TCLDDEDLL)
+dlls: setup $(TCLREGDLL) $(TCLDDEDLL)
all: setup $(TCLSH) dlls $(CAT32)
tcltest: setup $(TCLTEST) dlls $(CAT32)
plugin: setup $(TCLPLUGINDLL) $(TCLSHP)
@@ -379,11 +392,6 @@ $(TCLTEST): $(TCLTESTOBJS) $(TCLLIB) $(TMPDIR)\$(NAMEPREFIX)sh.res
$(TCLTESTOBJS), $@, -x, $(LNLIBS) $(TCLLIB),, $(TMPDIR)\$(NAMEPREFIX)sh.res
!
-$(TCLPIPEDLL): $(WINDIR)\stub16.c
- $(cc32) $(CFLAGS) -o$(TMPDIR)\stub16.obj $(WINDIR)\stub16.c
- $(link32) $(ldebug) $(LNFLAGS) $(LNFLAGS_CONS) $(TOOLS32)\lib\c0x32 \
- $(TMPDIR)\stub16.obj, $@, -x, $(LNLIBS),, $(TMPDIR)\$(NAMEPREFIX).res
-
$(TCLDDEDLL): $(TMPDIR)\tclWinDde.obj $(TCLSTUBLIB)
$(link32) $(ldebug) $(LNFLAGS) $(LNFLAGS_DLL) $(TOOLS32)\lib\c0d32 \
$(TMPDIR)\tclWinDde.obj, $@, -x, $(LNLIBS) $(TCLSTUBLIB),, \
@@ -407,10 +415,10 @@ install-binaries: $(TCLSH)
@copy "$(TCLLIB)" "$(LIB_INSTALL_DIR)"
@echo Installing "$(TCLSH)"
@copy "$(TCLSH)" "$(BIN_INSTALL_DIR)"
- @echo Installing $(TCLPIPEDLLNAME)
- @copy "$(TCLPIPEDLL)" "$(BIN_INSTALL_DIR)"
@echo Installing $(TCLSTUBLIBNAME)
@copy "$(TCLSTUBLIB)" "$(LIB_INSTALL_DIR)"
+ @echo Installing $(WINDIR)\tclooConfig.sh
+ @copy "$(WINDIR)\tclooConfig.sh" "$(LIB_INSTALL_DIR)"
install-libraries:
-@$(MKDIR) "$(LIB_INSTALL_DIR)"
@@ -420,10 +428,10 @@ install-libraries:
-@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\http1.0"
-@copy "$(ROOT)\library\http1.0\http.tcl" "$(SCRIPT_INSTALL_DIR)\http1.0"
-@copy "$(ROOT)\library\http1.0\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\http1.0"
- @echo Installing http2.7
- -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\http2.7"
- -@copy "$(ROOT)\library\http\http.tcl" "$(SCRIPT_INSTALL_DIR)\http2.7"
- -@copy "$(ROOT)\library\http\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\http2.7"
+ @echo Installing http2.8
+ -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\http2.8"
+ -@copy "$(ROOT)\library\http\http.tcl" "$(SCRIPT_INSTALL_DIR)\http2.8"
+ -@copy "$(ROOT)\library\http\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\http2.8"
@echo Installing opt0.4
-@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\opt0.4"
-@copy "$(ROOT)\library\opt\optparse.tcl" "$(SCRIPT_INSTALL_DIR)\opt0.4"
@@ -447,7 +455,7 @@ install-libraries:
-@copy "$(ROOT)\library\dde\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\dde1.3"
@echo Installing $(TCLREGDLLNAME)
-@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\reg1.2"
- -@copy "$(TCLREGDLL)" "$(SCRIPT_INSTALL_DIR)\reg1.2"
+ -@copy "$(TCLREGDLL)" "$(SCRIPT_INSTALL_DIR)\reg1.3"
-@copy "$(ROOT)\library\reg\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\reg1.2"
@echo Installing encoding files
-@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\encoding"
@@ -455,6 +463,8 @@ install-libraries:
@echo Installing library files
-@copy "$(GENERICDIR)\tcl.h" "$(INCLUDE_INSTALL_DIR)"
-@copy "$(GENERICDIR)\tclDecls.h" "$(INCLUDE_INSTALL_DIR)"
+ -@copy "$(GENERICDIR)\tclOO.h" "$(INCLUDE_INSTALL_DIR)"
+ -@copy "$(GENERICDIR)\tclOODecls.h" "$(INCLUDE_INSTALL_DIR)"
-@copy "$(GENERICDIR)\tclPlatDecls.h" "$(INCLUDE_INSTALL_DIR)"
-@copy "$(ROOT)\library\history.tcl" "$(SCRIPT_INSTALL_DIR)"
-@copy "$(ROOT)\library\init.tcl" "$(SCRIPT_INSTALL_DIR)"
@@ -474,29 +484,6 @@ genstubs:
$(GENERICDIR)\tcl.decls $(GENERICDIR)\tclInt.decls
#
-# Regenerate the windows help files.
-#
-
-TCLTOOLS = $(ROOT)/tools
-MAN2TCL = $(TCLTOOLS)/man2tcl
-TCLRTF = $(TCLTOOLS)/tcl.rtf
-TCLHPJ = $(TCLTOOLS)/tcl.hpj
-MAN2HELP = $(TCLTOOLS)/man2help.tcl
-HCRTF = $(TOOLS32)/bin/hcrtf.exe
-
-winhelp: $(TCLRTF)
- cd $(TCLTOOLS)
- start /wait $(HCRTF) -xn $(TCLHPJ)
-
-$(MAN2TCL).exe: $(MAN2TCL).obj
- cd $(TCLTOOLS)
- $(cc32) /nologo /G4 /ML /O2 $(MAN2TCL).c
-
-$(TCLRTF): $(MAN2TCL).exe $(TCLSH)
- cd $(TCLTOOLS)
- ..\win\$(TCLSH) $(MAN2HELP) $(NAMEPREFIX) $(VERSION) $(ROOT)/doc ../../tk$(DOTVERSION)/doc
-
-#
# Special case object file targets
#
$(TMPDIR)\tclWinInit.obj: $(WINDIR)\tclWinInit.c
@@ -542,6 +529,12 @@ $(TMPDIR)\tclWinDde.obj : $(WINDIR)\tclWinDde.c
$(TMPDIR)\tclStubLib.obj : $(GENERICDIR)\tclStubLib.c
$(cc32) $(TCL_CFLAGS) -DSTATIC_BUILD -o$(TMPDIR)\$@ $?
+$(TMPDIR)\tclTomMathStubLib.obj : $(GENERICDIR)\tclTomMathStubLib.c
+ $(cc32) $(TCL_CFLAGS) -DSTATIC_BUILD -o$(TMPDIR)\$@ $?
+
+$(TMPDIR)\tclOOStubLib.obj : $(GENERICDIR)\tclOOStubLib.c
+ $(cc32) $(TCL_CFLAGS) -DSTATIC_BUILD -o$(TMPDIR)\$@ $?
+
# Dedependency rules
@@ -595,3 +588,7 @@ clean:
-@$(RM) $(TMPDIR)\*.exe
-@$(RMDIR) $(OUTDIR)
-@$(RMDIR) $(TMPDIR)
+
+# Local Variables:
+# mode: makefile
+# End:
diff --git a/win/makefile.vc b/win/makefile.vc
index 8c8ecdf..f401541 100644
--- a/win/makefile.vc
+++ b/win/makefile.vc
@@ -1,4 +1,4 @@
-#------------------------------------------------------------- -*- makefile -*-
+#-------------------------------------------------------------
# makefile.vc --
#
# Microsoft Visual C++ makefile for use with nmake.exe v1.62+ (VC++ 5.0+)
@@ -43,8 +43,7 @@ the build instructions.
#
# 3) Targets are:
# release -- Builds the core, the shell and the dlls. (default)
-# dlls -- Just builds the windows extensions and the 16-bit DOS
-# pipe/thunk helper app.
+# dlls -- Just builds the windows extensions
# shell -- Just builds the shell and the core.
# core -- Only builds the core [tclXX.(dll|lib)].
# all -- Builds everything.
@@ -62,15 +61,17 @@ the build instructions.
# troff manual pages found in $(ROOT)\doc. You need to
# have installed the HTML Help Compiler package from Microsoft
# to produce the .chm file.
-# winhelp -- Builds the windows .hlp file for Tcl from the troff man
-# files found in $(ROOT)\doc.
+# winhelp -- (deprecated) Builds the windows .hlp file for Tcl from
+# the troff man files found in $(ROOT)\doc. This type of
+# help file is deprecated by Microsoft in favour of html
+# help files (.chm)
#
# 4) Macros usable on the commandline:
# INSTALLDIR=<path>
# Sets where to install Tcl from the built binaries.
# C:\Progra~1\Tcl is assumed when not specified.
#
-# OPTS=loimpact,msvcrt,static,staticpkg,symbols,threads,profile,unchecked,none
+# OPTS=loimpact,msvcrt,nothreads,pdbs,profile,static,staticpkg,symbols,thrdalloc,tclalloc,unchecked,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.
@@ -81,17 +82,24 @@ the build instructions.
# using libcmt(d) as the C runtime [by default] to
# msvcrt(d). This is useful for static embedding
# support.
+# nothreads= Turns off full multithreading support.
+# pdbs = Build detached symbols for release builds.
+# profile = Adds profiling hooks. Map file is assumed.
# 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
+# dll. The static library will contain the dde and reg
+# extensions. External applications who want to use
+# this, need to link with the stub library as well as
+# the static Tcl library.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.
-# threads = Turns on full multithreading support.
-# thrdalloc = Use the thread allocator (shared global free pool).
-# thrdstorage = Use the generic thread storage support.
-# symbols = Adds symbols for step debugging.
-# profile = Adds profiling hooks. Map file is assumed.
-# unchecked = Allows a symbols build to not use the debug
+# symbols = Debug build. Links to the debug C runtime, disables
+# optimizations and creates pdb symbols files.
+# thrdalloc = Use the thread allocator (shared global free pool)
+# This is the default on threaded builds.
+# tclalloc = Use the old non-thread allocator
+# unchecked= Allows a symbols build to not use the debug
# enabled runtime (msvcrt.dll not msvcrtd.dll
# or libcmt.lib not libcmtd.lib).
#
@@ -182,14 +190,14 @@ STUBPREFIX = $(PROJECT)stub
DOTVERSION = $(TCL_MAJOR_VERSION).$(TCL_MINOR_VERSION)
VERSION = $(TCL_MAJOR_VERSION)$(TCL_MINOR_VERSION)
-DDEDOTVERSION = 1.3
+DDEDOTVERSION = 1.4
DDEVERSION = $(DDEDOTVERSION:.=)
-REGDOTVERSION = 1.2
+REGDOTVERSION = 1.3
REGVERSION = $(REGDOTVERSION:.=)
-BINROOT = .
-ROOT = ..
+BINROOT = $(MAKEDIR) # originally .
+ROOT = $(MAKEDIR)\.. # originally ..
TCLIMPLIB = $(OUT_DIR)\$(PROJECT)$(VERSION)$(SUFX).lib
TCLLIBNAME = $(PROJECT)$(VERSION)$(SUFX).$(EXT)
@@ -200,8 +208,6 @@ TCLSTUBLIB = $(OUT_DIR)\$(TCLSTUBLIBNAME)
TCLSHNAME = $(PROJECT)sh$(VERSION)$(SUFX).exe
TCLSH = $(OUT_DIR)\$(TCLSHNAME)
-TCLPIPEDLLNAME = $(PROJECT)pip$(VERSION)$(SUFX:t=).dll
-TCLPIPEDLL = $(OUT_DIR)\$(TCLPIPEDLLNAME)
TCLREGLIBNAME = $(PROJECT)reg$(REGVERSION)$(SUFX:t=).$(EXT)
TCLREGLIB = $(OUT_DIR)\$(TCLREGLIBNAME)
@@ -230,10 +236,12 @@ INCLUDE_INSTALL_DIR = $(_INSTALLDIR)\include
TCLSHOBJS = \
$(TMP_DIR)\tclAppInit.obj \
+!if !$(STATIC_BUILD)
!if $(TCL_USE_STATIC_PACKAGES)
$(TMP_DIR)\tclWinReg.obj \
$(TMP_DIR)\tclWinDde.obj \
!endif
+!endif
$(TMP_DIR)\tclsh.res
TCLTESTOBJS = \
@@ -242,18 +250,21 @@ TCLTESTOBJS = \
$(TMP_DIR)\tclTestProcBodyObj.obj \
$(TMP_DIR)\tclThreadTest.obj \
$(TMP_DIR)\tclWinTest.obj \
+!if !$(STATIC_BUILD)
!if $(TCL_USE_STATIC_PACKAGES)
$(TMP_DIR)\tclWinReg.obj \
$(TMP_DIR)\tclWinDde.obj \
!endif
+!endif
$(TMP_DIR)\testMain.obj
-TCLOBJS = \
+COREOBJS = \
$(TMP_DIR)\regcomp.obj \
$(TMP_DIR)\regerror.obj \
$(TMP_DIR)\regexec.obj \
$(TMP_DIR)\regfree.obj \
$(TMP_DIR)\tclAlloc.obj \
+ $(TMP_DIR)\tclAssembly.obj \
$(TMP_DIR)\tclAsync.obj \
$(TMP_DIR)\tclBasic.obj \
$(TMP_DIR)\tclBinary.obj \
@@ -263,12 +274,16 @@ TCLOBJS = \
$(TMP_DIR)\tclCmdIL.obj \
$(TMP_DIR)\tclCmdMZ.obj \
$(TMP_DIR)\tclCompCmds.obj \
+ $(TMP_DIR)\tclCompCmdsGR.obj \
+ $(TMP_DIR)\tclCompCmdsSZ.obj \
$(TMP_DIR)\tclCompExpr.obj \
$(TMP_DIR)\tclCompile.obj \
$(TMP_DIR)\tclConfig.obj \
$(TMP_DIR)\tclDate.obj \
$(TMP_DIR)\tclDictObj.obj \
+ $(TMP_DIR)\tclDisassemble.obj \
$(TMP_DIR)\tclEncoding.obj \
+ $(TMP_DIR)\tclEnsemble.obj \
$(TMP_DIR)\tclEnv.obj \
$(TMP_DIR)\tclEvent.obj \
$(TMP_DIR)\tclExecute.obj \
@@ -285,14 +300,24 @@ TCLOBJS = \
$(TMP_DIR)\tclIOSock.obj \
$(TMP_DIR)\tclIOUtil.obj \
$(TMP_DIR)\tclIORChan.obj \
+ $(TMP_DIR)\tclIORTrans.obj \
$(TMP_DIR)\tclLink.obj \
$(TMP_DIR)\tclListObj.obj \
$(TMP_DIR)\tclLiteral.obj \
$(TMP_DIR)\tclLoad.obj \
$(TMP_DIR)\tclMain.obj \
+ $(TMP_DIR)\tclMain2.obj \
$(TMP_DIR)\tclNamesp.obj \
$(TMP_DIR)\tclNotify.obj \
+ $(TMP_DIR)\tclOO.obj \
+ $(TMP_DIR)\tclOOBasic.obj \
+ $(TMP_DIR)\tclOOCall.obj \
+ $(TMP_DIR)\tclOODefineCmds.obj \
+ $(TMP_DIR)\tclOOInfo.obj \
+ $(TMP_DIR)\tclOOMethod.obj \
+ $(TMP_DIR)\tclOOStubInit.obj \
$(TMP_DIR)\tclObj.obj \
+ $(TMP_DIR)\tclOptimize.obj \
$(TMP_DIR)\tclPanic.obj \
$(TMP_DIR)\tclParse.obj \
$(TMP_DIR)\tclPathObj.obj \
@@ -309,7 +334,6 @@ TCLOBJS = \
$(TMP_DIR)\tclStringObj.obj \
$(TMP_DIR)\tclStrToD.obj \
$(TMP_DIR)\tclStubInit.obj \
- $(TMP_DIR)\tclStubLib.obj \
$(TMP_DIR)\tclThread.obj \
$(TMP_DIR)\tclThreadAlloc.obj \
$(TMP_DIR)\tclThreadJoin.obj \
@@ -320,20 +344,22 @@ TCLOBJS = \
$(TMP_DIR)\tclUtf.obj \
$(TMP_DIR)\tclUtil.obj \
$(TMP_DIR)\tclVar.obj \
- $(TMP_DIR)\tclWin32Dll.obj \
- $(TMP_DIR)\tclWinChan.obj \
- $(TMP_DIR)\tclWinConsole.obj \
- $(TMP_DIR)\tclWinSerial.obj \
- $(TMP_DIR)\tclWinError.obj \
- $(TMP_DIR)\tclWinFCmd.obj \
- $(TMP_DIR)\tclWinFile.obj \
- $(TMP_DIR)\tclWinInit.obj \
- $(TMP_DIR)\tclWinLoad.obj \
- $(TMP_DIR)\tclWinNotify.obj \
- $(TMP_DIR)\tclWinPipe.obj \
- $(TMP_DIR)\tclWinSock.obj \
- $(TMP_DIR)\tclWinThrd.obj \
- $(TMP_DIR)\tclWinTime.obj \
+ $(TMP_DIR)\tclZlib.obj
+
+ZLIBOBJS = \
+ $(TMP_DIR)\adler32.obj \
+ $(TMP_DIR)\compress.obj \
+ $(TMP_DIR)\crc32.obj \
+ $(TMP_DIR)\deflate.obj \
+ $(TMP_DIR)\infback.obj \
+ $(TMP_DIR)\inffast.obj \
+ $(TMP_DIR)\inflate.obj \
+ $(TMP_DIR)\inftrees.obj \
+ $(TMP_DIR)\trees.obj \
+ $(TMP_DIR)\uncompr.obj \
+ $(TMP_DIR)\zutil.obj
+
+TOMMATHOBJS = \
$(TMP_DIR)\bncore.obj \
$(TMP_DIR)\bn_reverse.obj \
$(TMP_DIR)\bn_fast_s_mp_mul_digs.obj \
@@ -397,13 +423,36 @@ TCLOBJS = \
$(TMP_DIR)\bn_s_mp_add.obj \
$(TMP_DIR)\bn_s_mp_mul_digs.obj \
$(TMP_DIR)\bn_s_mp_sqr.obj \
- $(TMP_DIR)\bn_s_mp_sub.obj \
-!if !$(STATIC_BUILD)
+ $(TMP_DIR)\bn_s_mp_sub.obj
+
+PLATFORMOBJS = \
+ $(TMP_DIR)\tclWin32Dll.obj \
+ $(TMP_DIR)\tclWinChan.obj \
+ $(TMP_DIR)\tclWinConsole.obj \
+ $(TMP_DIR)\tclWinError.obj \
+ $(TMP_DIR)\tclWinFCmd.obj \
+ $(TMP_DIR)\tclWinFile.obj \
+ $(TMP_DIR)\tclWinInit.obj \
+ $(TMP_DIR)\tclWinLoad.obj \
+ $(TMP_DIR)\tclWinNotify.obj \
+ $(TMP_DIR)\tclWinPipe.obj \
+ $(TMP_DIR)\tclWinSerial.obj \
+ $(TMP_DIR)\tclWinSock.obj \
+ $(TMP_DIR)\tclWinThrd.obj \
+ $(TMP_DIR)\tclWinTime.obj \
+!if $(STATIC_BUILD)
+ $(TMP_DIR)\tclWinReg.obj \
+ $(TMP_DIR)\tclWinDde.obj \
+!else
$(TMP_DIR)\tcl.res
!endif
+TCLOBJS = $(COREOBJS) $(ZLIBOBJS) $(TOMMATHOBJS) $(PLATFORMOBJS)
+
TCLSTUBOBJS = \
- $(TMP_DIR)\tclStubLib.obj
+ $(TMP_DIR)\tclStubLib.obj \
+ $(TMP_DIR)\tclTomMathStubLib.obj \
+ $(TMP_DIR)\tclOOStubLib.obj
### The following paths CANNOT have spaces in them.
COMPATDIR = $(ROOT)\compat
@@ -412,6 +461,7 @@ GENERICDIR = $(ROOT)\generic
TOMMATHDIR = $(ROOT)\libtommath
TOOLSDIR = $(ROOT)\tools
WINDIR = $(ROOT)\win
+PKGSDIR = $(ROOT)\pkgs
#---------------------------------------------------------------------
# Compile flags
@@ -453,7 +503,7 @@ crt = -MT
!endif
TCL_INCLUDES = -I"$(WINDIR)" -I"$(GENERICDIR)" -I"$(TOMMATHDIR)"
-TCL_DEFINES = -DTCL_PIPE_DLL=\"$(TCLPIPEDLLNAME)\" -DTCL_TOMMATH -DMP_PREC=4 -Dinline=__inline
+TCL_DEFINES = -DTCL_TOMMATH -DMP_PREC=4 -Dinline=__inline -DHAVE_ZLIB=1
BASE_CFLAGS = $(cflags) $(cdebug) $(crt) $(TCL_INCLUDES) $(TCL_DEFINES)
CON_CFLAGS = $(cflags) $(cdebug) $(crt) -DCONSOLE
TCL_CFLAGS = $(BASE_CFLAGS) $(OPTDEFINES)
@@ -500,7 +550,7 @@ dlllflags = $(lflags) -dll
conlflags = $(lflags) -subsystem:console
guilflags = $(lflags) -subsystem:windows
-baselibs = kernel32.lib user32.lib ws2_32.lib
+baselibs = netapi32.lib kernel32.lib user32.lib advapi32.lib userenv.lib ws2_32.lib
# Avoid 'unresolved external symbol __security_cookie' errors.
# c.f. http://support.microsoft.com/?id=894573
!if "$(MACHINE)" == "IA64" || "$(MACHINE)" == "AMD64"
@@ -525,27 +575,27 @@ TESTFLAGS = $(TESTFLAGS) -file $(TESTPAT)
# Project specific targets
#---------------------------------------------------------------------
-release: setup $(TCLSH) $(TCLSTUBLIB) dlls
+release: setup $(TCLSH) $(TCLSTUBLIB) dlls pkgs
core: setup $(TCLLIB) $(TCLSTUBLIB)
shell: setup $(TCLSH)
-dlls: setup $(TCLPIPEDLL) $(TCLREGLIB) $(TCLDDELIB)
-all: setup $(TCLSH) $(TCLSTUBLIB) dlls $(CAT32)
+dlls: setup $(TCLREGLIB) $(TCLDDELIB)
+all: setup $(TCLSH) $(TCLSTUBLIB) dlls $(CAT32) pkgs
tcltest: setup $(TCLTEST) dlls $(CAT32)
-install: install-binaries install-libraries install-docs
+install: install-binaries install-libraries install-docs install-pkgs
-test: test-core
+test: test-core test-pkgs
test-core: setup $(TCLTEST) dlls $(CAT32)
set TCL_LIBRARY=$(ROOT:\=/)/library
!if "$(OS)" == "Windows_NT" || "$(MSVCDIR)" == "IDE"
$(DEBUGGER) $(TCLTEST) "$(ROOT:\=/)/tests/all.tcl" $(TESTFLAGS) -loadfile <<
- package ifneeded dde 1.3.3 [list load "$(TCLDDELIB:\=/)" dde]
- package ifneeded registry 1.2.2 [list load "$(TCLREGLIB:\=/)" registry]
+ package ifneeded dde 1.4.0 [list load "$(TCLDDELIB:\=/)" dde]
+ package ifneeded registry 1.3.2 [list load "$(TCLREGLIB:\=/)" registry]
<<
!else
@echo Please wait while the tests are collected...
$(TCLTEST) "$(ROOT:\=/)/tests/all.tcl" $(TESTFLAGS) -loadfile << > tests.log
- package ifneeded dde 1.3.3 "$(TCLDDELIB:\=/)" dde]
- package ifneeded registry 1.2.2 "$(TCLREGLIB:\=/)" registry]
+ package ifneeded dde 1.4.0 "$(TCLDDELIB:\=/)" dde]
+ package ifneeded registry 1.3.2 "$(TCLREGLIB:\=/)" registry]
<<
type tests.log | more
!endif
@@ -577,7 +627,6 @@ $**
$**
<<
$(_VC_MANIFEST_EMBED_DLL)
- -@del $*.exp
!endif
$(TCLSTUBLIB): $(TCLSTUBOBJS)
@@ -591,11 +640,6 @@ $(TCLTEST): $(TCLTESTOBJS) $(TCLSTUBLIB) $(TCLIMPLIB)
$(link32) $(conlflags) -stack:2300000 -out:$@ $(baselibs) $**
$(_VC_MANIFEST_EMBED_EXE)
-$(TCLPIPEDLL): $(WINDIR)\stub16.c
- $(cc32) $(CON_CFLAGS) -Fo$(TMP_DIR)\ $(WINDIR)\stub16.c
- $(link32) $(conlflags) -out:$@ $(TMP_DIR)\stub16.obj $(baselibs)
- $(_VC_MANIFEST_EMBED_DLL)
-
!if $(STATIC_BUILD)
$(TCLDDELIB): $(TMP_DIR)\tclWinDde.obj
$(lib32) -nologo $(LINKERFLAGS) -out:$@ $**
@@ -604,8 +648,6 @@ $(TCLDDELIB): $(TMP_DIR)\tclWinDde.obj $(TCLSTUBLIB)
$(link32) $(dlllflags) -base:@$(WINDIR)\coffbase.txt,tcldde -out:$@ \
$** $(baselibs)
$(_VC_MANIFEST_EMBED_DLL)
- -@del $*.exp
- -@del $*.lib
!endif
!if $(STATIC_BUILD)
@@ -616,10 +658,40 @@ $(TCLREGLIB): $(TMP_DIR)\tclWinReg.obj $(TCLSTUBLIB)
$(link32) $(dlllflags) -base:@$(WINDIR)\coffbase.txt,tclreg -out:$@ \
$** $(baselibs)
$(_VC_MANIFEST_EMBED_DLL)
- -@del $*.exp
- -@del $*.lib
!endif
+pkgs:
+ @for /d %d in ($(PKGSDIR)\*) do \
+ @if exist "%~fd\win\makefile.vc" ( \
+ pushd "%~fd\win" & \
+ $(MAKE) -$(MAKEFLAGS) -f makefile.vc TCLDIR=$(ROOT) &\
+ popd \
+ )
+
+test-pkgs:
+ @for /d %d in ($(PKGSDIR)\*) do \
+ @if exist "%~fd\win\makefile.vc" ( \
+ pushd "%~fd\win" & \
+ $(MAKE) -$(MAKEFLAGS) -f makefile.vc TCLDIR=$(ROOT) test &\
+ popd \
+ )
+
+install-pkgs:
+ @for /d %d in ($(PKGSDIR)\*) do \
+ @if exist "%~fd\win\makefile.vc" ( \
+ pushd "%~fd\win" & \
+ $(MAKE) -$(MAKEFLAGS) -f makefile.vc TCLDIR=$(ROOT) install &\
+ popd \
+ )
+
+clean-pkgs:
+ @for /d %d in ($(PKGSDIR)\*) do \
+ @if exist "%~fd\win\makefile.vc" ( \
+ pushd "%~fd\win" & \
+ $(MAKE) -$(MAKEFLAGS) -f makefile.vc TCLDIR=$(ROOT) clean &\
+ popd \
+ )
+
$(CAT32): $(WINDIR)\cat.c
$(cc32) $(CON_CFLAGS) -Fo$(TMP_DIR)\ $?
$(link32) $(conlflags) -out:$@ -stack:16384 $(TMP_DIR)\cat.obj \
@@ -637,6 +709,8 @@ genstubs:
$(TCLSH) $(TOOLSDIR:\=/)/genStubs.tcl $(GENERICDIR:\=/) \
$(GENERICDIR:\=/)/tcl.decls $(GENERICDIR:\=/)/tclInt.decls \
$(GENERICDIR:\=/)/tclTomMath.decls
+ $(TCLSH) $(TOOLSDIR:\=/)/genStubs.tcl $(GENERICDIR:\=/) \
+ $(GENERICDIR:\=/)/tclOO.decls
!endif
@@ -663,7 +737,7 @@ gentommath_h:
!ifndef HHC
HHC=""%ProgramFiles%\HTML Help Workshop\hhc.exe""
!endif
-HTMLDIR=$(ROOT)\html
+HTMLDIR=$(OUT_DIR)\html
HTMLBASE=TclTk$(VERSION)
HHPFILE=$(HTMLDIR)\$(HTMLBASE).hhp
CHMFILE=$(HTMLDIR)\$(HTMLBASE).chm
@@ -671,25 +745,27 @@ CHMFILE=$(HTMLDIR)\$(HTMLBASE).chm
htmlhelp: chmsetup $(CHMFILE)
$(CHMFILE): $(DOCDIR)\*
- @$(TCLSH) $(TOOLSDIR)\tcltk-man2html.tcl
+ @$(TCLSH) $(TOOLSDIR)\tcltk-man2html.tcl "--htmldir=$(HTMLDIR)"
@echo Compiling HTML help project
- @$(HHC) <<$(HHPFILE) >NUL
+ -$(HHC) <<$(HHPFILE) >NUL
[OPTIONS]
Compatibility=1.1 or later
Compiled file=$(HTMLBASE).chm
+Default topic=contents.htm
Display compile progress=no
Error log file=$(HTMLBASE).log
+Full-text search=Yes
Language=0x409 English (United States)
Title=Tcl/Tk $(DOT_VERSION) Help
[FILES]
contents.htm
docs.css
-Keywords
-TclCmd
-TclLib
-TkCmd
-TkLib
-UserCmd
+Keywords\*.htm
+TclCmd\*.htm
+TclLib\*.htm
+TkCmd\*.htm
+TkLib\*.htm
+UserCmd\*.htm
<<
chmsetup:
@@ -852,6 +928,10 @@ $(TMP_DIR)\testMain.obj: $(WINDIR)\tclAppInit.c
-DTCL_USE_STATIC_PACKAGES=$(TCL_USE_STATIC_PACKAGES) \
-Fo$@ $?
+$(TMP_DIR)\tclMain2.obj: $(GENERICDIR)\tclMain.c
+ $(cc32) $(TCL_CFLAGS) -DBUILD_tcl -DTCL_ASCII_MAIN \
+ -Fo$@ $?
+
$(TMP_DIR)\tclTest.obj: $(GENERICDIR)\tclTest.c
$(cc32) $(TCL_CFLAGS) -Fo$@ $?
@@ -861,6 +941,9 @@ $(TMP_DIR)\tclTestObj.obj: $(GENERICDIR)\tclTestObj.c
$(TMP_DIR)\tclWinTest.obj: $(WINDIR)\tclWinTest.c
$(cc32) $(TCL_CFLAGS) -Fo$@ $?
+$(TMP_DIR)\tclZlib.obj: $(GENERICDIR)\tclZlib.c
+ $(cc32) $(TCL_CFLAGS) -I$(COMPATDIR)\zlib -DBUILD_tcl -Fo$@ $?
+
$(TMP_DIR)\tclPkgConfig.obj: $(GENERICDIR)\tclPkgConfig.c
$(cc32) -DBUILD_tcl $(TCL_CFLAGS) \
-DCFG_INSTALL_LIBDIR="\"$(LIB_INSTALL_DIR:\=\\)\"" \
@@ -906,6 +989,12 @@ $(TMP_DIR)\tclWinDde.obj: $(WINDIR)\tclWinDde.c
$(TMP_DIR)\tclStubLib.obj: $(GENERICDIR)\tclStubLib.c
$(cc32) $(STUB_CFLAGS) -Zl -DSTATIC_BUILD $(TCL_INCLUDES) -Fo$@ $?
+$(TMP_DIR)\tclTomMathStubLib.obj: $(GENERICDIR)\tclTomMathStubLib.c
+ $(cc32) $(STUB_CFLAGS) -Zl -DSTATIC_BUILD $(TCL_INCLUDES) -Fo$@ $?
+
+$(TMP_DIR)\tclOOStubLib.obj: $(GENERICDIR)\tclOOStubLib.c
+ $(cc32) $(STUB_CFLAGS) -Zl -DSTATIC_BUILD $(TCL_INCLUDES) -Fo$@ $?
+
$(TMP_DIR)\tclsh.exe.manifest: $(WINDIR)\tclsh.exe.manifest.in
@nmakehlp -s << $** >$@
@MACHINE@ $(MACHINE:IX86=X86)
@@ -947,7 +1036,9 @@ $(TCLOBJS)
#---------------------------------------------------------------------
-# Implicit rules
+# Implicit rules. A limitation exists with nmake that requires that
+# source directory can not contain spaces in the path. This an
+# absolute.
#---------------------------------------------------------------------
{$(WINDIR)}.c{$(TMP_DIR)}.obj::
@@ -970,6 +1061,11 @@ $<
$<
<<
+{$(COMPATDIR)\zlib}.c{$(TMP_DIR)}.obj::
+ $(cc32) $(TCL_CFLAGS) -DBUILD_tcl -Fo$(TMP_DIR)\ @<<
+$<
+<<
+
{$(WINDIR)}.rc{$(TMP_DIR)}.res:
$(rc32) -fo $@ -r -i "$(GENERICDIR)" -i "$(TMP_DIR)" \
-d DEBUG=$(DEBUG) -d UNCHECKED=$(UNCHECKED) \
@@ -998,10 +1094,6 @@ install-binaries:
@echo Installing $(TCLSHNAME)
@$(CPY) "$(TCLSH)" "$(BIN_INSTALL_DIR)\"
!endif
-!if exist($(TCLPIPEDLL))
- @echo Installing $(TCLPIPEDLLNAME)
- @$(CPY) "$(TCLPIPEDLL)" "$(BIN_INSTALL_DIR)\"
-!endif
@echo Installing $(TCLSTUBLIBNAME)
@$(CPY) "$(TCLSTUBLIB)" "$(LIB_INSTALL_DIR)\"
@@ -1018,9 +1110,13 @@ install-libraries: tclConfig install-msgs install-tzdata
$(MKDIR) "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.4\platform"
@if not exist "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.5$(NULL)" \
$(MKDIR) "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.5"
+ @if not exist "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.6$(NULL)" \
+ $(MKDIR) "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.6"
@echo Installing header files
@$(CPY) "$(GENERICDIR)\tcl.h" "$(INCLUDE_INSTALL_DIR)\"
@$(CPY) "$(GENERICDIR)\tclDecls.h" "$(INCLUDE_INSTALL_DIR)\"
+ @$(CPY) "$(GENERICDIR)\tclOO.h" "$(INCLUDE_INSTALL_DIR)\"
+ @$(CPY) "$(GENERICDIR)\tclOODecls.h" "$(INCLUDE_INSTALL_DIR)\"
@$(CPY) "$(GENERICDIR)\tclPlatDecls.h" "$(INCLUDE_INSTALL_DIR)\"
@$(CPY) "$(GENERICDIR)\tclTomMath.h" "$(INCLUDE_INSTALL_DIR)\"
@$(CPY) "$(GENERICDIR)\tclTomMathDecls.h" "$(INCLUDE_INSTALL_DIR)\"
@@ -1038,6 +1134,7 @@ install-libraries: tclConfig 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)\"
@echo Installing library http1.0 directory
@$(CPY) "$(ROOT)\library\http1.0\*.tcl" \
"$(SCRIPT_INSTALL_DIR)\http1.0\"
@@ -1046,7 +1143,7 @@ install-libraries: tclConfig install-msgs install-tzdata
"$(SCRIPT_INSTALL_DIR)\opt0.4\"
@echo Installing package http $(PKG_HTTP_VER) as a Tcl Module
@$(COPY) "$(ROOT)\library\http\http.tcl" \
- "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.4\http-$(PKG_HTTP_VER).tm"
+ "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.6\http-$(PKG_HTTP_VER).tm"
@echo Installing package msgcat $(PKG_MSGCAT_VER) as a Tcl Module
@$(COPY) "$(ROOT)\library\msgcat\msgcat.tcl" \
"$(SCRIPT_INSTALL_DIR)\..\tcl8\8.5\msgcat-$(PKG_MSGCAT_VER).tm"
@@ -1117,7 +1214,7 @@ tidy:
@echo Removing $(TCLREGLIB) ...
@if exist $(TCLREGLIB) del $(TCLREGLIB)
-clean:
+clean: clean-pkgs
@echo Cleaning $(TMP_DIR)\* ...
@if exist $(TMP_DIR)\nul $(RMDIR) $(TMP_DIR)
@echo Cleaning $(WINDIR)\nmakehlp.obj ...
@@ -1138,3 +1235,7 @@ realclean: hose
hose:
@echo Hosing $(OUT_DIR)\* ...
@if exist $(OUT_DIR)\nul $(RMDIR) $(OUT_DIR)
+
+# Local Variables:
+# mode: makefile
+# End:
diff --git a/win/rules.vc b/win/rules.vc
index aa4ed1e..e12854d 100644
--- a/win/rules.vc
+++ b/win/rules.vc
@@ -159,7 +159,7 @@ DEBUGFLAGS = $(DEBUGFLAGS) -RTC1
DEBUGFLAGS = $(DEBUGFLAGS) -GZ
!endif
-COMPILERFLAGS =-W3 /D_ATL_XP_TARGETING
+COMPILERFLAGS =-W3 /DUNICODE /D_UNICODE /D_ATL_XP_TARGETING
# In v13 -GL and -YX are incompatible.
!if [nmakehlp -c -YX]
@@ -213,7 +213,7 @@ LINKERFLAGS =-ltcg
!if "$(OPTS)" == "" || [nmakehlp -f "$(OPTS)" "none"]
STATIC_BUILD = 0
-TCL_THREADS = 0
+TCL_THREADS = 1
DEBUG = 0
SYMBOLS = 0
PROFILE = 0
@@ -221,7 +221,7 @@ PGO = 0
MSVCRT = 1
LOIMPACT = 0
TCL_USE_STATIC_PACKAGES = 0
-USE_THREAD_ALLOC = 0
+USE_THREAD_ALLOC = 1
UNCHECKED = 0
!else
!if [nmakehlp -f $(OPTS) "static"]
@@ -230,6 +230,10 @@ STATIC_BUILD = 1
!else
STATIC_BUILD = 0
!endif
+!if [nmakehlp -f $(OPTS) "nomsvcrt"]
+!message *** Doing nomsvcrt
+MSVCRT = 0
+!else
!if [nmakehlp -f $(OPTS) "msvcrt"]
!message *** Doing msvcrt
MSVCRT = 1
@@ -240,19 +244,20 @@ MSVCRT = 1
MSVCRT = 0
!endif
!endif
+!endif
!if [nmakehlp -f $(OPTS) "staticpkg"] && $(STATIC_BUILD)
!message *** Doing staticpkg
TCL_USE_STATIC_PACKAGES = 1
!else
TCL_USE_STATIC_PACKAGES = 0
!endif
-!if [nmakehlp -f $(OPTS) "threads"]
-!message *** Doing threads
-TCL_THREADS = 1
-USE_THREAD_ALLOC = 1
-!else
+!if [nmakehlp -f $(OPTS) "nothreads"]
+!message *** Compile explicitly for non-threaded tcl
TCL_THREADS = 0
-USE_THREAD_ALLOC = 0
+USE_THREAD_ALLOC= 0
+!else
+TCL_THREADS = 1
+USE_THREAD_ALLOC= 1
!endif
!if [nmakehlp -f $(OPTS) "symbols"]
!message *** Doing symbols
@@ -585,8 +590,8 @@ TCLSH = "$(_TCLDIR)\bin\tclsh$(TCL_VERSION)t$(SUFX).exe"
TCLSTUBLIB = "$(_TCLDIR)\lib\tclstub$(TCL_VERSION).lib"
TCLIMPLIB = "$(_TCLDIR)\lib\tcl$(TCL_VERSION)$(SUFX).lib"
TCL_LIBRARY = $(_TCLDIR)\lib
-TCLREGLIB = "$(_TCLDIR)\lib\tclreg12$(SUFX:t=).lib"
-TCLDDELIB = "$(_TCLDIR)\lib\tcldde13$(SUFX:t=).lib"
+TCLREGLIB = "$(_TCLDIR)\lib\tclreg13$(SUFX:t=).lib"
+TCLDDELIB = "$(_TCLDIR)\lib\tcldde14$(SUFX:t=).lib"
COFFBASE = \must\have\tcl\sources\to\build\this\target
TCLTOOLSDIR = \must\have\tcl\sources\to\build\this\target
TCL_INCLUDES = -I"$(_TCLDIR)\include"
@@ -598,8 +603,8 @@ TCLSH = "$(_TCLDIR)\win\$(BUILDDIRTOP)\tclsh$(TCL_VERSION)t$(SUFX).exe"
TCLSTUBLIB = "$(_TCLDIR)\win\$(BUILDDIRTOP)\tclstub$(TCL_VERSION).lib"
TCLIMPLIB = "$(_TCLDIR)\win\$(BUILDDIRTOP)\tcl$(TCL_VERSION)$(SUFX).lib"
TCL_LIBRARY = $(_TCLDIR)\library
-TCLREGLIB = "$(_TCLDIR)\win\$(BUILDDIRTOP)\tclreg12$(SUFX:t=).lib"
-TCLDDELIB = "$(_TCLDIR)\win\$(BUILDDIRTOP)\tcldde13$(SUFX:t=).lib"
+TCLREGLIB = "$(_TCLDIR)\win\$(BUILDDIRTOP)\tclreg13$(SUFX:t=).lib"
+TCLDDELIB = "$(_TCLDIR)\win\$(BUILDDIRTOP)\tcldde14$(SUFX:t=).lib"
COFFBASE = "$(_TCLDIR)\win\coffbase.txt"
TCLTOOLSDIR = $(_TCLDIR)\tools
TCL_INCLUDES = -I"$(_TCLDIR)\generic" -I"$(_TCLDIR)\win"
diff --git a/win/stub16.c b/win/stub16.c
deleted file mode 100644
index 70fc051..0000000
--- a/win/stub16.c
+++ /dev/null
@@ -1,195 +0,0 @@
-/*
- * stub16.c
- *
- * A helper program used for running 16-bit DOS applications under
- * Windows 95.
- *
- * Copyright (c) 1996 by Sun Microsystems, Inc.
- *
- * See the file "license.terms" for information on usage and redistribution of
- * this file, and for a DISCLAIMER OF ALL WARRANTIES.
- */
-
-#define STRICT
-
-#include <windows.h>
-#include <stdio.h>
-
-static HANDLE CreateTempFile(void);
-
-/*
- *---------------------------------------------------------------------------
- *
- * main
- *
- * Entry point for the 32-bit console mode app used by Windows 95 to help
- * run the 16-bit program specified on the command line.
- *
- * 1. EOF on a pipe that connects a detached 16-bit process and a 32-bit
- * process is never seen. So, this process runs the 16-bit process
- * _attached_, and then it is run detached from the calling 32-bit
- * process.
- *
- * 2. If a 16-bit process blocks reading from or writing to a pipe, it
- * never wakes up, and eventually brings the whole system down with it if
- * you try to kill the process. This app simulates pipes. If any of the
- * stdio handles is a pipe, this program accumulates information into
- * temp files and forwards it to or from the DOS application as
- * appropriate. This means that this program must receive EOF from a
- * stdin pipe before it will actually start the DOS app, and the DOS app
- * must finish generating stdout or stderr before the data will be sent
- * to the next stage of the pipe. If the stdio handles are not pipes, no
- * accumulation occurs and the data is passed straight through to and
- * from the DOS application.
- *
- * Results:
- * None.
- *
- * Side effects:
- * The child process is created and this process waits for it to
- * complete.
- *
- *---------------------------------------------------------------------------
- */
-
-int
-main(void)
-{
- DWORD dwRead, dwWrite;
- char *cmdLine;
- HANDLE hStdInput, hStdOutput, hStdError;
- HANDLE hFileInput, hFileOutput, hFileError;
- STARTUPINFO si;
- PROCESS_INFORMATION pi;
- char buf[8192];
- DWORD result;
-
- hFileInput = INVALID_HANDLE_VALUE;
- hFileOutput = INVALID_HANDLE_VALUE;
- hFileError = INVALID_HANDLE_VALUE;
- result = 1;
-
- /*
- * Don't get command line from argc, argv, because the command line
- * tokenizer will have stripped off all the escape sequences needed for
- * quotes and backslashes, and then we'd have to put them all back in
- * again. Get the raw command line and parse off what we want ourselves.
- * The command line should be of the form:
- *
- * stub16.exe program arg1 arg2 ...
- */
-
- cmdLine = strchr(GetCommandLine(), ' ');
- if (cmdLine == NULL) {
- return 1;
- }
- cmdLine++;
-
- hStdInput = GetStdHandle(STD_INPUT_HANDLE);
- hStdOutput = GetStdHandle(STD_OUTPUT_HANDLE);
- hStdError = GetStdHandle(STD_ERROR_HANDLE);
-
- if (GetFileType(hStdInput) == FILE_TYPE_PIPE) {
- hFileInput = CreateTempFile();
- if (hFileInput == INVALID_HANDLE_VALUE) {
- goto cleanup;
- }
- while (ReadFile(hStdInput, buf, sizeof(buf), &dwRead, NULL) != FALSE) {
- if (dwRead == 0) {
- break;
- }
- if (WriteFile(hFileInput, buf, dwRead, &dwWrite, NULL) == FALSE) {
- goto cleanup;
- }
- }
- SetFilePointer(hFileInput, 0, 0, FILE_BEGIN);
- SetStdHandle(STD_INPUT_HANDLE, hFileInput);
- }
- if (GetFileType(hStdOutput) == FILE_TYPE_PIPE) {
- hFileOutput = CreateTempFile();
- if (hFileOutput == INVALID_HANDLE_VALUE) {
- goto cleanup;
- }
- SetStdHandle(STD_OUTPUT_HANDLE, hFileOutput);
- }
- if (GetFileType(hStdError) == FILE_TYPE_PIPE) {
- hFileError = CreateTempFile();
- if (hFileError == INVALID_HANDLE_VALUE) {
- goto cleanup;
- }
- SetStdHandle(STD_ERROR_HANDLE, hFileError);
- }
-
- ZeroMemory(&si, sizeof(si));
- si.cb = sizeof(si);
- if (CreateProcess(NULL, cmdLine, NULL, NULL, TRUE, 0, NULL, NULL, &si,
- &pi) == FALSE) {
- goto cleanup;
- }
-
- WaitForInputIdle(pi.hProcess, 5000);
- WaitForSingleObject(pi.hProcess, INFINITE);
- GetExitCodeProcess(pi.hProcess, &result);
- CloseHandle(pi.hProcess);
- CloseHandle(pi.hThread);
-
- if (hFileOutput != INVALID_HANDLE_VALUE) {
- SetFilePointer(hFileOutput, 0, 0, FILE_BEGIN);
- while (ReadFile(hFileOutput, buf, sizeof(buf), &dwRead, NULL) != FALSE) {
- if (dwRead == 0) {
- break;
- }
- if (WriteFile(hStdOutput, buf, dwRead, &dwWrite, NULL) == FALSE) {
- break;
- }
- }
- }
- if (hFileError != INVALID_HANDLE_VALUE) {
- SetFilePointer(hFileError, 0, 0, FILE_BEGIN);
- while (ReadFile(hFileError, buf, sizeof(buf), &dwRead, NULL) != FALSE) {
- if (dwRead == 0) {
- break;
- }
- if (WriteFile(hStdError, buf, dwRead, &dwWrite, NULL) == FALSE) {
- break;
- }
- }
- }
-
- cleanup:
- if (hFileInput != INVALID_HANDLE_VALUE) {
- CloseHandle(hFileInput);
- }
- if (hFileOutput != INVALID_HANDLE_VALUE) {
- CloseHandle(hFileOutput);
- }
- if (hFileError != INVALID_HANDLE_VALUE) {
- CloseHandle(hFileError);
- }
- CloseHandle(hStdInput);
- CloseHandle(hStdOutput);
- CloseHandle(hStdError);
- ExitProcess(result);
- return 1;
-}
-
-static HANDLE
-CreateTempFile(void)
-{
- char name[MAX_PATH];
- SECURITY_ATTRIBUTES sa;
-
- if (GetTempPath(sizeof(name), name) == 0) {
- return INVALID_HANDLE_VALUE;
- }
- if (GetTempFileName(name, "tcl", 0, name) == 0) {
- return INVALID_HANDLE_VALUE;
- }
-
- sa.nLength = sizeof(sa);
- sa.lpSecurityDescriptor = NULL;
- sa.bInheritHandle = TRUE;
- return CreateFile(name, GENERIC_READ | GENERIC_WRITE, 0, &sa,
- CREATE_ALWAYS, FILE_ATTRIBUTE_TEMPORARY | FILE_FLAG_DELETE_ON_CLOSE,
- NULL);
-}
diff --git a/win/tcl.dsp b/win/tcl.dsp
index 68920ad..96d5893 100644
--- a/win/tcl.dsp
+++ b/win/tcl.dsp
@@ -1300,6 +1300,14 @@ SOURCE=..\generic\tclStubLib.c
# End Source File
# Begin Source File
+SOURCE=..\generic\tclOOStubLib.c
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\tclTomMathStubLib.c
+# End Source File
+# Begin Source File
+
SOURCE=..\generic\tclTest.c
# End Source File
# Begin Source File
@@ -1452,10 +1460,6 @@ SOURCE=.\rules.vc
# End Source File
# Begin Source File
-SOURCE=.\stub16.c
-# End Source File
-# Begin Source File
-
SOURCE=.\tcl.hpj.in
# End Source File
# Begin Source File
@@ -1556,10 +1560,6 @@ SOURCE=.\tclWinThrd.c
# End Source File
# Begin Source File
-SOURCE=.\tclWinThrd.h
-# End Source File
-# Begin Source File
-
SOURCE=.\tclWinTime.c
# End Source File
# End Group
diff --git a/win/tcl.hpj.in b/win/tcl.hpj.in
index 8efff0b..a94cea6 100644
--- a/win/tcl.hpj.in
+++ b/win/tcl.hpj.in
@@ -5,9 +5,9 @@ HCW=0
LCID=0x409 0x0 0x0 ;English (United States)
REPORT=Yes
TITLE=Tcl/Tk Reference Manual
-CNT=tcl85.cnt
+CNT=tcl86.cnt
COPYRIGHT=Copyright © 2000 Ajuba Solutions
-HLP=tcl85.hlp
+HLP=tcl86.hlp
[FILES]
tcl.rtf
diff --git a/win/tcl.m4 b/win/tcl.m4
index 006778c..84f0dff 100644
--- a/win/tcl.m4
+++ b/win/tcl.m4
@@ -247,7 +247,7 @@ AC_DEFUN([SC_PATH_TKCONFIG], [
#
# Results:
#
-# Subst the following vars:
+# Substitutes the following vars:
# TCL_BIN_DIR
# TCL_SRC_DIR
# TCL_LIB_FILE
@@ -401,11 +401,11 @@ AC_DEFUN([SC_ENABLE_SHARED], [
AC_DEFUN([SC_ENABLE_THREADS], [
AC_MSG_CHECKING(for building with threads)
- AC_ARG_ENABLE(threads, [ --enable-threads build with threads (default: off)],
- [tcl_ok=$enableval], [tcl_ok=no])
+ AC_ARG_ENABLE(threads, [ --enable-threads build with threads (default: on)],
+ [tcl_ok=$enableval], [tcl_ok=yes])
if test "$tcl_ok" = "yes"; then
- AC_MSG_RESULT(yes)
+ AC_MSG_RESULT([yes (default)])
TCL_THREADS=1
AC_DEFINE(TCL_THREADS)
# USE_THREAD_ALLOC tells us to try the special thread-based
@@ -413,7 +413,7 @@ AC_DEFUN([SC_ENABLE_THREADS], [
AC_DEFINE(USE_THREAD_ALLOC)
else
TCL_THREADS=0
- AC_MSG_RESULT([no (default)])
+ AC_MSG_RESULT(no)
fi
AC_SUBST(TCL_THREADS)
])
@@ -557,6 +557,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [
# Set some defaults (may get changed below)
EXTRA_CFLAGS=""
+ AC_DEFINE(MODULE_SCOPE, [extern], [No need to mark inidividual symbols as hidden])
AC_CHECK_PROG(CYGPATH, cygpath, cygpath -m, echo)
@@ -571,7 +572,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [
AC_CACHE_CHECK(for cross-compile version of gcc,
ac_cv_cross,
AC_TRY_COMPILE([
- #ifndef __WIN32__
+ #ifndef _WIN32
#error cross-compiler
#endif
], [],
@@ -638,7 +639,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [
AC_CACHE_CHECK(for mingw32 version of gcc,
ac_cv_win32,
AC_TRY_COMPILE([
- #ifdef __WIN32__
+ #ifdef _WIN32
#error win32
#endif
], [],
@@ -648,13 +649,31 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [
if test "$ac_cv_win32" != "yes"; then
AC_MSG_ERROR([${CC} cannot produce win32 executables.])
fi
+
+ hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -mwindows -municode -Dmain=xxmain"
+ AC_CACHE_CHECK(for working -municode linker flag,
+ ac_cv_municode,
+ AC_TRY_LINK([
+ #include <windows.h>
+ int APIENTRY wWinMain(HINSTANCE a, HINSTANCE b, LPWSTR c, int d) {return 0;}
+ ],
+ [],
+ ac_cv_municode=yes,
+ ac_cv_municode=no)
+ )
+ CFLAGS=$hold_cflags
+ if test "$ac_cv_municode" = "yes" ; then
+ extra_ldflags="$extra_ldflags -municode"
+ else
+ extra_cflags="$extra_cflags -DTCL_BROKEN_MAINARGS"
+ fi
fi
AC_MSG_CHECKING([compiler flags])
if test "${GCC}" = "yes" ; then
SHLIB_LD=""
- SHLIB_LD_LIBS=""
- LIBS="-lws2_32"
+ SHLIB_LD_LIBS='${LIBS}'
+ LIBS="-lnetapi32 -lkernel32 -luser32 -ladvapi32 -luserenv -lws2_32"
# mingw needs to link ole32 and oleaut32 for [send], but MSVC doesn't
LIBS_GUI="-lgdi32 -lcomdlg32 -limm32 -lcomctl32 -lshell32 -luuid -lole32 -loleaut32"
STLIB_LD='${AR} cr'
@@ -673,9 +692,6 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [
# static
AC_MSG_RESULT([using static flags])
runtime=
- MAKE_DLL="echo "
- LIBSUFFIX="s\${DBGX}.a"
- LIBFLAGSUFFIX="s\${DBGX}"
LIBRARIES="\${STATIC_LIBRARIES}"
EXESUFFIX="s\${DBGX}.exe"
else
@@ -689,29 +705,29 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [
fi
runtime=
- # Link with gcc since ld does not link to default libs like
- # -luser32 and -lmsvcrt by default.
- SHLIB_LD='${CC} -shared'
- SHLIB_LD_LIBS='${LIBS}'
# Add SHLIB_LD_LIBS to the Make rule, not here.
- MAKE_DLL="\${SHLIB_LD} \$(LDFLAGS) -o \[$]@ ${extra_ldflags} \
- -Wl,--out-implib,\$(patsubst %.dll,lib%.a,\[$]@)"
- LIBSUFFIX="\${DBGX}.a"
- LIBFLAGSUFFIX="\${DBGX}"
EXESUFFIX="\${DBGX}.exe"
LIBRARIES="\${SHARED_LIBRARIES}"
fi
+ # Link with gcc since ld does not link to default libs like
+ # -luser32 and -lmsvcrt by default.
+ SHLIB_LD='${CC} -shared'
+ SHLIB_LD_LIBS='${LIBS}'
+ MAKE_DLL="\${SHLIB_LD} \$(LDFLAGS) -o \[$]@ ${extra_ldflags} \
+ -Wl,--out-implib,\$(patsubst %.dll,lib%.a,\[$]@)"
# DLLSUFFIX is separate because it is the building block for
# users of tclConfig.sh that may build shared or static.
DLLSUFFIX="\${DBGX}.dll"
+ LIBSUFFIX="\${DBGX}.a"
+ LIBFLAGSUFFIX="\${DBGX}"
SHLIB_SUFFIX=.dll
EXTRA_CFLAGS="${extra_cflags}"
CFLAGS_DEBUG=-g
CFLAGS_OPTIMIZE="-O2 -fomit-frame-pointer"
- CFLAGS_WARNING="-Wall"
+ CFLAGS_WARNING="-Wall -Wdeclaration-after-statement"
LDFLAGS_DEBUG=
LDFLAGS_OPTIMIZE=
@@ -766,23 +782,15 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [
# static
AC_MSG_RESULT([using static flags])
runtime=-MT
- MAKE_DLL="echo "
- LIBSUFFIX="s\${DBGX}.lib"
- LIBFLAGSUFFIX="s\${DBGX}"
LIBRARIES="\${STATIC_LIBRARIES}"
EXESUFFIX="s\${DBGX}.exe"
- SHLIB_LD_LIBS=""
else
# dynamic
AC_MSG_RESULT([using shared flags])
runtime=-MD
# Add SHLIB_LD_LIBS to the Make rule, not here.
- MAKE_DLL="\${SHLIB_LD} \$(LDFLAGS) -out:\[$]@"
- LIBSUFFIX="\${DBGX}.lib"
- LIBFLAGSUFFIX="\${DBGX}"
- EXESUFFIX="\${DBGX}.exe"
LIBRARIES="\${SHARED_LIBRARIES}"
- SHLIB_LD_LIBS='${LIBS}'
+ EXESUFFIX="\${DBGX}.exe"
case "x`echo \${VisualStudioVersion}`" in
x1[[4-9]]*)
lflags="${lflags} -nodefaultlib:libucrt.lib"
@@ -791,9 +799,12 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [
;;
esac
fi
+ MAKE_DLL="\${SHLIB_LD} \$(LDFLAGS) -out:\[$]@"
# DLLSUFFIX is separate because it is the building block for
# users of tclConfig.sh that may build shared or static.
DLLSUFFIX="\${DBGX}.dll"
+ LIBSUFFIX="\${DBGX}.lib"
+ LIBFLAGSUFFIX="\${DBGX}"
# This is a 2-stage check to make sure we have the 64-bit SDK
# We have to know where the SDK is installed.
@@ -820,7 +831,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [
AC_MSG_RESULT([ Using 64-bit $MACHINE mode])
fi
- LIBS="user32.lib advapi32.lib ws2_32.lib"
+ LIBS="netapi32.lib kernel32.lib user32.lib advapi32.lib userenv.lib ws2_32.lib"
case "x`echo \${VisualStudioVersion}`" in
x1[[4-9]]*)
@@ -954,6 +965,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [
fi
SHLIB_LD="${LINKBIN} -dll -incremental:no ${lflags}"
+ SHLIB_LD_LIBS='${LIBS}'
# link -lib only works when -lib is the first arg
STLIB_LD="${LINKBIN} -lib ${lflags}"
RC_OUT=-fo
@@ -1114,13 +1126,13 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [
#------------------------------------------------------------------------
AC_DEFUN([SC_WITH_TCL], [
- if test -d ../../tcl8.5$1/win; then
- TCL_BIN_DEFAULT=../../tcl8.5$1/win
+ if test -d ../../tcl8.6$1/win; then
+ TCL_BIN_DEFAULT=../../tcl8.6$1/win
else
- TCL_BIN_DEFAULT=../../tcl8.5/win
+ TCL_BIN_DEFAULT=../../tcl8.6/win
fi
- AC_ARG_WITH(tcl, [ --with-tcl=DIR use Tcl 8.5 binaries from DIR],
+ AC_ARG_WITH(tcl, [ --with-tcl=DIR use Tcl 8.6 binaries from DIR],
TCL_BIN_DIR=$withval, TCL_BIN_DIR=`cd $TCL_BIN_DEFAULT; pwd`)
if test ! -d $TCL_BIN_DIR; then
AC_MSG_ERROR(Tcl directory $TCL_BIN_DIR does not exist)
diff --git a/win/tclAppInit.c b/win/tclAppInit.c
index 251a610..e06eaf5 100644
--- a/win/tclAppInit.c
+++ b/win/tclAppInit.c
@@ -2,31 +2,67 @@
* tclAppInit.c --
*
* Provides a default version of the main program and Tcl_AppInit
- * function for Tcl applications (without Tk). Note that this program
- * must be built in Win32 console mode to work properly.
+ * procedure for tclsh and other Tcl-based applications (without Tk).
+ * Note that this program must be built in Win32 console mode to work
+ * properly.
*
- * Copyright (c) 1996-1997 by Sun Microsystems, Inc.
- * Copyright (c) 1998-1999 by Scriptics Corporation.
+ * Copyright (c) 1993 The Regents of the University of California.
+ * Copyright (c) 1994-1997 Sun Microsystems, Inc.
+ * Copyright (c) 1998-1999 Scriptics Corporation.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tcl.h"
+#define WIN32_LEAN_AND_MEAN
+#define STRICT /* See MSDN Article Q83456 */
#include <windows.h>
+#undef STRICT
+#undef WIN32_LEAN_AND_MEAN
#include <locale.h>
+#include <stdlib.h>
+#include <tchar.h>
#ifdef TCL_TEST
-extern Tcl_PackageInitProc Procbodytest_Init;
-extern Tcl_PackageInitProc Procbodytest_SafeInit;
-extern Tcl_PackageInitProc Tcltest_Init;
-extern Tcl_PackageInitProc TclObjTest_Init;
+extern Tcl_PackageInitProc Tcltest_Init;
+extern Tcl_PackageInitProc Tcltest_SafeInit;
#endif /* TCL_TEST */
-#if defined(__GNUC__)
+#if defined(STATIC_BUILD) && TCL_USE_STATIC_PACKAGES
+extern Tcl_PackageInitProc Registry_Init;
+extern Tcl_PackageInitProc Dde_Init;
+extern Tcl_PackageInitProc Dde_SafeInit;
+#endif
+
+#ifdef TCL_BROKEN_MAINARGS
int _CRT_glob = 0;
-static void setargv(int *argcPtr, char ***argvPtr);
-#endif /* __GNUC__ */
+static void setargv(int *argcPtr, TCHAR ***argvPtr);
+#endif /* TCL_BROKEN_MAINARGS */
+
+/*
+ * The following #if block allows you to change the AppInit function by using
+ * a #define of TCL_LOCAL_APPINIT instead of rewriting this entire file. The
+ * #if checks for that #define and uses Tcl_AppInit if it does not exist.
+ */
+
+#ifndef TCL_LOCAL_APPINIT
+#define TCL_LOCAL_APPINIT Tcl_AppInit
+#endif
+#ifndef MODULE_SCOPE
+# define MODULE_SCOPE extern
+#endif
+MODULE_SCOPE int TCL_LOCAL_APPINIT(Tcl_Interp *);
+
+/*
+ * The following #if block allows you to change how Tcl finds the startup
+ * script, prime the library or encoding paths, fiddle with the argv, etc.,
+ * without needing to rewrite Tcl_Main()
+ */
+
+#ifdef TCL_LOCAL_MAIN_HOOK
+MODULE_SCOPE int TCL_LOCAL_MAIN_HOOK(int *argc, TCHAR ***argv);
+#endif
/*
*----------------------------------------------------------------------
@@ -36,53 +72,45 @@ static void setargv(int *argcPtr, char ***argvPtr);
* This is the main program for the application.
*
* Results:
- * None: Tcl_Main never returns here, so this function never returns
+ * None: Tcl_Main never returns here, so this procedure never returns
* either.
*
* Side effects:
- * Whatever the application does.
+ * Just about anything, since from here we call arbitrary Tcl code.
*
*----------------------------------------------------------------------
*/
+#ifdef TCL_BROKEN_MAINARGS
int
main(
- int argc,
- char *argv[])
+ int argc, /* Number of command-line arguments. */
+ char *dummy[]) /* Not used. */
+{
+ TCHAR **argv;
+#else
+int
+_tmain(
+ int argc, /* Number of command-line arguments. */
+ TCHAR *argv[]) /* Values of command-line arguments. */
{
- /*
- * The following #if block allows you to change the AppInit function by
- * using a #define of TCL_LOCAL_APPINIT instead of rewriting this entire
- * file. The #if checks for that #define and uses Tcl_AppInit if it
- * doesn't exist.
- */
-
-#ifndef TCL_LOCAL_APPINIT
-#define TCL_LOCAL_APPINIT Tcl_AppInit
#endif
- extern int TCL_LOCAL_APPINIT (Tcl_Interp *interp);
+ TCHAR *p;
/*
- * The following #if block allows you to change how Tcl finds the startup
- * script, prime the library or encoding paths, fiddle with the argv,
- * etc., without needing to rewrite Tcl_Main()
+ * Set up the default locale to be standard "C" locale so parsing is
+ * performed correctly.
*/
-#ifdef TCL_LOCAL_MAIN_HOOK
- extern int TCL_LOCAL_MAIN_HOOK (int *argc, char ***argv);
-#endif
-
- char *p;
+ setlocale(LC_ALL, "C");
+#ifdef TCL_BROKEN_MAINARGS
/*
- * Set up the default locale to be standard "C" locale so parsing is
- * performed correctly.
+ * Get our args from the c-runtime. Ignore command line.
*/
-#if defined(__GNUC__)
- setargv( &argc, &argv );
+ setargv(&argc, &argv);
#endif
- setlocale(LC_ALL, "C");
/*
* Forward slashes substituted for backslashes.
@@ -99,7 +127,6 @@ main(
#endif
Tcl_Main(argc, argv, TCL_LOCAL_APPINIT);
-
return 0; /* Needed only to prevent compiler warning. */
}
@@ -108,9 +135,9 @@ main(
*
* Tcl_AppInit --
*
- * This function performs application-specific initialization. Most
+ * This procedure performs application-specific initialization. Most
* applications, especially those that incorporate additional packages,
- * will have their own version of this function.
+ * will have their own version of this procedure.
*
* Results:
* Returns a standard Tcl completion code, and leaves an error message in
@@ -126,57 +153,44 @@ int
Tcl_AppInit(
Tcl_Interp *interp) /* Interpreter for application. */
{
- if (Tcl_Init(interp) == TCL_ERROR) {
+ if ((Tcl_Init)(interp) == TCL_ERROR) {
return TCL_ERROR;
}
-#ifdef TCL_TEST
- if (Tcltest_Init(interp) == TCL_ERROR) {
+#if defined(STATIC_BUILD) && TCL_USE_STATIC_PACKAGES
+ if (Registry_Init(interp) == TCL_ERROR) {
return TCL_ERROR;
}
- Tcl_StaticPackage(interp, "Tcltest", Tcltest_Init, NULL);
- if (TclObjTest_Init(interp) == TCL_ERROR) {
+ Tcl_StaticPackage(interp, "registry", Registry_Init, NULL);
+
+ if (Dde_Init(interp) == TCL_ERROR) {
return TCL_ERROR;
}
- if (Procbodytest_Init(interp) == TCL_ERROR) {
+ Tcl_StaticPackage(interp, "dde", Dde_Init, Dde_SafeInit);
+#endif
+
+#ifdef TCL_TEST
+ if (Tcltest_Init(interp) == TCL_ERROR) {
return TCL_ERROR;
}
- Tcl_StaticPackage(interp, "procbodytest", Procbodytest_Init,
- Procbodytest_SafeInit);
+ Tcl_StaticPackage(interp, "Tcltest", Tcltest_Init, Tcltest_SafeInit);
#endif /* TCL_TEST */
-#if defined(STATIC_BUILD) && TCL_USE_STATIC_PACKAGES
- {
- extern Tcl_PackageInitProc Registry_Init;
- extern Tcl_PackageInitProc Dde_Init;
- extern Tcl_PackageInitProc Dde_SafeInit;
-
- if (Registry_Init(interp) == TCL_ERROR) {
- return TCL_ERROR;
- }
- Tcl_StaticPackage(interp, "registry", Registry_Init, NULL);
-
- if (Dde_Init(interp) == TCL_ERROR) {
- return TCL_ERROR;
- }
- Tcl_StaticPackage(interp, "dde", Dde_Init, Dde_SafeInit);
- }
-#endif
-
/*
- * Call the init functions for included packages. Each call should look
+ * Call the init procedures for included packages. Each call should look
* like this:
*
* if (Mod_Init(interp) == TCL_ERROR) {
* return TCL_ERROR;
* }
*
- * where "Mod" is the name of the module.
+ * where "Mod" is the name of the module. (Dynamically-loadable packages
+ * should have the same entry-point name.)
*/
/*
* Call Tcl_CreateCommand for application-specific commands, if they
- * weren't already created by the init functions called above.
+ * weren't already created by the init procedures called above.
*/
/*
@@ -186,7 +200,8 @@ Tcl_AppInit(
* user-specific startup file will be run under any conditions.
*/
- Tcl_SetVar(interp, "tcl_rcFileName", "~/tclshrc.tcl", TCL_GLOBAL_ONLY);
+ (Tcl_ObjSetVar2)(interp, Tcl_NewStringObj("tcl_rcFileName", -1), NULL,
+ Tcl_NewStringObj("~/tclshrc.tcl", -1), TCL_GLOBAL_ONLY);
return TCL_OK;
}
@@ -217,17 +232,17 @@ Tcl_AppInit(
*--------------------------------------------------------------------------
*/
-#if defined(__GNUC__)
+#ifdef TCL_BROKEN_MAINARGS
static void
setargv(
int *argcPtr, /* Filled with number of argument strings. */
- char ***argvPtr) /* Filled with argument strings (malloc'd). */
+ TCHAR ***argvPtr) /* Filled with argument strings (malloc'd). */
{
- char *cmdLine, *p, *arg, *argSpace;
- char **argv;
+ TCHAR *cmdLine, *p, *arg, *argSpace;
+ TCHAR **argv;
int argc, size, inquote, copy, slashes;
- cmdLine = GetCommandLine(); /* INTL: BUG */
+ cmdLine = GetCommandLine();
/*
* Precompute an overly pessimistic guess at the number of arguments in
@@ -246,10 +261,15 @@ setargv(
}
}
}
- argSpace = (char *) ckalloc(
- (unsigned) (size * sizeof(char *) + strlen(cmdLine) + 1));
- argv = (char **) argSpace;
- argSpace += size * sizeof(char *);
+
+ /* Make sure we don't call ckalloc through the (not yet initialized) stub table */
+ #undef Tcl_Alloc
+ #undef Tcl_DbCkalloc
+
+ argSpace = ckalloc(size * sizeof(char *)
+ + (_tcslen(cmdLine) * sizeof(TCHAR)) + sizeof(TCHAR));
+ argv = (TCHAR **) argSpace;
+ argSpace += size * (sizeof(char *)/sizeof(TCHAR));
size--;
p = cmdLine;
@@ -307,7 +327,7 @@ setargv(
*argcPtr = argc;
*argvPtr = argv;
}
-#endif /* __GNUC__ */
+#endif /* TCL_BROKEN_MAINARGS */
/*
* Local Variables:
diff --git a/win/tclWin32Dll.c b/win/tclWin32Dll.c
index e5e5202..688fa8d 100644
--- a/win/tclWin32Dll.c
+++ b/win/tclWin32Dll.c
@@ -12,30 +12,9 @@
*/
#include "tclWinInt.h"
-
-#ifndef TCL_NO_STACK_CHECK
-/*
- * The following functions implement stack depth checking
- */
-typedef struct ThreadSpecificData {
- int *stackBound; /* The current stack boundary */
-} ThreadSpecificData;
-static Tcl_ThreadDataKey dataKey;
-#endif /* TCL_NO_STACK_CHECK */
-
-/*
- * The following data structures are used when loading the thunking library
- * for execing child processes under Win32s.
- */
-
-typedef DWORD (WINAPI UT32PROC)(LPVOID lpBuff, DWORD dwUserDefined,
- LPVOID *lpTranslationList);
-
-typedef BOOL (WINAPI UTREGISTER)(HANDLE hModule, LPCSTR SixteenBitDLL,
- LPCSTR InitName, LPCSTR ProcName, UT32PROC **ThirtyTwoBitThunk,
- FARPROC UT32Callback, LPVOID Buff);
-
-typedef VOID (WINAPI UTUNREGISTER)(HANDLE hModule);
+#if defined(HAVE_INTRIN_H)
+# include <intrin.h>
+#endif
/*
* The following variables keep track of information about this DLL on a
@@ -54,150 +33,14 @@ static int platformId; /* Running under NT, or 95/98? */
#define cpuid __asm __emit 0fh __asm __emit 0a2h
#endif
-/*
- * The following function tables are used to dispatch to either the
- * wide-character or multi-byte versions of the operating system calls,
- * depending on whether the Unicode calls are available.
- */
-
-static TclWinProcs asciiProcs = {
- 0,
-
- (BOOL (WINAPI *)(CONST TCHAR *, LPDCB)) BuildCommDCBA,
- (TCHAR *(WINAPI *)(TCHAR *)) CharLowerA,
- (BOOL (WINAPI *)(CONST TCHAR *, CONST TCHAR *, BOOL)) CopyFileA,
- (BOOL (WINAPI *)(CONST TCHAR *, LPSECURITY_ATTRIBUTES)) CreateDirectoryA,
- (HANDLE (WINAPI *)(CONST TCHAR *, DWORD, DWORD, SECURITY_ATTRIBUTES *,
- DWORD, DWORD, HANDLE)) CreateFileA,
- (BOOL (WINAPI *)(CONST TCHAR *, TCHAR *, LPSECURITY_ATTRIBUTES,
- LPSECURITY_ATTRIBUTES, BOOL, DWORD, LPVOID, CONST TCHAR *,
- LPSTARTUPINFOA, LPPROCESS_INFORMATION)) CreateProcessA,
- (BOOL (WINAPI *)(CONST TCHAR *)) DeleteFileA,
- (HANDLE (WINAPI *)(CONST TCHAR *, WIN32_FIND_DATAT *)) FindFirstFileA,
- (BOOL (WINAPI *)(HANDLE, WIN32_FIND_DATAT *)) FindNextFileA,
- (BOOL (WINAPI *)(WCHAR *, LPDWORD)) GetComputerNameA,
- (DWORD (WINAPI *)(DWORD, WCHAR *)) GetCurrentDirectoryA,
- (DWORD (WINAPI *)(CONST TCHAR *)) GetFileAttributesA,
- (DWORD (WINAPI *)(CONST TCHAR *, DWORD nBufferLength, WCHAR *,
- TCHAR **)) GetFullPathNameA,
- (DWORD (WINAPI *)(HMODULE, WCHAR *, int)) GetModuleFileNameA,
- (DWORD (WINAPI *)(CONST TCHAR *, WCHAR *, DWORD)) GetShortPathNameA,
- (UINT (WINAPI *)(CONST TCHAR *, CONST TCHAR *, UINT uUnique,
- WCHAR *)) GetTempFileNameA,
- (DWORD (WINAPI *)(DWORD, WCHAR *)) GetTempPathA,
- (BOOL (WINAPI *)(CONST TCHAR *, WCHAR *, DWORD, LPDWORD, LPDWORD, LPDWORD,
- WCHAR *, DWORD)) GetVolumeInformationA,
- (HINSTANCE (WINAPI *)(CONST TCHAR *, HANDLE, DWORD)) LoadLibraryExA,
- (TCHAR (WINAPI *)(WCHAR *, CONST TCHAR *)) lstrcpyA,
- (BOOL (WINAPI *)(CONST TCHAR *, CONST TCHAR *)) MoveFileA,
- (BOOL (WINAPI *)(CONST TCHAR *)) RemoveDirectoryA,
- (DWORD (WINAPI *)(CONST TCHAR *, CONST TCHAR *, CONST TCHAR *, DWORD,
- WCHAR *, TCHAR **)) SearchPathA,
- (BOOL (WINAPI *)(CONST TCHAR *)) SetCurrentDirectoryA,
- (BOOL (WINAPI *)(CONST TCHAR *, DWORD)) SetFileAttributesA,
+static Tcl_Encoding winTCharEncoding = NULL;
- /*
- * The three NULL function pointers will only be set when
- * Tcl_FindExecutable is called. If you don't ever call that function, the
- * application will crash whenever WinTcl tries to call functions through
- * these null pointers. That is not a bug in Tcl - Tcl_FindExecutable is
- * mandatory in recent Tcl releases.
- */
-
- NULL,
- NULL,
- /* deleted (int (__cdecl*)(CONST TCHAR *, struct _utimbuf *)) _utime, */
- NULL,
- NULL,
- /* getLongPathNameProc */
- NULL,
- /* Security SDK - not available on 95,98,ME */
- NULL, NULL, NULL, NULL, NULL, NULL,
- /* ReadConsole and WriteConsole */
- (BOOL (WINAPI *)(HANDLE, LPVOID, DWORD, LPDWORD, LPVOID)) ReadConsoleA,
- (BOOL (WINAPI *)(HANDLE, const VOID*, DWORD, LPDWORD, LPVOID)) WriteConsoleA,
- (BOOL (WINAPI *)(LPTSTR, LPDWORD)) GetUserNameA
-};
-
-static TclWinProcs unicodeProcs = {
- 1,
-
- (BOOL (WINAPI *)(CONST TCHAR *, LPDCB)) BuildCommDCBW,
- (TCHAR *(WINAPI *)(TCHAR *)) CharLowerW,
- (BOOL (WINAPI *)(CONST TCHAR *, CONST TCHAR *, BOOL)) CopyFileW,
- (BOOL (WINAPI *)(CONST TCHAR *, LPSECURITY_ATTRIBUTES)) CreateDirectoryW,
- (HANDLE (WINAPI *)(CONST TCHAR *, DWORD, DWORD, SECURITY_ATTRIBUTES *,
- DWORD, DWORD, HANDLE)) CreateFileW,
- (BOOL (WINAPI *)(CONST TCHAR *, TCHAR *, LPSECURITY_ATTRIBUTES,
- LPSECURITY_ATTRIBUTES, BOOL, DWORD, LPVOID, CONST TCHAR *,
- LPSTARTUPINFOA, LPPROCESS_INFORMATION)) CreateProcessW,
- (BOOL (WINAPI *)(CONST TCHAR *)) DeleteFileW,
- (HANDLE (WINAPI *)(CONST TCHAR *, WIN32_FIND_DATAT *)) FindFirstFileW,
- (BOOL (WINAPI *)(HANDLE, WIN32_FIND_DATAT *)) FindNextFileW,
- (BOOL (WINAPI *)(WCHAR *, LPDWORD)) GetComputerNameW,
- (DWORD (WINAPI *)(DWORD, WCHAR *)) GetCurrentDirectoryW,
- (DWORD (WINAPI *)(CONST TCHAR *)) GetFileAttributesW,
- (DWORD (WINAPI *)(CONST TCHAR *, DWORD nBufferLength, WCHAR *,
- TCHAR **)) GetFullPathNameW,
- (DWORD (WINAPI *)(HMODULE, WCHAR *, int)) GetModuleFileNameW,
- (DWORD (WINAPI *)(CONST TCHAR *, WCHAR *, DWORD)) GetShortPathNameW,
- (UINT (WINAPI *)(CONST TCHAR *, CONST TCHAR *, UINT uUnique,
- WCHAR *)) GetTempFileNameW,
- (DWORD (WINAPI *)(DWORD, WCHAR *)) GetTempPathW,
- (BOOL (WINAPI *)(CONST TCHAR *, WCHAR *, DWORD, LPDWORD, LPDWORD, LPDWORD,
- WCHAR *, DWORD)) GetVolumeInformationW,
- (HINSTANCE (WINAPI *)(CONST TCHAR *, HANDLE, DWORD)) LoadLibraryExW,
- (TCHAR (WINAPI *)(WCHAR *, CONST TCHAR *)) lstrcpyW,
- (BOOL (WINAPI *)(CONST TCHAR *, CONST TCHAR *)) MoveFileW,
- (BOOL (WINAPI *)(CONST TCHAR *)) RemoveDirectoryW,
- (DWORD (WINAPI *)(CONST TCHAR *, CONST TCHAR *, CONST TCHAR *, DWORD,
- WCHAR *, TCHAR **)) SearchPathW,
- (BOOL (WINAPI *)(CONST TCHAR *)) SetCurrentDirectoryW,
- (BOOL (WINAPI *)(CONST TCHAR *, DWORD)) SetFileAttributesW,
-
- /*
- * The three NULL function pointers will only be set when
- * Tcl_FindExecutable is called. If you don't ever call that function, the
- * application will crash whenever WinTcl tries to call functions through
- * these null pointers. That is not a bug in Tcl - Tcl_FindExecutable is
- * mandatory in recent Tcl releases.
- */
-
- NULL,
- NULL,
- /* deleted (int (__cdecl*)(CONST TCHAR *, struct _utimbuf *)) _wutime, */
- NULL,
- NULL,
- /* getLongPathNameProc */
- NULL,
- /* Security SDK - will be filled in on NT,XP,2000,2003 */
- NULL, NULL, NULL, NULL, NULL, NULL,
- /* ReadConsole and WriteConsole */
- (BOOL (WINAPI *)(HANDLE, LPVOID, DWORD, LPDWORD, LPVOID)) ReadConsoleW,
- (BOOL (WINAPI *)(HANDLE, const VOID*, DWORD, LPDWORD, LPVOID)) WriteConsoleW,
- (BOOL (WINAPI *)(LPTSTR, LPDWORD)) GetUserNameW
-};
-
-TclWinProcs *tclWinProcs;
-static Tcl_Encoding tclWinTCharEncoding;
-
-#ifdef HAVE_NO_SEH
-/*
- * Need to add noinline flag to DllMain declaration so that gcc -O3 does not
- * inline asm code into DllEntryPoint and cause a compile time error because
- * of redefined local labels.
- */
-
-BOOL APIENTRY DllMain(HINSTANCE hInst, DWORD reason,
- LPVOID reserved) __attribute__ ((noinline));
-#else
/*
* The following declaration is for the VC++ DLL entry point.
*/
BOOL APIENTRY DllMain(HINSTANCE hInst, DWORD reason,
LPVOID reserved);
-#endif /* HAVE_NO_SEH */
/*
* The following structure and linked list is to allow us to map between
@@ -206,8 +49,8 @@ BOOL APIENTRY DllMain(HINSTANCE hInst, DWORD reason,
*/
typedef struct MountPointMap {
- CONST WCHAR *volumeName; /* Native wide string volume name. */
- char driveLetter; /* Drive letter corresponding to the volume
+ const TCHAR *volumeName; /* Native wide string volume name. */
+ TCHAR driveLetter; /* Drive letter corresponding to the volume
* name. */
struct MountPointMap *nextPtr;
/* Pointer to next structure in list, or
@@ -226,9 +69,7 @@ TCL_DECLARE_MUTEX(mountPointMap)
* We will need this below.
*/
-extern Tcl_FSDupInternalRepProc TclNativeDupInternalRep;
-
-#ifdef __WIN32__
+#ifdef _WIN32
#ifndef STATIC_BUILD
/*
@@ -270,10 +111,7 @@ DllEntryPoint(
* TRUE on sucess, FALSE on failure.
*
* Side effects:
- * Establishes 32-to-16 bit thunk and initializes sockets library. This
- * might call some sycronization functions, but MSDN documentation
- * states: "Waiting on synchronization objects in DllMain can cause a
- * deadlock."
+ * Initializes most rudimentary Windows bits.
*
*----------------------------------------------------------------------
*/
@@ -284,111 +122,22 @@ DllMain(
DWORD reason, /* Reason this function is being called. */
LPVOID reserved) /* Not used. */
{
-#if defined(HAVE_NO_SEH) && !defined(_WIN64)
- TCLEXCEPTION_REGISTRATION registration;
-#endif
-
switch (reason) {
case DLL_PROCESS_ATTACH:
DisableThreadLibraryCalls(hInst);
TclWinInit(hInst);
return TRUE;
- case DLL_PROCESS_DETACH:
/*
- * Protect the call to Tcl_Finalize. The OS could be unloading us from
- * an exception handler and the state of the stack might be unstable.
+ * DLL_PROCESS_DETACH is unnecessary as the user should call
+ * Tcl_Finalize explicitly before unloading Tcl.
*/
-
-#if defined(HAVE_NO_SEH) && !defined(_WIN64)
- __asm__ __volatile__ (
-
- /*
- * Construct an TCLEXCEPTION_REGISTRATION to protect the call to
- * Tcl_Finalize
- */
-
- "leal %[registration], %%edx" "\n\t"
- "movl %%fs:0, %%eax" "\n\t"
- "movl %%eax, 0x0(%%edx)" "\n\t" /* link */
- "leal 1f, %%eax" "\n\t"
- "movl %%eax, 0x4(%%edx)" "\n\t" /* handler */
- "movl %%ebp, 0x8(%%edx)" "\n\t" /* ebp */
- "movl %%esp, 0xc(%%edx)" "\n\t" /* esp */
- "movl %[error], 0x10(%%edx)" "\n\t" /* status */
-
- /*
- * Link the TCLEXCEPTION_REGISTRATION on the chain
- */
-
- "movl %%edx, %%fs:0" "\n\t"
-
- /*
- * Call Tcl_Finalize
- */
-
- "call _Tcl_Finalize" "\n\t"
-
- /*
- * Come here on a normal exit. Recover the TCLEXCEPTION_REGISTRATION
- * and store a TCL_OK status
- */
-
- "movl %%fs:0, %%edx" "\n\t"
- "movl %[ok], %%eax" "\n\t"
- "movl %%eax, 0x10(%%edx)" "\n\t"
- "jmp 2f" "\n"
-
- /*
- * Come here on an exception. Get the TCLEXCEPTION_REGISTRATION that
- * we previously put on the chain.
- */
-
- "1:" "\t"
- "movl %%fs:0, %%edx" "\n\t"
- "movl 0x8(%%edx), %%edx" "\n"
-
-
- /*
- * Come here however we exited. Restore context from the
- * TCLEXCEPTION_REGISTRATION in case the stack is unbalanced.
- */
-
- "2:" "\t"
- "movl 0xc(%%edx), %%esp" "\n\t"
- "movl 0x8(%%edx), %%ebp" "\n\t"
- "movl 0x0(%%edx), %%eax" "\n\t"
- "movl %%eax, %%fs:0" "\n\t"
-
- :
- /* No outputs */
- :
- [registration] "m" (registration),
- [ok] "i" (TCL_OK),
- [error] "i" (TCL_ERROR)
- :
- "%eax", "%ebx", "%ecx", "%edx", "%esi", "%edi", "memory"
- );
-
-#else
-#ifndef HAVE_NO_SEH
- __try {
-#endif
- Tcl_Finalize();
-#ifndef HAVE_NO_SEH
- } __except (EXCEPTION_EXECUTE_HANDLER) {
- /* empty handler body. */
- }
-#endif
-#endif
-
- break;
}
return TRUE;
}
#endif /* !STATIC_BUILD */
-#endif /* __WIN32__ */
+#endif /* _WIN32 */
/*
*----------------------------------------------------------------------
@@ -440,15 +189,18 @@ TclWinInit(
platformId = os.dwPlatformId;
/*
- * We no longer support Win32s, so just in case someone manages to get a
- * runtime there, make sure they know that.
+ * We no longer support Win32s or Win9x, so just in case someone manages
+ * to get a runtime there, make sure they know that.
*/
if (platformId == VER_PLATFORM_WIN32s) {
Tcl_Panic("Win32s is not a supported platform");
}
+ if (platformId == VER_PLATFORM_WIN32_WINDOWS) {
+ Tcl_Panic("Windows 9x is not a supported platform");
+ }
- tclWinProcs = &asciiProcs;
+ TclWinResetInterfaces();
}
/*
@@ -461,9 +213,10 @@ TclWinInit(
*
* Results:
* The return value is one of:
- * VER_PLATFORM_WIN32s Win32s on Windows 3.1. (not supported)
- * VER_PLATFORM_WIN32_WINDOWS Win32 on Windows 95, 98, ME.
- * VER_PLATFORM_WIN32_NT Win32 on Windows NT, 2000, XP
+ * VER_PLATFORM_WIN32s Win32s on Windows 3.1 (not supported)
+ * VER_PLATFORM_WIN32_WINDOWS Win32 on Windows 95, 98, ME (not supported)
+ * VER_PLATFORM_WIN32_NT Win32 on Windows NT, 2000, XP
+ * VER_PLATFORM_WIN32_CE Win32 on Windows CE
*
* Side effects:
* None.
@@ -509,95 +262,11 @@ TclWinNoBackslash(
}
/*
- *----------------------------------------------------------------------
- *
- * TclpGetStackParams --
- *
- * Determine the stack params for the current thread: in which
- * direction does the stack grow, and what is the stack lower (resp.
- * upper) bound for safe invocation of a new command? This is used to
- * cache the values needed for an efficient computation of
- * TclpCheckStackSpace() when the interp is known.
- *
- * Results:
- * Returns 1 if the stack grows down, in which case a stack lower bound
- * is stored at stackBoundPtr. If the stack grows up, 0 is returned and
- * an upper bound is stored at stackBoundPtr. If a bound cannot be
- * determined NULL is stored at stackBoundPtr.
- *
- *----------------------------------------------------------------------
- */
-
-#ifndef TCL_NO_STACK_CHECK
-int
-TclpGetCStackParams(
- int **stackBoundPtr)
-{
- ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
- SYSTEM_INFO si; /* The system information, used to
- * determine the page size */
- MEMORY_BASIC_INFORMATION mbi;
- /* The information about the memory
- * area in which the stack resides */
-
- if (!tsdPtr->stackBound
- || ((UINT_PTR)&tsdPtr < (UINT_PTR)tsdPtr->stackBound)) {
-
- /*
- * Either we haven't determined the stack bound in this thread,
- * or else we've overflowed the bound that we previously
- * determined. We need to find a new stack bound from
- * Windows.
- */
-
- GetSystemInfo(&si);
- if (VirtualQuery((LPCVOID) &tsdPtr, &mbi, sizeof(mbi)) == 0) {
-
- /* For some reason, the system didn't let us query the
- * stack size. Nevertheless, we got here and haven't
- * blown up yet. Don't update the calculated stack bound.
- * If there is no calculated stack bound yet, set it to
- * the base of the current page of stack. */
-
- if (!tsdPtr->stackBound) {
- tsdPtr->stackBound =
- (int*) ((UINT_PTR)(&tsdPtr)
- & ~ (UINT_PTR)(si.dwPageSize - 1));
- }
-
- } else {
-
- /* The allocation base of the stack segment has to be advanced
- * by one page (to allow for the guard page maintained in the
- * C runtime) and then by TCL_WIN_STACK_THRESHOLD (to allow
- * for the amount of stack that Tcl needs).
- */
-
- tsdPtr->stackBound =
- (int*) ((UINT_PTR)(mbi.AllocationBase)
- + (UINT_PTR)(si.dwPageSize)
- + TCL_WIN_STACK_THRESHOLD);
- }
- }
- *stackBoundPtr = tsdPtr->stackBound;
- return 1;
-}
-#endif
-
-
-/*
*---------------------------------------------------------------------------
*
- * TclWinSetInterfaces --
- *
- * A helper proc that allows the test library to change the tclWinProcs
- * structure to dispatch to either the wide-character or multi-byte
- * versions of the operating system calls, depending on whether Unicode
- * is the system encoding.
+ * TclpSetInterfaces --
*
- * As well as this, we can also try to load in some additional procs
- * which may/may not be present depending on the current Windows version
- * (e.g. Win95 will not have the procs below).
+ * A helper proc that initializes winTCharEncoding.
*
* Results:
* None.
@@ -609,115 +278,18 @@ TclpGetCStackParams(
*/
void
-TclWinSetInterfaces(
- int wide) /* Non-zero to use wide interfaces, 0
- * otherwise. */
+TclpSetInterfaces(void)
{
- Tcl_FreeEncoding(tclWinTCharEncoding);
-
- if (wide) {
- tclWinProcs = &unicodeProcs;
- tclWinTCharEncoding = Tcl_GetEncoding(NULL, "unicode");
- if (tclWinProcs->getFileAttributesExProc == NULL) {
- HINSTANCE hInstance = LoadLibraryA("kernel32");
- if (hInstance != NULL) {
- tclWinProcs->getFileAttributesExProc =
- (BOOL (WINAPI *)(CONST TCHAR *, GET_FILEEX_INFO_LEVELS,
- LPVOID)) GetProcAddress(hInstance,
- "GetFileAttributesExW");
- tclWinProcs->createHardLinkProc =
- (BOOL (WINAPI *)(CONST TCHAR *, CONST TCHAR*,
- LPSECURITY_ATTRIBUTES)) GetProcAddress(hInstance,
- "CreateHardLinkW");
- tclWinProcs->findFirstFileExProc =
- (HANDLE (WINAPI *)(CONST TCHAR*, UINT, LPVOID, UINT,
- LPVOID, DWORD)) GetProcAddress(hInstance,
- "FindFirstFileExW");
- tclWinProcs->getVolumeNameForVMPProc =
- (BOOL (WINAPI *)(CONST TCHAR*, TCHAR*,
- DWORD)) GetProcAddress(hInstance,
- "GetVolumeNameForVolumeMountPointW");
- tclWinProcs->getLongPathNameProc =
- (DWORD (WINAPI *)(CONST TCHAR*, TCHAR*,
- DWORD)) GetProcAddress(hInstance, "GetLongPathNameW");
- FreeLibrary(hInstance);
- }
- hInstance = LoadLibraryA("advapi32");
- if (hInstance != NULL) {
- tclWinProcs->getFileSecurityProc = (BOOL (WINAPI *)(
- LPCTSTR lpFileName,
- SECURITY_INFORMATION RequestedInformation,
- PSECURITY_DESCRIPTOR pSecurityDescriptor,
- DWORD nLength, LPDWORD lpnLengthNeeded))
- GetProcAddress(hInstance, "GetFileSecurityW");
- tclWinProcs->impersonateSelfProc = (BOOL (WINAPI *) (
- SECURITY_IMPERSONATION_LEVEL ImpersonationLevel))
- GetProcAddress(hInstance, "ImpersonateSelf");
- tclWinProcs->openThreadTokenProc = (BOOL (WINAPI *) (
- HANDLE ThreadHandle, DWORD DesiredAccess,
- BOOL OpenAsSelf, PHANDLE TokenHandle))
- GetProcAddress(hInstance, "OpenThreadToken");
- tclWinProcs->revertToSelfProc = (BOOL (WINAPI *) (void))
- GetProcAddress(hInstance, "RevertToSelf");
- tclWinProcs->mapGenericMaskProc = (VOID (WINAPI *) (
- PDWORD AccessMask, PGENERIC_MAPPING GenericMapping))
- GetProcAddress(hInstance, "MapGenericMask");
- tclWinProcs->accessCheckProc = (BOOL (WINAPI *)(
- PSECURITY_DESCRIPTOR pSecurityDescriptor,
- HANDLE ClientToken, DWORD DesiredAccess,
- PGENERIC_MAPPING GenericMapping,
- PPRIVILEGE_SET PrivilegeSet,
- LPDWORD PrivilegeSetLength, LPDWORD GrantedAccess,
- LPBOOL AccessStatus)) GetProcAddress(hInstance,
- "AccessCheck");
- FreeLibrary(hInstance);
- }
- }
- } else {
- tclWinProcs = &asciiProcs;
- tclWinTCharEncoding = NULL;
- if (tclWinProcs->getFileAttributesExProc == NULL) {
- HINSTANCE hInstance = LoadLibraryA("kernel32");
- if (hInstance != NULL) {
- tclWinProcs->getFileAttributesExProc =
- (BOOL (WINAPI *)(CONST TCHAR *, GET_FILEEX_INFO_LEVELS,
- LPVOID)) GetProcAddress(hInstance,
- "GetFileAttributesExA");
- tclWinProcs->createHardLinkProc =
- (BOOL (WINAPI *)(CONST TCHAR *, CONST TCHAR*,
- LPSECURITY_ATTRIBUTES)) GetProcAddress(hInstance,
- "CreateHardLinkA");
- tclWinProcs->findFirstFileExProc = NULL;
- tclWinProcs->getLongPathNameProc = NULL;
- /*
- * The 'findFirstFileExProc' function exists on some of
- * 95/98/ME, but it seems not to work as anticipated.
- * Therefore we don't set this function pointer. The relevant
- * code will fall back on a slower approach using the normal
- * findFirstFileProc.
- *
- * (HANDLE (WINAPI *)(CONST TCHAR*, UINT,
- * LPVOID, UINT, LPVOID, DWORD)) GetProcAddress(hInstance,
- * "FindFirstFileExA");
- */
- tclWinProcs->getVolumeNameForVMPProc =
- (BOOL (WINAPI *)(CONST TCHAR*, TCHAR*,
- DWORD)) GetProcAddress(hInstance,
- "GetVolumeNameForVolumeMountPointA");
- FreeLibrary(hInstance);
- }
- }
- }
+ TclWinResetInterfaces();
+ winTCharEncoding = Tcl_GetEncoding(NULL, "unicode");
}
/*
*---------------------------------------------------------------------------
*
- * TclWinResetInterfaceEncodings --
+ * TclWinEncodingsCleanup --
*
- * Called during finalization to free up any encodings we use. The
- * tclWinProcs-> look up table is still ok to use after this call,
- * provided no encoding conversion is required.
+ * Called during finalization to free up any encodings we use.
*
* We also clean up any memory allocated in our mount point map which is
* used to follow certain kinds of symlinks. That code should never be
@@ -733,13 +305,11 @@ TclWinSetInterfaces(
*/
void
-TclWinResetInterfaceEncodings(void)
+TclWinEncodingsCleanup(void)
{
MountPointMap *dlIter, *dlIter2;
- if (tclWinTCharEncoding != NULL) {
- Tcl_FreeEncoding(tclWinTCharEncoding);
- tclWinTCharEncoding = NULL;
- }
+
+ TclWinResetInterfaces();
/*
* Clean up the mount point map.
@@ -749,8 +319,8 @@ TclWinResetInterfaceEncodings(void)
dlIter = driveLetterLookup;
while (dlIter != NULL) {
dlIter2 = dlIter->nextPtr;
- ckfree((char*)dlIter->volumeName);
- ckfree((char*)dlIter);
+ ckfree(dlIter->volumeName);
+ ckfree(dlIter);
dlIter = dlIter2;
}
Tcl_MutexUnlock(&mountPointMap);
@@ -762,8 +332,6 @@ TclWinResetInterfaceEncodings(void)
* TclWinResetInterfaces --
*
* Called during finalization to reset us to a safe state for reuse.
- * After this call, it is best not to use the tclWinProcs-> look up table
- * since it is likely to be different to what is expected.
*
* Results:
* None.
@@ -776,7 +344,10 @@ TclWinResetInterfaceEncodings(void)
void
TclWinResetInterfaces(void)
{
- tclWinProcs = &asciiProcs;
+ if (winTCharEncoding != NULL) {
+ Tcl_FreeEncoding(winTCharEncoding);
+ winTCharEncoding = NULL;
+ }
}
/*
@@ -803,11 +374,11 @@ TclWinResetInterfaces(void)
char
TclWinDriveLetterForVolMountPoint(
- CONST WCHAR *mountPoint)
+ const TCHAR *mountPoint)
{
MountPointMap *dlIter, *dlPtr2;
- WCHAR Target[55]; /* Target of mount at mount point */
- WCHAR drive[4] = { L'A', L':', L'\\', L'\0' };
+ TCHAR Target[55]; /* Target of mount at mount point */
+ TCHAR drive[4] = TEXT("A:\\");
/*
* Detect the volume mounted there. Unfortunately, there is no simple way
@@ -818,28 +389,28 @@ TclWinDriveLetterForVolMountPoint(
Tcl_MutexLock(&mountPointMap);
dlIter = driveLetterLookup;
while (dlIter != NULL) {
- if (wcscmp(dlIter->volumeName, mountPoint) == 0) {
+ if (_tcscmp(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] = L'A' + (dlIter->driveLetter - 'A');
+ drive[0] = (TCHAR) dlIter->driveLetter;
/*
* Try to read the volume mount point and see where it points.
*/
- if ((*tclWinProcs->getVolumeNameForVMPProc)((TCHAR*)drive,
- (TCHAR*)Target, 55) != 0) {
- if (wcscmp((WCHAR*)dlIter->volumeName, Target) == 0) {
+ if (GetVolumeNameForVolumeMountPoint(drive,
+ Target, 55) != 0) {
+ if (_tcscmp(dlIter->volumeName, Target) == 0) {
/*
* Nothing has changed.
*/
Tcl_MutexUnlock(&mountPointMap);
- return dlIter->driveLetter;
+ return (char) dlIter->driveLetter;
}
}
@@ -866,8 +437,8 @@ TclWinDriveLetterForVolMountPoint(
* Now dlPtr2 points to the structure to free.
*/
- ckfree((char*)dlPtr2->volumeName);
- ckfree((char*)dlPtr2);
+ ckfree(dlPtr2->volumeName);
+ ckfree(dlPtr2);
/*
* Restart the loop - we could try to be clever and continue half
@@ -890,23 +461,23 @@ TclWinDriveLetterForVolMountPoint(
* Try to read the volume mount point and see where it points.
*/
- if ((*tclWinProcs->getVolumeNameForVMPProc)((TCHAR*)drive,
- (TCHAR*)Target, 55) != 0) {
+ if (GetVolumeNameForVolumeMountPoint(drive,
+ Target, 55) != 0) {
int alreadyStored = 0;
for (dlIter = driveLetterLookup; dlIter != NULL;
dlIter = dlIter->nextPtr) {
- if (wcscmp((WCHAR*)dlIter->volumeName, Target) == 0) {
+ if (_tcscmp(dlIter->volumeName, Target) == 0) {
alreadyStored = 1;
break;
}
}
if (!alreadyStored) {
- dlPtr2 = (MountPointMap *) ckalloc(sizeof(MountPointMap));
+ dlPtr2 = ckalloc(sizeof(MountPointMap));
dlPtr2->volumeName = TclNativeDupInternalRep(Target);
- dlPtr2->driveLetter = 'A' + (drive[0] - L'A');
+ dlPtr2->driveLetter = (char) drive[0];
dlPtr2->nextPtr = driveLetterLookup;
- driveLetterLookup = dlPtr2;
+ driveLetterLookup = dlPtr2;
}
}
}
@@ -917,9 +488,9 @@ TclWinDriveLetterForVolMountPoint(
for (dlIter = driveLetterLookup; dlIter != NULL;
dlIter = dlIter->nextPtr) {
- if (wcscmp(dlIter->volumeName, mountPoint) == 0) {
+ if (_tcscmp(dlIter->volumeName, mountPoint) == 0) {
Tcl_MutexUnlock(&mountPointMap);
- return dlIter->driveLetter;
+ return (char) dlIter->driveLetter;
}
}
@@ -928,11 +499,11 @@ TclWinDriveLetterForVolMountPoint(
* that fact and store '-1' so we don't have to look it up each time.
*/
- dlPtr2 = (MountPointMap*) ckalloc(sizeof(MountPointMap));
- dlPtr2->volumeName = TclNativeDupInternalRep((ClientData)mountPoint);
+ dlPtr2 = ckalloc(sizeof(MountPointMap));
+ dlPtr2->volumeName = TclNativeDupInternalRep((ClientData) mountPoint);
dlPtr2->driveLetter = -1;
dlPtr2->nextPtr = driveLetterLookup;
- driveLetterLookup = dlPtr2;
+ driveLetterLookup = dlPtr2;
Tcl_MutexUnlock(&mountPointMap);
return -1;
}
@@ -989,27 +560,27 @@ TclWinDriveLetterForVolMountPoint(
TCHAR *
Tcl_WinUtfToTChar(
- CONST char *string, /* Source string in UTF-8. */
+ const char *string, /* Source string in UTF-8. */
int len, /* Source string length in bytes, or < 0 for
* strlen(). */
Tcl_DString *dsPtr) /* Uninitialized or free DString in which the
* converted string is stored. */
{
- return (TCHAR *) Tcl_UtfToExternalDString(tclWinTCharEncoding,
+ return (TCHAR *) Tcl_UtfToExternalDString(winTCharEncoding,
string, len, dsPtr);
}
char *
Tcl_WinTCharToUtf(
- CONST TCHAR *string, /* Source string in Unicode when running NT,
+ const TCHAR *string, /* Source string in Unicode when running NT,
* ANSI when running 95. */
int len, /* Source string length in bytes, or < 0 for
* platform-specific string length. */
Tcl_DString *dsPtr) /* Uninitialized or free DString in which the
* converted string is stored. */
{
- return Tcl_ExternalToUtfDString(tclWinTCharEncoding,
- (CONST char *) string, len, dsPtr);
+ return Tcl_ExternalToUtfDString(winTCharEncoding,
+ (const char *) string, len, dsPtr);
}
/*
@@ -1037,11 +608,16 @@ TclWinCPUID(
{
int status = TCL_ERROR;
-#if defined(__GNUC__)
+#if defined(HAVE_INTRIN_H) && defined(_WIN64)
+
+ __cpuid(regsPtr, index);
+ status = TCL_OK;
+
+#elif defined(__GNUC__)
# if defined(_WIN64)
/*
* Execute the CPUID instruction with the given index, and store results
- * off 'regsPtr'.
+ * off 'regPtr'.
*/
__asm__ __volatile__(
diff --git a/win/tclWinChan.c b/win/tclWinChan.c
index a271919..78b510b 100644
--- a/win/tclWinChan.c
+++ b/win/tclWinChan.c
@@ -83,7 +83,7 @@ static ThreadSpecificData *FileInit(void);
static int FileInputProc(ClientData instanceData, char *buf,
int toRead, int *errorCode);
static int FileOutputProc(ClientData instanceData,
- CONST char *buf, int toWrite, int *errorCode);
+ const char *buf, int toWrite, int *errorCode);
static int FileSeekProc(ClientData instanceData, long offset,
int mode, int *errorCode);
static Tcl_WideInt FileWideSeekProc(ClientData instanceData,
@@ -95,12 +95,12 @@ 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 TCHAR *nativeName);
/*
* This structure describes the channel type structure for file based IO.
*/
-static Tcl_ChannelType fileChannelType = {
+static const Tcl_ChannelType fileChannelType = {
"file", /* Type name. */
TCL_CHANNEL_VERSION_5, /* v5 channel */
FileCloseProc, /* Close proc. */
@@ -117,7 +117,7 @@ static Tcl_ChannelType fileChannelType = {
NULL, /* handler proc. */
FileWideSeekProc, /* Wide seek proc. */
FileThreadActionProc, /* Thread action proc. */
- FileTruncateProc, /* Truncate proc. */
+ FileTruncateProc /* Truncate proc. */
};
/*
@@ -257,7 +257,7 @@ FileCheckProc(
infoPtr = infoPtr->nextPtr) {
if (infoPtr->watchMask && !(infoPtr->flags & FILE_PENDING)) {
infoPtr->flags |= FILE_PENDING;
- evPtr = (FileEvent *) ckalloc(sizeof(FileEvent));
+ evPtr = ckalloc(sizeof(FileEvent));
evPtr->header.proc = FileEventProc;
evPtr->infoPtr = infoPtr;
Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL);
@@ -340,7 +340,7 @@ FileBlockProc(
int mode) /* TCL_MODE_BLOCKING or
* TCL_MODE_NONBLOCKING. */
{
- FileInfo *infoPtr = (FileInfo *) instanceData;
+ FileInfo *infoPtr = instanceData;
/*
* Files on Windows can not be switched between blocking and nonblocking,
@@ -378,7 +378,7 @@ FileCloseProc(
ClientData instanceData, /* Pointer to FileInfo structure. */
Tcl_Interp *interp) /* Not used. */
{
- FileInfo *fileInfoPtr = (FileInfo *) instanceData;
+ FileInfo *fileInfoPtr = instanceData;
FileInfo *infoPtr;
ThreadSpecificData *tsdPtr;
int errorCode = 0;
@@ -424,7 +424,7 @@ FileCloseProc(
break;
}
}
- ckfree((char *)fileInfoPtr);
+ ckfree(fileInfoPtr);
return errorCode;
}
@@ -453,7 +453,7 @@ FileSeekProc(
int mode, /* Relative to where should we seek? */
int *errorCodePtr) /* To store error code. */
{
- FileInfo *infoPtr = (FileInfo *) instanceData;
+ FileInfo *infoPtr = instanceData;
LONG newPos, newPosHigh, oldPos, oldPosHigh;
DWORD moveMethod;
@@ -531,7 +531,7 @@ FileWideSeekProc(
int mode, /* Relative to where should we seek? */
int *errorCodePtr) /* To store error code. */
{
- FileInfo *infoPtr = (FileInfo *) instanceData;
+ FileInfo *infoPtr = instanceData;
DWORD moveMethod;
LONG newPos, newPosHigh;
@@ -580,7 +580,7 @@ FileTruncateProc(
ClientData instanceData, /* File state. */
Tcl_WideInt length) /* Length to truncate at. */
{
- FileInfo *infoPtr = (FileInfo *) instanceData;
+ FileInfo *infoPtr = instanceData;
LONG newPos, newPosHigh, oldPos, oldPosHigh;
/*
@@ -656,13 +656,16 @@ FileInputProc(
int bufSize, /* Num bytes available in buffer. */
int *errorCode) /* Where to store error code. */
{
- FileInfo *infoPtr;
+ FileInfo *infoPtr = instanceData;
DWORD bytesRead;
*errorCode = 0;
- infoPtr = (FileInfo *) instanceData;
/*
+ * TODO: This comment appears to be out of date. We *do* have a
+ * console driver, over in tclWinConsole.c. After some Windows
+ * developer confirms, this comment should be revised.
+ *
* Note that we will block on reads from a console buffer until a full
* line has been entered. The only way I know of to get around this is to
* write a console driver. We should probably do this at some point, but
@@ -704,11 +707,11 @@ FileInputProc(
static int
FileOutputProc(
ClientData instanceData, /* File state. */
- CONST char *buf, /* The data buffer. */
+ const char *buf, /* The data buffer. */
int toWrite, /* How many bytes to write? */
int *errorCode) /* Where to store error code. */
{
- FileInfo *infoPtr = (FileInfo *) instanceData;
+ FileInfo *infoPtr = instanceData;
DWORD bytesWritten;
*errorCode = 0;
@@ -755,7 +758,7 @@ FileWatchProc(
* of TCL_READABLE, TCL_WRITABLE and
* TCL_EXCEPTION. */
{
- FileInfo *infoPtr = (FileInfo *) instanceData;
+ FileInfo *infoPtr = instanceData;
Tcl_Time blockTime = { 0, 0 };
/*
@@ -793,7 +796,7 @@ FileGetHandleProc(
int direction, /* TCL_READABLE or TCL_WRITABLE */
ClientData *handlePtr) /* Where to store the handle. */
{
- FileInfo *infoPtr = (FileInfo *) instanceData;
+ FileInfo *infoPtr = instanceData;
if (direction & infoPtr->validMask) {
*handlePtr = (ClientData) infoPtr->handle;
@@ -833,12 +836,12 @@ TclpOpenFileChannel(
Tcl_Channel channel = 0;
int channelPermissions = 0;
DWORD accessMode = 0, createMode, shareMode, flags;
- CONST TCHAR *nativeName;
+ const TCHAR *nativeName;
HANDLE handle;
char channelName[16 + TCL_INTEGER_SPACE];
TclFile readFile = NULL, writeFile = NULL;
- nativeName = (TCHAR*) Tcl_FSGetNativePath(pathPtr);
+ nativeName = Tcl_FSGetNativePath(pathPtr);
if (nativeName == NULL) {
if (interp != (Tcl_Interp *) NULL) {
Tcl_AppendResult(interp, "couldn't open \"",
@@ -929,7 +932,7 @@ TclpOpenFileChannel(
flags = FILE_ATTRIBUTE_READONLY;
}
} else {
- flags = (*tclWinProcs->getFileAttributesProc)(nativeName);
+ flags = GetFileAttributes(nativeName);
if (flags == 0xFFFFFFFF) {
flags = 0;
}
@@ -945,8 +948,8 @@ TclpOpenFileChannel(
* Now we get to create the file.
*/
- handle = (*tclWinProcs->createFileProc)(nativeName, accessMode,
- shareMode, NULL, createMode, flags, (HANDLE) NULL);
+ handle = CreateFile(nativeName, accessMode, shareMode,
+ NULL, createMode, flags, (HANDLE) NULL);
if (handle == INVALID_HANDLE_VALUE) {
DWORD err = GetLastError();
@@ -956,8 +959,9 @@ TclpOpenFileChannel(
}
TclWinConvertError(err);
if (interp != (Tcl_Interp *) NULL) {
- Tcl_AppendResult(interp, "couldn't open \"", TclGetString(pathPtr),
- "\": ", Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't open \"%s\": %s",
+ TclGetString(pathPtr), Tcl_PosixError(interp)));
}
return NULL;
}
@@ -967,7 +971,7 @@ TclpOpenFileChannel(
switch (FileGetType(handle)) {
case FILE_TYPE_SERIAL:
/*
- * Natively named serial ports "com1-9", "\\\\.\\comXX" are
+ * Natively named serial ports "com1-9", "\\\\.\\comXX" are
* already done with the code above.
* Here we handle all other serial port names.
*
@@ -979,9 +983,9 @@ TclpOpenFileChannel(
if (handle == INVALID_HANDLE_VALUE) {
TclWinConvertError(GetLastError());
if (interp != (Tcl_Interp *) NULL) {
- Tcl_AppendResult(interp, "couldn't reopen serial \"",
- TclGetString(pathPtr), "\": ",
- Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't reopen serial \"%s\": %s",
+ TclGetString(pathPtr), Tcl_PosixError(interp)));
}
return NULL;
}
@@ -1015,8 +1019,11 @@ TclpOpenFileChannel(
*/
channel = NULL;
- Tcl_AppendResult(interp, "couldn't open \"", TclGetString(pathPtr),
- "\": bad file type", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't open \"%s\": bad file type",
+ TclGetString(pathPtr)));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "CHANNEL", "BAD_TYPE",
+ NULL);
break;
}
@@ -1242,8 +1249,8 @@ TclpGetDefaultStdChannel(
Tcl_Channel channel;
HANDLE handle;
int mode = -1;
- char *bufMode = NULL;
- DWORD handleId = (DWORD)-1;
+ const char *bufMode = NULL;
+ DWORD handleId = (DWORD) -1;
/* Standard handle to retrieve. */
switch (type) {
@@ -1342,7 +1349,7 @@ TclWinOpenFileChannel(
}
}
- infoPtr = (FileInfo *) ckalloc((unsigned) sizeof(FileInfo));
+ infoPtr = ckalloc(sizeof(FileInfo));
/*
* TIP #218. Removed the code inserting the new structure into the global
@@ -1356,10 +1363,10 @@ TclWinOpenFileChannel(
infoPtr->flags = appendMode;
infoPtr->handle = handle;
infoPtr->dirty = 0;
- sprintf(channelName, "file%" TCL_I_MODIFIER "x", (size_t)infoPtr);
+ sprintf(channelName, "file%" TCL_I_MODIFIER "x", (size_t) infoPtr);
infoPtr->channel = Tcl_CreateChannel(&fileChannelType, channelName,
- (ClientData) infoPtr, permissions);
+ infoPtr, permissions);
/*
* Files have default translation of AUTO and ^Z eof char, which means
@@ -1433,7 +1440,7 @@ FileThreadActionProc(
int action)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
- FileInfo *infoPtr = (FileInfo *) instanceData;
+ FileInfo *infoPtr = instanceData;
if (action == TCL_CHANNEL_THREAD_INSERT) {
infoPtr->nextPtr = tsdPtr->firstFilePtr;
@@ -1518,12 +1525,11 @@ FileGetType(
* NativeIsComPort --
*
* Determines if a path refers to a Windows serial port.
- * A simple and efficient solution is to use a "name hint" to detect
- * COM ports by their filename instead of resorting to a syscall
+ * A simple and efficient solution is to use a "name hint" to detect
+ * COM ports by their filename instead of resorting to a syscall
* to detect serialness after the fact.
* The following patterns cover common serial port names:
- * COM[1-9]:?
- * //./COM[0-9]+
+ * COM[1-9]
* \\.\COM[0-9]+
*
* Results:
@@ -1536,94 +1542,39 @@ static int
NativeIsComPort(
const TCHAR *nativePath) /* Path of file to access, native encoding. */
{
+ const WCHAR *p = (const WCHAR *) nativePath;
+ int i, len = wcslen(p);
+
/*
- * Use wide-char or plain character case-insensitive comparison
+ * 1. Look for com[1-9]:?
*/
- if (tclWinProcs->useWide) {
- const WCHAR *p = (const WCHAR *) nativePath;
- int i, len = wcslen(p);
+ if ( (len == 4) && (_wcsnicmp(p, L"com", 3) == 0) ) {
/*
- * 1. Look for com[1-9]:?
- */
-
- if ( (len >= 4) && (len <= 5)
- && (_wcsnicmp(p, L"com", 3) == 0) ) {
- /*
- * The 4th character must be a digit 1..9 optionally followed by a ":"
- */
-
- if ( (p[3] < L'1') || (p[3] > L'9') ) {
- return 0;
- }
- if ( (len == 5) && (p[4] != L':') ) {
- return 0;
- }
- return 1;
- }
-
- /*
- * 2. Look for //./com[0-9]+ or \\.\com[0-9]+
- */
-
- if ( (len >= 8) && (
- (_wcsnicmp(p, L"//./com", 7) == 0)
- || (_wcsnicmp(p, L"\\\\.\\com", 7) == 0) ) )
- {
- /*
- * Charaters 8..end must be a digits 0..9
- */
+ * The 4th character must be a digit 1..9
+ */
- for ( i=7; i<len; i++ ) {
- if ( (p[i] < '0') || (p[i] > '9') ) {
- return 0;
- }
- }
- return 1;
+ if ( (p[3] < L'1') || (p[3] > L'9') ) {
+ return 0;
}
+ return 1;
+ }
- } else {
- const char *p = (const char *) nativePath;
- int i, len = strlen(p);
+ /*
+ * 2. Look for \\.\com[0-9]+
+ */
+ if ((len >= 8) && (_wcsnicmp(p, L"\\\\.\\com", 7) == 0)) {
/*
- * 1. Look for com[1-9]:?
- */
-
- if ( (len >= 4) && (len <= 5)
- && (strnicmp(p, "com", 3) == 0) ) {
- /*
- * The 4th character must be a digit 1..9 optionally followed by a ":"
- */
+ * Charaters 8..end must be a digits 0..9
+ */
- if ( (p[3] < '1') || (p[3] > '9') ) {
+ for ( i=7; i<len; i++ ) {
+ if ( (p[i] < '0') || (p[i] > '9') ) {
return 0;
}
- if ( (len == 5) && (p[4] != ':') ) {
- return 0;
- }
- return 1;
- }
-
- /*
- * 2. Look for //./com[0-9]+ or \\.\com[0-9]+
- */
-
- if ( (len >= 8) && (
- (strnicmp(p, "//./com", 7) == 0)
- || (strnicmp(p, "\\\\.\\com", 7) == 0) ) )
- {
- /*
- * Charaters 8..end must be a digits 0..9
- */
-
- for ( i=7; i<len; i++ ) {
- if ( (p[i] < '0') || (p[i] > '9') ) {
- return 0;
- }
- }
- return 1;
}
+ return 1;
}
return 0;
}
diff --git a/win/tclWinConsole.c b/win/tclWinConsole.c
index 361fb3d..ab55035 100644
--- a/win/tclWinConsole.c
+++ b/win/tclWinConsole.c
@@ -12,9 +12,6 @@
#include "tclWinInt.h"
-#include <fcntl.h>
-#include <io.h>
-
/*
* The following variable is used to tell whether this module has been
* initialized.
@@ -48,6 +45,23 @@ TCL_DECLARE_MUTEX(consoleMutex)
#define CONSOLE_BUFFER_SIZE (8*1024)
/*
+ * Structure containing handles associated with one of the special console
+ * threads.
+ */
+
+typedef struct ConsoleThreadInfo {
+ HANDLE thread; /* Handle to reader or writer thread. */
+ HANDLE readyEvent; /* Manual-reset event to signal _to_ the main
+ * thread when the worker thread has finished
+ * waiting for its normal work to happen. */
+ HANDLE startEvent; /* Auto-reset event used by the main thread to
+ * signal when the thread should attempt to do
+ * its normal work. */
+ HANDLE stopEvent; /* Auto-reset event used by the main thread to
+ * signal when the thread should exit. */
+} ConsoleThreadInfo;
+
+/*
* This structure describes per-instance data for a console based channel.
*/
@@ -66,24 +80,18 @@ typedef struct ConsoleInfo {
Tcl_ThreadId threadId; /* Thread to which events should be reported.
* This value is used by the reader/writer
* threads. */
- HANDLE writeThread; /* Handle to writer thread. */
- HANDLE readThread; /* Handle to reader thread. */
- HANDLE writable; /* Manual-reset event to signal when the
- * writer thread has finished waiting for the
- * current buffer to be written. */
- HANDLE readable; /* Manual-reset event to signal when the
- * reader thread has finished waiting for
- * input. */
- HANDLE startWriter; /* Auto-reset event used by the main thread to
- * signal when the writer thread should
- * attempt to write to the console. */
- HANDLE stopWriter; /* Auto-reset event used by the main thread to
- * signal when the writer thread should exit */
- HANDLE startReader; /* Auto-reset event used by the main thread to
- * signal when the reader thread should
- * attempt to read from the console. */
- HANDLE stopReader; /* Auto-reset event used by the main thread to
- * signal when the reader thread should exit */
+ ConsoleThreadInfo writer; /* A specialized thread for handling
+ * asynchronous writes to the console; the
+ * waiting starts when a start event is sent,
+ * and a reset event is sent back to the main
+ * thread when the write is done. A stop event
+ * is used to terminate the thread. */
+ ConsoleThreadInfo reader; /* A specialized thread for handling
+ * asynchronous reads from the console; the
+ * waiting starts when a start event is sent,
+ * and a reset event is sent back to the main
+ * thread when input is available. A stop
+ * event is used to terminate the thread. */
DWORD writeError; /* An error caused by the last background
* write. Set to 0 if no error has been
* detected. This word is shared with the
@@ -98,8 +106,8 @@ typedef struct ConsoleInfo {
int readFlags; /* Flags that are shared with the reader
* thread. Access is synchronized with the
* readable object. */
- int bytesRead; /* number of bytes in the buffer */
- int offset; /* number of bytes read out of the buffer */
+ int bytesRead; /* Number of bytes in the buffer. */
+ int offset; /* Number of bytes read out of the buffer. */
char buffer[CONSOLE_BUFFER_SIZE];
/* Data consumed by reader thread. */
} ConsoleInfo;
@@ -133,7 +141,8 @@ typedef struct ConsoleEvent {
* Declarations for functions used only in this file.
*/
-static int ConsoleBlockModeProc(ClientData instanceData,int mode);
+static int ConsoleBlockModeProc(ClientData instanceData,
+ int mode);
static void ConsoleCheckProc(ClientData clientData, int flags);
static int ConsoleCloseProc(ClientData instanceData,
Tcl_Interp *interp);
@@ -145,7 +154,7 @@ 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);
+ const char *buf, int toWrite, int *errorCode);
static DWORD WINAPI ConsoleReaderThread(LPVOID arg);
static void ConsoleSetupProc(ClientData clientData, int flags);
static void ConsoleWatchProc(ClientData instanceData, int mask);
@@ -154,13 +163,22 @@ static void ProcExitHandler(ClientData clientData);
static int WaitForRead(ConsoleInfo *infoPtr, int blocking);
static void ConsoleThreadActionProc(ClientData instanceData,
int action);
+static BOOL ReadConsoleBytes(HANDLE hConsole, LPVOID lpBuffer,
+ DWORD nbytes, LPDWORD nbytesread);
+static BOOL WriteConsoleBytes(HANDLE hConsole,
+ const void *lpBuffer, DWORD nbytes,
+ LPDWORD nbyteswritten);
+static void StartChannelThread(ConsoleInfo *infoPtr,
+ ConsoleThreadInfo *threadInfoPtr,
+ LPTHREAD_START_ROUTINE threadProc);
+static void StopChannelThread(ConsoleThreadInfo *threadInfoPtr);
/*
* This structure describes the channel type structure for command console
* based IO.
*/
-static Tcl_ChannelType consoleChannelType = {
+static const Tcl_ChannelType consoleChannelType = {
"console", /* Type name. */
TCL_CHANNEL_VERSION_5, /* v5 channel */
ConsoleCloseProc, /* Close proc. */
@@ -172,23 +190,27 @@ static Tcl_ChannelType consoleChannelType = {
ConsoleWatchProc, /* Set up notifier to watch the channel. */
ConsoleGetHandleProc, /* Get an OS handle from channel. */
NULL, /* close2proc. */
- ConsoleBlockModeProc, /* Set blocking or non-blocking mode.*/
- NULL, /* flush proc. */
- NULL, /* handler proc. */
- NULL, /* wide seek proc */
- ConsoleThreadActionProc, /* thread action proc */
- NULL, /* truncation */
+ ConsoleBlockModeProc, /* Set blocking or non-blocking mode. */
+ NULL, /* Flush proc. */
+ NULL, /* Handler proc. */
+ NULL, /* Wide seek proc. */
+ ConsoleThreadActionProc, /* Thread action proc. */
+ NULL /* Truncation proc. */
};
/*
*----------------------------------------------------------------------
*
- * readConsoleBytes, writeConsoleBytes --
- * Wrapper for ReadConsole{A,W}, that takes and returns number of bytes
- * instead of number of TCHARS
+ * ReadConsoleBytes, WriteConsoleBytes --
+ *
+ * Wrapper for ReadConsole{A,W}, that takes and returns number of bytes
+ * instead of number of TCHARS.
+ *
+ *----------------------------------------------------------------------
*/
+
static BOOL
-readConsoleBytes(
+ReadConsoleBytes(
HANDLE hConsole,
LPVOID lpBuffer,
DWORD nbytes,
@@ -196,30 +218,44 @@ readConsoleBytes(
{
DWORD ntchars;
BOOL result;
- int tcharsize;
- tcharsize = tclWinProcs->useWide? 2 : 1;
- result = tclWinProcs->readConsoleProc(
- hConsole, lpBuffer, nbytes / tcharsize, &ntchars, NULL);
- if (nbytesread)
- *nbytesread = (ntchars*tcharsize);
+ int tcharsize = sizeof(TCHAR);
+
+ /*
+ * If user types a Ctrl-Break or Ctrl-C, ReadConsole will return
+ * success with ntchars == 0 and GetLastError() will be
+ * ERROR_OPERATION_ABORTED. We do not want to treat this case
+ * as EOF so we will loop around again. If no Ctrl signal handlers
+ * have been established, the default signal OS handler in a separate
+ * thread will terminate the program. If a Ctrl signal handler
+ * has been established (through an extension for example), it
+ * will run and take whatever action it deems appropriate.
+ */
+ do {
+ result = ReadConsole(hConsole, lpBuffer, nbytes / tcharsize, &ntchars,
+ NULL);
+ } while (result && ntchars == 0 && GetLastError() == ERROR_OPERATION_ABORTED);
+ if (nbytesread != NULL) {
+ *nbytesread = ntchars * tcharsize;
+ }
return result;
}
static BOOL
-writeConsoleBytes(
+WriteConsoleBytes(
HANDLE hConsole,
- const VOID *lpBuffer,
+ const void *lpBuffer,
DWORD nbytes,
LPDWORD nbyteswritten)
{
DWORD ntchars;
BOOL result;
- int tcharsize;
- tcharsize = tclWinProcs->useWide? 2 : 1;
- result = tclWinProcs->writeConsoleProc(
- hConsole, lpBuffer, nbytes / tcharsize, &ntchars, NULL);
- if (nbyteswritten)
- *nbyteswritten = (ntchars*tcharsize);
+ int tcharsize = sizeof(TCHAR);
+
+ result = WriteConsole(hConsole, lpBuffer, nbytes / tcharsize, &ntchars,
+ NULL);
+ if (nbyteswritten != NULL) {
+ *nbyteswritten = ntchars * tcharsize;
+ }
return result;
}
@@ -242,8 +278,6 @@ writeConsoleBytes(
static void
ConsoleInit(void)
{
- ThreadSpecificData *tsdPtr;
-
/*
* Check the initialized flag first, then check again in the mutex. This
* is a speed enhancement.
@@ -258,9 +292,9 @@ ConsoleInit(void)
Tcl_MutexUnlock(&consoleMutex);
}
- tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
- if (tsdPtr == NULL) {
- tsdPtr = TCL_TSD_INIT(&dataKey);
+ if (TclThreadDataKeyGet(&dataKey) == NULL) {
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+
tsdPtr->firstConsolePtr = NULL;
Tcl_CreateEventSource(ConsoleSetupProc, ConsoleCheckProc, NULL);
Tcl_CreateThreadExitHandler(ConsoleExitHandler, NULL);
@@ -286,7 +320,7 @@ ConsoleInit(void)
static void
ConsoleExitHandler(
- ClientData clientData) /* Old window proc */
+ ClientData clientData) /* Old window proc. */
{
Tcl_DeleteEventSource(ConsoleSetupProc, ConsoleCheckProc, NULL);
}
@@ -310,7 +344,7 @@ ConsoleExitHandler(
static void
ProcExitHandler(
- ClientData clientData) /* Old window proc */
+ ClientData clientData) /* Old window proc. */
{
Tcl_MutexLock(&consoleMutex);
initialized = 0;
@@ -355,7 +389,8 @@ ConsoleSetupProc(
for (infoPtr = tsdPtr->firstConsolePtr; infoPtr != NULL;
infoPtr = infoPtr->nextPtr) {
if (infoPtr->watchMask & TCL_WRITABLE) {
- if (WaitForSingleObject(infoPtr->writable, 0) != WAIT_TIMEOUT) {
+ if (WaitForSingleObject(infoPtr->writer.readyEvent,
+ 0) != WAIT_TIMEOUT) {
block = 0;
}
}
@@ -393,7 +428,6 @@ ConsoleCheckProc(
int flags) /* Event flags as passed to Tcl_DoOneEvent. */
{
ConsoleInfo *infoPtr;
- ConsoleEvent *evPtr;
int needEvent;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
@@ -418,7 +452,8 @@ ConsoleCheckProc(
needEvent = 0;
if (infoPtr->watchMask & TCL_WRITABLE) {
- if (WaitForSingleObject(infoPtr->writable, 0) != WAIT_TIMEOUT) {
+ if (WaitForSingleObject(infoPtr->writer.readyEvent,
+ 0) != WAIT_TIMEOUT) {
needEvent = 1;
}
}
@@ -430,8 +465,9 @@ ConsoleCheckProc(
}
if (needEvent) {
+ ConsoleEvent *evPtr = ckalloc(sizeof(ConsoleEvent));
+
infoPtr->flags |= CONSOLE_PENDING;
- evPtr = (ConsoleEvent *) ckalloc(sizeof(ConsoleEvent));
evPtr->header.proc = ConsoleEventProc;
evPtr->infoPtr = infoPtr;
Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL);
@@ -439,7 +475,6 @@ ConsoleCheckProc(
}
}
-
/*
*----------------------------------------------------------------------
*
@@ -462,7 +497,7 @@ ConsoleBlockModeProc(
int mode) /* TCL_MODE_BLOCKING or
* TCL_MODE_NONBLOCKING. */
{
- ConsoleInfo *infoPtr = (ConsoleInfo *) instanceData;
+ ConsoleInfo *infoPtr = instanceData;
/*
* Consoles on Windows can not be switched between blocking and
@@ -475,7 +510,7 @@ ConsoleBlockModeProc(
if (mode == TCL_MODE_NONBLOCKING) {
infoPtr->flags |= CONSOLE_ASYNC;
} else {
- infoPtr->flags &= ~(CONSOLE_ASYNC);
+ infoPtr->flags &= ~CONSOLE_ASYNC;
}
return 0;
}
@@ -483,6 +518,84 @@ ConsoleBlockModeProc(
/*
*----------------------------------------------------------------------
*
+ * StartChannelThread, StopChannelThread --
+ *
+ * Helpers that codify how to ask one of the console service threads to
+ * start and stop.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+StartChannelThread(
+ ConsoleInfo *infoPtr,
+ ConsoleThreadInfo *threadInfoPtr,
+ LPTHREAD_START_ROUTINE threadProc)
+{
+ DWORD id;
+
+ threadInfoPtr->readyEvent = CreateEvent(NULL, TRUE, TRUE, NULL);
+ threadInfoPtr->startEvent = CreateEvent(NULL, FALSE, FALSE, NULL);
+ threadInfoPtr->stopEvent = CreateEvent(NULL, FALSE, FALSE, NULL);
+ threadInfoPtr->thread = CreateThread(NULL, 256, threadProc, infoPtr, 0,
+ &id);
+ SetThreadPriority(threadInfoPtr->thread, THREAD_PRIORITY_HIGHEST);
+}
+
+static void
+StopChannelThread(
+ ConsoleThreadInfo *threadInfoPtr)
+{
+ DWORD exitCode = 0;
+
+ /*
+ * The thread may already have closed on it's own. Check it's exit
+ * code.
+ */
+
+ GetExitCodeThread(threadInfoPtr->thread, &exitCode);
+ if (exitCode == STILL_ACTIVE) {
+ /*
+ * Set the stop event so that if the reader thread is blocked in
+ * ConsoleReaderThread on WaitForMultipleEvents, it will exit cleanly.
+ */
+
+ SetEvent(threadInfoPtr->stopEvent);
+
+ /*
+ * Wait at most 20 milliseconds for the reader thread to close.
+ */
+
+ if (WaitForSingleObject(threadInfoPtr->thread, 20) == WAIT_TIMEOUT) {
+ /*
+ * Forcibly terminate the background thread as a last resort.
+ * 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.
+ */
+
+ Tcl_MutexLock(&consoleMutex);
+ /* BUG: this leaks memory. */
+ TerminateThread(threadInfoPtr->thread, 0);
+ Tcl_MutexUnlock(&consoleMutex);
+ }
+ }
+
+ /*
+ * Close all the handles associated with the thread, and set the thread
+ * handle field to NULL to mark that the thread has been cleaned up.
+ */
+
+ CloseHandle(threadInfoPtr->thread);
+ CloseHandle(threadInfoPtr->readyEvent);
+ CloseHandle(threadInfoPtr->startEvent);
+ CloseHandle(threadInfoPtr->stopEvent);
+ threadInfoPtr->thread = NULL;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* ConsoleCloseProc --
*
* Closes a console based IO channel.
@@ -501,13 +614,10 @@ ConsoleCloseProc(
ClientData instanceData, /* Pointer to ConsoleInfo structure. */
Tcl_Interp *interp) /* For error reporting. */
{
- ConsoleInfo *consolePtr = (ConsoleInfo *) instanceData;
- int errorCode;
+ ConsoleInfo *consolePtr = instanceData;
+ int errorCode = 0;
ConsoleInfo *infoPtr, **nextPtrPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
- DWORD exitCode;
-
- errorCode = 0;
/*
* Clean up the background thread if necessary. Note that this must be
@@ -515,49 +625,8 @@ ConsoleCloseProc(
* trying to read from the console.
*/
- if (consolePtr->readThread) {
- /*
- * The thread may already have closed on it's own. Check it's exit
- * code.
- */
-
- GetExitCodeThread(consolePtr->readThread, &exitCode);
-
- if (exitCode == STILL_ACTIVE) {
- /*
- * Set the stop event so that if the reader thread is blocked in
- * ConsoleReaderThread on WaitForMultipleEvents, it will exit
- * cleanly.
- */
-
- SetEvent(consolePtr->stopReader);
-
- /*
- * Wait at most 20 milliseconds for the reader thread to close.
- */
-
- if (WaitForSingleObject(consolePtr->readThread, 20)
- == WAIT_TIMEOUT) {
- /*
- * Forcibly terminate the background thread as a last resort.
- * 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.
- */
-
- Tcl_MutexLock(&consoleMutex);
-
- /* BUG: this leaks memory. */
- TerminateThread(consolePtr->readThread, 0);
- Tcl_MutexUnlock(&consoleMutex);
- }
- }
-
- CloseHandle(consolePtr->readThread);
- CloseHandle(consolePtr->readable);
- CloseHandle(consolePtr->startReader);
- CloseHandle(consolePtr->stopReader);
- consolePtr->readThread = NULL;
+ if (consolePtr->reader.thread) {
+ StopChannelThread(&consolePtr->reader);
}
consolePtr->validMask &= ~TCL_READABLE;
@@ -567,62 +636,20 @@ ConsoleCloseProc(
* should be no pending write operations.
*/
- if (consolePtr->writeThread) {
+ if (consolePtr->writer.thread) {
if (consolePtr->toWrite) {
/*
* We only need to wait if there is something to write. This may
- * prevent infinite wait on exit. [python bug 216289]
- */
-
- WaitForSingleObject(consolePtr->writable, INFINITE);
- }
-
- /*
- * The thread may already have closed on it's own. Check it's exit
- * code.
- */
-
- GetExitCodeThread(consolePtr->writeThread, &exitCode);
-
- if (exitCode == STILL_ACTIVE) {
- /*
- * Set the stop event so that if the reader thread is blocked in
- * ConsoleWriterThread on WaitForMultipleEvents, it will exit
- * cleanly.
- */
-
- SetEvent(consolePtr->stopWriter);
-
- /*
- * Wait at most 20 milliseconds for the writer thread to close.
+ * prevent infinite wait on exit. [Python Bug 216289]
*/
- if (WaitForSingleObject(consolePtr->writeThread, 20)
- == WAIT_TIMEOUT) {
- /*
- * Forcibly terminate the background thread as a last resort.
- * 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.
- */
-
- Tcl_MutexLock(&consoleMutex);
-
- /* BUG: this leaks memory. */
- TerminateThread(consolePtr->writeThread, 0);
- Tcl_MutexUnlock(&consoleMutex);
- }
+ WaitForSingleObject(consolePtr->writer.readyEvent, INFINITE);
}
- CloseHandle(consolePtr->writeThread);
- CloseHandle(consolePtr->writable);
- CloseHandle(consolePtr->startWriter);
- CloseHandle(consolePtr->stopWriter);
- consolePtr->writeThread = NULL;
+ StopChannelThread(&consolePtr->writer);
}
consolePtr->validMask &= ~TCL_WRITABLE;
-
/*
* Don't close the Win32 handle if the handle is a standard channel during
* the thread exit process. Otherwise, one thread may kill the stdio of
@@ -648,7 +675,7 @@ ConsoleCloseProc(
for (nextPtrPtr = &(tsdPtr->firstConsolePtr), infoPtr = *nextPtrPtr;
infoPtr != NULL;
nextPtrPtr = &infoPtr->nextPtr, infoPtr = *nextPtrPtr) {
- if (infoPtr == (ConsoleInfo *)consolePtr) {
+ if (infoPtr == (ConsoleInfo *) consolePtr) {
*nextPtrPtr = infoPtr->nextPtr;
break;
}
@@ -657,7 +684,7 @@ ConsoleCloseProc(
ckfree(consolePtr->writeBuf);
consolePtr->writeBuf = 0;
}
- ckfree((char*) consolePtr);
+ ckfree(consolePtr);
return errorCode;
}
@@ -688,7 +715,7 @@ ConsoleInputProc(
* buffer? */
int *errorCode) /* Where to store error code. */
{
- ConsoleInfo *infoPtr = (ConsoleInfo *) instanceData;
+ ConsoleInfo *infoPtr = instanceData;
DWORD count, bytesRead = 0;
int result;
@@ -723,7 +750,7 @@ ConsoleInputProc(
bytesRead = infoPtr->bytesRead - infoPtr->offset;
/*
- * Reset the buffer
+ * Reset the buffer.
*/
infoPtr->readFlags &= ~CONSOLE_BUFFERED;
@@ -739,8 +766,15 @@ ConsoleInputProc(
* byte is available or an EOF occurs.
*/
- if (readConsoleBytes(infoPtr->handle, (LPVOID) buf, (DWORD) bufSize, &count)
- == TRUE) {
+ if (ReadConsoleBytes(infoPtr->handle, (LPVOID) buf, (DWORD) bufSize,
+ &count) == TRUE) {
+ /*
+ * TODO: This potentially writes beyond the limits specified
+ * by the caller. In practice this is harmless, since all writes
+ * are into ChannelBuffers, and those have padding, but still
+ * ought to remove this, unless some Windows wizard can give
+ * a reason not to.
+ */
buf[count] = '\0';
return count;
}
@@ -769,22 +803,23 @@ ConsoleInputProc(
static int
ConsoleOutputProc(
ClientData instanceData, /* Console state. */
- CONST char *buf, /* The data buffer. */
+ const char *buf, /* The data buffer. */
int toWrite, /* How many bytes to write? */
int *errorCode) /* Where to store error code. */
{
- ConsoleInfo *infoPtr = (ConsoleInfo *) instanceData;
+ ConsoleInfo *infoPtr = instanceData;
+ ConsoleThreadInfo *threadInfo = &infoPtr->reader;
DWORD bytesWritten, timeout;
*errorCode = 0;
timeout = (infoPtr->flags & CONSOLE_ASYNC) ? 0 : INFINITE;
- if (WaitForSingleObject(infoPtr->writable, timeout) == WAIT_TIMEOUT) {
+ if (WaitForSingleObject(threadInfo->readyEvent,timeout) == WAIT_TIMEOUT) {
/*
* The writer thread is blocked waiting for a write to complete and
* the channel is in non-blocking mode.
*/
- errno = EAGAIN;
+ errno = EWOULDBLOCK;
goto error;
}
@@ -813,12 +848,12 @@ ConsoleOutputProc(
ckfree(infoPtr->writeBuf);
}
infoPtr->writeBufLen = toWrite;
- infoPtr->writeBuf = ckalloc((size_t)toWrite);
+ infoPtr->writeBuf = ckalloc(toWrite);
}
- memcpy(infoPtr->writeBuf, buf, (size_t)toWrite);
+ memcpy(infoPtr->writeBuf, buf, (size_t) toWrite);
infoPtr->toWrite = toWrite;
- ResetEvent(infoPtr->writable);
- SetEvent(infoPtr->startWriter);
+ ResetEvent(threadInfo->readyEvent);
+ SetEvent(threadInfo->startEvent);
bytesWritten = toWrite;
} else {
/*
@@ -826,9 +861,8 @@ ConsoleOutputProc(
* avoids an unnecessary copy.
*/
- if (writeConsoleBytes(infoPtr->handle, buf, (DWORD)toWrite,
- &bytesWritten)
- == FALSE) {
+ if (WriteConsoleBytes(infoPtr->handle, buf, (DWORD) toWrite,
+ &bytesWritten) == FALSE) {
TclWinConvertError(GetLastError());
goto error;
}
@@ -867,7 +901,7 @@ ConsoleEventProc(
int flags) /* Flags that indicate what events to handle,
* such as TCL_FILE_EVENTS. */
{
- ConsoleEvent *consoleEvPtr = (ConsoleEvent *)evPtr;
+ ConsoleEvent *consoleEvPtr = (ConsoleEvent *) evPtr;
ConsoleInfo *infoPtr;
int mask;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
@@ -886,7 +920,7 @@ ConsoleEventProc(
for (infoPtr = tsdPtr->firstConsolePtr; infoPtr != NULL;
infoPtr = infoPtr->nextPtr) {
if (consoleEvPtr->infoPtr == infoPtr) {
- infoPtr->flags &= ~(CONSOLE_PENDING);
+ infoPtr->flags &= ~CONSOLE_PENDING;
break;
}
}
@@ -907,7 +941,8 @@ ConsoleEventProc(
mask = 0;
if (infoPtr->watchMask & TCL_WRITABLE) {
- if (WaitForSingleObject(infoPtr->writable, 0) != WAIT_TIMEOUT) {
+ if (WaitForSingleObject(infoPtr->writer.readyEvent,
+ 0) != WAIT_TIMEOUT) {
mask = TCL_WRITABLE;
}
}
@@ -954,7 +989,7 @@ ConsoleWatchProc(
* TCL_EXCEPTION. */
{
ConsoleInfo **nextPtrPtr, *ptr;
- ConsoleInfo *infoPtr = (ConsoleInfo *) instanceData;
+ ConsoleInfo *infoPtr = instanceData;
int oldMask = infoPtr->watchMask;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
@@ -966,6 +1001,7 @@ ConsoleWatchProc(
infoPtr->watchMask = mask & infoPtr->validMask;
if (infoPtr->watchMask) {
Tcl_Time blockTime = { 0, 0 };
+
if (!oldMask) {
infoPtr->nextPtr = tsdPtr->firstConsolePtr;
tsdPtr->firstConsolePtr = infoPtr;
@@ -1008,12 +1044,12 @@ ConsoleWatchProc(
static int
ConsoleGetHandleProc(
ClientData instanceData, /* The console state. */
- int direction, /* TCL_READABLE or TCL_WRITABLE */
+ int direction, /* TCL_READABLE or TCL_WRITABLE. */
ClientData *handlePtr) /* Where to store the handle. */
{
- ConsoleInfo *infoPtr = (ConsoleInfo *) instanceData;
+ ConsoleInfo *infoPtr = instanceData;
- *handlePtr = (ClientData) infoPtr->handle;
+ *handlePtr = infoPtr->handle;
return TCL_OK;
}
@@ -1046,6 +1082,7 @@ WaitForRead(
{
DWORD timeout, count;
HANDLE *handle = infoPtr->handle;
+ ConsoleThreadInfo *threadInfo = &infoPtr->reader;
INPUT_RECORD input;
while (1) {
@@ -1054,13 +1091,14 @@ WaitForRead(
*/
timeout = blocking ? INFINITE : 0;
- if (WaitForSingleObject(infoPtr->readable, timeout) == WAIT_TIMEOUT) {
+ if (WaitForSingleObject(threadInfo->readyEvent,
+ timeout) == WAIT_TIMEOUT) {
/*
* The reader thread is blocked waiting for data and the channel
* is in non-blocking mode.
*/
- errno = EAGAIN;
+ errno = EWOULDBLOCK;
return -1;
}
@@ -1113,8 +1151,8 @@ WaitForRead(
* There wasn't any data available, so reset the thread and try again.
*/
- ResetEvent(infoPtr->readable);
- SetEvent(infoPtr->startReader);
+ ResetEvent(threadInfo->readyEvent);
+ SetEvent(threadInfo->startEvent);
}
}
@@ -1141,14 +1179,18 @@ static DWORD WINAPI
ConsoleReaderThread(
LPVOID arg)
{
- ConsoleInfo *infoPtr = (ConsoleInfo *)arg;
+ ConsoleInfo *infoPtr = arg;
HANDLE *handle = infoPtr->handle;
+ ConsoleThreadInfo *threadInfo = &infoPtr->reader;
DWORD waitResult;
HANDLE wEvents[2];
- /* The first event takes precedence. */
- wEvents[0] = infoPtr->stopReader;
- wEvents[1] = infoPtr->startReader;
+ /*
+ * The first event takes precedence.
+ */
+
+ wEvents[0] = threadInfo->stopEvent;
+ wEvents[1] = threadInfo->startEvent;
for (;;) {
/*
@@ -1171,7 +1213,7 @@ ConsoleReaderThread(
* not KEY_EVENTs.
*/
- if (readConsoleBytes(handle, infoPtr->buffer, CONSOLE_BUFFER_SIZE,
+ if (ReadConsoleBytes(handle, infoPtr->buffer, CONSOLE_BUFFER_SIZE,
(LPDWORD) &infoPtr->bytesRead) != FALSE) {
/*
* Data was stored in the buffer.
@@ -1179,10 +1221,9 @@ ConsoleReaderThread(
infoPtr->readFlags |= CONSOLE_BUFFERED;
} else {
- DWORD err;
- err = GetLastError();
+ DWORD err = GetLastError();
- if (err == (DWORD)EOF) {
+ if (err == (DWORD) EOF) {
infoPtr->readFlags = CONSOLE_EOF;
}
}
@@ -1192,7 +1233,7 @@ ConsoleReaderThread(
* waking up the notifier thread.
*/
- SetEvent(infoPtr->readable);
+ SetEvent(threadInfo->readyEvent);
/*
* Alert the foreground thread. Note that we need to treat this like a
@@ -1206,6 +1247,7 @@ ConsoleReaderThread(
* TIP #218. When in flight ignore the event, no one will receive
* it anyway.
*/
+
Tcl_ThreadAlert(infoPtr->threadId);
}
Tcl_MutexUnlock(&consoleMutex);
@@ -1237,16 +1279,19 @@ static DWORD WINAPI
ConsoleWriterThread(
LPVOID arg)
{
-
- ConsoleInfo *infoPtr = (ConsoleInfo *)arg;
+ ConsoleInfo *infoPtr = arg;
HANDLE *handle = infoPtr->handle;
+ ConsoleThreadInfo *threadInfo = &infoPtr->writer;
DWORD count, toWrite, waitResult;
char *buf;
HANDLE wEvents[2];
- /* The first event takes precedence. */
- wEvents[0] = infoPtr->stopWriter;
- wEvents[1] = infoPtr->startWriter;
+ /*
+ * The first event takes precedence.
+ */
+
+ wEvents[0] = threadInfo->stopEvent;
+ wEvents[1] = threadInfo->startEvent;
for (;;) {
/*
@@ -1272,14 +1317,13 @@ ConsoleWriterThread(
*/
while (toWrite > 0) {
- if (writeConsoleBytes(handle, buf, (DWORD)toWrite,
- &count) == FALSE) {
+ if (WriteConsoleBytes(handle, buf, (DWORD) toWrite,
+ &count) == FALSE) {
infoPtr->writeError = GetLastError();
break;
- } else {
- toWrite -= count;
- buf += count;
}
+ toWrite -= count;
+ buf += count;
}
/*
@@ -1287,7 +1331,7 @@ ConsoleWriterThread(
* waking up the notifier thread.
*/
- SetEvent(infoPtr->writable);
+ SetEvent(threadInfo->readyEvent);
/*
* Alert the foreground thread. Note that we need to treat this like a
@@ -1323,7 +1367,7 @@ ConsoleWriterThread(
* Returns the new channel, or NULL.
*
* Side effects:
- * May open the channel
+ * May open the channel.
*
*----------------------------------------------------------------------
*/
@@ -1336,7 +1380,7 @@ TclWinOpenConsoleChannel(
{
char encoding[4 + TCL_INTEGER_SPACE];
ConsoleInfo *infoPtr;
- DWORD id, modes;
+ DWORD modes;
ConsoleInit();
@@ -1344,7 +1388,7 @@ TclWinOpenConsoleChannel(
* See if a channel with this handle already exists.
*/
- infoPtr = (ConsoleInfo *) ckalloc((unsigned) sizeof(ConsoleInfo));
+ infoPtr = ckalloc(sizeof(ConsoleInfo));
memset(infoPtr, 0, sizeof(ConsoleInfo));
infoPtr->validMask = permissions;
@@ -1361,10 +1405,10 @@ TclWinOpenConsoleChannel(
* for instance).
*/
- sprintf(channelName, "file%" TCL_I_MODIFIER "x", (size_t)infoPtr);
+ sprintf(channelName, "file%" TCL_I_MODIFIER "x", (size_t) infoPtr);
infoPtr->channel = Tcl_CreateChannel(&consoleChannelType, channelName,
- (ClientData) infoPtr, permissions);
+ infoPtr, permissions);
if (permissions & TCL_READABLE) {
/*
@@ -1377,22 +1421,11 @@ TclWinOpenConsoleChannel(
modes &= ~(ENABLE_WINDOW_INPUT | ENABLE_MOUSE_INPUT);
modes |= ENABLE_LINE_INPUT;
SetConsoleMode(infoPtr->handle, modes);
-
- infoPtr->readable = CreateEvent(NULL, TRUE, TRUE, NULL);
- infoPtr->startReader = CreateEvent(NULL, FALSE, FALSE, NULL);
- infoPtr->stopReader = CreateEvent(NULL, FALSE, FALSE, NULL);
- infoPtr->readThread = CreateThread(NULL, 256, ConsoleReaderThread,
- infoPtr, 0, &id);
- SetThreadPriority(infoPtr->readThread, THREAD_PRIORITY_HIGHEST);
+ StartChannelThread(infoPtr, &infoPtr->reader, ConsoleReaderThread);
}
if (permissions & TCL_WRITABLE) {
- infoPtr->writable = CreateEvent(NULL, TRUE, TRUE, NULL);
- infoPtr->startWriter = CreateEvent(NULL, FALSE, FALSE, NULL);
- infoPtr->stopWriter = CreateEvent(NULL, FALSE, FALSE, NULL);
- infoPtr->writeThread = CreateThread(NULL, 256, ConsoleWriterThread,
- infoPtr, 0, &id);
- SetThreadPriority(infoPtr->writeThread, THREAD_PRIORITY_HIGHEST);
+ StartChannelThread(infoPtr, &infoPtr->writer, ConsoleWriterThread);
}
/*
@@ -1402,11 +1435,11 @@ TclWinOpenConsoleChannel(
Tcl_SetChannelOption(NULL, infoPtr->channel, "-translation", "auto");
Tcl_SetChannelOption(NULL, infoPtr->channel, "-eofchar", "\032 {}");
- if (tclWinProcs->useWide)
- Tcl_SetChannelOption(NULL, infoPtr->channel, "-encoding", "unicode");
- else
- Tcl_SetChannelOption(NULL, infoPtr->channel, "-encoding", encoding);
-
+#ifdef UNICODE
+ Tcl_SetChannelOption(NULL, infoPtr->channel, "-encoding", "unicode");
+#else
+ Tcl_SetChannelOption(NULL, infoPtr->channel, "-encoding", encoding);
+#endif
return infoPtr->channel;
}
@@ -1431,9 +1464,10 @@ ConsoleThreadActionProc(
ClientData instanceData,
int action)
{
- ConsoleInfo *infoPtr = (ConsoleInfo *) instanceData;
+ ConsoleInfo *infoPtr = instanceData;
- /* We do not access firstConsolePtr in the thread structures. This is not
+ /*
+ * We do not access firstConsolePtr in the thread structures. This is not
* for all serials managed by the thread, but only those we are watching.
* Removal of the filevent handlers before transfer thus takes care of
* this structure.
diff --git a/win/tclWinDde.c b/win/tclWinDde.c
index eef5caa..ce0b413 100644
--- a/win/tclWinDde.c
+++ b/win/tclWinDde.c
@@ -10,11 +10,29 @@
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
+#undef STATIC_BUILD
+#ifndef USE_TCL_STUBS
+# define USE_TCL_STUBS
+#endif
#include "tclInt.h"
-#include "tclPort.h"
#include <dde.h>
#include <ddeml.h>
+#ifndef UNICODE
+# undef CP_WINUNICODE
+# define CP_WINUNICODE CP_WINANSI
+# undef Tcl_WinTCharToUtf
+# define Tcl_WinTCharToUtf(a,b,c) Tcl_ExternalToUtfDString(NULL,a,b,c)
+# undef Tcl_WinUtfToTChar
+# define Tcl_WinUtfToTChar(a,b,c) Tcl_UtfToExternalDString(NULL,a,b,c)
+#endif
+
+#if !defined(NDEBUG)
+ /* test POKE server Implemented for debug mode only */
+# undef CBF_FAIL_POKES
+# define CBF_FAIL_POKES 0
+#endif
+
/*
* TCL_STORAGE_CLASS is set unconditionally to DLLEXPORT because the Dde_Init
* declaration is in the source file itself, which is only accessed when we
@@ -34,7 +52,7 @@ typedef struct RegisteredInterp {
struct RegisteredInterp *nextPtr;
/* The next interp this application knows
* about. */
- char *name; /* Interpreter's name (malloc-ed). */
+ TCHAR *name; /* Interpreter's name (malloc-ed). */
Tcl_Obj *handlerPtr; /* The server handler command */
Tcl_Interp *interp; /* The interpreter attached to this name. */
} RegisteredInterp;
@@ -79,9 +97,10 @@ static DWORD ddeInstance; /* The application instance handle given to us
* by DdeInitialize. */
static int ddeIsServer = 0;
+#define TCL_DDE_VERSION "1.4.0"
#define TCL_DDE_PACKAGE_NAME "dde"
-#define TCL_DDE_SERVICE_NAME "TclEval"
-#define TCL_DDE_EXECUTE_RESULT "$TCLEVAL$EXECUTE$RESULT"
+#define TCL_DDE_SERVICE_NAME TEXT("TclEval")
+#define TCL_DDE_EXECUTE_RESULT TEXT("$TCLEVAL$EXECUTE$RESULT")
#define DDE_FLAG_ASYNC 1
#define DDE_FLAG_BINARY 2
@@ -100,7 +119,7 @@ static BOOL CALLBACK DdeEnumWindowsCallback(HWND hwndTarget,
LPARAM lParam);
static void DdeExitProc(ClientData clientData);
static int DdeGetServicesList(Tcl_Interp *interp,
- const char *serviceName, const char *topicName);
+ const TCHAR *serviceName, const TCHAR *topicName);
static HDDEDATA CALLBACK DdeServerProc(UINT uType, UINT uFmt, HCONV hConv,
HSZ ddeTopic, HSZ ddeItem, HDDEDATA hData,
DWORD dwData1, DWORD dwData2);
@@ -110,7 +129,7 @@ static void DeleteProc(ClientData clientData);
static Tcl_Obj * ExecuteRemoteObject(RegisteredInterp *riPtr,
Tcl_Obj *ddeObjectPtr);
static int MakeDdeConnection(Tcl_Interp *interp,
- const char *name, HCONV *ddeConvPtr);
+ const TCHAR *name, HCONV *ddeConvPtr);
static void SetDdeError(Tcl_Interp *interp);
static int DdeObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
@@ -143,9 +162,16 @@ Dde_Init(
return TCL_ERROR;
}
+#ifdef UNICODE
+ if (TclWinGetPlatformId() < VER_PLATFORM_WIN32_NT) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "Win32s and Windows 9x are not supported platforms", -1));
+ return TCL_ERROR;
+ }
+#endif
Tcl_CreateObjCommand(interp, "dde", DdeObjCmd, NULL, NULL);
Tcl_CreateExitHandler(DdeExitProc, NULL);
- return Tcl_PkgProvide(interp, TCL_DDE_PACKAGE_NAME, "1.3.3");
+ return Tcl_PkgProvide(interp, TCL_DDE_PACKAGE_NAME, TCL_DDE_VERSION);
}
/*
@@ -229,7 +255,7 @@ Initialize(void)
ddeIsServer = 1;
Tcl_CreateExitHandler(DdeExitProc, NULL);
ddeServiceGlobal = DdeCreateStringHandle(ddeInstance,
- TCL_DDE_SERVICE_NAME, 0);
+ TCL_DDE_SERVICE_NAME, CP_WINUNICODE);
DdeNameService(ddeInstance, ddeServiceGlobal, 0L, DNS_REGISTER);
} else {
ddeIsServer = 0;
@@ -263,10 +289,10 @@ Initialize(void)
*----------------------------------------------------------------------
*/
-static const char *
+static const TCHAR *
DdeSetServerName(
Tcl_Interp *interp,
- const char *name, /* The name that will be used to refer to the
+ const TCHAR *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 */
@@ -276,7 +302,7 @@ DdeSetServerName(
int suffix, offset;
RegisteredInterp *riPtr, *prevPtr;
Tcl_DString dString;
- const char *actualName;
+ const TCHAR *actualName;
Tcl_Obj *srvListPtr = NULL, **srvPtrPtr = NULL;
int n, srvCount = 0, lastSuffix, r = TCL_OK;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
@@ -314,7 +340,7 @@ DdeSetServerName(
* current interp, but it doesn't have a name.
*/
- return "";
+ return TEXT("");
}
/*
@@ -335,7 +361,9 @@ DdeSetServerName(
&srvPtrPtr);
}
if (r != TCL_OK) {
- OutputDebugString(Tcl_GetStringResult(interp));
+ Tcl_WinUtfToTChar(Tcl_GetStringResult(interp), -1, &dString);
+ OutputDebugString((TCHAR *) Tcl_DStringValue(&dString));
+ Tcl_DStringFree(&dString);
return NULL;
}
@@ -352,13 +380,14 @@ DdeSetServerName(
lastSuffix = suffix;
if (suffix > 1) {
if (suffix == 2) {
- Tcl_DStringAppend(&dString, name, -1);
- Tcl_DStringAppend(&dString, " #", 2);
+ Tcl_DStringAppend(&dString, (char *)name, _tcslen(name) * sizeof(TCHAR));
+ Tcl_DStringAppend(&dString, (char *)TEXT(" #"), 2 * sizeof(TCHAR));
offset = Tcl_DStringLength(&dString);
- Tcl_DStringSetLength(&dString, offset + TCL_INTEGER_SPACE);
- actualName = Tcl_DStringValue(&dString);
+ Tcl_DStringSetLength(&dString, offset + sizeof(TCHAR) * TCL_INTEGER_SPACE);
+ actualName = (TCHAR *) Tcl_DStringValue(&dString);
}
- sprintf(Tcl_DStringValue(&dString) + offset, "%d", suffix);
+ _sntprintf((TCHAR *) (Tcl_DStringValue(&dString) + offset),
+ TCL_INTEGER_SPACE, TEXT("%d"), suffix);
}
/*
@@ -367,39 +396,41 @@ DdeSetServerName(
for (n = 0; n < srvCount; ++n) {
Tcl_Obj* namePtr;
+ Tcl_DString ds;
Tcl_ListObjIndex(interp, srvPtrPtr[n], 1, &namePtr);
- if (strcmp(actualName, Tcl_GetString(namePtr)) == 0) {
+ Tcl_WinUtfToTChar(Tcl_GetString(namePtr), -1, &ds);
+ if (_tcscmp(actualName, (TCHAR *)Tcl_DStringValue(&ds)) == 0) {
suffix++;
+ Tcl_DStringFree(&ds);
break;
}
+ Tcl_DStringFree(&ds);
}
}
- Tcl_DStringSetLength(&dString,
- offset + (int)strlen(Tcl_DStringValue(&dString)+offset));
}
/*
* We have found a unique name. Now add it to the registry.
*/
- riPtr = (RegisteredInterp *) ckalloc(sizeof(RegisteredInterp));
+ riPtr = ckalloc(sizeof(RegisteredInterp));
riPtr->interp = interp;
- riPtr->name = ckalloc((unsigned int) strlen(actualName) + 1);
+ riPtr->name = ckalloc((_tcslen(actualName) + 1) * sizeof(TCHAR));
riPtr->nextPtr = tsdPtr->interpListPtr;
riPtr->handlerPtr = handlerPtr;
if (riPtr->handlerPtr != NULL) {
Tcl_IncrRefCount(riPtr->handlerPtr);
}
tsdPtr->interpListPtr = riPtr;
- strcpy(riPtr->name, actualName);
+ _tcscpy(riPtr->name, actualName);
if (Tcl_IsSafe(interp)) {
Tcl_ExposeCommand(interp, "dde", "dde");
}
Tcl_CreateObjCommand(interp, "dde", DdeObjCmd,
- (ClientData) riPtr, DeleteProc);
+ riPtr, DeleteProc);
if (Tcl_IsSafe(interp)) {
Tcl_HideCommand(interp, "dde", "dde");
}
@@ -528,6 +559,7 @@ ExecuteRemoteObject(
Tcl_SetObjResult(riPtr->interp, Tcl_NewStringObj("permission denied: "
"a handler procedure must be defined for use in a safe "
"interp", -1));
+ Tcl_SetErrorCode(riPtr->interp, "TCL", "DDE", "SECURITY_CHECK", NULL);
result = TCL_ERROR;
}
@@ -607,7 +639,7 @@ DdeServerProc(
Tcl_DString dString;
int len;
DWORD dlen;
- char *utilString;
+ TCHAR *utilString;
Tcl_Obj *ddeObjectPtr;
HDDEDATA ddeReturn = NULL;
RegisteredInterp *riPtr;
@@ -621,16 +653,16 @@ DdeServerProc(
* sure we have a valid topic.
*/
- len = DdeQueryString(ddeInstance, ddeTopic, NULL, 0, 0);
+ len = DdeQueryString(ddeInstance, ddeTopic, NULL, 0, CP_WINUNICODE);
Tcl_DStringInit(&dString);
- Tcl_DStringSetLength(&dString, len);
- utilString = Tcl_DStringValue(&dString);
+ Tcl_DStringSetLength(&dString, (len + 1) * sizeof(TCHAR) - 1);
+ utilString = (TCHAR *) Tcl_DStringValue(&dString);
DdeQueryString(ddeInstance, ddeTopic, utilString, (DWORD) len + 1,
- CP_WINANSI);
+ CP_WINUNICODE);
for (riPtr = tsdPtr->interpListPtr; riPtr != NULL;
riPtr = riPtr->nextPtr) {
- if (stricmp(utilString, riPtr->name) == 0) {
+ if (_tcsicmp(utilString, riPtr->name) == 0) {
Tcl_DStringFree(&dString);
return (HDDEDATA) TRUE;
}
@@ -646,16 +678,16 @@ DdeServerProc(
* result to return in an XTYP_REQUEST.
*/
- len = DdeQueryString(ddeInstance, ddeTopic, NULL, 0, 0);
+ len = DdeQueryString(ddeInstance, ddeTopic, NULL, 0, CP_WINUNICODE);
Tcl_DStringInit(&dString);
- Tcl_DStringSetLength(&dString, len);
- utilString = Tcl_DStringValue(&dString);
+ Tcl_DStringSetLength(&dString, (len + 1) * sizeof(TCHAR) - 1);
+ utilString = (TCHAR *) Tcl_DStringValue(&dString);
DdeQueryString(ddeInstance, ddeTopic, utilString, (DWORD) len + 1,
- CP_WINANSI);
+ CP_WINUNICODE);
for (riPtr = tsdPtr->interpListPtr; riPtr != NULL;
riPtr = riPtr->nextPtr) {
- if (stricmp(riPtr->name, utilString) == 0) {
- convPtr = (Conversation *) ckalloc(sizeof(Conversation));
+ if (_tcsicmp(riPtr->name, utilString) == 0) {
+ convPtr = ckalloc(sizeof(Conversation));
convPtr->nextPtr = tsdPtr->currentConversations;
convPtr->returnPackagePtr = NULL;
convPtr->hConv = hConv;
@@ -685,7 +717,7 @@ DdeServerProc(
if (convPtr->returnPackagePtr != NULL) {
Tcl_DecrRefCount(convPtr->returnPackagePtr);
}
- ckfree((char *) convPtr);
+ ckfree(convPtr);
break;
}
}
@@ -713,20 +745,20 @@ DdeServerProc(
if (convPtr != NULL) {
char *returnString;
- len = DdeQueryString(ddeInstance, ddeItem, NULL, 0, CP_WINANSI);
+ len = DdeQueryString(ddeInstance, ddeItem, NULL, 0, CP_WINUNICODE);
Tcl_DStringInit(&dString);
- Tcl_DStringSetLength(&dString, len);
- utilString = Tcl_DStringValue(&dString);
+ Tcl_DStringSetLength(&dString, (len + 1) * sizeof(TCHAR) - 1);
+ utilString = (TCHAR *) Tcl_DStringValue(&dString);
DdeQueryString(ddeInstance, ddeItem, utilString, (DWORD) len + 1,
- CP_WINANSI);
- if (stricmp(utilString, TCL_DDE_EXECUTE_RESULT) == 0) {
+ CP_WINUNICODE);
+ if (_tcsicmp(utilString, TCL_DDE_EXECUTE_RESULT) == 0) {
if (uFmt == CF_TEXT) {
returnString =
Tcl_GetStringFromObj(convPtr->returnPackagePtr, &len);
} else {
returnString = (char *)
Tcl_GetUnicodeFromObj(convPtr->returnPackagePtr, &len);
- len = 2 * len + 1;
+ len = sizeof(TCHAR) * len + 1;
}
ddeReturn = DdeCreateDataHandle(ddeInstance, (BYTE *)returnString,
(DWORD) len+1, 0, ddeItem, uFmt, 0);
@@ -734,8 +766,11 @@ DdeServerProc(
if (Tcl_IsSafe(convPtr->riPtr->interp)) {
ddeReturn = NULL;
} else {
- Tcl_Obj *variableObjPtr = Tcl_GetVar2Ex(
- convPtr->riPtr->interp, utilString, NULL,
+ Tcl_DString ds;
+ Tcl_Obj *variableObjPtr;
+ Tcl_WinTCharToUtf(utilString, -1, &ds);
+ variableObjPtr = Tcl_GetVar2Ex(
+ convPtr->riPtr->interp, Tcl_DStringValue(&ds), NULL,
TCL_GLOBAL_ONLY);
if (variableObjPtr != NULL) {
if (uFmt == CF_TEXT) {
@@ -744,7 +779,7 @@ DdeServerProc(
} else {
returnString = (char *) Tcl_GetUnicodeFromObj(
variableObjPtr, &len);
- len = 2 * len + 1;
+ len = sizeof(TCHAR) * len + 1;
}
ddeReturn = DdeCreateDataHandle(ddeInstance,
(BYTE *)returnString, (DWORD) len+1, 0, ddeItem,
@@ -752,12 +787,60 @@ DdeServerProc(
} else {
ddeReturn = NULL;
}
+ Tcl_DStringFree(&ds);
}
}
Tcl_DStringFree(&dString);
}
return ddeReturn;
+#if !CBF_FAIL_POKES
+ case XTYP_POKE:
+ /*
+ * This is a poke for a Tcl variable, only implemented in
+ * debug/UNICODE mode.
+ */
+ ddeReturn = DDE_FNOTPROCESSED;
+
+ if ((uFmt != CF_TEXT) && (uFmt != CF_UNICODETEXT)) {
+ return ddeReturn;
+ }
+
+ for (convPtr = tsdPtr->currentConversations; (convPtr != NULL)
+ && (convPtr->hConv != hConv); convPtr = convPtr->nextPtr) {
+ /*
+ * Empty loop body.
+ */
+ }
+
+ if (convPtr && !Tcl_IsSafe(convPtr->riPtr->interp)) {
+ Tcl_DString ds;
+ Tcl_Obj *variableObjPtr;
+
+ len = DdeQueryString(ddeInstance, ddeItem, NULL, 0, CP_WINUNICODE);
+ Tcl_DStringInit(&dString);
+ Tcl_DStringSetLength(&dString, (len + 1) * sizeof(TCHAR) - 1);
+ utilString = (TCHAR *) Tcl_DStringValue(&dString);
+ DdeQueryString(ddeInstance, ddeItem, utilString, (DWORD) len + 1,
+ CP_WINUNICODE);
+ Tcl_WinTCharToUtf(utilString, -1, &ds);
+ utilString = (TCHAR *) DdeAccessData(hData, &dlen);
+ if (uFmt == CF_TEXT) {
+ variableObjPtr = Tcl_NewStringObj((char *)utilString, -1);
+ } else {
+ variableObjPtr = Tcl_NewUnicodeObj(utilString, -1);
+ }
+
+ Tcl_SetVar2Ex(convPtr->riPtr->interp, Tcl_DStringValue(&ds), NULL,
+ variableObjPtr, TCL_GLOBAL_ONLY);
+
+ Tcl_DStringFree(&ds);
+ Tcl_DStringFree(&dString);
+ ddeReturn = (HDDEDATA) DDE_FACK;
+ }
+ return ddeReturn;
+
+#endif
case XTYP_EXECUTE: {
/*
* Execute this script. The results will be saved into a list object
@@ -765,7 +848,7 @@ DdeServerProc(
*/
Tcl_Obj *returnPackagePtr;
- Tcl_UniChar *uniStr;
+ char *string;
for (convPtr = tsdPtr->currentConversations; (convPtr != NULL)
&& (convPtr->hConv != hConv); convPtr = convPtr->nextPtr) {
@@ -778,21 +861,21 @@ DdeServerProc(
return (HDDEDATA) DDE_FNOTPROCESSED;
}
- utilString = (char *) DdeAccessData(hData, &dlen);
- uniStr = (Tcl_UniChar *) utilString;
+ utilString = (TCHAR *) DdeAccessData(hData, &dlen);
+ string = (char *) utilString;
if (!dlen) {
/* Empty binary array. */
ddeObjectPtr = Tcl_NewObj();
- } else if ((dlen & 1) || uniStr[(dlen>>1)-1]) {
+ } else if ((dlen & 1) || utilString[(dlen>>1)-1]) {
/* Cannot be unicode, so assume utf-8 */
- if (!utilString[dlen-1]) {
+ if (!string[dlen-1]) {
dlen--;
}
- ddeObjectPtr = Tcl_NewStringObj(utilString, dlen);
+ ddeObjectPtr = Tcl_NewStringObj(string, dlen);
} else {
/* unicode */
dlen >>= 1;
- ddeObjectPtr = Tcl_NewUnicodeObj(uniStr, dlen - 1);
+ ddeObjectPtr = Tcl_NewUnicodeObj((Tcl_UniChar *)utilString, dlen - 1);
}
Tcl_IncrRefCount(ddeObjectPtr);
DdeUnaccessData(hData);
@@ -845,9 +928,9 @@ DdeServerProc(
for (i = 0, riPtr = tsdPtr->interpListPtr; i < numItems;
i++, riPtr = riPtr->nextPtr) {
returnPtr[i].hszSvc = DdeCreateStringHandle(ddeInstance,
- TCL_DDE_SERVICE_NAME, CP_WINANSI);
+ TCL_DDE_SERVICE_NAME, CP_WINUNICODE);
returnPtr[i].hszTopic = DdeCreateStringHandle(ddeInstance,
- riPtr->name, CP_WINANSI);
+ riPtr->name, CP_WINUNICODE);
}
returnPtr[i].hszSvc = NULL;
returnPtr[i].hszTopic = NULL;
@@ -905,14 +988,14 @@ DdeExitProc(
static int
MakeDdeConnection(
Tcl_Interp *interp, /* Used to report errors. */
- const char *name, /* The connection to use. */
+ const TCHAR *name, /* The connection to use. */
HCONV *ddeConvPtr)
{
HSZ ddeTopic, ddeService;
HCONV ddeConv;
- ddeService = DdeCreateStringHandle(ddeInstance, TCL_DDE_SERVICE_NAME, 0);
- ddeTopic = DdeCreateStringHandle(ddeInstance, name, 0);
+ ddeService = DdeCreateStringHandle(ddeInstance, TCL_DDE_SERVICE_NAME, CP_WINUNICODE);
+ ddeTopic = DdeCreateStringHandle(ddeInstance, name, CP_WINUNICODE);
ddeConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL);
DdeFreeStringHandle(ddeInstance, ddeService);
@@ -920,8 +1003,13 @@ MakeDdeConnection(
if (ddeConv == (HCONV) NULL) {
if (interp != NULL) {
- Tcl_AppendResult(interp, "no registered server named \"",
- name, "\"", NULL);
+ Tcl_DString dString;
+
+ Tcl_WinTCharToUtf(name, -1, &dString);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "no registered server named \"%s\"", Tcl_DStringValue(&dString)));
+ Tcl_DStringFree(&dString);
+ Tcl_SetErrorCode(interp, "TCL", "DDE", "NO_SERVER", NULL);
}
return TCL_ERROR;
}
@@ -955,8 +1043,8 @@ DdeCreateClient(
struct DdeEnumServices *es)
{
WNDCLASSEX wc;
- static const char *szDdeClientClassName = "TclEval client class";
- static const char *szDdeClientWindowName = "TclEval client window";
+ static const TCHAR *szDdeClientClassName = TEXT("TclEval client class");
+ static const TCHAR *szDdeClientWindowName = TEXT("TclEval client window");
memset(&wc, 0, sizeof(wc));
wc.cbSize = sizeof(wc);
@@ -1011,7 +1099,8 @@ DdeServicesOnAck(
ATOM service = (ATOM)LOWORD(lParam);
ATOM topic = (ATOM)HIWORD(lParam);
struct DdeEnumServices *es;
- char sz[255];
+ TCHAR sz[255];
+ Tcl_DString dString;
#ifdef _WIN64
es = (struct DdeEnumServices *) GetWindowLongPtr(hwnd, GWLP_USERDATA);
@@ -1025,9 +1114,13 @@ DdeServicesOnAck(
Tcl_Obj *resultPtr = Tcl_GetObjResult(es->interp);
GlobalGetAtomName(service, sz, 255);
- Tcl_ListObjAppendElement(NULL, matchPtr, Tcl_NewStringObj(sz, -1));
+ Tcl_WinTCharToUtf(sz, -1, &dString);
+ Tcl_ListObjAppendElement(NULL, matchPtr, Tcl_NewStringObj(Tcl_DStringValue(&dString), -1));
+ Tcl_DStringFree(&dString);
GlobalGetAtomName(topic, sz, 255);
- Tcl_ListObjAppendElement(NULL, matchPtr, Tcl_NewStringObj(sz, -1));
+ Tcl_WinTCharToUtf(sz, -1, &dString);
+ Tcl_ListObjAppendElement(NULL, matchPtr, Tcl_NewStringObj(Tcl_DStringValue(&dString), -1));
+ Tcl_DStringFree(&dString);
/*
* Adding the hwnd as a third list element provides a unique
@@ -1074,8 +1167,8 @@ DdeEnumWindowsCallback(
static int
DdeGetServicesList(
Tcl_Interp *interp,
- const char *serviceName,
- const char *topicName)
+ const TCHAR *serviceName,
+ const TCHAR *topicName)
{
struct DdeEnumServices es;
@@ -1122,25 +1215,30 @@ static void
SetDdeError(
Tcl_Interp *interp) /* The interp to put the message in. */
{
- const char *errorMessage;
+ const char *errorMessage, *errorCode;
switch (DdeGetLastError(ddeInstance)) {
case DMLERR_DATAACKTIMEOUT:
case DMLERR_EXECACKTIMEOUT:
case DMLERR_POKEACKTIMEOUT:
errorMessage = "remote interpreter did not respond";
+ errorCode = "TIMEOUT";
break;
case DMLERR_BUSY:
errorMessage = "remote server is busy";
+ errorCode = "BUSY";
break;
case DMLERR_NOTPROCESSED:
errorMessage = "remote server cannot handle this command";
+ errorCode = "NOCANDO";
break;
default:
errorMessage = "dde command failed";
+ errorCode = "FAILED";
}
Tcl_SetObjResult(interp, Tcl_NewStringObj(errorMessage, -1));
+ Tcl_SetErrorCode(interp, "TCL", "DDE", errorCode, NULL);
}
/*
@@ -1167,23 +1265,29 @@ DdeObjCmd(
int objc, /* Number of arguments */
Tcl_Obj *const *objv) /* The arguments */
{
- static const char *ddeCommands[] = {
+ static const char *const ddeCommands[] = {
"servername", "execute", "poke", "request", "services", "eval",
(char *) NULL};
enum DdeSubcommands {
DDE_SERVERNAME, DDE_EXECUTE, DDE_POKE, DDE_REQUEST, DDE_SERVICES,
DDE_EVAL
};
- static const char *ddeSrvOptions[] = {
+ static const char *const ddeSrvOptions[] = {
"-force", "-handler", "--", NULL
};
enum DdeSrvOptions {
DDE_SERVERNAME_EXACT, DDE_SERVERNAME_HANDLER, DDE_SERVERNAME_LAST,
};
- static const char *ddeExecOptions[] = {
+ static const char *const ddeExecOptions[] = {
+ "-async", "-binary", NULL
+ };
+ enum DdeExecOptions {
+ DDE_EXEC_ASYNC, DDE_EXEC_BINARY
+ };
+ static const char *const ddeEvalOptions[] = {
"-async", NULL
};
- static const char *ddeReqOptions[] = {
+ static const char *const ddeReqOptions[] = {
"-binary", NULL
};
@@ -1192,7 +1296,8 @@ DdeObjCmd(
HSZ ddeService = NULL, ddeTopic = NULL, ddeItem = NULL, ddeCookie = NULL;
HDDEDATA ddeData = NULL, ddeItemData = NULL, ddeReturn;
HCONV hConv = NULL;
- const char *serviceName = NULL, *topicName = NULL, *string;
+ const TCHAR *serviceName = NULL, *topicName = NULL;
+ const char *string;
DWORD ddeResult;
Tcl_Obj *objPtr, *handlerPtr = NULL;
@@ -1259,38 +1364,53 @@ DdeObjCmd(
if (objc == 5) {
firstArg = 2;
break;
- } else if (objc == 6) {
- if (Tcl_GetIndexFromObj(NULL, objv[2], ddeExecOptions, "option", 0,
- &argIndex) == TCL_OK) {
- flags |= DDE_FLAG_ASYNC;
- firstArg = 3;
- break;
+ } else if (objc >= 6 && objc <= 7) {
+ firstArg = objc - 3;
+ for (i = 2; i < firstArg; i++) {
+ if (Tcl_GetIndexFromObj(interp, objv[i], ddeExecOptions,
+ "option", 0, &argIndex) != TCL_OK) {
+ goto wrongDdeExecuteArgs;
+ }
+ if (argIndex == DDE_EXEC_ASYNC) {
+ flags |= DDE_FLAG_ASYNC;
+ } else {
+ flags |= DDE_FLAG_BINARY;
+ }
}
+ break;
}
/* otherwise... */
+ wrongDdeExecuteArgs:
Tcl_WrongNumArgs(interp, 2, objv,
- "?-async? serviceName topicName value");
+ "?-async? ?-binary? serviceName topicName value");
return TCL_ERROR;
case DDE_POKE:
- if (objc != 6) {
- Tcl_WrongNumArgs(interp, 2, objv,
- "serviceName topicName item value");
- return TCL_ERROR;
+ if (objc == 6) {
+ firstArg = 2;
+ break;
+ } else if ((objc == 7) && (Tcl_GetIndexFromObj(NULL, objv[2],
+ ddeReqOptions, "option", 0, &argIndex) == TCL_OK)) {
+ flags |= DDE_FLAG_BINARY;
+ firstArg = 3;
+ break;
}
- firstArg = 2;
- break;
+
+ /*
+ * Otherwise...
+ */
+
+ Tcl_WrongNumArgs(interp, 2, objv,
+ "?-binary? serviceName topicName item value");
+ return TCL_ERROR;
case DDE_REQUEST:
if (objc == 5) {
firstArg = 2;
break;
- } else if (objc == 6) {
- int dummy;
- if (Tcl_GetIndexFromObj(NULL, objv[2], ddeReqOptions, "option", 0,
- &dummy) == TCL_OK) {
- flags |= DDE_FLAG_BINARY;
- firstArg = 3;
- break;
- }
+ } else if ((objc == 6) && (Tcl_GetIndexFromObj(NULL, objv[2],
+ ddeReqOptions, "option", 0, &argIndex) == TCL_OK)) {
+ flags |= DDE_FLAG_BINARY;
+ firstArg = 3;
+ break;
}
/*
@@ -1314,7 +1434,7 @@ DdeObjCmd(
return TCL_ERROR;
} else {
firstArg = 2;
- if (Tcl_GetIndexFromObj(NULL, objv[2], ddeExecOptions, "option",
+ if (Tcl_GetIndexFromObj(NULL, objv[2], ddeEvalOptions, "option",
0, &argIndex) == TCL_OK) {
if (objc < 5) {
goto wrongDdeEvalArgs;
@@ -1329,7 +1449,11 @@ DdeObjCmd(
Initialize();
if (firstArg != 1) {
+#ifdef UNICODE
+ serviceName = Tcl_GetUnicodeFromObj(objv[firstArg], &length);
+#else
serviceName = Tcl_GetStringFromObj(objv[firstArg], &length);
+#endif
} else {
length = 0;
}
@@ -1338,16 +1462,20 @@ DdeObjCmd(
serviceName = NULL;
} else if ((index != DDE_SERVERNAME) && (index != DDE_EVAL)) {
ddeService = DdeCreateStringHandle(ddeInstance, (void *) serviceName,
- CP_WINANSI);
+ CP_WINUNICODE);
}
if ((index != DDE_SERVERNAME) && (index != DDE_EVAL)) {
+#ifdef UNICODE
+ topicName = (TCHAR *) Tcl_GetUnicodeFromObj(objv[firstArg + 1], &length);
+#else
topicName = Tcl_GetStringFromObj(objv[firstArg + 1], &length);
+#endif
if (length == 0) {
topicName = NULL;
} else {
ddeTopic = DdeCreateStringHandle(ddeInstance, (void *) topicName,
- CP_WINANSI);
+ CP_WINUNICODE);
}
}
@@ -1356,7 +1484,11 @@ DdeObjCmd(
serviceName = DdeSetServerName(interp, serviceName, flags,
handlerPtr);
if (serviceName != NULL) {
+#ifdef UNICODE
+ Tcl_SetObjResult(interp, Tcl_NewUnicodeObj((Tcl_UniChar *) serviceName, -1));
+#else
Tcl_SetObjResult(interp, Tcl_NewStringObj(serviceName, -1));
+#endif
} else {
Tcl_ResetResult(interp);
}
@@ -1364,12 +1496,21 @@ DdeObjCmd(
case DDE_EXECUTE: {
int dataLength;
- BYTE *dataString = (BYTE *) Tcl_GetStringFromObj(
- objv[firstArg + 2], &dataLength);
+ const Tcl_UniChar *dataString;
- if (dataLength == 0) {
+ if (flags & DDE_FLAG_BINARY) {
+ dataString = (const Tcl_UniChar *)
+ Tcl_GetByteArrayFromObj(objv[firstArg + 2], &dataLength);
+ } else {
+ dataString =
+ Tcl_GetUnicodeFromObj(objv[firstArg + 2], &dataLength);
+ dataLength = (dataLength + 1) * sizeof(Tcl_UniChar);
+ }
+
+ if (dataLength <= 0) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("cannot execute null data", -1));
+ Tcl_SetErrorCode(interp, "TCL", "DDE", "NULL", NULL);
result = TCL_ERROR;
break;
}
@@ -1383,16 +1524,16 @@ DdeObjCmd(
break;
}
- ddeData = DdeCreateDataHandle(ddeInstance, dataString,
- (DWORD) dataLength+1, 0, 0, CF_TEXT, 0);
+ ddeData = DdeCreateDataHandle(ddeInstance, (BYTE *) dataString,
+ (DWORD) dataLength, 0, 0, (flags & DDE_FLAG_BINARY) ? CF_TEXT : CF_UNICODETEXT, 0);
if (ddeData != NULL) {
if (flags & DDE_FLAG_ASYNC) {
DdeClientTransaction((LPBYTE) ddeData, 0xFFFFFFFF, hConv, 0,
- CF_TEXT, XTYP_EXECUTE, TIMEOUT_ASYNC, &ddeResult);
+ (flags & DDE_FLAG_BINARY) ? CF_TEXT : CF_UNICODETEXT, XTYP_EXECUTE, TIMEOUT_ASYNC, &ddeResult);
DdeAbandonTransaction(ddeInstance, hConv, ddeResult);
} else {
ddeReturn = DdeClientTransaction((LPBYTE) ddeData, 0xFFFFFFFF,
- hConv, 0, CF_TEXT, XTYP_EXECUTE, 30000, NULL);
+ hConv, 0, (flags & DDE_FLAG_BINARY) ? CF_TEXT : CF_UNICODETEXT, XTYP_EXECUTE, 30000, NULL);
if (ddeReturn == 0) {
SetDdeError(interp);
result = TCL_ERROR;
@@ -1406,12 +1547,18 @@ DdeObjCmd(
break;
}
case DDE_REQUEST: {
- const char *itemString = Tcl_GetStringFromObj(objv[firstArg + 2],
+#ifdef UNICODE
+ const TCHAR *itemString = (TCHAR *) Tcl_GetUnicodeFromObj(objv[firstArg + 2],
+ &length);
+#else
+ const TCHAR *itemString = Tcl_GetStringFromObj(objv[firstArg + 2],
&length);
+#endif
if (length == 0) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("cannot request value of null data", -1));
+ Tcl_SetErrorCode(interp, "TCL", "DDE", "NULL", NULL);
result = TCL_ERROR;
goto cleanup;
}
@@ -1424,26 +1571,27 @@ DdeObjCmd(
result = TCL_ERROR;
} else {
Tcl_Obj *returnObjPtr;
- ddeItem = DdeCreateStringHandle(ddeInstance, (void *)itemString,
- CP_WINANSI);
+ ddeItem = DdeCreateStringHandle(ddeInstance, (void *) itemString,
+ CP_WINUNICODE);
if (ddeItem != NULL) {
ddeData = DdeClientTransaction(NULL, 0, hConv, ddeItem,
- CF_TEXT, XTYP_REQUEST, 5000, NULL);
+ (flags & DDE_FLAG_BINARY) ? CF_TEXT : CF_UNICODETEXT, XTYP_REQUEST, 5000, NULL);
if (ddeData == NULL) {
SetDdeError(interp);
result = TCL_ERROR;
} else {
DWORD tmp;
- const char *dataString = (const char *) DdeAccessData(ddeData, &tmp);
+ const Tcl_UniChar *dataString = (const Tcl_UniChar *) DdeAccessData(ddeData, &tmp);
if (flags & DDE_FLAG_BINARY) {
returnObjPtr =
Tcl_NewByteArrayObj((BYTE *) dataString, (int) tmp);
} else {
- if (tmp && !dataString[tmp-1]) {
+ tmp >>= 1;
+ if (tmp && !dataString[(tmp-1)]) {
--tmp;
}
- returnObjPtr = Tcl_NewStringObj(dataString,
+ returnObjPtr = Tcl_NewUnicodeObj(dataString,
(int) tmp);
}
DdeUnaccessData(ddeData);
@@ -1459,18 +1607,30 @@ DdeObjCmd(
break;
}
case DDE_POKE: {
- const char *itemString = Tcl_GetStringFromObj(objv[firstArg + 2],
+#ifdef UNICODE
+ const TCHAR *itemString = (TCHAR *) Tcl_GetUnicodeFromObj(objv[firstArg + 2],
+ &length);
+#else
+ const TCHAR *itemString = Tcl_GetStringFromObj(objv[firstArg + 2],
&length);
+#endif
BYTE *dataString;
if (length == 0) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("cannot have a null item", -1));
+ Tcl_SetErrorCode(interp, "TCL", "DDE", "NULL", NULL);
result = TCL_ERROR;
goto cleanup;
}
- dataString = (BYTE *) Tcl_GetStringFromObj(objv[firstArg + 3],
- &length);
+ if (flags & DDE_FLAG_BINARY) {
+ dataString = (BYTE *)
+ Tcl_GetByteArrayFromObj(objv[firstArg + 3], &length);
+ } else {
+ dataString = (BYTE *)
+ Tcl_GetUnicodeFromObj(objv[firstArg + 3], &length);
+ length = 2 * length + 1;
+ }
hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL);
DdeFreeStringHandle(ddeInstance, ddeService);
@@ -1481,10 +1641,10 @@ DdeObjCmd(
result = TCL_ERROR;
} else {
ddeItem = DdeCreateStringHandle(ddeInstance, (void *) itemString,
- CP_WINANSI);
+ CP_WINUNICODE);
if (ddeItem != NULL) {
- ddeData = DdeClientTransaction(dataString, (DWORD) length+1,
- hConv, ddeItem, CF_TEXT, XTYP_POKE, 5000, NULL);
+ ddeData = DdeClientTransaction(dataString, (DWORD) length,
+ hConv, ddeItem, (flags & DDE_FLAG_BINARY) ? CF_TEXT : CF_UNICODETEXT, XTYP_POKE, 5000, NULL);
if (ddeData == NULL) {
SetDdeError(interp);
result = TCL_ERROR;
@@ -1508,6 +1668,7 @@ DdeObjCmd(
if (serviceName == NULL) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("invalid service name \"\"", -1));
+ Tcl_SetErrorCode(interp, "TCL", "DDE", "NO_SERVER", NULL);
result = TCL_ERROR;
goto cleanup;
}
@@ -1526,7 +1687,7 @@ DdeObjCmd(
for (riPtr = tsdPtr->interpListPtr; riPtr != NULL;
riPtr = riPtr->nextPtr) {
- if (stricmp(serviceName, riPtr->name) == 0) {
+ if (_tcsicmp(serviceName, riPtr->name) == 0) {
break;
}
}
@@ -1539,9 +1700,9 @@ DdeObjCmd(
* server.
*/
- Tcl_Preserve((ClientData) riPtr);
+ Tcl_Preserve(riPtr);
sendInterp = riPtr->interp;
- Tcl_Preserve((ClientData) sendInterp);
+ Tcl_Preserve(sendInterp);
/*
* Don't exchange objects between interps. The target interp would
@@ -1552,9 +1713,11 @@ DdeObjCmd(
*/
if (Tcl_IsSafe(riPtr->interp) && riPtr->handlerPtr == NULL) {
- Tcl_SetResult(riPtr->interp, "permission denied: "
- "a handler procedure must be defined for use in "
- "a safe interp", TCL_STATIC);
+ Tcl_SetObjResult(riPtr->interp, Tcl_NewStringObj(
+ "permission denied: a handler procedure must be"
+ " defined for use in a safe interp", -1));
+ Tcl_SetErrorCode(interp, "TCL", "DDE", "SECURITY_CHECK",
+ NULL);
result = TCL_ERROR;
}
@@ -1606,8 +1769,8 @@ DdeObjCmd(
}
Tcl_SetObjResult(interp, Tcl_GetObjResult(sendInterp));
}
- Tcl_Release((ClientData) riPtr);
- Tcl_Release((ClientData) sendInterp);
+ Tcl_Release(riPtr);
+ Tcl_Release(sendInterp);
} else {
/*
* This is a non-local request. Send the script to the server and
@@ -1617,31 +1780,31 @@ DdeObjCmd(
if (MakeDdeConnection(interp, serviceName, &hConv) != TCL_OK) {
invalidServerResponse:
Tcl_SetObjResult(interp,
- Tcl_NewStringObj("invalid data returned from server",
- -1));
+ Tcl_NewStringObj("invalid data returned from server", -1));
+ Tcl_SetErrorCode(interp, "TCL", "DDE", "BAD_RESPONSE", NULL);
result = TCL_ERROR;
goto cleanup;
}
objPtr = Tcl_ConcatObj(objc, objv);
- string = Tcl_GetStringFromObj(objPtr, &length);
+ string = (const char *) Tcl_GetUnicodeFromObj(objPtr, &length);
ddeItemData = DdeCreateDataHandle(ddeInstance,
- (BYTE *) string, (DWORD) length+1, 0, 0, CF_TEXT, 0);
+ (BYTE *) string, (DWORD) 2*length+2, 0, 0, CF_UNICODETEXT, 0);
if (flags & DDE_FLAG_ASYNC) {
ddeData = DdeClientTransaction((LPBYTE) ddeItemData,
0xFFFFFFFF, hConv, 0,
- CF_TEXT, XTYP_EXECUTE, TIMEOUT_ASYNC, &ddeResult);
+ CF_UNICODETEXT, XTYP_EXECUTE, TIMEOUT_ASYNC, &ddeResult);
DdeAbandonTransaction(ddeInstance, hConv, ddeResult);
} else {
ddeData = DdeClientTransaction((LPBYTE) ddeItemData,
0xFFFFFFFF, hConv, 0,
- CF_TEXT, XTYP_EXECUTE, 30000, NULL);
+ CF_UNICODETEXT, XTYP_EXECUTE, 30000, NULL);
if (ddeData != 0) {
ddeCookie = DdeCreateStringHandle(ddeInstance,
- TCL_DDE_EXECUTE_RESULT, CP_WINANSI);
+ TCL_DDE_EXECUTE_RESULT, CP_WINUNICODE);
ddeData = DdeClientTransaction(NULL, 0, hConv, ddeCookie,
- CF_TEXT, XTYP_REQUEST, 30000, NULL);
+ CF_UNICODETEXT, XTYP_REQUEST, 30000, NULL);
}
}
@@ -1650,10 +1813,12 @@ DdeObjCmd(
if (ddeData == 0) {
SetDdeError(interp);
result = TCL_ERROR;
+ goto cleanup;
}
if (!(flags & DDE_FLAG_ASYNC)) {
Tcl_Obj *resultPtr;
+ Tcl_UniChar *ddeDataString;
/*
* The return handle has a two or four element list in it. The
@@ -1666,10 +1831,11 @@ DdeObjCmd(
resultPtr = Tcl_NewObj();
length = DdeGetData(ddeData, NULL, 0, 0);
- Tcl_SetObjLength(resultPtr, length);
- string = Tcl_GetString(resultPtr);
- DdeGetData(ddeData, (BYTE *) string, (DWORD) length, 0);
- Tcl_SetObjLength(resultPtr, (int) strlen(string));
+ ddeDataString = ckalloc(length);
+ DdeGetData(ddeData, (BYTE *) ddeDataString, (DWORD) length, 0);
+ length = (length >> 1) - 1;
+ resultPtr = Tcl_NewUnicodeObj(ddeDataString, length);
+ ckfree(ddeDataString);
if (Tcl_ListObjIndex(NULL, resultPtr, 0, &objPtr) != TCL_OK) {
Tcl_DecrRefCount(resultPtr);
diff --git a/win/tclWinError.c b/win/tclWinError.c
index a74d2e2..30079b9 100644
--- a/win/tclWinError.c
+++ b/win/tclWinError.c
@@ -11,13 +11,11 @@
*/
#include "tclInt.h"
-#include "tclPort.h"
-
/*
* The following table contains the mapping from Win32 errors to errno errors.
*/
-static CONST unsigned char errorTable[] = {
+static const unsigned char errorTable[] = {
0,
EINVAL, /* ERROR_INVALID_FUNCTION 1 */
ENOENT, /* ERROR_FILE_NOT_FOUND 2 */
@@ -293,7 +291,7 @@ static CONST unsigned char errorTable[] = {
* errno errors.
*/
-static CONST int wsaErrorTable[] = {
+static const unsigned char wsaErrorTable[] = {
EWOULDBLOCK, /* WSAEWOULDBLOCK */
EINPROGRESS, /* WSAEINPROGRESS */
EALREADY, /* WSAEALREADY */
@@ -364,39 +362,62 @@ TclWinConvertError(
Tcl_SetErrno(errorTable[errCode]);
}
}
-
+
+#ifdef __CYGWIN__
/*
*----------------------------------------------------------------------
*
- * TclWinConvertWSAError --
+ * tclWinDebugPanic --
*
- * This routine converts a WinSock error into an errno value.
+ * Display a message. If a debugger is present, present it directly to
+ * the debugger, otherwise send it to stderr.
*
* Results:
* None.
*
* Side effects:
- * Sets the errno global variable.
+ * None.
*
*----------------------------------------------------------------------
*/
-void
-TclWinConvertWSAError(
- DWORD errCode) /* Win32 error code. */
+TCL_NORETURN void
+tclWinDebugPanic(
+ const char *format, ...)
{
- if (errCode >= sizeof(errorTable)/sizeof(errorTable[0])) {
- errCode -= WSAEWOULDBLOCK;
- if (errCode >= sizeof(wsaErrorTable)/sizeof(wsaErrorTable[0])) {
- Tcl_SetErrno(errorTable[1]);
- } else {
- Tcl_SetErrno(wsaErrorTable[errCode]);
+#define TCL_MAX_WARN_LEN 1024
+ va_list argList;
+ va_start(argList, format);
+
+ if (IsDebuggerPresent()) {
+ WCHAR msgString[TCL_MAX_WARN_LEN];
+ char buf[TCL_MAX_WARN_LEN * TCL_UTF_MAX];
+
+ vsnprintf(buf, sizeof(buf), format, argList);
+ msgString[TCL_MAX_WARN_LEN-1] = L'\0';
+ MultiByteToWideChar(CP_UTF8, 0, buf, -1, msgString, TCL_MAX_WARN_LEN);
+
+ /*
+ * Truncate MessageBox string if it is too long to not overflow the buffer.
+ */
+
+ if (msgString[TCL_MAX_WARN_LEN-1] != L'\0') {
+ memcpy(msgString + (TCL_MAX_WARN_LEN - 5), L" ...", 5 * sizeof(WCHAR));
}
+ OutputDebugStringW(msgString);
} else {
- Tcl_SetErrno(errorTable[errCode]);
+ vfprintf(stderr, format, argList);
+ fprintf(stderr, "\n");
+ fflush(stderr);
}
+# if defined(__GNUC__)
+ __builtin_trap();
+# else
+ DebugBreak();
+# endif
+ abort();
}
-
+#endif
/*
* Local Variables:
* mode: c
diff --git a/win/tclWinFCmd.c b/win/tclWinFCmd.c
index 441337e..52ea8c6 100644
--- a/win/tclWinFCmd.c
+++ b/win/tclWinFCmd.c
@@ -54,12 +54,12 @@ static const int attributeArray[] = {FILE_ATTRIBUTE_ARCHIVE, FILE_ATTRIBUTE_HIDD
0, FILE_ATTRIBUTE_READONLY, 0, FILE_ATTRIBUTE_SYSTEM};
-CONST char *tclpFileAttrStrings[] = {
+const char *const tclpFileAttrStrings[] = {
"-archive", "-hidden", "-longname", "-readonly",
"-shortname", "-system", (char *) NULL
};
-CONST TclFileAttrProcs tclpFileAttrProcs[] = {
+const TclFileAttrProcs tclpFileAttrProcs[] = {
{GetWinFileAttributes, SetWinFileAttributes},
{GetWinFileAttributes, SetWinFileAttributes},
{GetWinFileLongName, CannotSetAttribute},
@@ -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 TCHAR *srcPtr, const TCHAR *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 TCHAR *srcPtr, const TCHAR *dstPtr);
+static int DoCreateDirectory(const TCHAR *pathPtr);
+static int DoRemoveJustDirectory(const TCHAR *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 TCHAR *nativeSrc,
+ const TCHAR *dstPtr);
+static int TraversalCopy(const TCHAR *srcPtr, const TCHAR *dstPtr,
int type, Tcl_DString *errorPtr);
-static int TraversalDelete(CONST TCHAR *srcPtr,
- CONST TCHAR *dstPtr, int type,
+static int TraversalDelete(const TCHAR *srcPtr,
+ const TCHAR *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 TCHAR *nativeSrc, /* Pathname of file or dir to be renamed
* (native). */
- CONST TCHAR *nativeDst) /* New pathname for file or directory
+ const TCHAR *nativeDst) /* New pathname for file or directory
* (native). */
{
#if defined(HAVE_NO_SEH) && !defined(_WIN64)
@@ -256,7 +256,7 @@ DoRenameFile(
[registration] "m" (registration),
[nativeDst] "m" (nativeDst),
[nativeSrc] "m" (nativeSrc),
- [moveFile] "r" (tclWinProcs->moveFileProc)
+ [moveFile] "r" (MoveFile)
:
"%eax", "%ebx", "%ecx", "%edx", "memory"
);
@@ -267,7 +267,7 @@ DoRenameFile(
#ifndef HAVE_NO_SEH
__try {
#endif
- if ((*tclWinProcs->moveFileProc)(nativeSrc, nativeDst) != FALSE) {
+ if ((*MoveFile)(nativeSrc, nativeDst) != FALSE) {
retval = TCL_OK;
}
#ifndef HAVE_NO_SEH
@@ -281,10 +281,10 @@ DoRenameFile(
TclWinConvertError(GetLastError());
- srcAttr = (*tclWinProcs->getFileAttributesProc)(nativeSrc);
- dstAttr = (*tclWinProcs->getFileAttributesProc)(nativeDst);
+ srcAttr = GetFileAttributes(nativeSrc);
+ dstAttr = GetFileAttributes(nativeDst);
if (srcAttr == 0xffffffff) {
- if ((*tclWinProcs->getFullPathNameProc)(nativeSrc, 0, NULL,
+ if (GetFullPathName(nativeSrc, 0, NULL,
NULL) >= MAX_PATH) {
errno = ENAMETOOLONG;
return TCL_ERROR;
@@ -292,7 +292,7 @@ DoRenameFile(
srcAttr = 0;
}
if (dstAttr == 0xffffffff) {
- if ((*tclWinProcs->getFullPathNameProc)(nativeDst, 0, NULL,
+ if (GetFullPathName(nativeDst, 0, NULL,
NULL) >= MAX_PATH) {
errno = ENAMETOOLONG;
return TCL_ERROR;
@@ -308,28 +308,28 @@ DoRenameFile(
decode:
if (srcAttr & FILE_ATTRIBUTE_DIRECTORY) {
TCHAR *nativeSrcRest, *nativeDstRest;
- CONST char **srcArgv, **dstArgv;
+ const char **srcArgv, **dstArgv;
int size, srcArgc, dstArgc;
- WCHAR nativeSrcPath[MAX_PATH];
- WCHAR nativeDstPath[MAX_PATH];
+ TCHAR nativeSrcPath[MAX_PATH];
+ TCHAR nativeDstPath[MAX_PATH];
Tcl_DString srcString, dstString;
- CONST char *src, *dst;
+ const char *src, *dst;
- size = (*tclWinProcs->getFullPathNameProc)(nativeSrc, MAX_PATH,
+ size = GetFullPathName(nativeSrc, MAX_PATH,
nativeSrcPath, &nativeSrcRest);
if ((size == 0) || (size > MAX_PATH)) {
return TCL_ERROR;
}
- size = (*tclWinProcs->getFullPathNameProc)(nativeDst, MAX_PATH,
+ size = GetFullPathName(nativeDst, MAX_PATH,
nativeDstPath, &nativeDstRest);
if ((size == 0) || (size > MAX_PATH)) {
return TCL_ERROR;
}
- (*tclWinProcs->charLowerProc)((TCHAR *) nativeSrcPath);
- (*tclWinProcs->charLowerProc)((TCHAR *) nativeDstPath);
+ CharLower(nativeSrcPath);
+ CharLower(nativeDstPath);
- src = Tcl_WinTCharToUtf((TCHAR *) nativeSrcPath, -1, &srcString);
- dst = Tcl_WinTCharToUtf((TCHAR *) nativeDstPath, -1, &dstString);
+ src = Tcl_WinTCharToUtf(nativeSrcPath, -1, &srcString);
+ dst = Tcl_WinTCharToUtf(nativeDstPath, -1, &dstString);
/*
* Check whether the destination path is actually inside the
@@ -376,8 +376,8 @@ DoRenameFile(
Tcl_SetErrno(EXDEV);
}
- ckfree((char *) srcArgv);
- ckfree((char *) dstArgv);
+ ckfree(srcArgv);
+ ckfree(dstArgv);
}
/*
@@ -408,7 +408,7 @@ DoRenameFile(
* directory back, for completeness.
*/
- if ((*tclWinProcs->moveFileProc)(nativeSrc,
+ if (MoveFile(nativeSrc,
nativeDst) != FALSE) {
return TCL_OK;
}
@@ -419,8 +419,8 @@ DoRenameFile(
*/
TclWinConvertError(GetLastError());
- (*tclWinProcs->createDirectoryProc)(nativeDst, NULL);
- (*tclWinProcs->setFileAttributesProc)(nativeDst, dstAttr);
+ CreateDirectory(nativeDst, NULL);
+ SetFileAttributes(nativeDst, dstAttr);
if (Tcl_GetErrno() == EACCES) {
/*
* Decode the EACCES to a more meaningful error.
@@ -447,22 +447,20 @@ DoRenameFile(
TCHAR *nativeRest, *nativeTmp, *nativePrefix;
int result, size;
- WCHAR tempBuf[MAX_PATH];
+ TCHAR tempBuf[MAX_PATH];
- size = (*tclWinProcs->getFullPathNameProc)(nativeDst, MAX_PATH,
+ size = GetFullPathName(nativeDst, MAX_PATH,
tempBuf, &nativeRest);
if ((size == 0) || (size > MAX_PATH) || (nativeRest == NULL)) {
return TCL_ERROR;
}
nativeTmp = (TCHAR *) tempBuf;
- ((char *) nativeRest)[0] = '\0';
- ((char *) nativeRest)[1] = '\0'; /* In case it's Unicode. */
+ nativeRest[0] = L'\0';
result = TCL_ERROR;
- nativePrefix = (tclWinProcs->useWide)
- ? (TCHAR *) L"tclr" : (TCHAR *) "tclr";
- if ((*tclWinProcs->getTempFileNameProc)(nativeTmp,
- nativePrefix, 0, tempBuf) != 0) {
+ nativePrefix = (TCHAR *) L"tclr";
+ if (GetTempFileName(nativeTmp, nativePrefix,
+ 0, tempBuf) != 0) {
/*
* Strictly speaking, need the following DeleteFile and
* MoveFile to be joined as an atomic operation so no
@@ -470,19 +468,16 @@ DoRenameFile(
* same temp file.
*/
- nativeTmp = (TCHAR *) tempBuf;
- (*tclWinProcs->deleteFileProc)(nativeTmp);
- if ((*tclWinProcs->moveFileProc)(nativeDst,
- nativeTmp) != FALSE) {
- if ((*tclWinProcs->moveFileProc)(nativeSrc,
- nativeDst) != FALSE) {
- (*tclWinProcs->setFileAttributesProc)(nativeTmp,
- FILE_ATTRIBUTE_NORMAL);
- (*tclWinProcs->deleteFileProc)(nativeTmp);
+ nativeTmp = tempBuf;
+ DeleteFile(nativeTmp);
+ if (MoveFile(nativeDst, nativeTmp) != FALSE) {
+ if (MoveFile(nativeSrc, nativeDst) != FALSE) {
+ SetFileAttributes(nativeTmp, FILE_ATTRIBUTE_NORMAL);
+ DeleteFile(nativeTmp);
return TCL_OK;
} else {
- (*tclWinProcs->deleteFileProc)(nativeDst);
- (*tclWinProcs->moveFileProc)(nativeTmp, nativeDst);
+ DeleteFile(nativeDst);
+ MoveFile(nativeTmp, nativeDst);
}
}
@@ -545,8 +540,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 TCHAR *nativeSrc, /* Pathname of file to be copied (native). */
+ const TCHAR *nativeDst) /* Pathname of file to copy to (native). */
{
#if defined(HAVE_NO_SEH) && !defined(_WIN64)
TCLEXCEPTION_REGISTRATION registration;
@@ -649,7 +644,7 @@ DoCopyFile(
[registration] "m" (registration),
[nativeDst] "m" (nativeDst),
[nativeSrc] "m" (nativeSrc),
- [copyFile] "r" (tclWinProcs->copyFileProc)
+ [copyFile] "r" (CopyFile)
:
"%eax", "%ebx", "%ecx", "%edx", "memory"
);
@@ -660,7 +655,7 @@ DoCopyFile(
#ifndef HAVE_NO_SEH
__try {
#endif
- if ((*tclWinProcs->copyFileProc)(nativeSrc, nativeDst, 0) != FALSE) {
+ if (CopyFile(nativeSrc, nativeDst, 0) != FALSE) {
retval = TCL_OK;
}
#ifndef HAVE_NO_SEH
@@ -680,8 +675,8 @@ DoCopyFile(
if (Tcl_GetErrno() == EACCES) {
DWORD srcAttr, dstAttr;
- srcAttr = (*tclWinProcs->getFileAttributesProc)(nativeSrc);
- dstAttr = (*tclWinProcs->getFileAttributesProc)(nativeDst);
+ srcAttr = GetFileAttributes(nativeSrc);
+ dstAttr = GetFileAttributes(nativeDst);
if (srcAttr != 0xffffffff) {
if (dstAttr == 0xffffffff) {
dstAttr = 0;
@@ -697,9 +692,9 @@ DoCopyFile(
Tcl_SetErrno(EISDIR);
}
if (dstAttr & FILE_ATTRIBUTE_READONLY) {
- (*tclWinProcs->setFileAttributesProc)(nativeDst,
+ SetFileAttributes(nativeDst,
dstAttr & ~((DWORD)FILE_ATTRIBUTE_READONLY));
- if ((*tclWinProcs->copyFileProc)(nativeSrc, nativeDst,
+ if (CopyFile(nativeSrc, nativeDst,
0) != FALSE) {
return TCL_OK;
}
@@ -710,7 +705,7 @@ DoCopyFile(
*/
TclWinConvertError(GetLastError());
- (*tclWinProcs->setFileAttributesProc)(nativeDst, dstAttr);
+ SetFileAttributes(nativeDst, dstAttr);
}
}
}
@@ -751,34 +746,35 @@ TclpObjDeleteFile(
int
TclpDeleteFile(
- CONST TCHAR *nativePath) /* Pathname of file to be removed (native). */
+ const void *nativePath) /* Pathname of file to be removed (native). */
{
DWORD attr;
+ const TCHAR *path = nativePath;
/*
* The DeleteFile API acts differently under Win95/98 and NT WRT NULL and
* "". Avoid passing these values.
*/
- if (nativePath == NULL || nativePath[0] == '\0') {
+ if (path == NULL || path[0] == '\0') {
Tcl_SetErrno(ENOENT);
return TCL_ERROR;
}
- if ((*tclWinProcs->deleteFileProc)(nativePath) != FALSE) {
+ if (DeleteFile(path) != FALSE) {
return TCL_OK;
}
TclWinConvertError(GetLastError());
if (Tcl_GetErrno() == EACCES) {
- attr = (*tclWinProcs->getFileAttributesProc)(nativePath);
+ attr = GetFileAttributes(path);
if (attr != 0xffffffff) {
if (attr & FILE_ATTRIBUTE_DIRECTORY) {
if (attr & FILE_ATTRIBUTE_REPARSE_POINT) {
/*
* It is a symbolic link - remove it.
*/
- if (TclWinSymLinkDelete(nativePath, 0) == 0) {
+ if (TclWinSymLinkDelete(path, 0) == 0) {
return TCL_OK;
}
}
@@ -792,21 +788,21 @@ TclpDeleteFile(
Tcl_SetErrno(EISDIR);
} else if (attr & FILE_ATTRIBUTE_READONLY) {
- int res = (*tclWinProcs->setFileAttributesProc)(nativePath,
- attr & ~((DWORD)FILE_ATTRIBUTE_READONLY));
+ int res = SetFileAttributes(path,
+ attr & ~((DWORD) FILE_ATTRIBUTE_READONLY));
- if ((res != 0) && ((*tclWinProcs->deleteFileProc)(nativePath)
- != FALSE)) {
+ if ((res != 0) &&
+ (DeleteFile(path) != FALSE)) {
return TCL_OK;
}
TclWinConvertError(GetLastError());
if (res != 0) {
- (*tclWinProcs->setFileAttributesProc)(nativePath, attr);
+ SetFileAttributes(path, attr);
}
}
}
} else if (Tcl_GetErrno() == ENOENT) {
- attr = (*tclWinProcs->getFileAttributesProc)(nativePath);
+ attr = GetFileAttributes(path);
if (attr != 0xffffffff) {
if (attr & FILE_ATTRIBUTE_DIRECTORY) {
/*
@@ -863,11 +859,11 @@ TclpObjCreateDirectory(
static int
DoCreateDirectory(
- CONST TCHAR *nativePath) /* Pathname of directory to create (native). */
+ const TCHAR *nativePath) /* Pathname of directory to create (native). */
{
- DWORD error;
- if ((*tclWinProcs->createDirectoryProc)(nativePath, NULL) == 0) {
- error = GetLastError();
+ if (CreateDirectory(nativePath, NULL) == 0) {
+ DWORD error = GetLastError();
+
TclWinConvertError(error);
return TCL_ERROR;
}
@@ -996,13 +992,12 @@ TclpObjRemoveDirectory(
}
if (ret != TCL_OK) {
- int len = Tcl_DStringLength(&ds);
- if (len > 0) {
+ if (Tcl_DStringLength(&ds) > 0) {
if (normPtr != NULL &&
!strcmp(Tcl_DStringValue(&ds), TclGetString(normPtr))) {
*errorPtr = pathPtr;
} else {
- *errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1);
+ *errorPtr = TclDStringToObj(&ds);
}
Tcl_IncrRefCount(*errorPtr);
}
@@ -1014,7 +1009,7 @@ TclpObjRemoveDirectory(
static int
DoRemoveJustDirectory(
- CONST TCHAR *nativePath, /* Pathname of directory to be removed
+ const TCHAR *nativePath, /* Pathname of directory to be removed
* (native). */
int ignoreError, /* If non-zero, don't initialize the errorPtr
* under some circumstances on return. */
@@ -1034,7 +1029,7 @@ DoRemoveJustDirectory(
goto end;
}
- attr = (*tclWinProcs->getFileAttributesProc)(nativePath);
+ attr = GetFileAttributes(nativePath);
if (attr & FILE_ATTRIBUTE_REPARSE_POINT) {
/*
@@ -1048,7 +1043,7 @@ DoRemoveJustDirectory(
* Ordinary directory.
*/
- if ((*tclWinProcs->removeDirectoryProc)(nativePath) != FALSE) {
+ if (RemoveDirectory(nativePath) != FALSE) {
return TCL_OK;
}
}
@@ -1056,7 +1051,7 @@ DoRemoveJustDirectory(
TclWinConvertError(GetLastError());
if (Tcl_GetErrno() == EACCES) {
- attr = (*tclWinProcs->getFileAttributesProc)(nativePath);
+ attr = GetFileAttributes(nativePath);
if (attr != 0xffffffff) {
if ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0) {
/*
@@ -1080,60 +1075,17 @@ DoRemoveJustDirectory(
if (attr & FILE_ATTRIBUTE_READONLY) {
attr &= ~FILE_ATTRIBUTE_READONLY;
- if ((*tclWinProcs->setFileAttributesProc)(nativePath,
+ if (SetFileAttributes(nativePath,
attr) == FALSE) {
goto end;
}
- if ((*tclWinProcs->removeDirectoryProc)(nativePath) != FALSE) {
+ if (RemoveDirectory(nativePath) != FALSE) {
return TCL_OK;
}
TclWinConvertError(GetLastError());
- (*tclWinProcs->setFileAttributesProc)(nativePath,
+ SetFileAttributes(nativePath,
attr | FILE_ATTRIBUTE_READONLY);
}
-
- /*
- * Windows 95 and Win32s report removing a non-empty directory as
- * EACCES, not EEXIST. If the directory is not empty, change errno
- * so caller knows what's going on.
- */
-
- if (TclWinGetPlatformId() != VER_PLATFORM_WIN32_NT) {
- CONST char *path, *find;
- HANDLE handle;
- WIN32_FIND_DATAA data;
- Tcl_DString buffer;
- int len;
-
- path = (CONST char *) nativePath;
-
- Tcl_DStringInit(&buffer);
- len = strlen(path);
- find = Tcl_DStringAppend(&buffer, path, len);
- if ((len > 0) && (find[len - 1] != '\\')) {
- Tcl_DStringAppend(&buffer, "\\", 1);
- }
- find = Tcl_DStringAppend(&buffer, "*.*", 3);
- handle = FindFirstFileA(find, &data);
- if (handle != INVALID_HANDLE_VALUE) {
- while (1) {
- if ((strcmp(data.cFileName, ".") != 0)
- && (strcmp(data.cFileName, "..") != 0)) {
- /*
- * Found something in this directory.
- */
-
- Tcl_SetErrno(EEXIST);
- break;
- }
- if (FindNextFileA(handle, &data) == FALSE) {
- break;
- }
- }
- FindClose(handle);
- }
- Tcl_DStringFree(&buffer);
- }
}
}
@@ -1178,7 +1130,7 @@ DoRemoveDirectory(
* filled with UTF-8 name of file causing
* error. */
{
- int res = DoRemoveJustDirectory(Tcl_DStringValue(pathPtr), recursive,
+ int res = DoRemoveJustDirectory((const TCHAR *)Tcl_DStringValue(pathPtr), recursive,
errorPtr);
if ((res == TCL_ERROR) && (recursive != 0) && (Tcl_GetErrno() == EEXIST)) {
@@ -1232,7 +1184,7 @@ TraverseWinTree(
TCHAR *nativeSource, *nativeTarget, *nativeErrfile;
int result, found, sourceLen, targetLen = 0, oldSourceLen, oldTargetLen;
HANDLE handle;
- WIN32_FIND_DATAT data;
+ WIN32_FIND_DATA data;
nativeErrfile = NULL;
result = TCL_OK;
@@ -1243,7 +1195,7 @@ TraverseWinTree(
(targetPtr == NULL ? NULL : Tcl_DStringValue(targetPtr));
oldSourceLen = Tcl_DStringLength(sourcePtr);
- sourceAttr = (*tclWinProcs->getFileAttributesProc)(nativeSource);
+ sourceAttr = GetFileAttributes(nativeSource);
if (sourceAttr == 0xffffffff) {
nativeErrfile = nativeSource;
goto end;
@@ -1254,7 +1206,7 @@ TraverseWinTree(
* Process the symbolic link
*/
- return (*traverseProc)(nativeSource, nativeTarget, DOTREE_LINK,
+ return traverseProc(nativeSource, nativeTarget, DOTREE_LINK,
errorPtr);
}
@@ -1263,18 +1215,14 @@ TraverseWinTree(
* Process the regular file
*/
- return (*traverseProc)(nativeSource, nativeTarget, DOTREE_F, errorPtr);
+ return traverseProc(nativeSource, nativeTarget, DOTREE_F, errorPtr);
}
- if (tclWinProcs->useWide) {
- Tcl_DStringAppend(sourcePtr, (char *) L"\\*.*", 4 * sizeof(WCHAR) + 1);
- Tcl_DStringSetLength(sourcePtr, Tcl_DStringLength(sourcePtr) - 1);
- } else {
- Tcl_DStringAppend(sourcePtr, "\\*.*", 4);
- }
+ Tcl_DStringAppend(sourcePtr, (char *) TEXT("\\*.*"), 4 * sizeof(TCHAR) + 1);
+ Tcl_DStringSetLength(sourcePtr, Tcl_DStringLength(sourcePtr) - 1);
nativeSource = (TCHAR *) Tcl_DStringValue(sourcePtr);
- handle = (*tclWinProcs->findFirstFileProc)(nativeSource, &data);
+ handle = FindFirstFile(nativeSource, &data);
if (handle == INVALID_HANDLE_VALUE) {
/*
* Can't read directory.
@@ -1285,67 +1233,44 @@ TraverseWinTree(
goto end;
}
- nativeSource[oldSourceLen + 1] = '\0';
+ Tcl_DStringSetLength(sourcePtr, oldSourceLen + 1);
Tcl_DStringSetLength(sourcePtr, oldSourceLen);
- result = (*traverseProc)(nativeSource, nativeTarget, DOTREE_PRED,
+ result = traverseProc(nativeSource, nativeTarget, DOTREE_PRED,
errorPtr);
if (result != TCL_OK) {
FindClose(handle);
return result;
}
- sourceLen = oldSourceLen;
-
- if (tclWinProcs->useWide) {
- sourceLen += sizeof(WCHAR);
- Tcl_DStringAppend(sourcePtr, (char *) L"\\", sizeof(WCHAR) + 1);
- Tcl_DStringSetLength(sourcePtr, sourceLen);
- } else {
- sourceLen += 1;
- Tcl_DStringAppend(sourcePtr, "\\", 1);
- }
+ sourceLen = oldSourceLen + sizeof(TCHAR);
+ Tcl_DStringAppend(sourcePtr, (char *) TEXT("\\"), sizeof(TCHAR) + 1);
+ Tcl_DStringSetLength(sourcePtr, sourceLen);
if (targetPtr != NULL) {
oldTargetLen = Tcl_DStringLength(targetPtr);
targetLen = oldTargetLen;
- if (tclWinProcs->useWide) {
- targetLen += sizeof(WCHAR);
- Tcl_DStringAppend(targetPtr, (char *) L"\\", sizeof(WCHAR) + 1);
- Tcl_DStringSetLength(targetPtr, targetLen);
- } else {
- targetLen += 1;
- Tcl_DStringAppend(targetPtr, "\\", 1);
- }
+ targetLen += sizeof(TCHAR);
+ Tcl_DStringAppend(targetPtr, (char *) TEXT("\\"), sizeof(TCHAR) + 1);
+ Tcl_DStringSetLength(targetPtr, targetLen);
}
found = 1;
- for (; found; found = (*tclWinProcs->findNextFileProc)(handle, &data)) {
+ for (; found; found = FindNextFile(handle, &data)) {
TCHAR *nativeName;
int len;
- if (tclWinProcs->useWide) {
- WCHAR *wp;
-
- wp = data.w.cFileName;
+ TCHAR *wp = data.cFileName;
+ if (*wp == '.') {
+ wp++;
if (*wp == '.') {
wp++;
- if (*wp == '.') {
- wp++;
- }
- if (*wp == '\0') {
- continue;
- }
}
- nativeName = (TCHAR *) data.w.cFileName;
- len = wcslen(data.w.cFileName) * sizeof(WCHAR);
- } else {
- if ((strcmp(data.a.cFileName, ".") == 0)
- || (strcmp(data.a.cFileName, "..") == 0)) {
+ if (*wp == '\0') {
continue;
}
- nativeName = (TCHAR *) data.a.cFileName;
- len = strlen(data.a.cFileName);
}
+ nativeName = (TCHAR *) data.cFileName;
+ len = _tcslen(data.cFileName) * sizeof(TCHAR);
/*
* Append name after slash, and recurse on the file.
@@ -1390,8 +1315,8 @@ TraverseWinTree(
* files in that directory.
*/
- result = (*traverseProc)(Tcl_DStringValue(sourcePtr),
- (targetPtr == NULL ? NULL : Tcl_DStringValue(targetPtr)),
+ result = traverseProc((const TCHAR *)Tcl_DStringValue(sourcePtr),
+ (const TCHAR *)(targetPtr == NULL ? NULL : Tcl_DStringValue(targetPtr)),
DOTREE_POSTD, errorPtr);
}
@@ -1426,8 +1351,8 @@ TraverseWinTree(
static int
TraversalCopy(
- CONST TCHAR *nativeSrc, /* Source pathname to copy. */
- CONST TCHAR *nativeDst, /* Destination pathname of copy. */
+ const TCHAR *nativeSrc, /* Source pathname to copy. */
+ const TCHAR *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. */
@@ -1445,9 +1370,9 @@ TraversalCopy(
break;
case DOTREE_PRED:
if (DoCreateDirectory(nativeDst) == TCL_OK) {
- DWORD attr = (tclWinProcs->getFileAttributesProc)(nativeSrc);
+ DWORD attr = GetFileAttributes(nativeSrc);
- if ((tclWinProcs->setFileAttributesProc)(nativeDst,
+ if (SetFileAttributes(nativeDst,
attr) != FALSE) {
return TCL_OK;
}
@@ -1492,8 +1417,8 @@ TraversalCopy(
static int
TraversalDelete(
- CONST TCHAR *nativeSrc, /* Source pathname to delete. */
- CONST TCHAR *dstPtr, /* Not used. */
+ const TCHAR *nativeSrc, /* Source pathname to delete. */
+ const TCHAR *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. */
@@ -1548,8 +1473,8 @@ StatError(
* error. */
{
TclWinConvertError(GetLastError());
- Tcl_AppendResult(interp, "could not read \"", TclGetString(fileName),
- "\": ", Tcl_PosixError(interp), (char *) NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf("could not read \"%s\": %s",
+ TclGetString(fileName), Tcl_PosixError(interp)));
}
/*
@@ -1579,11 +1504,11 @@ GetWinFileAttributes(
Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */
{
DWORD result;
- CONST TCHAR *nativeName;
+ const TCHAR *nativeName;
int attr;
nativeName = Tcl_FSGetNativePath(fileName);
- result = (*tclWinProcs->getFileAttributesProc)(nativeName);
+ result = GetFileAttributes(nativeName);
if (result == 0xffffffff) {
StatError(interp, fileName);
@@ -1601,7 +1526,7 @@ GetWinFileAttributes(
*/
int len;
- char *str = Tcl_GetStringFromObj(fileName,&len);
+ const char *str = Tcl_GetStringFromObj(fileName,&len);
if (len < 4) {
if (len == 0) {
@@ -1667,9 +1592,11 @@ ConvertFileNameFormat(
if (splitPath == NULL || pathc == 0) {
if (interp != NULL) {
- Tcl_AppendResult(interp, "could not read \"",
- Tcl_GetString(fileName), "\": no such file or directory",
- (char *) NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "could not read \"%s\": no such file or directory",
+ Tcl_GetString(fileName)));
+ errno = ENOENT;
+ Tcl_PosixError(interp);
}
goto cleanup;
}
@@ -1710,10 +1637,10 @@ ConvertFileNameFormat(
Tcl_Obj *tempPath;
Tcl_DString ds;
Tcl_DString dsTemp;
- TCHAR *nativeName;
- char *tempString;
+ const TCHAR *nativeName;
+ const char *tempString;
int tempLen;
- WIN32_FIND_DATAT data;
+ WIN32_FIND_DATA data;
HANDLE handle;
DWORD attr;
@@ -1729,7 +1656,7 @@ ConvertFileNameFormat(
tempString = Tcl_GetStringFromObj(tempPath,&tempLen);
nativeName = Tcl_WinUtfToTChar(tempString, tempLen, &ds);
Tcl_DecrRefCount(tempPath);
- handle = (*tclWinProcs->findFirstFileProc)(nativeName, &data);
+ handle = FindFirstFile(nativeName, &data);
if (handle == INVALID_HANDLE_VALUE) {
/*
* FindFirstFile() doesn't like root directories. We would
@@ -1738,7 +1665,7 @@ ConvertFileNameFormat(
* root directory
*/
- attr = (*tclWinProcs->getFileAttributesProc)(nativeName);
+ attr = GetFileAttributes(nativeName);
if ((attr!=0xFFFFFFFF) && (attr & FILE_ATTRIBUTE_DIRECTORY)) {
Tcl_DStringFree(&ds);
goto simple;
@@ -1752,27 +1679,14 @@ ConvertFileNameFormat(
}
goto cleanup;
}
- if (tclWinProcs->useWide) {
- nativeName = (TCHAR *) data.w.cAlternateFileName;
- if (longShort) {
- if (data.w.cFileName[0] != '\0') {
- nativeName = (TCHAR *) data.w.cFileName;
- }
- } else {
- if (data.w.cAlternateFileName[0] == '\0') {
- nativeName = (TCHAR *) data.w.cFileName;
- }
+ nativeName = data.cAlternateFileName;
+ if (longShort) {
+ if (data.cFileName[0] != '\0') {
+ nativeName = data.cFileName;
}
} else {
- nativeName = (TCHAR *) data.a.cAlternateFileName;
- if (longShort) {
- if (data.a.cFileName[0] != '\0') {
- nativeName = (TCHAR *) data.a.cFileName;
- }
- } else {
- if (data.a.cAlternateFileName[0] == '\0') {
- nativeName = (TCHAR *) data.a.cFileName;
- }
+ if (data.cAlternateFileName[0] == '\0') {
+ nativeName = (TCHAR *) data.cFileName;
}
}
@@ -1790,22 +1704,21 @@ ConvertFileNameFormat(
Tcl_DStringInit(&dsTemp);
Tcl_WinTCharToUtf(nativeName, -1, &dsTemp);
+ Tcl_DStringFree(&ds);
/*
* Deal with issues of tildes being absolute.
*/
if (Tcl_DStringValue(&dsTemp)[0] == '~') {
- tempPath = Tcl_NewStringObj("./",2);
+ TclNewLiteralStringObj(tempPath, "./");
Tcl_AppendToObj(tempPath, Tcl_DStringValue(&dsTemp),
Tcl_DStringLength(&dsTemp));
+ Tcl_DStringFree(&dsTemp);
} else {
- tempPath = Tcl_NewStringObj(Tcl_DStringValue(&dsTemp),
- Tcl_DStringLength(&dsTemp));
+ tempPath = TclDStringToObj(&dsTemp);
}
Tcl_ListObjReplace(NULL, splitPath, i, 1, 1, &tempPath);
- Tcl_DStringFree(&ds);
- Tcl_DStringFree(&dsTemp);
FindClose(handle);
}
}
@@ -1917,13 +1830,12 @@ SetWinFileAttributes(
Tcl_Obj *fileName, /* The name of the file. */
Tcl_Obj *attributePtr) /* The new value of the attribute. */
{
- DWORD fileAttributes;
- int yesNo;
- int result;
- CONST TCHAR *nativeName;
+ DWORD fileAttributes, old;
+ int yesNo, result;
+ const TCHAR *nativeName;
nativeName = Tcl_FSGetNativePath(fileName);
- fileAttributes = (*tclWinProcs->getFileAttributesProc)(nativeName);
+ fileAttributes = old = GetFileAttributes(nativeName);
if (fileAttributes == 0xffffffff) {
StatError(interp, fileName);
@@ -1941,7 +1853,8 @@ SetWinFileAttributes(
fileAttributes &= ~(attributeArray[objIndex]);
}
- if (!(*tclWinProcs->setFileAttributesProc)(nativeName, fileAttributes)) {
+ if ((fileAttributes != old)
+ && !SetFileAttributes(nativeName, fileAttributes)) {
StatError(interp, fileName);
return TCL_ERROR;
}
@@ -1972,13 +1885,13 @@ CannotSetAttribute(
Tcl_Obj *fileName, /* The name of the file. */
Tcl_Obj *attributePtr) /* The new value of the attribute. */
{
- Tcl_AppendResult(interp, "cannot set attribute \"",
- tclpFileAttrStrings[objIndex], "\" for file \"",
- Tcl_GetString(fileName), "\": attribute is readonly",
- (char *) NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "cannot set attribute \"%s\" for file \"%s\": attribute is readonly",
+ tclpFileAttrStrings[objIndex], Tcl_GetString(fileName)));
+ errno = EINVAL;
+ Tcl_PosixError(interp);
return TCL_ERROR;
}
-
/*
*---------------------------------------------------------------------------
@@ -1996,7 +1909,7 @@ CannotSetAttribute(
*---------------------------------------------------------------------------
*/
-Tcl_Obj*
+Tcl_Obj *
TclpObjListVolumes(void)
{
Tcl_Obj *resultPtr, *elemPtr;
diff --git a/win/tclWinFile.c b/win/tclWinFile.c
index e671058..6662327 100755
--- a/win/tclWinFile.c
+++ b/win/tclWinFile.c
@@ -16,9 +16,13 @@
#include "tclFileSystem.h"
#include <winioctl.h>
#include <shlobj.h>
-#include <lmaccess.h> /* For TclpGetUserHome(). */
+#include <lm.h> /* For TclpGetUserHome(). */
#include <userenv.h> /* For TclpGetUserHome(). */
+#include <aclapi.h> /* For GetNamedSecurityInfo */
+#ifdef _MSC_VER
+# pragma comment(lib, "userenv.lib")
+#endif
/*
* The number of 100-ns intervals between the Windows system epoch (1601-01-01
* on the proleptic Gregorian calendar) and the Posix epoch (1970-01-01).
@@ -141,28 +145,6 @@ typedef struct {
WCHAR dummyBuf[MAX_PATH * 3];
} DUMMY_REPARSE_BUFFER;
-#if defined(_MSC_VER) && (_MSC_VER <= 1100)
-#undef HAVE_NO_FINDEX_ENUMS
-#define HAVE_NO_FINDEX_ENUMS
-#elif !defined(_WIN32_WINNT) || (_WIN32_WINNT < 0x0400)
-#undef HAVE_NO_FINDEX_ENUMS
-#define HAVE_NO_FINDEX_ENUMS
-#endif
-
-#ifdef HAVE_NO_FINDEX_ENUMS
-/* These two aren't in VC++ 5.2 headers */
-typedef enum _FINDEX_INFO_LEVELS {
- FindExInfoStandard,
- FindExInfoMaxInfoLevel
-} FINDEX_INFO_LEVELS;
-typedef enum _FINDEX_SEARCH_OPS {
- FindExSearchNameMatch,
- FindExSearchLimitToDirectories,
- FindExSearchLimitToDevices,
- FindExSearchMaxSearchOp
-} FINDEX_SEARCH_OPS;
-#endif /* HAVE_NO_FINDEX_ENUMS */
-
/*
* Other typedefs required by this code.
*/
@@ -170,18 +152,6 @@ typedef enum _FINDEX_SEARCH_OPS {
static time_t ToCTime(FILETIME fileTime);
static void FromCTime(time_t posixTime, FILETIME *fileTime);
-typedef NET_API_STATUS NET_API_FUNCTION NETUSERGETINFOPROC(
- LPWSTR servername, LPWSTR username, DWORD level, LPBYTE *bufptr);
-
-typedef NET_API_STATUS NET_API_FUNCTION NETAPIBUFFERFREEPROC(LPVOID Buffer);
-
-typedef NET_API_STATUS NET_API_FUNCTION NETGETDCNAMEPROC(
- LPWSTR servername, LPWSTR domainname, LPBYTE *bufptr);
-
-typedef BOOL WINAPI GETPROFILESDIRECTORYPROC(
- LPWSTR lpProfilesDir, LPDWORD lpcchSize
-);
-
/*
* Declarations for local functions defined in this file:
*/
@@ -207,6 +177,7 @@ static int WinLink(const TCHAR *LinkSource,
const TCHAR *LinkTarget, int linkAction);
static int WinSymLinkDirectory(const TCHAR *LinkDirectory,
const TCHAR *LinkTarget);
+MODULE_SCOPE TCL_NORETURN void tclWinDebugPanic(const char *format, ...);
/*
*--------------------------------------------------------------------
@@ -224,7 +195,7 @@ WinLink(
const TCHAR *linkTargetPath,
int linkAction)
{
- WCHAR tempFileName[MAX_PATH];
+ TCHAR tempFileName[MAX_PATH];
TCHAR *tempFilePart;
DWORD attr;
@@ -232,8 +203,8 @@ WinLink(
* Get the full path referenced by the target.
*/
- if (!(*tclWinProcs->getFullPathNameProc)(linkTargetPath, MAX_PATH,
- tempFileName, &tempFilePart)) {
+ if (!GetFullPathName(linkTargetPath, MAX_PATH, tempFileName,
+ &tempFilePart)) {
/*
* Invalid file.
*/
@@ -246,7 +217,7 @@ WinLink(
* Make sure source file doesn't exist.
*/
- attr = (*tclWinProcs->getFileAttributesProc)(linkSourcePath);
+ attr = GetFileAttributes(linkSourcePath);
if (attr != INVALID_FILE_ATTRIBUTES) {
Tcl_SetErrno(EEXIST);
return -1;
@@ -256,8 +227,8 @@ WinLink(
* Get the full path referenced by the source file/directory.
*/
- if (!(*tclWinProcs->getFullPathNameProc)(linkSourcePath, MAX_PATH,
- tempFileName, &tempFilePart)) {
+ if (!GetFullPathName(linkSourcePath, MAX_PATH, tempFileName,
+ &tempFilePart)) {
/*
* Invalid file.
*/
@@ -270,43 +241,36 @@ WinLink(
* Check the target.
*/
- attr = (*tclWinProcs->getFileAttributesProc)(linkTargetPath);
+ attr = GetFileAttributes(linkTargetPath);
if (attr == INVALID_FILE_ATTRIBUTES) {
/*
* The target doesn't exist.
*/
TclWinConvertError(GetLastError());
- return -1;
-
} else if ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0) {
/*
* It is a file.
*/
- if (tclWinProcs->createHardLinkProc == NULL) {
- Tcl_SetErrno(ENOTDIR);
- return -1;
- }
-
if (linkAction & TCL_CREATE_HARD_LINK) {
- if (!(*tclWinProcs->createHardLinkProc)(linkSourcePath,
- linkTargetPath, NULL)) {
- TclWinConvertError(GetLastError());
- return -1;
+ if (CreateHardLink(linkSourcePath, linkTargetPath, NULL)) {
+ /*
+ * Success!
+ */
+
+ return 0;
}
- return 0;
+ TclWinConvertError(GetLastError());
} else if (linkAction & TCL_CREATE_SYMBOLIC_LINK) {
/*
* Can't symlink files.
*/
Tcl_SetErrno(ENOTDIR);
- return -1;
} else {
Tcl_SetErrno(ENODEV);
- return -1;
}
} else {
/*
@@ -323,12 +287,11 @@ WinLink(
*/
Tcl_SetErrno(EISDIR);
- return -1;
} else {
Tcl_SetErrno(ENODEV);
- return -1;
}
}
+ return -1;
}
/*
@@ -345,7 +308,7 @@ static Tcl_Obj *
WinReadLink(
const TCHAR *linkSourcePath)
{
- WCHAR tempFileName[MAX_PATH];
+ TCHAR tempFileName[MAX_PATH];
TCHAR *tempFilePart;
DWORD attr;
@@ -353,8 +316,8 @@ WinReadLink(
* Get the full path referenced by the target.
*/
- if (!(*tclWinProcs->getFullPathNameProc)(linkSourcePath, MAX_PATH,
- tempFileName, &tempFilePart)) {
+ if (!GetFullPathName(linkSourcePath, MAX_PATH, tempFileName,
+ &tempFilePart)) {
/*
* Invalid file.
*/
@@ -367,7 +330,7 @@ WinReadLink(
* Make sure source file does exist.
*/
- attr = (*tclWinProcs->getFileAttributesProc)(linkSourcePath);
+ attr = GetFileAttributes(linkSourcePath);
if (attr == INVALID_FILE_ATTRIBUTES) {
/*
* The source doesn't exist.
@@ -383,9 +346,9 @@ WinReadLink(
Tcl_SetErrno(ENOTDIR);
return NULL;
- } else {
- return WinReadLinkDirectory(linkSourcePath);
}
+
+ return WinReadLinkDirectory(linkSourcePath);
}
/*
@@ -524,9 +487,8 @@ TclWinSymLinkDelete(
memset(reparseBuffer, 0, sizeof(DUMMY_REPARSE_BUFFER));
reparseBuffer->ReparseTag = IO_REPARSE_TAG_MOUNT_POINT;
- hFile = (*tclWinProcs->createFileProc)(linkOrigPath, GENERIC_WRITE, 0,
- NULL, OPEN_EXISTING,
- FILE_FLAG_OPEN_REPARSE_POINT|FILE_FLAG_BACKUP_SEMANTICS, NULL);
+ hFile = CreateFile(linkOrigPath, GENERIC_WRITE, 0, NULL, OPEN_EXISTING,
+ FILE_FLAG_OPEN_REPARSE_POINT | FILE_FLAG_BACKUP_SEMANTICS, NULL);
if (hFile != INVALID_HANDLE_VALUE) {
if (!DeviceIoControl(hFile, FSCTL_DELETE_REPARSE_POINT, reparseBuffer,
@@ -540,7 +502,7 @@ TclWinSymLinkDelete(
} else {
CloseHandle(hFile);
if (!linkOnly) {
- (*tclWinProcs->removeDirectoryProc)(linkOrigPath);
+ RemoveDirectory(linkOrigPath);
}
return 0;
}
@@ -580,7 +542,7 @@ WinReadLinkDirectory(
Tcl_DString ds;
const char *copy;
- attr = (*tclWinProcs->getFileAttributesProc)(linkDirPath);
+ attr = GetFileAttributes(linkDirPath);
if (!(attr & FILE_ATTRIBUTE_REPARSE_POINT)) {
goto invalidError;
}
@@ -605,6 +567,7 @@ WinReadLinkDirectory(
*/
offset = 0;
+#ifdef UNICODE
if (reparseBuffer->MountPointReparseBuffer.PathBuffer[0] == L'\\') {
/*
* Check whether this is a mounted volume.
@@ -666,8 +629,9 @@ WinReadLinkDirectory(
offset = 4;
}
}
+#endif /* UNICODE */
- Tcl_WinTCharToUtf((const char *)
+ Tcl_WinTCharToUtf((const TCHAR *)
reparseBuffer->MountPointReparseBuffer.PathBuffer,
(int) reparseBuffer->MountPointReparseBuffer
.SubstituteNameLength, &ds);
@@ -709,9 +673,8 @@ NativeReadReparse(
HANDLE hFile;
DWORD returnedLength;
- hFile = (*tclWinProcs->createFileProc)(linkDirPath, desiredAccess, FILE_SHARE_READ,
- NULL, OPEN_EXISTING,
- FILE_FLAG_OPEN_REPARSE_POINT|FILE_FLAG_BACKUP_SEMANTICS, NULL);
+ hFile = CreateFile(linkDirPath, desiredAccess, FILE_SHARE_READ, NULL, OPEN_EXISTING,
+ FILE_FLAG_OPEN_REPARSE_POINT | FILE_FLAG_BACKUP_SEMANTICS, NULL);
if (hFile == INVALID_HANDLE_VALUE) {
/*
@@ -769,7 +732,7 @@ NativeWriteReparse(
* Create the directory - it must not already exist.
*/
- if ((*tclWinProcs->createDirectoryProc)(linkDirPath, NULL) == 0) {
+ if (CreateDirectory(linkDirPath, NULL) == 0) {
/*
* Error creating directory.
*/
@@ -777,9 +740,9 @@ NativeWriteReparse(
TclWinConvertError(GetLastError());
return -1;
}
- hFile = (*tclWinProcs->createFileProc)(linkDirPath, GENERIC_WRITE, 0,
- NULL, OPEN_EXISTING,
- FILE_FLAG_OPEN_REPARSE_POINT|FILE_FLAG_BACKUP_SEMANTICS, NULL);
+ hFile = CreateFile(linkDirPath, GENERIC_WRITE, 0, NULL,
+ OPEN_EXISTING, FILE_FLAG_OPEN_REPARSE_POINT
+ | FILE_FLAG_BACKUP_SEMANTICS, NULL);
if (hFile == INVALID_HANDLE_VALUE) {
/*
* Error creating directory.
@@ -802,7 +765,7 @@ NativeWriteReparse(
TclWinConvertError(GetLastError());
CloseHandle(hFile);
- (*tclWinProcs->removeDirectoryProc)(linkDirPath);
+ RemoveDirectory(linkDirPath);
return -1;
}
CloseHandle(hFile);
@@ -815,6 +778,65 @@ NativeWriteReparse(
}
/*
+ *----------------------------------------------------------------------
+ *
+ * tclWinDebugPanic --
+ *
+ * Display a message. If a debugger is present, present it directly to
+ * the debugger, otherwise use a MessageBox.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+TCL_NORETURN void
+tclWinDebugPanic(
+ const char *format, ...)
+{
+#define TCL_MAX_WARN_LEN 1024
+ va_list argList;
+ char buf[TCL_MAX_WARN_LEN * TCL_UTF_MAX];
+ WCHAR msgString[TCL_MAX_WARN_LEN];
+
+ va_start(argList, format);
+ vsnprintf(buf, sizeof(buf), format, argList);
+
+ msgString[TCL_MAX_WARN_LEN-1] = L'\0';
+ MultiByteToWideChar(CP_UTF8, 0, buf, -1, msgString, TCL_MAX_WARN_LEN);
+
+ /*
+ * Truncate MessageBox string if it is too long to not overflow the screen
+ * and cause possible oversized window error.
+ */
+
+ if (msgString[TCL_MAX_WARN_LEN-1] != L'\0') {
+ memcpy(msgString + (TCL_MAX_WARN_LEN - 5), L" ...", 5 * sizeof(WCHAR));
+ }
+ if (IsDebuggerPresent()) {
+ OutputDebugStringW(msgString);
+ } else {
+ MessageBeep(MB_ICONEXCLAMATION);
+ MessageBoxW(NULL, msgString, L"Fatal Error",
+ MB_ICONSTOP | MB_OK | MB_TASKMODAL | MB_SETFOREGROUND);
+ }
+#if defined(__GNUC__)
+ __builtin_trap();
+#elif defined(_WIN64)
+ __debugbreak();
+#elif defined(_MSC_VER)
+ _asm {int 3}
+#else
+ DebugBreak();
+#endif
+ abort();
+}
+
+/*
*---------------------------------------------------------------------------
*
* TclpFindExecutable --
@@ -833,28 +855,33 @@ NativeWriteReparse(
void
TclpFindExecutable(
- const char *argv0) /* The value of the application's argv[0]
- * (native). */
+ const char *argv0) /* If NULL, install PanicMessageBox, otherwise
+ * ignore. */
{
WCHAR wName[MAX_PATH];
char name[MAX_PATH * TCL_UTF_MAX];
/*
* Under Windows we ignore argv0, and return the path for the file used to
- * create this process.
+ * create this process. Only if it is NULL, install a new panic handler.
*/
- if (GetModuleFileNameW(NULL, wName, MAX_PATH) == 0) {
- GetModuleFileNameA(NULL, name, sizeof(name));
+ if (argv0 == NULL) {
+ Tcl_SetPanicProc(tclWinDebugPanic);
+ }
- /*
- * Convert to WCHAR to get out of ANSI codepage
- */
+#ifdef UNICODE
+ GetModuleFileNameW(NULL, wName, MAX_PATH);
+#else
+ GetModuleFileNameA(NULL, name, sizeof(name));
- MultiByteToWideChar(CP_ACP, 0, name, -1, wName, MAX_PATH);
- }
+ /*
+ * Convert to WCHAR to get out of ANSI codepage
+ */
- WideCharToMultiByte(CP_UTF8, 0, wName, -1, name, sizeof(name), NULL,NULL);
+ MultiByteToWideChar(CP_ACP, 0, name, -1, wName, MAX_PATH);
+#endif
+ WideCharToMultiByte(CP_UTF8, 0, wName, -1, name, sizeof(name), NULL, NULL);
TclWinNoBackslash(name);
TclSetObjNameOfExecutable(Tcl_NewStringObj(name, -1), NULL);
}
@@ -900,6 +927,7 @@ TclpMatchInDirectory(
if (pattern == NULL || (*pattern == '\0')) {
Tcl_Obj *norm = Tcl_FSGetNormalizedPath(NULL, pathPtr);
+
if (norm != NULL) {
/*
* Match a single file directly.
@@ -907,23 +935,16 @@ TclpMatchInDirectory(
int len;
DWORD attr;
+ WIN32_FILE_ATTRIBUTE_DATA data;
const char *str = Tcl_GetStringFromObj(norm,&len);
- native = (const TCHAR *) Tcl_FSGetNativePath(pathPtr);
+ native = Tcl_FSGetNativePath(pathPtr);
- if (tclWinProcs->getFileAttributesExProc == NULL) {
- attr = (*tclWinProcs->getFileAttributesProc)(native);
- if (attr == 0xffffffff) {
- return TCL_OK;
- }
- } else {
- WIN32_FILE_ATTRIBUTE_DATA data;
- if ((*tclWinProcs->getFileAttributesExProc)(native,
- GetFileExInfoStandard, &data) != TRUE) {
- return TCL_OK;
- }
- attr = data.dwFileAttributes;
+ if (GetFileAttributesEx(native,
+ GetFileExInfoStandard, &data) != TRUE) {
+ return TCL_OK;
}
+ attr = data.dwFileAttributes;
if (NativeMatchType(WinIsDrive(str,len), attr, native, types)) {
Tcl_ListObjAppendElement(interp, resultPtr, pathPtr);
@@ -933,7 +954,7 @@ TclpMatchInDirectory(
} else {
DWORD attr;
HANDLE handle;
- WIN32_FIND_DATAT data;
+ WIN32_FIND_DATA data;
const char *dirName; /* UTF-8 dir name, later with pattern
* appended. */
int dirLength;
@@ -962,9 +983,10 @@ TclpMatchInDirectory(
if (native == NULL) {
return TCL_OK;
}
- attr = (*tclWinProcs->getFileAttributesProc)(native);
+ attr = GetFileAttributes(native);
- if ((attr == 0xffffffff) || ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0)) {
+ if ((attr == INVALID_FILE_ATTRIBUTES)
+ || ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0)) {
return TCL_OK;
}
@@ -979,7 +1001,7 @@ TclpMatchInDirectory(
lastChar = dirName[dirLength -1];
if ((lastChar != '\\') && (lastChar != '/') && (lastChar != ':')) {
- Tcl_DStringAppend(&dsOrig, "/", 1);
+ TclDStringAppendLiteral(&dsOrig, "/");
dirLength++;
}
dirName = Tcl_DStringValue(&dsOrig);
@@ -999,25 +1021,25 @@ TclpMatchInDirectory(
dirName = Tcl_DStringAppend(&dsOrig, pattern, -1);
} else {
- dirName = Tcl_DStringAppend(&dsOrig, "*.*", 3);
+ dirName = TclDStringAppendLiteral(&dsOrig, "*.*");
}
native = Tcl_WinUtfToTChar(dirName, -1, &ds);
- if (tclWinProcs->findFirstFileExProc == NULL || (types == NULL)
- || (types->type != TCL_GLOB_TYPE_DIR)) {
- handle = (*tclWinProcs->findFirstFileProc)(native, &data);
+ if ((types == NULL) || (types->type != TCL_GLOB_TYPE_DIR)) {
+ handle = FindFirstFile(native, &data);
} else {
/*
* We can be more efficient, for pure directory requests.
*/
- handle = (*tclWinProcs->findFirstFileExProc)(native,
+ handle = FindFirstFileEx(native,
FindExInfoStandard, &data,
FindExSearchLimitToDirectories, NULL, 0);
}
if (handle == INVALID_HANDLE_VALUE) {
DWORD err = GetLastError();
+
Tcl_DStringFree(&ds);
if (err == ERROR_FILE_NOT_FOUND) {
/*
@@ -1031,10 +1053,9 @@ TclpMatchInDirectory(
TclWinConvertError(err);
if (interp != NULL) {
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "couldn't read directory \"",
- Tcl_DStringValue(&dsOrig), "\": ",
- Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't read directory \"%s\": %s",
+ Tcl_DStringValue(&dsOrig), Tcl_PosixError(interp)));
}
Tcl_DStringFree(&dsOrig);
return TCL_ERROR;
@@ -1074,14 +1095,8 @@ TclpMatchInDirectory(
int checkDrive = 0, isDrive;
DWORD attr;
- if (tclWinProcs->useWide) {
- native = (const TCHAR *) data.w.cFileName;
- attr = data.w.dwFileAttributes;
- } else {
- native = (const TCHAR *) data.a.cFileName;
- attr = data.a.dwFileAttributes;
- }
-
+ native = data.cFileName;
+ attr = data.dwFileAttributes;
utfname = Tcl_WinTCharToUtf(native, -1, &ds);
if (!matchSpecialDots) {
@@ -1124,6 +1139,7 @@ TclpMatchInDirectory(
if (checkDrive) {
const char *fullname = Tcl_DStringAppend(&dsOrig, utfname,
Tcl_DStringLength(&ds));
+
isDrive = WinIsDrive(fullname, Tcl_DStringLength(&dsOrig));
Tcl_DStringSetLength(&dsOrig, dirLength);
} else {
@@ -1141,7 +1157,7 @@ TclpMatchInDirectory(
*/
Tcl_DStringFree(&ds);
- } while ((*tclWinProcs->findNextFileProc)(handle, &data) == TRUE);
+ } while (FindNextFile(handle, &data) == TRUE);
FindClose(handle);
Tcl_DStringFree(&dsOrig);
@@ -1314,81 +1330,80 @@ NativeMatchType(
* If invisible, don't return the file.
*/
- if (attr & FILE_ATTRIBUTE_HIDDEN && !isDrive) {
+ return !(attr & FILE_ATTRIBUTE_HIDDEN && !isDrive);
+ }
+
+ if (attr & FILE_ATTRIBUTE_HIDDEN && !isDrive) {
+ /*
+ * If invisible.
+ */
+
+ if ((types->perm == 0) || !(types->perm & TCL_GLOB_PERM_HIDDEN)) {
return 0;
}
} else {
- if (attr & FILE_ATTRIBUTE_HIDDEN && !isDrive) {
- /*
- * If invisible.
- */
-
- if ((types->perm == 0) || !(types->perm & TCL_GLOB_PERM_HIDDEN)) {
- return 0;
- }
- } else {
- /*
- * Visible.
- */
+ /*
+ * Visible.
+ */
- if (types->perm & TCL_GLOB_PERM_HIDDEN) {
- return 0;
- }
+ if (types->perm & TCL_GLOB_PERM_HIDDEN) {
+ return 0;
}
+ }
- if (types->perm != 0) {
- if (((types->perm & TCL_GLOB_PERM_RONLY) &&
- !(attr & FILE_ATTRIBUTE_READONLY)) ||
- ((types->perm & TCL_GLOB_PERM_R) &&
- (0 /* File exists => R_OK on Windows */)) ||
- ((types->perm & TCL_GLOB_PERM_W) &&
- (attr & FILE_ATTRIBUTE_READONLY)) ||
- ((types->perm & TCL_GLOB_PERM_X) &&
- (!(attr & FILE_ATTRIBUTE_DIRECTORY)
- && !NativeIsExec(nativeName)))) {
- return 0;
- }
+ if (types->perm != 0) {
+ if (((types->perm & TCL_GLOB_PERM_RONLY) &&
+ !(attr & FILE_ATTRIBUTE_READONLY)) ||
+ ((types->perm & TCL_GLOB_PERM_R) &&
+ (0 /* File exists => R_OK on Windows */)) ||
+ ((types->perm & TCL_GLOB_PERM_W) &&
+ (attr & FILE_ATTRIBUTE_READONLY)) ||
+ ((types->perm & TCL_GLOB_PERM_X) &&
+ (!(attr & FILE_ATTRIBUTE_DIRECTORY)
+ && !NativeIsExec(nativeName)))) {
+ return 0;
}
- if ((types->type & TCL_GLOB_TYPE_DIR)
- && (attr & FILE_ATTRIBUTE_DIRECTORY)) {
- /*
- * Quicker test for directory, which is a common case.
- */
+ }
- return 1;
+ if ((types->type & TCL_GLOB_TYPE_DIR)
+ && (attr & FILE_ATTRIBUTE_DIRECTORY)) {
+ /*
+ * Quicker test for directory, which is a common case.
+ */
- } else if (types->type != 0) {
- unsigned short st_mode;
- int isExec = NativeIsExec(nativeName);
+ return 1;
- st_mode = NativeStatMode(attr, 0, isExec);
+ } else if (types->type != 0) {
+ unsigned short st_mode;
+ int isExec = NativeIsExec(nativeName);
- /*
- * In order bcdpfls as in 'find -t'
- */
+ st_mode = NativeStatMode(attr, 0, isExec);
- if (((types->type&TCL_GLOB_TYPE_BLOCK) && S_ISBLK(st_mode)) ||
- ((types->type&TCL_GLOB_TYPE_CHAR) && S_ISCHR(st_mode)) ||
- ((types->type&TCL_GLOB_TYPE_DIR) && S_ISDIR(st_mode)) ||
- ((types->type&TCL_GLOB_TYPE_PIPE) && S_ISFIFO(st_mode)) ||
+ /*
+ * In order bcdpfls as in 'find -t'
+ */
+
+ if (((types->type&TCL_GLOB_TYPE_BLOCK) && S_ISBLK(st_mode)) ||
+ ((types->type&TCL_GLOB_TYPE_CHAR) && S_ISCHR(st_mode)) ||
+ ((types->type&TCL_GLOB_TYPE_DIR) && S_ISDIR(st_mode)) ||
+ ((types->type&TCL_GLOB_TYPE_PIPE) && S_ISFIFO(st_mode)) ||
#ifdef S_ISSOCK
- ((types->type&TCL_GLOB_TYPE_SOCK) && S_ISSOCK(st_mode)) ||
+ ((types->type&TCL_GLOB_TYPE_SOCK) && S_ISSOCK(st_mode)) ||
#endif
- ((types->type&TCL_GLOB_TYPE_FILE) && S_ISREG(st_mode))) {
- /*
- * Do nothing - this file is ok.
- */
- } else {
+ ((types->type&TCL_GLOB_TYPE_FILE) && S_ISREG(st_mode))) {
+ /*
+ * Do nothing - this file is ok.
+ */
+ } else {
#ifdef S_ISLNK
- if (types->type & TCL_GLOB_TYPE_LINK) {
- st_mode = NativeStatMode(attr, 1, isExec);
- if (S_ISLNK(st_mode)) {
- return 1;
- }
+ if (types->type & TCL_GLOB_TYPE_LINK) {
+ st_mode = NativeStatMode(attr, 1, isExec);
+ if (S_ISLNK(st_mode)) {
+ return 1;
}
-#endif
- return 0;
}
+#endif /* S_ISLNK */
+ return 0;
}
}
return 1;
@@ -1415,90 +1430,60 @@ NativeMatchType(
*----------------------------------------------------------------------
*/
-char *
+const char *
TclpGetUserHome(
const char *name, /* User name for desired home directory. */
Tcl_DString *bufferPtr) /* Uninitialized or free DString filled with
* name of user's home directory. */
{
- char *result;
- HINSTANCE netapiInst;
- HINSTANCE userenvInst;
+ const char *result = NULL;
+ USER_INFO_1 *uiPtr, **uiPtrPtr = &uiPtr;
+ Tcl_DString ds;
+ int nameLen = -1;
+ int badDomain = 0;
+ char *domain;
+ WCHAR *wName, *wHomeDir, *wDomain, **wDomainPtr = &wDomain;
+ WCHAR buf[MAX_PATH];
- result = NULL;
Tcl_DStringInit(bufferPtr);
-
- netapiInst = LoadLibraryA("netapi32.dll");
- userenvInst = LoadLibraryA("userenv.dll");
- if (netapiInst != NULL && userenvInst != NULL) {
- NETAPIBUFFERFREEPROC *netApiBufferFreeProc;
- NETGETDCNAMEPROC *netGetDCNameProc;
- NETUSERGETINFOPROC *netUserGetInfoProc;
- GETPROFILESDIRECTORYPROC *getProfilesDirectoryProc;
-
- netApiBufferFreeProc = (NETAPIBUFFERFREEPROC *)
- GetProcAddress(netapiInst, "NetApiBufferFree");
- netGetDCNameProc = (NETGETDCNAMEPROC *)
- GetProcAddress(netapiInst, "NetGetDCName");
- netUserGetInfoProc = (NETUSERGETINFOPROC *)
- GetProcAddress(netapiInst, "NetUserGetInfo");
- getProfilesDirectoryProc = (GETPROFILESDIRECTORYPROC *)
- GetProcAddress(userenvInst, "GetProfilesDirectoryW");
- if ((netUserGetInfoProc != NULL) && (netGetDCNameProc != NULL)
- && (netApiBufferFreeProc != NULL) && (getProfilesDirectoryProc != NULL)) {
- USER_INFO_1 *uiPtr, **uiPtrPtr = &uiPtr;
- Tcl_DString ds;
- int nameLen, badDomain;
- char *domain;
- WCHAR *wName, *wHomeDir, *wDomain, **wDomainPtr = &wDomain;
- WCHAR buf[MAX_PATH];
-
- badDomain = 0;
- nameLen = -1;
- wDomain = NULL;
- domain = strchr(name, '@');
- if (domain != NULL) {
- Tcl_DStringInit(&ds);
- wName = Tcl_UtfToUniCharDString(domain + 1, -1, &ds);
- badDomain = (netGetDCNameProc)(NULL, wName,
- (LPBYTE *) wDomainPtr);
- Tcl_DStringFree(&ds);
- nameLen = domain - name;
- }
- if (badDomain == 0) {
- Tcl_DStringInit(&ds);
- wName = Tcl_UtfToUniCharDString(name, nameLen, &ds);
- if ((netUserGetInfoProc)(wDomain, wName, 1,
- (LPBYTE *) uiPtrPtr) == 0) {
- wHomeDir = uiPtr->usri1_home_dir;
- if ((wHomeDir != NULL) && (wHomeDir[0] != L'\0')) {
- Tcl_UniCharToUtfDString(wHomeDir, lstrlenW(wHomeDir),
- bufferPtr);
- } else {
- /*
- * User exists but has no home dir. Return
- * "{GetProfilesDirectory}/<user>".
- */
- DWORD i, size = MAX_PATH;
- getProfilesDirectoryProc(buf, &size);
- for (i = 0; i < size; ++i){
- if (buf[i] == '\\') buf[i] = '/';
- }
- Tcl_UniCharToUtfDString(buf, size-1, bufferPtr);
- Tcl_DStringAppend(bufferPtr, "/", -1);
- Tcl_DStringAppend(bufferPtr, name, -1);
- }
- result = Tcl_DStringValue(bufferPtr);
- (*netApiBufferFreeProc)((void *) uiPtr);
+ wDomain = NULL;
+ domain = strchr(name, '@');
+ if (domain != NULL) {
+ Tcl_DStringInit(&ds);
+ wName = Tcl_UtfToUniCharDString(domain + 1, -1, &ds);
+ badDomain = NetGetDCName(NULL, wName, (LPBYTE *) wDomainPtr);
+ Tcl_DStringFree(&ds);
+ nameLen = domain - name;
+ }
+ if (badDomain == 0) {
+ Tcl_DStringInit(&ds);
+ wName = Tcl_UtfToUniCharDString(name, nameLen, &ds);
+ if (NetUserGetInfo(wDomain, wName, 1, (LPBYTE *) uiPtrPtr) == 0) {
+ wHomeDir = uiPtr->usri1_home_dir;
+ if ((wHomeDir != NULL) && (wHomeDir[0] != L'\0')) {
+ Tcl_UniCharToUtfDString(wHomeDir, lstrlenW(wHomeDir),
+ bufferPtr);
+ } else {
+ /*
+ * User exists but has no home dir. Return
+ * "{GetProfilesDirectory}/<user>".
+ */
+ DWORD i, size = MAX_PATH;
+ GetProfilesDirectoryW(buf, &size);
+ for (i = 0; i < size; ++i){
+ if (buf[i] == '\\') buf[i] = '/';
}
- Tcl_DStringFree(&ds);
- }
- if (wDomain != NULL) {
- (*netApiBufferFreeProc)((void *) wDomain);
+ Tcl_UniCharToUtfDString(buf, size-1, bufferPtr);
+ Tcl_DStringAppend(bufferPtr, "/", -1);
+ Tcl_DStringAppend(bufferPtr, name, -1);
}
+ result = Tcl_DStringValue(bufferPtr);
+ NetApiBufferFree((void *) uiPtr);
}
- FreeLibrary(userenvInst);
- FreeLibrary(netapiInst);
+ Tcl_DStringFree(&ds);
+ }
+ if (wDomain != NULL) {
+ NetApiBufferFree((void *) wDomain);
}
if (result == NULL) {
/*
@@ -1554,9 +1539,9 @@ NativeAccess(
{
DWORD attr;
- attr = (*tclWinProcs->getFileAttributesProc)(nativePath);
+ attr = GetFileAttributes(nativePath);
- if (attr == 0xffffffff) {
+ if (attr == INVALID_FILE_ATTRIBUTES) {
/*
* File might not exist.
*/
@@ -1612,7 +1597,8 @@ NativeAccess(
* what permissions the OS has set for a file.
*/
- if (tclWinProcs->getFileSecurityProc != NULL) {
+#ifdef UNICODE
+ {
SECURITY_DESCRIPTOR *sdPtr = NULL;
unsigned long size;
PSID pSid = 0;
@@ -1627,11 +1613,11 @@ NativeAccess(
int error;
/*
- * First find out how big the buffer needs to be
+ * First find out how big the buffer needs to be.
*/
size = 0;
- (*tclWinProcs->getFileSecurityProc)(nativePath,
+ GetFileSecurity(nativePath,
OWNER_SECURITY_INFORMATION | GROUP_SECURITY_INFORMATION
| DACL_SECURITY_INFORMATION | LABEL_SECURITY_INFORMATION,
0, 0, &size);
@@ -1665,7 +1651,7 @@ NativeAccess(
* Call GetFileSecurity() for real.
*/
- if (!(*tclWinProcs->getFileSecurityProc)(nativePath,
+ if (!GetFileSecurity(nativePath,
OWNER_SECURITY_INFORMATION | GROUP_SECURITY_INFORMATION
| DACL_SECURITY_INFORMATION | LABEL_SECURITY_INFORMATION,
sdPtr, size, &size)) {
@@ -1701,14 +1687,14 @@ NativeAccess(
* thread token.
*/
- if (!(*tclWinProcs->impersonateSelfProc)(SecurityImpersonation)) {
+ if (!ImpersonateSelf(SecurityImpersonation)) {
/*
* Unable to perform security impersonation.
*/
goto accessError;
}
- if (!(*tclWinProcs->openThreadTokenProc)(GetCurrentThread(),
+ if (!OpenThreadToken(GetCurrentThread(),
TOKEN_DUPLICATE | TOKEN_QUERY, FALSE, &hToken)) {
/*
* Unable to get current thread's token.
@@ -1717,7 +1703,7 @@ NativeAccess(
goto accessError;
}
- (*tclWinProcs->revertToSelfProc)();
+ RevertToSelf();
/*
* Setup desiredAccess according to the access priveleges we are
@@ -1744,7 +1730,7 @@ NativeAccess(
* Perform access check using the token.
*/
- if (!(*tclWinProcs->accessCheckProc)(sdPtr, hToken, desiredAccess,
+ if (!AccessCheck(sdPtr, hToken, desiredAccess,
&genMap, &privSet, &privSetSize, &grantedAccess,
&accessYesNo)) {
/*
@@ -1774,6 +1760,7 @@ NativeAccess(
}
}
+#endif /* !UNICODE */
return 0;
}
@@ -1793,57 +1780,23 @@ NativeAccess(
static int
NativeIsExec(
- const TCHAR *nativePath)
+ const TCHAR *path)
{
- if (tclWinProcs->useWide) {
- const WCHAR *path = (const WCHAR *) nativePath;
- int len = wcslen(path);
-
- if (len < 5) {
- return 0;
- }
+ int len = _tcslen(path);
- if (path[len-4] != L'.') {
- return 0;
- }
-
- /*
- * Use wide-char case-insensitive comparison
- */
-
- if ((_wcsicmp(path+len-3, L"exe") == 0)
- || (_wcsicmp(path+len-3, L"com") == 0)
- || (_wcsicmp(path+len-3, L"bat") == 0)) {
- return 1;
- }
- } else {
- const char *p;
-
- /*
- * We are only looking for pure ascii.
- */
-
- p = strrchr((const char *) nativePath, '.');
- if (p != NULL) {
- p++;
-
- /*
- * Note: in the old code, stat considered '.pif' files as
- * executable, whereas access did not.
- */
+ if (len < 5) {
+ return 0;
+ }
- if ((strcasecmp(p, "exe") == 0)
- || (strcasecmp(p, "com") == 0)
- || (strcasecmp(p, "cmd") == 0)
- || (strcasecmp(p, "ps1") == 0)
- || (strcasecmp(p, "bat") == 0)) {
- /*
- * File that ends with .exe, .com, or .bat is executable.
- */
+ if (path[len-4] != '.') {
+ return 0;
+ }
- return 1;
- }
- }
+ if ((_tcsicmp(path+len-3, TEXT("exe")) == 0)
+ || (_tcsicmp(path+len-3, TEXT("com")) == 0)
+ || (_tcsicmp(path+len-3, TEXT("cmd")) == 0)
+ || (_tcsicmp(path+len-3, TEXT("bat")) == 0)) {
+ return 1;
}
return 0;
}
@@ -1871,12 +1824,12 @@ TclpObjChdir(
int result;
const TCHAR *nativePath;
- nativePath = (const TCHAR *) Tcl_FSGetNativePath(pathPtr);
+ nativePath = Tcl_FSGetNativePath(pathPtr);
if (!nativePath) {
return -1;
}
- result = (*tclWinProcs->setCurrentDirectoryProc)(nativePath);
+ result = SetCurrentDirectory(nativePath);
if (result == 0) {
TclWinConvertError(GetLastError());
@@ -1913,14 +1866,16 @@ TclpGetCwd(
Tcl_DString *bufferPtr) /* Uninitialized or free DString filled with
* name of current directory. */
{
- WCHAR buffer[MAX_PATH];
+ TCHAR buffer[MAX_PATH];
char *p;
+ WCHAR *native;
- if ((*tclWinProcs->getCurrentDirectoryProc)(MAX_PATH, buffer) == 0) {
+ if (GetCurrentDirectory(MAX_PATH, buffer) == 0) {
TclWinConvertError(GetLastError());
if (interp != NULL) {
- Tcl_AppendResult(interp, "error getting working directory name: ",
- Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "error getting working directory name: %s",
+ Tcl_PosixError(interp)));
}
return NULL;
}
@@ -1929,25 +1884,12 @@ TclpGetCwd(
* Watch for the weird Windows c:\\UNC syntax.
*/
- if (tclWinProcs->useWide) {
- WCHAR *native;
-
- native = (WCHAR *) buffer;
- if ((native[0] != '\0') && (native[1] == ':')
- && (native[2] == '\\') && (native[3] == '\\')) {
- native += 2;
- }
- Tcl_WinTCharToUtf((TCHAR *) native, -1, bufferPtr);
- } else {
- char *native;
-
- native = (char *) buffer;
- if ((native[0] != '\0') && (native[1] == ':')
- && (native[2] == '\\') && (native[3] == '\\')) {
- native += 2;
- }
- Tcl_WinTCharToUtf((TCHAR *) native, -1, bufferPtr);
+ native = (WCHAR *) buffer;
+ if ((native[0] != '\0') && (native[1] == ':')
+ && (native[2] == '\\') && (native[3] == '\\')) {
+ native += 2;
}
+ Tcl_WinTCharToUtf((TCHAR *) native, -1, bufferPtr);
/*
* Convert to forward slashes for easier use in scripts.
@@ -1974,8 +1916,7 @@ TclpObjStat(
TclWinFlushDirtyChannels();
- return NativeStat((const TCHAR *) Tcl_FSGetNativePath(pathPtr),
- statPtr, 0);
+ return NativeStat(Tcl_FSGetNativePath(pathPtr), statPtr, 0);
}
/*
@@ -2012,6 +1953,7 @@ NativeStat(
unsigned short mode;
unsigned int inode = 0;
HANDLE fileHandle;
+ DWORD fileType = FILE_TYPE_UNKNOWN;
/*
* If we can use 'createFile' on this, then we can use the resulting
@@ -2019,9 +1961,17 @@ NativeStat(
* other attributes reading APIs. If not, then we try to fall back on the
* 'getFileAttributesExProc', and if that isn't available, then on even
* simpler routines.
+ *
+ * Special consideration must be given to Windows hardcoded names
+ * like CON, NULL, COM1, LPT1 etc. For these, we still need to
+ * do the CreateFile as some may not exist (e.g. there is no CON
+ * in wish by default). However the subsequent GetFileInformationByHandle
+ * will fail. We do a WinIsReserved to see if it is one of the special
+ * names, and if successful, mock up a BY_HANDLE_FILE_INFORMATION
+ * structure.
*/
- fileHandle = (tclWinProcs->createFileProc)(nativePath, GENERIC_READ,
+ fileHandle = CreateFile(nativePath, GENERIC_READ,
FILE_SHARE_READ | FILE_SHARE_WRITE, NULL, OPEN_EXISTING,
FILE_FLAG_BACKUP_SEMANTICS | FILE_FLAG_OPEN_REPARSE_POINT, NULL);
@@ -2029,19 +1979,26 @@ NativeStat(
BY_HANDLE_FILE_INFORMATION data;
if (GetFileInformationByHandle(fileHandle,&data) != TRUE) {
- CloseHandle(fileHandle);
- Tcl_SetErrno(ENOENT);
- return -1;
- }
- CloseHandle(fileHandle);
-
+ fileType = GetFileType(fileHandle);
+ CloseHandle(fileHandle);
+ if (fileType != FILE_TYPE_CHAR && fileType != FILE_TYPE_DISK) {
+ Tcl_SetErrno(ENOENT);
+ return -1;
+ }
+ /* Mock up the expected structure */
+ memset(&data, 0, sizeof(data));
+ statPtr->st_atime = 0;
+ statPtr->st_mtime = 0;
+ statPtr->st_ctime = 0;
+ } else {
+ CloseHandle(fileHandle);
+ statPtr->st_atime = ToCTime(data.ftLastAccessTime);
+ statPtr->st_mtime = ToCTime(data.ftLastWriteTime);
+ statPtr->st_ctime = ToCTime(data.ftCreationTime);
+ }
attr = data.dwFileAttributes;
-
statPtr->st_size = ((Tcl_WideInt) data.nFileSizeLow) |
(((Tcl_WideInt) data.nFileSizeHigh) << 32);
- statPtr->st_atime = ToCTime(data.ftLastAccessTime);
- statPtr->st_mtime = ToCTime(data.ftLastWriteTime);
- statPtr->st_ctime = ToCTime(data.ftCreationTime);
/*
* On Unix, for directories, nlink apparently depends on the number of
@@ -2060,24 +2017,24 @@ NativeStat(
*/
inode = data.nFileIndexHigh | data.nFileIndexLow;
- } else if (tclWinProcs->getFileAttributesExProc != NULL) {
+ } else {
/*
* Fall back on the less capable routines. This means no nlink or ino.
*/
WIN32_FILE_ATTRIBUTE_DATA data;
- if ((*tclWinProcs->getFileAttributesExProc)(nativePath,
+ if (GetFileAttributesEx(nativePath,
GetFileExInfoStandard, &data) != TRUE) {
HANDLE hFind;
- WIN32_FIND_DATAT ffd;
+ WIN32_FIND_DATA ffd;
DWORD lasterror = GetLastError();
if (lasterror != ERROR_SHARING_VIOLATION) {
TclWinConvertError(lasterror);
return -1;
}
- hFind = (*tclWinProcs->findFirstFileProc)(nativePath, &ffd);
+ hFind = FindFirstFile(nativePath, &ffd);
if (hFind == INVALID_HANDLE_VALUE) {
TclWinConvertError(GetLastError());
return -1;
@@ -2093,50 +2050,17 @@ NativeStat(
statPtr->st_atime = ToCTime(data.ftLastAccessTime);
statPtr->st_mtime = ToCTime(data.ftLastWriteTime);
statPtr->st_ctime = ToCTime(data.ftCreationTime);
- } else {
- /*
- * We don't have the faster attributes proc, so we're probably running
- * on Win95.
- */
-
- WIN32_FIND_DATAT data;
- HANDLE handle;
-
- handle = (*tclWinProcs->findFirstFileProc)(nativePath, &data);
- if (handle == INVALID_HANDLE_VALUE) {
- /*
- * FindFirstFile() doesn't work on root directories, so call
- * GetFileAttributes() to see if the specified file exists.
- */
-
- attr = (*tclWinProcs->getFileAttributesProc)(nativePath);
- if (attr == INVALID_FILE_ATTRIBUTES) {
- Tcl_SetErrno(ENOENT);
- return -1;
- }
-
- /*
- * Make up some fake information for this file. It has the correct
- * file attributes and a time of 0.
- */
-
- memset(&data, 0, sizeof(data));
- data.a.dwFileAttributes = attr;
- } else {
- FindClose(handle);
- }
-
- attr = data.a.dwFileAttributes;
-
- statPtr->st_size = ((Tcl_WideInt) data.a.nFileSizeLow) |
- (((Tcl_WideInt) data.a.nFileSizeHigh) << 32);
- statPtr->st_atime = ToCTime(data.a.ftLastAccessTime);
- statPtr->st_mtime = ToCTime(data.a.ftLastWriteTime);
- statPtr->st_ctime = ToCTime(data.a.ftCreationTime);
}
dev = NativeDev(nativePath);
mode = NativeStatMode(attr, checkLinks, NativeIsExec(nativePath));
+ if (fileType == FILE_TYPE_CHAR) {
+ mode &= ~S_IFMT;
+ mode |= S_IFCHR;
+ } else if (fileType == FILE_TYPE_DISK) {
+ mode &= ~S_IFMT;
+ mode |= S_IFBLK;
+ }
statPtr->st_dev = (dev_t) dev;
statPtr->st_ino = inode;
@@ -2164,14 +2088,12 @@ NativeDev(
{
int dev;
Tcl_DString ds;
- WCHAR nativeFullPath[MAX_PATH];
+ TCHAR nativeFullPath[MAX_PATH];
TCHAR *nativePart;
const char *fullPath;
- (*tclWinProcs->getFullPathNameProc)(nativePath, MAX_PATH,
- nativeFullPath, &nativePart);
-
- fullPath = Tcl_WinTCharToUtf((TCHAR *) nativeFullPath, -1, &ds);
+ GetFullPathName(nativePath, MAX_PATH, nativeFullPath, &nativePart);
+ fullPath = Tcl_WinTCharToUtf(nativeFullPath, -1, &ds);
if ((fullPath[0] == '\\') && (fullPath[1] == '\\')) {
const char *p;
@@ -2187,15 +2109,14 @@ NativeDev(
* won't work.
*/
- fullPath = Tcl_DStringAppend(&ds, "\\", 1);
+ fullPath = TclDStringAppendLiteral(&ds, "\\");
p = fullPath + Tcl_DStringLength(&ds);
} else {
p++;
}
nativeVol = Tcl_WinUtfToTChar(fullPath, p - fullPath, &volString);
dw = (DWORD) -1;
- (*tclWinProcs->getVolumeInformationProc)(nativeVol, NULL, 0, &dw,
- NULL, NULL, NULL, 0);
+ GetVolumeInformation(nativeVol, NULL, 0, &dw, NULL, NULL, NULL, 0);
/*
* GetFullPathName() turns special devices like "NUL" into "\\.\NUL",
@@ -2307,8 +2228,9 @@ FromCTime(
FILETIME *fileTime) /* UTC Time */
{
LARGE_INTEGER convertedTime;
+
convertedTime.QuadPart = ((LONGLONG) posixTime) * 10000000
- + POSIX_EPOCH_AS_FILETIME;
+ + POSIX_EPOCH_AS_FILETIME;
fileTime->dwLowDateTime = convertedTime.LowPart;
fileTime->dwHighDateTime = convertedTime.HighPart;
}
@@ -2338,34 +2260,20 @@ ClientData
TclpGetNativeCwd(
ClientData clientData)
{
- WCHAR buffer[MAX_PATH];
+ TCHAR buffer[MAX_PATH];
- if ((*tclWinProcs->getCurrentDirectoryProc)(MAX_PATH, buffer) == 0) {
+ if (GetCurrentDirectory(MAX_PATH, buffer) == 0) {
TclWinConvertError(GetLastError());
return NULL;
}
if (clientData != NULL) {
- if (tclWinProcs->useWide) {
- /*
- * Unicode representation when running on NT/2K/XP.
- */
-
- if (wcscmp((const WCHAR*)clientData, (const WCHAR*)buffer) == 0) {
- return clientData;
- }
- } else {
- /*
- * ANSI representation when running on 95/98/ME.
- */
-
- if (strcmp((const char*) clientData, (const char*) buffer) == 0) {
- return clientData;
- }
+ if (_tcscmp((const TCHAR*)clientData, buffer) == 0) {
+ return clientData;
}
}
- return TclNativeDupInternalRep((ClientData) buffer);
+ return TclNativeDupInternalRep(buffer);
}
int
@@ -2373,7 +2281,7 @@ TclpObjAccess(
Tcl_Obj *pathPtr,
int mode)
{
- return NativeAccess((const TCHAR *) Tcl_FSGetNativePath(pathPtr), mode);
+ return NativeAccess(Tcl_FSGetNativePath(pathPtr), mode);
}
int
@@ -2389,8 +2297,7 @@ TclpObjLstat(
TclWinFlushDirtyChannels();
- return NativeStat((const TCHAR *) Tcl_FSGetNativePath(pathPtr),
- statPtr, 1);
+ return NativeStat(Tcl_FSGetNativePath(pathPtr), statPtr, 1);
}
#ifdef S_IFLNK
@@ -2402,15 +2309,15 @@ TclpObjLink(
{
if (toPtr != NULL) {
int res;
- TCHAR *LinkTarget;
- TCHAR *LinkSource = (TCHAR *) Tcl_FSGetNativePath(pathPtr);
+ const TCHAR *LinkTarget;
+ const TCHAR *LinkSource = Tcl_FSGetNativePath(pathPtr);
Tcl_Obj *normalizedToPtr = Tcl_FSGetNormalizedPath(NULL, toPtr);
if (normalizedToPtr == NULL) {
return NULL;
}
- LinkTarget = (TCHAR *) Tcl_FSGetNativePath(normalizedToPtr);
+ LinkTarget = Tcl_FSGetNativePath(normalizedToPtr);
if (LinkSource == NULL || LinkTarget == NULL) {
return NULL;
@@ -2422,7 +2329,7 @@ TclpObjLink(
return NULL;
}
} else {
- TCHAR *LinkSource = (TCHAR *) Tcl_FSGetNativePath(pathPtr);
+ const TCHAR *LinkSource = Tcl_FSGetNativePath(pathPtr);
if (LinkSource == NULL) {
return NULL;
@@ -2430,7 +2337,7 @@ TclpObjLink(
return WinReadLink(LinkSource);
}
}
-#endif
+#endif /* S_IFLNK */
/*
*---------------------------------------------------------------------------
@@ -2456,7 +2363,7 @@ TclpFilesystemPathType(
{
#define VOL_BUF_SIZE 32
int found;
- WCHAR volType[VOL_BUF_SIZE];
+ TCHAR volType[VOL_BUF_SIZE];
char *firstSeparator;
const char *path;
Tcl_Obj *normPath = Tcl_FSGetNormalizedPath(NULL, pathPtr);
@@ -2471,16 +2378,14 @@ TclpFilesystemPathType(
firstSeparator = strchr(path, '/');
if (firstSeparator == NULL) {
- found = tclWinProcs->getVolumeInformationProc(
- Tcl_FSGetNativePath(pathPtr), NULL, 0, NULL, NULL, NULL,
- (WCHAR *) volType, VOL_BUF_SIZE);
+ found = GetVolumeInformation(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 = tclWinProcs->getVolumeInformationProc(
- Tcl_FSGetNativePath(driveName), NULL, 0, NULL, NULL, NULL,
- (WCHAR *) volType, VOL_BUF_SIZE);
+ found = GetVolumeInformation(Tcl_FSGetNativePath(driveName),
+ NULL, 0, NULL, NULL, NULL, volType, VOL_BUF_SIZE);
Tcl_DecrRefCount(driveName);
}
@@ -2488,13 +2393,9 @@ TclpFilesystemPathType(
return NULL;
} else {
Tcl_DString ds;
- Tcl_Obj *objPtr;
- Tcl_WinTCharToUtf((const char *) volType, -1, &ds);
- objPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds),
- Tcl_DStringLength(&ds));
- Tcl_DStringFree(&ds);
- return objPtr;
+ Tcl_WinTCharToUtf(volType, -1, &ds);
+ return TclDStringToObj(&ds);
}
#undef VOL_BUF_SIZE
}
@@ -2544,377 +2445,219 @@ TclpObjNormalizePath(
Tcl_DString dsNorm; /* This will hold the normalized string. */
char *path, *currentPathEndPosition;
Tcl_Obj *temp = NULL;
+ int isDrive = 1;
+ Tcl_DString ds; /* Some workspace. */
Tcl_DStringInit(&dsNorm);
path = Tcl_GetString(pathPtr);
- if (TclWinGetPlatformId() == VER_PLATFORM_WIN32_WINDOWS) {
- /*
- * We're on Win95, 98 or ME. There are two assumptions in this block
- * of code. First that the native (NULL) encoding is basically ascii,
- * and second that symbolic links are not possible. Both of these
- * assumptions appear to be true of these operating systems.
- */
-
- int isDrive = 1;
- Tcl_DString ds;
-
- currentPathEndPosition = path + nextCheckpoint;
- if (*currentPathEndPosition == '/') {
- currentPathEndPosition++;
- }
-
- while (1) {
- char cur = *currentPathEndPosition;
+ currentPathEndPosition = path + nextCheckpoint;
+ if (*currentPathEndPosition == '/') {
+ currentPathEndPosition++;
+ }
+ while (1) {
+ char cur = *currentPathEndPosition;
- if ((cur=='/' || cur==0) && (path != currentPathEndPosition)) {
- /*
- * Reached directory separator, or end of string.
- */
+ if ((cur=='/' || cur==0) && (path != currentPathEndPosition)) {
+ /*
+ * Reached directory separator, or end of string.
+ */
- const char *nativePath = Tcl_UtfToExternalDString(NULL, path,
- currentPathEndPosition - path, &ds);
+ WIN32_FILE_ATTRIBUTE_DATA data;
+ const TCHAR *nativePath = Tcl_WinUtfToTChar(path,
+ currentPathEndPosition - path, &ds);
+ if (GetFileAttributesEx(nativePath,
+ GetFileExInfoStandard, &data) != TRUE) {
/*
- * 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 the file exists.
+ * File doesn't exist.
*/
if (isDrive) {
- if (GetFileAttributesA(nativePath)
- == INVALID_FILE_ATTRIBUTES) {
- /*
- * File doesn't exist.
- */
-
- if (isDrive) {
- int len = WinIsReserved(path);
-
- if (len > 0) {
- /*
- * Actually it does exist - COM1, etc.
- */
-
- int i;
-
- for (i=0 ; i<len ; i++) {
- if (nativePath[i] >= 'a') {
- ((char *) nativePath)[i] -= ('a'-'A');
- }
- }
- Tcl_DStringAppend(&dsNorm, nativePath, len);
- lastValidPathEnd = currentPathEndPosition;
- } else if (nextCheckpoint == 0) {
- /* Path starts with a drive designation
- * that's not actually on the system.
- * We still must normalize up past the
- * first separator. [Bug 3603434] */
- currentPathEndPosition++;
- }
- }
- Tcl_DStringFree(&ds);
- break;
- }
- if (nativePath[0] >= 'a') {
- ((char *) nativePath)[0] -= ('a' - 'A');
- }
- Tcl_DStringAppend(&dsNorm, nativePath,
- Tcl_DStringLength(&ds));
- } else {
- char *checkDots = NULL;
-
- if (lastValidPathEnd[1] == '.') {
- checkDots = lastValidPathEnd + 1;
- while (checkDots < currentPathEndPosition) {
- if (*checkDots != '.') {
- checkDots = NULL;
- break;
- }
- checkDots++;
- }
- }
- if (checkDots != NULL) {
- int dotLen = currentPathEndPosition-lastValidPathEnd;
+ int len = WinIsReserved(path);
+ if (len > 0) {
/*
- * 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
+ * Actually it does exist - COM1, etc.
*/
- Tcl_DStringAppend(&dsNorm, (TCHAR *)
- (nativePath + Tcl_DStringLength(&ds)-dotLen),
- dotLen);
- } else {
- /*
- * Normal path.
- */
-
- WIN32_FIND_DATA fData;
- HANDLE handle;
-
- handle = FindFirstFileA(nativePath, &fData);
- if (handle == INVALID_HANDLE_VALUE) {
- if (GetFileAttributesA(nativePath)
- == INVALID_FILE_ATTRIBUTES) {
- /*
- * File doesn't exist.
- */
-
- Tcl_DStringFree(&ds);
- break;
- }
+ int i;
- /*
- * This is usually the '/' in 'c:/' at end of
- * string.
- */
+ for (i=0 ; i<len ; i++) {
+ WCHAR wc = ((WCHAR *) nativePath)[i];
- Tcl_DStringAppend(&dsNorm,"/", 1);
- } else {
- char *nativeName;
-
- if (fData.cFileName[0] != '\0') {
- nativeName = fData.cFileName;
- } else {
- nativeName = fData.cAlternateFileName;
+ if (wc >= L'a') {
+ wc -= (L'a' - L'A');
+ ((WCHAR *) nativePath)[i] = wc;
}
- FindClose(handle);
- Tcl_DStringAppend(&dsNorm,"/", 1);
- Tcl_DStringAppend(&dsNorm,nativeName,-1);
}
+ Tcl_DStringAppend(&dsNorm,
+ (const char *)nativePath,
+ (int)(sizeof(WCHAR) * len));
+ lastValidPathEnd = currentPathEndPosition;
+ } else if (nextCheckpoint == 0) {
+ /* Path starts with a drive designation
+ * that's not actually on the system.
+ * We still must normalize up past the
+ * first separator. [Bug 3603434] */
+ currentPathEndPosition++;
}
}
Tcl_DStringFree(&ds);
- lastValidPathEnd = currentPathEndPosition;
- if (cur == 0) {
- break;
- }
-
- /*
- * If we get here, we've got past one directory delimiter, so
- * we know it is no longer a drive.
- */
-
- isDrive = 0;
+ break;
}
- currentPathEndPosition++;
- }
- } else {
- /*
- * We're on WinNT (or 2000 or XP; something with an NT core).
- */
- int isDrive = 1;
- Tcl_DString ds;
-
- currentPathEndPosition = path + nextCheckpoint;
- if (*currentPathEndPosition == '/') {
- currentPathEndPosition++;
- }
- while (1) {
- char cur = *currentPathEndPosition;
+ /*
+ * File 'nativePath' does exist if we get here. We now want to
+ * check if it is a symlink and otherwise continue with the
+ * rest of the path.
+ */
- if ((cur=='/' || cur==0) && (path != currentPathEndPosition)) {
- /*
- * Reached directory separator, or end of string.
- */
+ /*
+ * 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.
+ */
- WIN32_FILE_ATTRIBUTE_DATA data;
- const char *nativePath = Tcl_WinUtfToTChar(path,
- currentPathEndPosition - path, &ds);
+ if (cur != 0 && !isDrive &&
+ data.dwFileAttributes & FILE_ATTRIBUTE_REPARSE_POINT){
+ Tcl_Obj *to = WinReadLinkDirectory(nativePath);
- if ((*tclWinProcs->getFileAttributesExProc)(nativePath,
- GetFileExInfoStandard, &data) != TRUE) {
+ if (to != NULL) {
/*
- * File doesn't exist.
+ * Read the reparse point ok. Now, reparse points need
+ * not be normalized, otherwise we could use:
+ *
+ * Tcl_GetStringFromObj(to, &pathLen);
+ * nextCheckpoint = pathLen;
+ *
+ * So, instead we have to start from the beginning.
*/
- if (isDrive) {
- int len = WinIsReserved(path);
+ nextCheckpoint = 0;
+ Tcl_AppendToObj(to, currentPathEndPosition, -1);
- if (len > 0) {
- /*
- * Actually it does exist - COM1, etc.
- */
-
- int i;
-
- for (i=0 ; i<len ; i++) {
- WCHAR wc = ((WCHAR *) nativePath)[i];
+ /*
+ * Convert link to forward slashes.
+ */
- if (wc >= L'a') {
- wc -= (L'a' - L'A');
- ((WCHAR *) nativePath)[i] = wc;
- }
- }
- Tcl_DStringAppend(&dsNorm, nativePath,
- (int)(sizeof(WCHAR) * len));
- lastValidPathEnd = currentPathEndPosition;
- } else if (nextCheckpoint == 0) {
- /* Path starts with a drive designation
- * that's not actually on the system.
- * We still must normalize up past the
- * first separator. [Bug 3603434] */
- currentPathEndPosition++;
+ for (path = Tcl_GetString(to); *path != 0; path++) {
+ if (*path == '\\') {
+ *path = '/';
}
}
- Tcl_DStringFree(&ds);
- break;
- }
-
- /*
- * File 'nativePath' does exist if we get here. We now want to
- * check if it is a symlink and otherwise continue with the
- * rest of the path.
- */
-
- /*
- * Check for symlinks, except at last component of path (we
- * don't follow final symlinks). Also a drive (C:/) for
- * example, may sometimes have the reparse flag set for some
- * reason I don't understand. We therefore don't perform this
- * check for drives.
- */
+ path = Tcl_GetString(to);
+ currentPathEndPosition = path + nextCheckpoint;
+ if (temp != NULL) {
+ Tcl_DecrRefCount(temp);
+ }
+ temp = to;
- if (cur != 0 && !isDrive &&
- data.dwFileAttributes & FILE_ATTRIBUTE_REPARSE_POINT){
- Tcl_Obj *to = WinReadLinkDirectory(nativePath);
+ /*
+ * Reset variables so we can restart normalization.
+ */
- if (to != NULL) {
- /*
- * Read the reparse point ok. Now, reparse points need
- * not be normalized, otherwise we could use:
- *
- * Tcl_GetStringFromObj(to, &pathLen);
- * nextCheckpoint = pathLen
- *
- * So, instead we have to start from the beginning.
- */
+ isDrive = 1;
+ Tcl_DStringFree(&dsNorm);
+ Tcl_DStringFree(&ds);
+ continue;
+ }
+ }
- nextCheckpoint = 0;
- Tcl_AppendToObj(to, currentPathEndPosition, -1);
+#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
+ */
- /*
- * Convert link to forward slashes.
- */
+ if (isDrive) {
+ WCHAR drive = ((WCHAR *) nativePath)[0];
- for (path = Tcl_GetString(to); *path != 0; path++) {
- if (*path == '\\') {
- *path = '/';
- }
- }
- path = Tcl_GetString(to);
- currentPathEndPosition = path + nextCheckpoint;
- if (temp != NULL) {
- Tcl_DecrRefCount(temp);
+ if (drive >= L'a') {
+ drive -= (L'a' - L'A');
+ ((WCHAR *) nativePath)[0] = drive;
+ }
+ Tcl_DStringAppend(&dsNorm, (const char *)nativePath,
+ Tcl_DStringLength(&ds));
+ } else {
+ char *checkDots = NULL;
+
+ if (lastValidPathEnd[1] == '.') {
+ checkDots = lastValidPathEnd + 1;
+ while (checkDots < currentPathEndPosition) {
+ if (*checkDots != '.') {
+ checkDots = NULL;
+ break;
}
- temp = to;
-
- /*
- * Reset variables so we can restart normalization.
- */
-
- isDrive = 1;
- Tcl_DStringFree(&dsNorm);
- Tcl_DStringInit(&dsNorm);
- Tcl_DStringFree(&ds);
- continue;
+ checkDots++;
}
}
+ if (checkDots != NULL) {
+ int dotLen = currentPathEndPosition-lastValidPathEnd;
-#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
- */
+ /*
+ * 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.
+ */
- if (isDrive) {
- WCHAR drive = ((WCHAR *) nativePath)[0];
- if (drive >= L'a') {
- drive -= (L'a' - L'A');
- ((WCHAR *) nativePath)[0] = drive;
- }
- Tcl_DStringAppend(&dsNorm, nativePath,
- Tcl_DStringLength(&ds));
+ Tcl_DStringAppend(&dsNorm, ((const char *)nativePath)
+ + Tcl_DStringLength(&ds)
+ - (dotLen * sizeof(TCHAR)),
+ (int)(dotLen * sizeof(TCHAR)));
} else {
- char *checkDots = NULL;
-
- if (lastValidPathEnd[1] == '.') {
- checkDots = lastValidPathEnd + 1;
- while (checkDots < currentPathEndPosition) {
- if (*checkDots != '.') {
- checkDots = NULL;
- break;
- }
- checkDots++;
- }
- }
- if (checkDots != NULL) {
- int dotLen = currentPathEndPosition-lastValidPathEnd;
+ /*
+ * Normal path.
+ */
- /*
- * 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.
- */
+ WIN32_FIND_DATAW fData;
+ HANDLE handle;
- Tcl_DStringAppend(&dsNorm, (TCHAR *)
- ((WCHAR*)(nativePath + Tcl_DStringLength(&ds))
- - dotLen), (int)(dotLen * sizeof(WCHAR)));
- } else {
+ handle = FindFirstFileW((WCHAR *) nativePath, &fData);
+ if (handle == INVALID_HANDLE_VALUE) {
/*
- * Normal path.
+ * This is usually the '/' in 'c:/' at end of
+ * string.
*/
- WIN32_FIND_DATAW fData;
- HANDLE handle;
-
- handle = FindFirstFileW((WCHAR *) nativePath, &fData);
- if (handle == INVALID_HANDLE_VALUE) {
- /*
- * This is usually the '/' in 'c:/' at end of
- * string.
- */
+ Tcl_DStringAppend(&dsNorm, (const char *) L"/",
+ sizeof(WCHAR));
+ } else {
+ WCHAR *nativeName;
- Tcl_DStringAppend(&dsNorm, (const char *) L"/",
- sizeof(WCHAR));
+ if (fData.cFileName[0] != '\0') {
+ nativeName = fData.cFileName;
} else {
- WCHAR *nativeName;
-
- if (fData.cFileName[0] != '\0') {
- nativeName = fData.cFileName;
- } else {
- nativeName = fData.cAlternateFileName;
- }
- FindClose(handle);
- Tcl_DStringAppend(&dsNorm, (const char *) L"/",
- sizeof(WCHAR));
- Tcl_DStringAppend(&dsNorm, (TCHAR *) nativeName,
- (int) (wcslen(nativeName)*sizeof(WCHAR)));
+ nativeName = fData.cAlternateFileName;
}
+ FindClose(handle);
+ Tcl_DStringAppend(&dsNorm, (const char *) L"/",
+ sizeof(WCHAR));
+ Tcl_DStringAppend(&dsNorm,
+ (const char *) nativeName,
+ (int) (wcslen(nativeName)*sizeof(WCHAR)));
}
}
-#endif
- Tcl_DStringFree(&ds);
- lastValidPathEnd = currentPathEndPosition;
- if (cur == 0) {
- break;
- }
+ }
+#endif /* !TclNORM_LONG_PATH */
+ Tcl_DStringFree(&ds);
+ lastValidPathEnd = currentPathEndPosition;
+ if (cur == 0) {
+ break;
+ }
- /*
- * If we get here, we've got past one directory delimiter, so
- * we know it is no longer a drive.
- */
+ /*
+ * If we get here, we've got past one directory delimiter, so
+ * we know it is no longer a drive.
+ */
- isDrive = 0;
- }
- currentPathEndPosition++;
+ isDrive = 0;
}
+ currentPathEndPosition++;
#ifdef TclNORM_LONG_PATH
/*
@@ -2923,10 +2666,10 @@ TclpObjNormalizePath(
if (1) {
WCHAR wpath[MAX_PATH];
- const char *nativePath =
+ const TCHAR *nativePath =
Tcl_WinUtfToTChar(path, lastValidPathEnd - path, &ds);
- DWORD wpathlen = (*tclWinProcs->getLongPathNameProc)(
- nativePath, (TCHAR *) wpath, MAX_PATH);
+ DWORD wpathlen = GetLongPathNameProc(nativePath,
+ (TCHAR *) wpath, MAX_PATH);
/*
* We have to make the drive letter uppercase.
@@ -2935,10 +2678,11 @@ TclpObjNormalizePath(
if (wpath[0] >= L'a') {
wpath[0] -= (L'a' - L'A');
}
- Tcl_DStringAppend(&dsNorm, (TCHAR*)wpath, wpathlen*sizeof(WCHAR));
+ Tcl_DStringAppend(&dsNorm, (const char *) wpath,
+ wpathlen * sizeof(WCHAR));
Tcl_DStringFree(&ds);
}
-#endif
+#endif /* TclNORM_LONG_PATH */
}
/*
@@ -2953,11 +2697,9 @@ TclpObjNormalizePath(
* native encoding, so we have to convert it to Utf.
*/
- Tcl_DString dsTemp;
-
- Tcl_WinTCharToUtf(Tcl_DStringValue(&dsNorm),
- Tcl_DStringLength(&dsNorm), &dsTemp);
- nextCheckpoint = Tcl_DStringLength(&dsTemp);
+ Tcl_WinTCharToUtf((const TCHAR *) Tcl_DStringValue(&dsNorm),
+ Tcl_DStringLength(&dsNorm), &ds);
+ nextCheckpoint = Tcl_DStringLength(&ds);
if (*lastValidPathEnd != 0) {
/*
* Not the end of the string.
@@ -2967,7 +2709,7 @@ TclpObjNormalizePath(
char *path;
Tcl_Obj *tmpPathPtr;
- tmpPathPtr = Tcl_NewStringObj(Tcl_DStringValue(&dsTemp),
+ tmpPathPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds),
nextCheckpoint);
Tcl_AppendToObj(tmpPathPtr, lastValidPathEnd, -1);
path = Tcl_GetStringFromObj(tmpPathPtr, &len);
@@ -2978,10 +2720,9 @@ TclpObjNormalizePath(
* End of string was reached above.
*/
- Tcl_SetStringObj(pathPtr, Tcl_DStringValue(&dsTemp),
- nextCheckpoint);
+ Tcl_SetStringObj(pathPtr, Tcl_DStringValue(&ds), nextCheckpoint);
}
- Tcl_DStringFree(&dsTemp);
+ Tcl_DStringFree(&ds);
}
Tcl_DStringFree(&dsNorm);
@@ -2993,6 +2734,7 @@ TclpObjNormalizePath(
if (temp != NULL) {
Tcl_DecrRefCount(temp);
}
+
return nextCheckpoint;
}
@@ -3132,7 +2874,7 @@ TclpNativeToNormalized(
int len;
char *copy, *p;
- Tcl_WinTCharToUtf((const char *) clientData, -1, &ds);
+ Tcl_WinTCharToUtf((const TCHAR *) clientData, -1, &ds);
copy = Tcl_DStringValue(&ds);
len = Tcl_DStringLength(&ds);
@@ -3188,10 +2930,11 @@ ClientData
TclNativeCreateNativeRep(
Tcl_Obj *pathPtr)
{
- char *nativePathPtr, *str;
- Tcl_DString ds;
+ WCHAR *nativePathPtr = NULL;
+ const char *str;
Tcl_Obj *validPathPtr;
- int len;
+ size_t len;
+ WCHAR *wp;
if (TclFSCwdIsNative()) {
/*
@@ -3204,6 +2947,7 @@ TclNativeCreateNativeRep(
if (validPathPtr == NULL) {
return NULL;
}
+ /* refCount of validPathPtr was already incremented in Tcl_FSGetTranslatedPath */
} else {
/*
* Make sure the normalized path is set.
@@ -3213,87 +2957,86 @@ TclNativeCreateNativeRep(
if (validPathPtr == NULL) {
return NULL;
}
+ /* validPathPtr returned from Tcl_FSGetNormalizedPath is owned by Tcl, so incr refCount here */
Tcl_IncrRefCount(validPathPtr);
}
- str = Tcl_GetStringFromObj(validPathPtr, &len);
- Tcl_WinUtfToTChar(str, len, &ds);
- if (tclWinProcs->useWide) {
- WCHAR *wp = (WCHAR *) Tcl_DStringValue(&ds);
- /* For a reserved device, strip a possible postfix ':' */
- len = WinIsReserved(str);
- /* For normal devices */
- if (len == 0) len = Tcl_DStringLength(&ds)>>1;
- /*
- ** If path starts with "//?/" or "\\?\" (extended path), translate
- ** any slashes to backslashes but accept the '?' as being valid.
- */
- 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;
- len -= 4;
- }
- /*
- ** If there is a drive prefix, the ':' must be considered valid.
- **/
- if (((str[0]>='A'&&str[0]<='Z') || (str[0]>='a'&&str[0]<='z'))
- && str[1]==':') {
- wp += 2;
- len -= 2;
- }
- while (len-->0) {
- if ((*wp < ' ') || wcschr(L"\"*:<>?|", *wp)) {
- Tcl_DecrRefCount(validPathPtr);
- Tcl_DStringFree(&ds);
- return NULL;
- } else if (*wp=='/') {
- *wp = '\\';
- }
- ++wp;
+ str = Tcl_GetString(validPathPtr);
+ len = validPathPtr->length;
+
+ if (strlen(str)!=(unsigned int)len) {
+ /* String contains NUL-bytes. This is invalid. */
+ goto done;
+ }
+ /* For a reserved device, strip a possible postfix ':' */
+ len = WinIsReserved(str);
+ if (len == 0) {
+ /* Let MultiByteToWideChar check for other invalid sequences, like
+ * 0xC0 0x80 (== overlong NUL). See bug [3118489]: NUL in filenames */
+ len = MultiByteToWideChar(CP_UTF8, MB_ERR_INVALID_CHARS, str, -1, 0, 0);
+ if (len==0) {
+ goto done;
}
- len = Tcl_DStringLength(&ds) + sizeof(WCHAR);
- } else {
- char *p = Tcl_DStringValue(&ds);
- len = Tcl_DStringLength(&ds);
- /*
- ** If path starts with "//?/" or "\\?\" (extended path), translate
- ** any slashes to backslashes but accept the '?' as being valid.
- */
- if ((str[0]=='\\' || str[0]=='/') && (str[1]=='\\' || str[1]=='/')
- && str[2]=='?' && (str[3]=='\\' || str[3]=='/')) {
- p[0] = p[1] = p[3] = '\\';
- str += 4;
- p += 4;
- len -= 4;
+ }
+ /* 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);
+ /*
+ ** If path starts with "//?/" or "\\?\" (extended path), translate
+ ** any slashes to backslashes but leave the '?' intact
+ */
+ if ((str[0]=='\\' || str[0]=='/') && (str[1]=='\\' || str[1]=='/')
+ && str[2]=='?' && (str[3]=='\\' || str[3]=='/')) {
+ wp[0] = wp[1] = wp[3] = '\\';
+ str += 4;
+ wp += 4;
+ }
+ /*
+ ** If there is no "\\?\" prefix but there is a drive or UNC
+ ** path prefix and the path is larger than MAX_PATH chars,
+ ** no Win32 API function can handle that unless it is
+ ** prefixed with the extended path prefix. See:
+ ** <http://msdn.microsoft.com/en-us/library/aa365247(VS.85).aspx#maxpath>
+ **/
+ if (((str[0]>='A'&&str[0]<='Z') || (str[0]>='a'&&str[0]<='z'))
+ && str[1]==':') {
+ if (wp==nativePathPtr && len>MAX_PATH && (str[2]=='\\' || str[2]=='/')) {
+ memmove(wp+4, wp, len*sizeof(WCHAR));
+ memcpy(wp, L"\\\\?\\", 4*sizeof(WCHAR));
+ wp += 4;
}
/*
- ** If there is a drive prefix, the ':' must be considered valid.
- **/
- if (((str[0]>='A'&&str[0]<='Z') || (str[0]>='a'&&str[0]<='z'))
- && str[1]==':') {
- p += 2;
- len -= 2;
- }
- while (len-->0) {
- if ((*p < ' ') || strchr("\"*:<>?|", *p)) {
- Tcl_DecrRefCount(validPathPtr);
- Tcl_DStringFree(&ds);
- return NULL;
- } else if (*p=='/') {
- *p = '\\';
- }
- ++p;
+ ** If (remainder of) path starts with "<drive>:",
+ ** leave the ':' intact.
+ */
+ wp += 2;
+ } else if (wp==nativePathPtr && len>MAX_PATH
+ && (str[0]=='\\' || str[0]=='/')
+ && (str[1]=='\\' || str[1]=='/') && str[2]!='?') {
+ memmove(wp+6, wp, len*sizeof(WCHAR));
+ memcpy(wp, L"\\\\?\\UNC", 7*sizeof(WCHAR));
+ wp += 7;
+ }
+ /*
+ ** In the remainder of the path, translate invalid characters to
+ ** characters in the Unicode private use area.
+ */
+ while (*wp != '\0') {
+ if ((*wp < ' ') || wcschr(L"\"*:<>?|", *wp)) {
+ *wp |= 0xF000;
+ } else if (*wp == '/') {
+ *wp = '\\';
}
- len = Tcl_DStringLength(&ds) + sizeof(char);
+ ++wp;
}
- Tcl_DecrRefCount(validPathPtr);
- nativePathPtr = ckalloc((unsigned) len);
- memcpy(nativePathPtr, Tcl_DStringValue(&ds), (size_t) len);
- Tcl_DStringFree(&ds);
- return (ClientData) nativePathPtr;
+ done:
+
+ TclDecrRefCount(validPathPtr);
+ return nativePathPtr;
}
/*
@@ -3324,23 +3067,11 @@ TclNativeDupInternalRep(
return NULL;
}
- if (tclWinProcs->useWide) {
- /*
- * Unicode representation when running on NT/2K/XP.
- */
+ len = sizeof(TCHAR) * (_tcslen((const TCHAR *) clientData) + 1);
- len = sizeof(WCHAR) * (wcslen((const WCHAR *) clientData) + 1);
- } else {
- /*
- * ANSI representation when running on 95/98/ME.
- */
-
- len = sizeof(char) * (strlen((const char *) clientData) + 1);
- }
-
- copy = (char *) ckalloc(len);
+ copy = ckalloc(len);
memcpy(copy, clientData, len);
- return (ClientData) copy;
+ return copy;
}
/*
@@ -3375,9 +3106,9 @@ TclpUtime(
FromCTime(tval->actime, &lastAccessTime);
FromCTime(tval->modtime, &lastModTime);
- native = (const TCHAR *) Tcl_FSGetNativePath(pathPtr);
+ native = Tcl_FSGetNativePath(pathPtr);
- attr = (*tclWinProcs->getFileAttributesProc)(native);
+ attr = GetFileAttributes(native);
if (attr != INVALID_FILE_ATTRIBUTES && attr & FILE_ATTRIBUTE_DIRECTORY) {
flags = FILE_FLAG_BACKUP_SEMANTICS;
@@ -3388,8 +3119,8 @@ TclpUtime(
* savings complications that utime gets wrong.
*/
- fileHandle = (tclWinProcs->createFileProc)(native, FILE_WRITE_ATTRIBUTES,
- 0, NULL, OPEN_EXISTING, flags, NULL);
+ fileHandle = CreateFile(native, FILE_WRITE_ATTRIBUTES, 0, NULL,
+ OPEN_EXISTING, flags, NULL);
if (fileHandle == INVALID_HANDLE_VALUE ||
!SetFileTime(fileHandle, NULL, &lastAccessTime, &lastModTime)) {
@@ -3403,6 +3134,68 @@ TclpUtime(
}
/*
+ *---------------------------------------------------------------------------
+ *
+ * TclWinFileOwned --
+ *
+ * Returns 1 if the specified file exists and is owned by the current
+ * user and 0 otherwise. Like the Unix case, the check is made using
+ * the real process SID, not the effective (impersonation) one.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+int
+TclWinFileOwned(
+ Tcl_Obj *pathPtr) /* File whose ownership is to be checked */
+{
+ const TCHAR *native;
+ PSID ownerSid = NULL;
+ PSECURITY_DESCRIPTOR secd = NULL;
+ HANDLE token;
+ LPBYTE buf = NULL;
+ DWORD bufsz;
+ int owned = 0;
+
+ native = Tcl_FSGetNativePath(pathPtr);
+
+ if (GetNamedSecurityInfo((LPTSTR) native, SE_FILE_OBJECT,
+ OWNER_SECURITY_INFORMATION, &ownerSid,
+ NULL, NULL, NULL, &secd) != ERROR_SUCCESS) {
+ /* Either not a file, or we do not have access to it in which
+ case we are in all likelihood not the owner */
+ return 0;
+ }
+
+ /*
+ * Getting the current process SID is a multi-step process.
+ * We make the assumption that if a call fails, this process is
+ * so underprivileged it could not possibly own anything. Normally
+ * a process can *always* look up its own token.
+ */
+ if (OpenProcessToken(GetCurrentProcess(), TOKEN_QUERY, &token)) {
+ /* Find out how big the buffer needs to be */
+ bufsz = 0;
+ GetTokenInformation(token, TokenUser, NULL, 0, &bufsz);
+ if (bufsz) {
+ buf = ckalloc(bufsz);
+ if (GetTokenInformation(token, TokenUser, buf, bufsz, &bufsz)) {
+ owned = EqualSid(ownerSid, ((PTOKEN_USER) buf)->User.Sid);
+ }
+ }
+ CloseHandle(token);
+ }
+
+ /* Free allocations and be done */
+ if (secd)
+ LocalFree(secd); /* Also frees ownerSid */
+ if (buf)
+ ckfree(buf);
+
+ return (owned != 0); /* Convert non-0 to 1 */
+}
+
+/*
* Local Variables:
* mode: c
* c-basic-offset: 4
diff --git a/win/tclWinInit.c b/win/tclWinInit.c
index 4e860b2..8b600f6 100644
--- a/win/tclWinInit.c
+++ b/win/tclWinInit.c
@@ -83,12 +83,12 @@ typedef struct {
#define NUMPLATFORMS 4
-static char* platforms[NUMPLATFORMS] = {
+static const char *const platforms[NUMPLATFORMS] = {
"Win32s", "Windows 95", "Windows NT", "Windows CE"
};
#define NUMPROCESSORS 11
-static char* processors[NUMPROCESSORS] = {
+static const char *const processors[NUMPROCESSORS] = {
"intel", "mips", "alpha", "ppc", "shx", "arm", "ia64", "alpha64", "msil",
"amd64", "ia32_on_win64"
};
@@ -105,8 +105,8 @@ static TclInitProcessGlobalValueProc InitializeSourceLibraryDir;
static ProcessGlobalValue sourceLibraryDir =
{0, 0, NULL, NULL, InitializeSourceLibraryDir, NULL, NULL};
-static void AppendEnvironment(Tcl_Obj *listPtr, CONST char *lib);
-static int ToUtf(CONST WCHAR *wSrc, char *dst);
+static void AppendEnvironment(Tcl_Obj *listPtr, const char *lib);
+static int ToUtf(const WCHAR *wSrc, char *dst);
/*
*---------------------------------------------------------------------------
@@ -135,11 +135,11 @@ TclpInitPlatform(void)
tclPlatform = TCL_PLATFORM_WINDOWS;
- /*
- * Initialize the winsock library. On Windows XP and higher this
- * can never fail.
- */
- WSAStartup(wVersionRequested, &wsaData);
+ /*
+ * Initialize the winsock library. On Windows XP and higher this
+ * can never fail.
+ */
+ WSAStartup(wVersionRequested, &wsaData);
#ifdef STATIC_BUILD
/*
@@ -178,7 +178,7 @@ TclpInitLibraryPath(
#define LIBRARY_SIZE 64
Tcl_Obj *pathPtr;
char installLib[LIBRARY_SIZE];
- char *bytes;
+ const char *bytes;
pathPtr = Tcl_NewObj();
@@ -215,7 +215,7 @@ TclpInitLibraryPath(
*encodingPtr = NULL;
bytes = Tcl_GetStringFromObj(pathPtr, lengthPtr);
- *valuePtr = ckalloc((unsigned int)(*lengthPtr)+1);
+ *valuePtr = ckalloc((*lengthPtr) + 1);
memcpy(*valuePtr, bytes, (size_t)(*lengthPtr)+1);
Tcl_DecrRefCount(pathPtr);
}
@@ -242,14 +242,14 @@ TclpInitLibraryPath(
static void
AppendEnvironment(
Tcl_Obj *pathPtr,
- CONST char *lib)
+ const char *lib)
{
int pathc;
WCHAR wBuf[MAX_PATH];
char buf[MAX_PATH * TCL_UTF_MAX];
Tcl_Obj *objPtr;
Tcl_DString ds;
- CONST char **pathv;
+ const char **pathv;
char *shortlib;
/*
@@ -295,8 +295,6 @@ AppendEnvironment(
*/
if ((pathc > 0) && (lstrcmpiA(shortlib, pathv[pathc - 1]) != 0)) {
- CONST char *str;
-
/*
* TCL_LIBRARY is set but refers to a different tcl installation
* than the current version. Try fiddling with the specified
@@ -306,14 +304,13 @@ AppendEnvironment(
pathv[pathc - 1] = shortlib;
Tcl_DStringInit(&ds);
- str = Tcl_JoinPath(pathc, pathv, &ds);
- objPtr = Tcl_NewStringObj(str, Tcl_DStringLength(&ds));
- Tcl_DStringFree(&ds);
+ (void) Tcl_JoinPath(pathc, pathv, &ds);
+ objPtr = TclDStringToObj(&ds);
} else {
objPtr = Tcl_NewStringObj(buf, -1);
}
Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
- ckfree((char *) pathv);
+ ckfree(pathv);
}
}
@@ -413,7 +410,7 @@ InitializeSourceLibraryDir(
TclWinNoBackslash(name);
sprintf(end + 1, "../library");
*lengthPtr = strlen(name);
- *valuePtr = ckalloc((unsigned int) *lengthPtr + 1);
+ *valuePtr = ckalloc(*lengthPtr + 1);
*encodingPtr = NULL;
memcpy(*valuePtr, name, (size_t) *lengthPtr + 1);
}
@@ -436,7 +433,7 @@ InitializeSourceLibraryDir(
static int
ToUtf(
- CONST WCHAR *wSrc,
+ const WCHAR *wSrc,
char *dst)
{
char *start;
@@ -453,31 +450,6 @@ ToUtf(
/*
*---------------------------------------------------------------------------
*
- * TclWinEncodingsCleanup --
- *
- * Reset information to its original state in finalization to allow for
- * reinitialization to be possible. This must not be called until after
- * the filesystem has been finalised, or exit crashes may occur when
- * using virtual filesystems.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Static information reset to startup state.
- *
- *---------------------------------------------------------------------------
- */
-
-void
-TclWinEncodingsCleanup(void)
-{
- TclWinResetInterfaceEncodings();
-}
-
-/*
- *---------------------------------------------------------------------------
- *
* TclpSetInitialEncodings --
*
* Based on the locale, determine the encoding of the operating system
@@ -510,18 +482,13 @@ TclpSetInitialEncodings(void)
Tcl_DStringFree(&encodingName);
}
-void
-TclpSetInterfaces(void)
+void TclWinSetInterfaces(
+ int dummy) /* Not used. */
{
- int platformId, useWide;
-
- platformId = TclWinGetPlatformId();
- useWide = ((platformId == VER_PLATFORM_WIN32_NT)
- || (platformId == VER_PLATFORM_WIN32_CE));
- TclWinSetInterfaces(useWide);
+ TclpSetInterfaces();
}
-CONST char *
+const char *
Tcl_GetEncodingNameFromEnvironment(
Tcl_DString *bufPtr)
{
@@ -553,7 +520,7 @@ void
TclpSetVariables(
Tcl_Interp *interp) /* Interp to initialize. */
{
- CONST char *ptr;
+ const char *ptr;
char buffer[TCL_INTEGER_SPACE * 2];
union {
SYSTEM_INFO info;
@@ -562,7 +529,7 @@ TclpSetVariables(
static OSVERSIONINFOW osInfo;
static int osInfoInitialized = 0;
Tcl_DString ds;
- WCHAR szUserName[UNLEN+1];
+ TCHAR szUserName[UNLEN+1];
DWORD cchUserNameLen = UNLEN;
Tcl_SetVar2Ex(interp, "tclDefaultLibrary", NULL,
@@ -601,7 +568,7 @@ TclpSetVariables(
TCL_GLOBAL_ONLY);
}
-#ifndef NDEBUG
+#ifdef _DEBUG
/*
* The existence of the "debug" element of the tcl_platform array
* indicates that this particular Tcl shell has been compiled with debug
@@ -646,15 +613,21 @@ TclpSetVariables(
Tcl_DStringInit(&ds);
if (TclGetEnv("USERNAME", &ds) == NULL) {
- if (tclWinProcs->getUserName((LPTSTR)szUserName, &cchUserNameLen) != 0) {
+ if (GetUserName(szUserName, &cchUserNameLen) != 0) {
int cbUserNameLen = cchUserNameLen - 1;
- if (tclWinProcs->useWide) cbUserNameLen *= sizeof(WCHAR);
- Tcl_WinTCharToUtf((LPTSTR)szUserName, cbUserNameLen, &ds);
+ cbUserNameLen *= sizeof(TCHAR);
+ Tcl_WinTCharToUtf(szUserName, cbUserNameLen, &ds);
}
}
Tcl_SetVar2(interp, "tcl_platform", "user", Tcl_DStringValue(&ds),
TCL_GLOBAL_ONLY);
Tcl_DStringFree(&ds);
+
+ /*
+ * Define what the platform PATH separator is. [TIP #315]
+ */
+
+ Tcl_SetVar2(interp, "tcl_platform","pathSeparator", ";", TCL_GLOBAL_ONLY);
}
/*
@@ -679,7 +652,7 @@ TclpSetVariables(
int
TclpFindVariable(
- CONST char *name, /* Name of desired environment variable
+ const char *name, /* Name of desired environment variable
* (UTF-8). */
int *lengthPtr) /* Used to return length of name (for
* successful searches) or number of non-NULL
@@ -687,7 +660,7 @@ TclpFindVariable(
* searches). */
{
int i, length, result = -1;
- register CONST char *env, *p1, *p2;
+ register const char *env, *p1, *p2;
char *envUpper, *nameUpper;
Tcl_DString envString;
@@ -696,7 +669,7 @@ TclpFindVariable(
*/
length = strlen(name);
- nameUpper = (char *) ckalloc((unsigned) length+1);
+ nameUpper = ckalloc(length + 1);
memcpy(nameUpper, name, (size_t) length+1);
Tcl_UtfToUpper(nameUpper);
diff --git a/win/tclWinInt.h b/win/tclWinInt.h
index ccf48bb..6b098f8 100644
--- a/win/tclWinInt.h
+++ b/win/tclWinInt.h
@@ -32,14 +32,6 @@ typedef struct TCLEXCEPTION_REGISTRATION {
#endif
/*
- * The following specifies how much stack space TclpCheckStackSpace()
- * ensures is available. TclpCheckStackSpace() is called by Tcl_EvalObj()
- * to help avoid overflowing the stack in the case of infinite recursion.
- */
-
-#define TCL_WIN_STACK_THRESHOLD 0x8000
-
-/*
* Some versions of Borland C have a define for the OSVERSIONINFO for
* Win32s and for NT, but not for Windows 95.
* Define VER_PLATFORM_WIN32_CE for those without newer headers.
@@ -59,124 +51,12 @@ typedef struct TCLEXCEPTION_REGISTRATION {
#endif
/*
- * The following structure keeps track of whether we are using the
- * multi-byte or the wide-character interfaces to the operating system.
- * System calls should be made through the following function table.
- */
-
-typedef union {
- WIN32_FIND_DATAA a;
- WIN32_FIND_DATAW w;
-} WIN32_FIND_DATAT;
-
-typedef struct TclWinProcs {
- int useWide;
-
- BOOL (WINAPI *buildCommDCBProc)(CONST TCHAR *, LPDCB);
- TCHAR *(WINAPI *charLowerProc)(TCHAR *);
- BOOL (WINAPI *copyFileProc)(CONST TCHAR *, CONST TCHAR *, BOOL);
- BOOL (WINAPI *createDirectoryProc)(CONST TCHAR *, LPSECURITY_ATTRIBUTES);
- HANDLE (WINAPI *createFileProc)(CONST TCHAR *, DWORD, DWORD,
- LPSECURITY_ATTRIBUTES, DWORD, DWORD, HANDLE);
- BOOL (WINAPI *createProcessProc)(CONST TCHAR *, TCHAR *,
- LPSECURITY_ATTRIBUTES, LPSECURITY_ATTRIBUTES, BOOL, DWORD,
- LPVOID, CONST TCHAR *, LPSTARTUPINFOA, LPPROCESS_INFORMATION);
- BOOL (WINAPI *deleteFileProc)(CONST TCHAR *);
- HANDLE (WINAPI *findFirstFileProc)(CONST TCHAR *, WIN32_FIND_DATAT *);
- BOOL (WINAPI *findNextFileProc)(HANDLE, WIN32_FIND_DATAT *);
- BOOL (WINAPI *getComputerNameProc)(WCHAR *, LPDWORD);
- DWORD (WINAPI *getCurrentDirectoryProc)(DWORD, WCHAR *);
- DWORD (WINAPI *getFileAttributesProc)(CONST TCHAR *);
- DWORD (WINAPI *getFullPathNameProc)(CONST TCHAR *, DWORD nBufferLength,
- WCHAR *, TCHAR **);
- DWORD (WINAPI *getModuleFileNameProc)(HMODULE, WCHAR *, int);
- DWORD (WINAPI *getShortPathNameProc)(CONST TCHAR *, WCHAR *, DWORD);
- UINT (WINAPI *getTempFileNameProc)(CONST TCHAR *, CONST TCHAR *, UINT,
- WCHAR *);
- DWORD (WINAPI *getTempPathProc)(DWORD, WCHAR *);
- BOOL (WINAPI *getVolumeInformationProc)(CONST TCHAR *, WCHAR *, DWORD,
- LPDWORD, LPDWORD, LPDWORD, WCHAR *, DWORD);
- HINSTANCE (WINAPI *loadLibraryExProc)(CONST TCHAR *, HANDLE, DWORD);
- TCHAR (WINAPI *lstrcpyProc)(WCHAR *, CONST TCHAR *);
- BOOL (WINAPI *moveFileProc)(CONST TCHAR *, CONST TCHAR *);
- BOOL (WINAPI *removeDirectoryProc)(CONST TCHAR *);
- DWORD (WINAPI *searchPathProc)(CONST TCHAR *, CONST TCHAR *,
- CONST TCHAR *, DWORD, WCHAR *, TCHAR **);
- BOOL (WINAPI *setCurrentDirectoryProc)(CONST TCHAR *);
- BOOL (WINAPI *setFileAttributesProc)(CONST TCHAR *, DWORD);
- /*
- * These two function pointers will only be set when
- * Tcl_FindExecutable is called. If you don't ever call that
- * function, the application will crash whenever WinTcl tries to call
- * functions through these null pointers. That is not a bug in Tcl
- * -- Tcl_FindExecutable is obligatory in recent Tcl releases.
- */
- BOOL (WINAPI *getFileAttributesExProc)(CONST TCHAR *,
- GET_FILEEX_INFO_LEVELS, LPVOID);
- BOOL (WINAPI *createHardLinkProc)(CONST TCHAR*, CONST TCHAR*,
- LPSECURITY_ATTRIBUTES);
-
- /* deleted INT (__cdecl *utimeProc)(CONST TCHAR*, struct _utimbuf *); */
- /* These two are also NULL at start; see comment above */
- HANDLE (WINAPI *findFirstFileExProc)(CONST TCHAR*, UINT,
- LPVOID, UINT,
- LPVOID, DWORD);
- BOOL (WINAPI *getVolumeNameForVMPProc)(CONST TCHAR*, TCHAR*, DWORD);
- DWORD (WINAPI *getLongPathNameProc)(CONST TCHAR*, TCHAR*, DWORD);
- /*
- * These six are for the security sdk to get correct file
- * permissions on NT, 2000, XP, etc. On 95,98,ME they are
- * always null.
- */
- BOOL (WINAPI *getFileSecurityProc)(LPCTSTR lpFileName,
- SECURITY_INFORMATION RequestedInformation,
- PSECURITY_DESCRIPTOR pSecurityDescriptor,
- DWORD nLength,
- LPDWORD lpnLengthNeeded);
- BOOL (WINAPI *impersonateSelfProc) (SECURITY_IMPERSONATION_LEVEL
- ImpersonationLevel);
- BOOL (WINAPI *openThreadTokenProc) (HANDLE ThreadHandle,
- DWORD DesiredAccess, BOOL OpenAsSelf,
- PHANDLE TokenHandle);
- BOOL (WINAPI *revertToSelfProc) (void);
- VOID (WINAPI *mapGenericMaskProc) (PDWORD AccessMask,
- PGENERIC_MAPPING GenericMapping);
- BOOL (WINAPI *accessCheckProc)(PSECURITY_DESCRIPTOR pSecurityDescriptor,
- HANDLE ClientToken, DWORD DesiredAccess,
- PGENERIC_MAPPING GenericMapping,
- PPRIVILEGE_SET PrivilegeSet,
- LPDWORD PrivilegeSetLength,
- LPDWORD GrantedAccess,
- LPBOOL AccessStatus);
- /*
- * Unicode console support. WriteConsole and ReadConsole
- */
- BOOL (WINAPI *readConsoleProc)(
- HANDLE hConsoleInput,
- LPVOID lpBuffer,
- DWORD nNumberOfCharsToRead,
- LPDWORD lpNumberOfCharsRead,
- LPVOID lpReserved
- );
- BOOL (WINAPI *writeConsoleProc)(
- HANDLE hConsoleOutput,
- const VOID* lpBuffer,
- DWORD nNumberOfCharsToWrite,
- LPDWORD lpNumberOfCharsWritten,
- LPVOID lpReserved
- );
- BOOL (WINAPI *getUserName)(LPTSTR lpBuffer, LPDWORD lpnSize);
-} TclWinProcs;
-
-MODULE_SCOPE TclWinProcs *tclWinProcs;
-
-/*
* Declarations of functions that are not accessible by way of the
* stubs table.
*/
MODULE_SCOPE char TclWinDriveLetterForVolMountPoint(
- CONST WCHAR *mountPoint);
+ const TCHAR *mountPoint);
MODULE_SCOPE void TclWinEncodingsCleanup();
MODULE_SCOPE void TclWinInit(HINSTANCE hInst);
MODULE_SCOPE TclFile TclWinMakeFile(HANDLE handle);
@@ -186,13 +66,13 @@ 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 void TclWinResetInterfaceEncodings();
-MODULE_SCOPE HANDLE TclWinSerialOpen(HANDLE handle, CONST TCHAR *name,
+MODULE_SCOPE HANDLE TclWinSerialOpen(HANDLE handle, const TCHAR *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 TCHAR *LinkOriginal,
+ const TCHAR *LinkCopy);
+MODULE_SCOPE int TclWinSymLinkDelete(const TCHAR *LinkOriginal,
int linkOnly);
+MODULE_SCOPE int TclWinFileOwned(Tcl_Obj *);
#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC)
MODULE_SCOPE void TclWinFreeAllocCache(void);
MODULE_SCOPE void TclFreeAllocCache(void *);
diff --git a/win/tclWinLoad.c b/win/tclWinLoad.c
index c4d08e8..26512b1 100644
--- a/win/tclWinLoad.c
+++ b/win/tclWinLoad.c
@@ -13,6 +13,23 @@
#include "tclWinInt.h"
+/*
+ * Native name of the directory in the native filesystem where DLLs used in
+ * this process are copied prior to loading, and mutex used to protect its
+ * allocation.
+ */
+
+static WCHAR *dllDirectoryName = NULL;
+static Tcl_Mutex dllDirectoryNameMutex;
+
+/*
+ * Static functions defined within this file.
+ */
+
+static void * FindSymbol(Tcl_Interp *interp,
+ Tcl_LoadHandle loadHandle, const char *symbol);
+static int InitDLLDirectoryName(void);
+static void UnloadFile(Tcl_LoadHandle loadHandle);
/*
*----------------------------------------------------------------------
@@ -40,13 +57,15 @@ TclpDlopen(
Tcl_LoadHandle *loadHandle, /* Filled with token for dynamically loaded
* file which will be passed back to
* (*unloadProcPtr)() to unload the file. */
- Tcl_FSUnloadFileProc **unloadProcPtr)
+ Tcl_FSUnloadFileProc **unloadProcPtr,
/* Filled with address of Tcl_FSUnloadFileProc
* function which should be used for this
* file. */
+ int flags)
{
- HINSTANCE handle;
- CONST TCHAR *nativeName;
+ HINSTANCE hInstance;
+ const TCHAR *nativeName;
+ Tcl_LoadHandle handlePtr;
/*
* First try the full path the user gave us. This is particularly
@@ -55,9 +74,8 @@ TclpDlopen(
*/
nativeName = Tcl_FSGetNativePath(pathPtr);
- handle = (*tclWinProcs->loadLibraryExProc)(nativeName, NULL,
- LOAD_WITH_ALTERED_SEARCH_PATH);
- if (handle == NULL) {
+ hInstance = LoadLibraryEx(nativeName,NULL,LOAD_WITH_ALTERED_SEARCH_PATH);
+ if (hInstance == NULL) {
/*
* Let the OS loader examine the binary search path for whatever
* string the user gave us which hopefully refers to a file on the
@@ -65,38 +83,17 @@ TclpDlopen(
*/
Tcl_DString ds;
- char *fileName = Tcl_GetString(pathPtr);
- nativeName = Tcl_WinUtfToTChar(fileName, -1, &ds);
- handle = (*tclWinProcs->loadLibraryExProc)(nativeName, NULL,
+ nativeName = Tcl_WinUtfToTChar(Tcl_GetString(pathPtr), -1, &ds);
+ hInstance = LoadLibraryEx(nativeName, NULL,
LOAD_WITH_ALTERED_SEARCH_PATH);
Tcl_DStringFree(&ds);
}
- *loadHandle = (Tcl_LoadHandle) handle;
-
- if (handle == NULL) {
+ if (hInstance == NULL) {
DWORD lastError = GetLastError();
-
-#if 0
- /*
- * It would be ideal if the FormatMessage stuff worked better, but
- * unfortunately it doesn't seem to want to...
- */
-
- LPTSTR lpMsgBuf;
- char *buf;
- int size;
-
- size = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM |
- FORMAT_MESSAGE_ALLOCATE_BUFFER, NULL, lastError, 0,
- (LPTSTR) &lpMsgBuf, 0, NULL);
- buf = (char *) ckalloc((unsigned) TCL_INTEGER_SPACE + size + 1);
- sprintf(buf, "%d %s", lastError, (char *)lpMsgBuf);
-#endif
-
- Tcl_AppendResult(interp, "couldn't load library \"",
- Tcl_GetString(pathPtr), "\": ", NULL);
+ Tcl_Obj *errMsg = Tcl_ObjPrintf("couldn't load library \"%s\": ",
+ Tcl_GetString(pathPtr));
/*
* Check for possible DLL errors. This doesn't work quite right,
@@ -105,40 +102,59 @@ TclpDlopen(
* better if there was a way to get what DLLs
*/
- switch (lastError) {
- case ERROR_MOD_NOT_FOUND:
- case ERROR_DLL_NOT_FOUND:
- Tcl_AppendResult(interp, "this library or a dependent library"
- " could not be found in library path", NULL);
- break;
- case ERROR_PROC_NOT_FOUND:
- Tcl_AppendResult(interp, "A function specified in the import"
- " table could not be resolved by the system. Windows"
- " is not telling which one, I'm sorry.", NULL);
- break;
- case ERROR_INVALID_DLL:
- Tcl_AppendResult(interp, "this library or a dependent library"
- " is damaged", NULL);
- break;
- case ERROR_DLL_INIT_FAILED:
- Tcl_AppendResult(interp, "the library initialization"
- " routine failed", NULL);
- break;
- default:
- TclWinConvertError(lastError);
- Tcl_AppendResult(interp, Tcl_PosixError(interp), NULL);
+ if (interp) {
+ switch (lastError) {
+ case ERROR_MOD_NOT_FOUND:
+ Tcl_SetErrorCode(interp, "WIN_LOAD", "MOD_NOT_FOUND", NULL);
+ goto notFoundMsg;
+ case ERROR_DLL_NOT_FOUND:
+ Tcl_SetErrorCode(interp, "WIN_LOAD", "DLL_NOT_FOUND", NULL);
+ notFoundMsg:
+ Tcl_AppendToObj(errMsg, "this library or a dependent library"
+ " could not be found in library path", -1);
+ break;
+ case ERROR_PROC_NOT_FOUND:
+ Tcl_SetErrorCode(interp, "WIN_LOAD", "PROC_NOT_FOUND", NULL);
+ Tcl_AppendToObj(errMsg, "A function specified in the import"
+ " table could not be resolved by the system. Windows"
+ " is not telling which one, I'm sorry.", -1);
+ break;
+ case ERROR_INVALID_DLL:
+ Tcl_SetErrorCode(interp, "WIN_LOAD", "INVALID_DLL", NULL);
+ Tcl_AppendToObj(errMsg, "this library or a dependent library"
+ " is damaged", -1);
+ break;
+ case ERROR_DLL_INIT_FAILED:
+ Tcl_SetErrorCode(interp, "WIN_LOAD", "DLL_INIT_FAILED", NULL);
+ Tcl_AppendToObj(errMsg, "the library initialization"
+ " routine failed", -1);
+ break;
+ default:
+ TclWinConvertError(lastError);
+ Tcl_AppendToObj(errMsg, Tcl_PosixError(interp), -1);
+ }
+ Tcl_SetObjResult(interp, errMsg);
}
return TCL_ERROR;
- } else {
- *unloadProcPtr = &TclpUnloadFile;
}
+
+ /*
+ * Succeded; package everything up for Tcl.
+ */
+
+ handlePtr = ckalloc(sizeof(struct Tcl_LoadHandle_));
+ handlePtr->clientData = (ClientData) hInstance;
+ handlePtr->findSymbolProcPtr = &FindSymbol;
+ handlePtr->unloadFileProcPtr = &UnloadFile;
+ *loadHandle = handlePtr;
+ *unloadProcPtr = &UnloadFile;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
- * TclpFindSymbol --
+ * FindSymbol --
*
* Looks up a symbol, by name, through a handle associated with a
* previously loaded piece of code (shared library).
@@ -151,37 +167,43 @@ TclpDlopen(
*----------------------------------------------------------------------
*/
-Tcl_PackageInitProc *
-TclpFindSymbol(
+static void *
+FindSymbol(
Tcl_Interp *interp,
Tcl_LoadHandle loadHandle,
- CONST char *symbol)
+ const char *symbol)
{
+ HINSTANCE hInstance = (HINSTANCE) loadHandle->clientData;
Tcl_PackageInitProc *proc = NULL;
- HINSTANCE handle = (HINSTANCE)loadHandle;
/*
* For each symbol, check for both Symbol and _Symbol, since Borland
* generates C symbols with a leading '_' by default.
*/
- proc = (Tcl_PackageInitProc *) GetProcAddress(handle, symbol);
+ proc = (void *) GetProcAddress(hInstance, symbol);
if (proc == NULL) {
Tcl_DString ds;
+ const char *sym2;
Tcl_DStringInit(&ds);
- Tcl_DStringAppend(&ds, "_", 1);
- symbol = Tcl_DStringAppend(&ds, symbol, -1);
- proc = (Tcl_PackageInitProc *) GetProcAddress(handle, symbol);
+ TclDStringAppendLiteral(&ds, "_");
+ sym2 = Tcl_DStringAppend(&ds, symbol, -1);
+ proc = (Tcl_PackageInitProc *) GetProcAddress(hInstance, sym2);
Tcl_DStringFree(&ds);
}
+ if (proc == NULL && interp != NULL) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "cannot find symbol \"%s\"", symbol));
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LOAD_SYMBOL", symbol, NULL);
+ }
return proc;
}
/*
*----------------------------------------------------------------------
*
- * TclpUnloadFile --
+ * UnloadFile --
*
* Unloads a dynamically loaded binary code file from memory. Code
* pointers in the formerly loaded file are no longer valid after calling
@@ -196,16 +218,16 @@ TclpFindSymbol(
*----------------------------------------------------------------------
*/
-void
-TclpUnloadFile(
+static void
+UnloadFile(
Tcl_LoadHandle loadHandle) /* loadHandle returned by a previous call to
* TclpDlopen(). The loadHandle is a token
* that represents the loaded file. */
{
- HINSTANCE handle;
+ HINSTANCE hInstance = (HINSTANCE) loadHandle->clientData;
- handle = (HINSTANCE) loadHandle;
- FreeLibrary(handle);
+ FreeLibrary(hInstance);
+ ckfree(loadHandle);
}
/*
@@ -230,7 +252,7 @@ TclpUnloadFile(
int
TclGuessPackageName(
- CONST char *fileName, /* Name of file containing package (already
+ const char *fileName, /* Name of file containing package (already
* translated to local form if needed). */
Tcl_DString *bufPtr) /* Initialized empty dstring. Append package
* name to this if possible. */
@@ -239,6 +261,139 @@ TclGuessPackageName(
}
/*
+ *----------------------------------------------------------------------
+ *
+ * TclpTempFileNameForLibrary --
+ *
+ * Constructs a temporary file name for loading a shared object (DLL).
+ *
+ * Results:
+ * Returns the constructed file name.
+ *
+ * On Windows, a DLL is identified by the final component of its path name.
+ * Cross linking among DLL's (and hence, preloading) will not work unless this
+ * name is preserved when copying a DLL from a VFS to a temp file for
+ * preloading. For this reason, all DLLs in a given process are copied to a
+ * temp directory, and their names are preserved.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+TclpTempFileNameForLibrary(
+ Tcl_Interp *interp, /* Tcl interpreter. */
+ Tcl_Obj *path) /* Path name of the DLL in the VFS. */
+{
+ Tcl_Obj *fileName; /* Name of the temp file. */
+ Tcl_Obj *tail; /* Tail of the source path. */
+
+ Tcl_MutexLock(&dllDirectoryNameMutex);
+ if (dllDirectoryName == NULL) {
+ if (InitDLLDirectoryName() == TCL_ERROR) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't create temporary directory: %s",
+ Tcl_PosixError(interp)));
+ Tcl_MutexUnlock(&dllDirectoryNameMutex);
+ return NULL;
+ }
+ }
+ Tcl_MutexUnlock(&dllDirectoryNameMutex);
+
+ /*
+ * Now we know where to put temporary DLLs, construct the name.
+ */
+
+ fileName = TclpNativeToNormalized(dllDirectoryName);
+ tail = TclPathPart(interp, path, TCL_PATH_TAIL);
+ if (tail == NULL) {
+ Tcl_DecrRefCount(fileName);
+ return NULL;
+ }
+ Tcl_AppendToObj(fileName, "/", 1);
+ Tcl_AppendObjToObj(fileName, tail);
+ return fileName;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * InitDLLDirectoryName --
+ *
+ * Helper for TclpTempFileNameForLibrary; builds a temporary directory
+ * that is specific to the current process. Should only be called once
+ * per process start. Caller must hold dllDirectoryNameMutex.
+ *
+ * Results:
+ * Tcl result code.
+ *
+ * Side-effects:
+ * Creates temp directory.
+ * Allocates memory pointed to by dllDirectoryName.
+ *
+ *----------------------------------------------------------------------
+ * [Candidate for process global?]
+ */
+
+static int
+InitDLLDirectoryName(void)
+{
+ size_t nameLen; /* Length of the temp folder name. */
+ WCHAR name[MAX_PATH]; /* Path name of the temp folder. */
+ DWORD id; /* The process id. */
+ DWORD lastError; /* Last error to happen in Win API. */
+ int i;
+
+ /*
+ * Determine the name of the directory to use, and create it. (Keep
+ * trying with new names until an attempt to create the directory
+ * succeeds)
+ */
+
+ nameLen = GetTempPathW(MAX_PATH, name);
+ if (nameLen >= MAX_PATH-12) {
+ Tcl_SetErrno(ENAMETOOLONG);
+ return TCL_ERROR;
+ }
+
+ wcscpy(name+nameLen, L"TCLXXXXXXXX");
+ nameLen += 11;
+
+ id = GetCurrentProcessId();
+ lastError = ERROR_ALREADY_EXISTS;
+
+ for (i=0 ; i<256 ; i++) {
+ wsprintfW(name+nameLen-8, L"%08x", id);
+ if (CreateDirectoryW(name, NULL)) {
+ /*
+ * Issue: we don't schedule this directory for deletion by anyone.
+ * Can we ask the OS to do this for us? There appears to be
+ * potential for using CreateFile (with the flag
+ * FILE_FLAG_BACKUP_SEMANTICS) and RemoveDirectory to do this...
+ */
+
+ goto copyToGlobalBuffer;
+ }
+ lastError = GetLastError();
+ if (lastError != ERROR_ALREADY_EXISTS) {
+ break;
+ }
+ id *= 16777619;
+ }
+
+ TclWinConvertError(lastError);
+ return TCL_ERROR;
+
+ /*
+ * Store our computed value in the global.
+ */
+
+ copyToGlobalBuffer:
+ dllDirectoryName = ckalloc((nameLen+1) * sizeof(WCHAR));
+ wcscpy(dllDirectoryName, name);
+ return TCL_OK;
+}
+
+/*
* Local Variables:
* mode: c
* c-basic-offset: 4
diff --git a/win/tclWinNotify.c b/win/tclWinNotify.c
index 1cd5823..4543b02 100644
--- a/win/tclWinNotify.c
+++ b/win/tclWinNotify.c
@@ -42,9 +42,6 @@ typedef struct ThreadSpecificData {
static Tcl_ThreadDataKey dataKey;
-extern TclStubs tclStubs;
-extern Tcl_NotifierProcs tclOriginalNotifier;
-
/*
* The following static indicates the number of threads that have initialized
* notifiers. It controls the lifetime of the TclNotifier window class.
@@ -53,6 +50,7 @@ extern Tcl_NotifierProcs tclOriginalNotifier;
*/
static int notifierCount = 0;
+static const TCHAR classname[] = TEXT("TclNotifier");
TCL_DECLARE_MUTEX(notifierMutex)
/*
@@ -81,45 +79,49 @@ static LRESULT CALLBACK NotifierProc(HWND hwnd, UINT message,
ClientData
Tcl_InitNotifier(void)
{
- ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
- WNDCLASS class;
+ if (tclNotifierHooks.initNotifierProc) {
+ return tclNotifierHooks.initNotifierProc();
+ } else {
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+ WNDCLASS class;
- /*
- * Register Notifier window class if this is the first thread to use this
- * module.
- */
+ /*
+ * Register Notifier window class if this is the first thread to use
+ * this module.
+ */
- Tcl_MutexLock(&notifierMutex);
- if (notifierCount == 0) {
- class.style = 0;
- class.cbClsExtra = 0;
- class.cbWndExtra = 0;
- class.hInstance = TclWinGetTclInstance();
- class.hbrBackground = NULL;
- class.lpszMenuName = NULL;
- class.lpszClassName = "TclNotifier";
- class.lpfnWndProc = NotifierProc;
- class.hIcon = NULL;
- class.hCursor = NULL;
-
- if (!RegisterClassA(&class)) {
- Tcl_Panic("Unable to register TclNotifier window class");
+ Tcl_MutexLock(&notifierMutex);
+ 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)) {
+ Tcl_Panic("Unable to register TclNotifier window class");
+ }
}
- }
- notifierCount++;
- Tcl_MutexUnlock(&notifierMutex);
+ notifierCount++;
+ Tcl_MutexUnlock(&notifierMutex);
- tsdPtr->pending = 0;
- tsdPtr->timerActive = 0;
+ tsdPtr->pending = 0;
+ tsdPtr->timerActive = 0;
- InitializeCriticalSection(&tsdPtr->crit);
+ InitializeCriticalSection(&tsdPtr->crit);
- tsdPtr->hwnd = NULL;
- tsdPtr->thread = GetCurrentThreadId();
- tsdPtr->event = CreateEvent(NULL, TRUE /* manual */,
- FALSE /* !signaled */, NULL);
+ tsdPtr->hwnd = NULL;
+ tsdPtr->thread = GetCurrentThreadId();
+ tsdPtr->event = CreateEvent(NULL, TRUE /* manual */,
+ FALSE /* !signaled */, NULL);
- return (ClientData) tsdPtr;
+ return tsdPtr;
+ }
}
/*
@@ -143,46 +145,51 @@ void
Tcl_FinalizeNotifier(
ClientData clientData) /* Pointer to notifier data. */
{
- ThreadSpecificData *tsdPtr = (ThreadSpecificData *) clientData;
+ if (tclNotifierHooks.finalizeNotifierProc) {
+ tclNotifierHooks.finalizeNotifierProc(clientData);
+ return;
+ } else {
+ ThreadSpecificData *tsdPtr = (ThreadSpecificData *) clientData;
- /*
- * Only finalize the notifier if a notifier was installed in the current
- * thread; there is a route in which this is not guaranteed to be true
- * (when tclWin32Dll.c:DllMain() is called with the flag
- * DLL_PROCESS_DETACH by the OS, which could be doing so from a thread
- * that's never previously been involved with Tcl, e.g. the task manager)
- * so this check is important.
- *
- * Fixes Bug #217982 reported by Hugh Vu and Gene Leache.
- */
+ /*
+ * Only finalize the notifier if a notifier was installed in the
+ * current thread; there is a route in which this is not guaranteed to
+ * be true (when tclWin32Dll.c:DllMain() is called with the flag
+ * DLL_PROCESS_DETACH by the OS, which could be doing so from a thread
+ * that's never previously been involved with Tcl, e.g. the task
+ * manager) so this check is important.
+ *
+ * Fixes Bug #217982 reported by Hugh Vu and Gene Leache.
+ */
- if (tsdPtr == NULL) {
- return;
- }
+ if (tsdPtr == NULL) {
+ return;
+ }
- DeleteCriticalSection(&tsdPtr->crit);
- CloseHandle(tsdPtr->event);
+ DeleteCriticalSection(&tsdPtr->crit);
+ CloseHandle(tsdPtr->event);
- /*
- * Clean up the timer and messaging window for this thread.
- */
+ /*
+ * Clean up the timer and messaging window for this thread.
+ */
- if (tsdPtr->hwnd) {
- KillTimer(tsdPtr->hwnd, INTERVAL_TIMER);
- DestroyWindow(tsdPtr->hwnd);
- }
+ if (tsdPtr->hwnd) {
+ KillTimer(tsdPtr->hwnd, INTERVAL_TIMER);
+ DestroyWindow(tsdPtr->hwnd);
+ }
- /*
- * If this is the last thread to use the notifier, unregister the notifier
- * window class.
- */
+ /*
+ * If this is the last thread to use the notifier, unregister the
+ * notifier window class.
+ */
- Tcl_MutexLock(&notifierMutex);
- notifierCount--;
- if (notifierCount == 0) {
- UnregisterClassA("TclNotifier", TclWinGetTclInstance());
+ Tcl_MutexLock(&notifierMutex);
+ notifierCount--;
+ if (notifierCount == 0) {
+ UnregisterClass(classname, TclWinGetTclInstance());
+ }
+ Tcl_MutexUnlock(&notifierMutex);
}
- Tcl_MutexUnlock(&notifierMutex);
}
/*
@@ -211,27 +218,32 @@ void
Tcl_AlertNotifier(
ClientData clientData) /* Pointer to thread data. */
{
- ThreadSpecificData *tsdPtr = (ThreadSpecificData *) clientData;
-
- /*
- * Note that we do not need to lock around access to the hwnd because the
- * race condition has no effect since any race condition implies that the
- * notifier thread is already awake.
- */
+ if (tclNotifierHooks.alertNotifierProc) {
+ tclNotifierHooks.alertNotifierProc(clientData);
+ return;
+ } else {
+ ThreadSpecificData *tsdPtr = (ThreadSpecificData *) clientData;
- if (tsdPtr->hwnd) {
/*
- * We do need to lock around access to the pending flag.
+ * Note that we do not need to lock around access to the hwnd because
+ * the race condition has no effect since any race condition implies
+ * that the notifier thread is already awake.
*/
- EnterCriticalSection(&tsdPtr->crit);
- if (!tsdPtr->pending) {
- PostMessage(tsdPtr->hwnd, WM_WAKEUP, 0, 0);
+ if (tsdPtr->hwnd) {
+ /*
+ * We do need to lock around access to the pending flag.
+ */
+
+ EnterCriticalSection(&tsdPtr->crit);
+ if (!tsdPtr->pending) {
+ PostMessage(tsdPtr->hwnd, WM_WAKEUP, 0, 0);
+ }
+ tsdPtr->pending = 1;
+ LeaveCriticalSection(&tsdPtr->crit);
+ } else {
+ SetEvent(tsdPtr->event);
}
- tsdPtr->pending = 1;
- LeaveCriticalSection(&tsdPtr->crit);
- } else {
- SetEvent(tsdPtr->event);
}
}
@@ -255,52 +267,47 @@ Tcl_AlertNotifier(
void
Tcl_SetTimer(
- Tcl_Time *timePtr) /* Maximum block time, or NULL. */
+ const Tcl_Time *timePtr) /* Maximum block time, or NULL. */
{
- ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
- UINT timeout;
-
- /*
- * Allow the notifier to be hooked. This may not make sense on Windows,
- * but mirrors the UNIX hook.
- */
-
- if (tclStubs.tcl_SetTimer != tclOriginalNotifier.setTimerProc) {
- tclStubs.tcl_SetTimer(timePtr);
- return;
- }
-
- /*
- * We only need to set up an interval timer if we're being called from an
- * external event loop. If we don't have a window handle then we just
- * return immediately and let Tcl_WaitForEvent handle timeouts.
- */
-
- if (!tsdPtr->hwnd) {
+ if (tclNotifierHooks.setTimerProc) {
+ tclNotifierHooks.setTimerProc(timePtr);
return;
- }
-
- if (!timePtr) {
- timeout = 0;
} else {
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+ UINT timeout;
+
/*
- * Make sure we pass a non-zero value into the timeout argument.
- * Windows seems to get confused by zero length timers.
+ * We only need to set up an interval timer if we're being called from
+ * an external event loop. If we don't have a window handle then we
+ * just return immediately and let Tcl_WaitForEvent handle timeouts.
*/
- timeout = timePtr->sec * 1000 + timePtr->usec / 1000;
- if (timeout == 0) {
- timeout = 1;
+ if (!tsdPtr->hwnd) {
+ return;
+ }
+
+ if (!timePtr) {
+ timeout = 0;
+ } else {
+ /*
+ * Make sure we pass a non-zero value into the timeout argument.
+ * Windows seems to get confused by zero length timers.
+ */
+
+ timeout = timePtr->sec * 1000 + timePtr->usec / 1000;
+ if (timeout == 0) {
+ timeout = 1;
+ }
+ }
+ tsdPtr->timeout = timeout;
+ if (timeout != 0) {
+ tsdPtr->timerActive = 1;
+ SetTimer(tsdPtr->hwnd, INTERVAL_TIMER,
+ (unsigned long) tsdPtr->timeout, NULL);
+ } else {
+ tsdPtr->timerActive = 0;
+ KillTimer(tsdPtr->hwnd, INTERVAL_TIMER);
}
- }
- tsdPtr->timeout = timeout;
- if (timeout != 0) {
- tsdPtr->timerActive = 1;
- SetTimer(tsdPtr->hwnd, INTERVAL_TIMER, (unsigned long) tsdPtr->timeout,
- NULL);
- } else {
- tsdPtr->timerActive = 0;
- KillTimer(tsdPtr->hwnd, INTERVAL_TIMER);
}
}
@@ -326,29 +333,36 @@ Tcl_ServiceModeHook(
int mode) /* Either TCL_SERVICE_ALL, or
* TCL_SERVICE_NONE. */
{
- ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
-
- /*
- * If this is the first time that the notifier has been used from a modal
- * loop, then create a communication window. Note that after this point,
- * the application needs to service events in a timely fashion or Windows
- * will hang waiting for the window to respond to synchronous system
- * messages. At some point, we may want to consider destroying the window
- * if we leave the modal loop, but for now we'll leave it around.
- */
-
- if (mode == TCL_SERVICE_ALL && !tsdPtr->hwnd) {
- tsdPtr->hwnd = CreateWindowA("TclNotifier", "TclNotifier", WS_TILED,
- 0, 0, 0, 0, NULL, NULL, TclWinGetTclInstance(), NULL);
+ if (tclNotifierHooks.serviceModeHookProc) {
+ tclNotifierHooks.serviceModeHookProc(mode);
+ return;
+ } else {
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
/*
- * Send an initial message to the window to ensure that we wake up the
- * notifier once we get into the modal loop. This will force the
- * notifier to recompute the timeout value and schedule a timer if one
- * is needed.
+ * If this is the first time that the notifier has been used from a
+ * modal loop, then create a communication window. Note that after this
+ * point, the application needs to service events in a timely fashion
+ * or Windows will hang waiting for the window to respond to
+ * synchronous system messages. At some point, we may want to consider
+ * destroying the window if we leave the modal loop, but for now we'll
+ * leave it around.
*/
- Tcl_AlertNotifier((ClientData)tsdPtr);
+ if (mode == TCL_SERVICE_ALL && !tsdPtr->hwnd) {
+ tsdPtr->hwnd = CreateWindow(classname, classname,
+ WS_TILED, 0, 0, 0, 0, NULL, NULL, TclWinGetTclInstance(),
+ NULL);
+
+ /*
+ * Send an initial message to the window to ensure that we wake up
+ * the notifier once we get into the modal loop. This will force
+ * the notifier to recompute the timeout value and schedule a timer
+ * if one is needed.
+ */
+
+ Tcl_AlertNotifier(tsdPtr);
+ }
}
}
@@ -416,107 +430,102 @@ NotifierProc(
int
Tcl_WaitForEvent(
- Tcl_Time *timePtr) /* Maximum block time, or NULL. */
+ const Tcl_Time *timePtr) /* Maximum block time, or NULL. */
{
- ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
- MSG msg;
- DWORD timeout, result;
- int status;
-
- /*
- * Allow the notifier to be hooked. This may not make sense on windows,
- * but mirrors the UNIX hook.
- */
-
- if (tclStubs.tcl_WaitForEvent != tclOriginalNotifier.waitForEventProc) {
- return tclStubs.tcl_WaitForEvent(timePtr);
- }
-
- /*
- * Compute the timeout in milliseconds.
- */
+ if (tclNotifierHooks.waitForEventProc) {
+ return tclNotifierHooks.waitForEventProc(timePtr);
+ } else {
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+ MSG msg;
+ DWORD timeout, result;
+ int status;
- if (timePtr) {
/*
- * TIP #233 (Virtualized Time). Convert virtual domain delay to
- * real-time.
+ * Compute the timeout in milliseconds.
*/
- Tcl_Time myTime;
+ if (timePtr) {
+ /*
+ * TIP #233 (Virtualized Time). Convert virtual domain delay to
+ * real-time.
+ */
- myTime.sec = timePtr->sec;
- myTime.usec = timePtr->usec;
+ Tcl_Time myTime;
- if (myTime.sec != 0 || myTime.usec != 0) {
- (*tclScaleTimeProcPtr) (&myTime, tclTimeClientData);
- }
+ myTime.sec = timePtr->sec;
+ myTime.usec = timePtr->usec;
- timeout = myTime.sec * 1000 + myTime.usec / 1000;
- } else {
- timeout = INFINITE;
- }
+ if (myTime.sec != 0 || myTime.usec != 0) {
+ tclScaleTimeProcPtr(&myTime, tclTimeClientData);
+ }
- /*
- * Check to see if there are any messages in the queue before waiting
- * because MsgWaitForMultipleObjects will not wake up if there are events
- * currently sitting in the queue.
- */
+ timeout = myTime.sec * 1000 + myTime.usec / 1000;
+ } else {
+ timeout = INFINITE;
+ }
- if (!PeekMessage(&msg, NULL, 0, 0, PM_NOREMOVE)) {
/*
- * Wait for something to happen (a signal from another thread, a
- * message, or timeout) or loop servicing asynchronous procedure calls
- * queued to this thread.
+ * Check to see if there are any messages in the queue before waiting
+ * because MsgWaitForMultipleObjects will not wake up if there are
+ * events currently sitting in the queue.
*/
- again:
- result = MsgWaitForMultipleObjectsEx(1, &tsdPtr->event, timeout,
- QS_ALLINPUT, MWMO_ALERTABLE);
- if (result == WAIT_IO_COMPLETION) {
- goto again;
- } else if (result == WAIT_FAILED) {
- status = -1;
- goto end;
- }
- }
+ if (!PeekMessage(&msg, NULL, 0, 0, PM_NOREMOVE)) {
+ /*
+ * Wait for something to happen (a signal from another thread, a
+ * message, or timeout) or loop servicing asynchronous procedure
+ * calls queued to this thread.
+ */
- /*
- * Check to see if there are any messages to process.
- */
+ again:
+ result = MsgWaitForMultipleObjectsEx(1, &tsdPtr->event, timeout,
+ QS_ALLINPUT, MWMO_ALERTABLE);
+ if (result == WAIT_IO_COMPLETION) {
+ goto again;
+ } else if (result == WAIT_FAILED) {
+ status = -1;
+ goto end;
+ }
+ }
- if (PeekMessage(&msg, NULL, 0, 0, PM_NOREMOVE)) {
/*
- * Retrieve and dispatch the first message.
+ * Check to see if there are any messages to process.
*/
- result = GetMessage(&msg, NULL, 0, 0);
- if (result == 0) {
- /*
- * We received a request to exit this thread (WM_QUIT), so
- * propagate the quit message and start unwinding.
- */
-
- PostQuitMessage((int) msg.wParam);
- status = -1;
- } else if (result == (DWORD)-1) {
+ if (PeekMessage(&msg, NULL, 0, 0, PM_NOREMOVE)) {
/*
- * We got an error from the system. I have no idea why this would
- * happen, so we'll just unwind.
+ * Retrieve and dispatch the first message.
*/
- status = -1;
+ result = GetMessage(&msg, NULL, 0, 0);
+ if (result == 0) {
+ /*
+ * We received a request to exit this thread (WM_QUIT), so
+ * propagate the quit message and start unwinding.
+ */
+
+ PostQuitMessage((int) msg.wParam);
+ status = -1;
+ } else if (result == (DWORD)-1) {
+ /*
+ * We got an error from the system. I have no idea why this
+ * would happen, so we'll just unwind.
+ */
+
+ status = -1;
+ } else {
+ TranslateMessage(&msg);
+ DispatchMessage(&msg);
+ status = 1;
+ }
} else {
- TranslateMessage(&msg);
- DispatchMessage(&msg);
- status = 1;
+ status = 0;
}
- } else {
- status = 0;
- }
- end:
- ResetEvent(tsdPtr->event);
- return status;
+ end:
+ ResetEvent(tsdPtr->event);
+ return status;
+ }
}
/*
@@ -570,11 +579,11 @@ Tcl_Sleep(
* TIP #233: Scale delay from virtual to real-time.
*/
- (*tclScaleTimeProcPtr) (&vdelay, tclTimeClientData);
+ tclScaleTimeProcPtr(&vdelay, tclTimeClientData);
sleepTime = vdelay.sec * 1000 + vdelay.usec / 1000;
for (;;) {
- Sleep(sleepTime);
+ SleepEx(sleepTime, TRUE);
Tcl_GetTime(&now);
if (now.sec > desired.sec) {
break;
@@ -585,7 +594,7 @@ Tcl_Sleep(
vdelay.sec = desired.sec - now.sec;
vdelay.usec = desired.usec - now.usec;
- (*tclScaleTimeProcPtr) (&vdelay, tclTimeClientData);
+ tclScaleTimeProcPtr(&vdelay, tclTimeClientData);
sleepTime = vdelay.sec * 1000 + vdelay.usec / 1000;
}
}
diff --git a/win/tclWinPipe.c b/win/tclWinPipe.c
index ee088a5..4666deb 100644
--- a/win/tclWinPipe.c
+++ b/win/tclWinPipe.c
@@ -50,7 +50,7 @@ TCL_DECLARE_MUTEX(pipeMutex)
* used in a pipeline.
*/
-typedef struct WinFile {
+typedef struct {
int type; /* One of the file types defined above. */
HANDLE handle; /* Open file handle. */
} WinFile;
@@ -82,6 +82,12 @@ static ProcInfo *procList;
#define PIPE_EXTRABYTE (1<<3) /* The reader thread has consumed one byte. */
/*
+ * TODO: It appears the whole EXTRABYTE machinery is in place to support
+ * outdated Win 95 systems. If this can be confirmed, much code can be
+ * deleted.
+ */
+
+/*
* This structure describes per-instance data for a pipe based channel.
*/
@@ -142,7 +148,7 @@ typedef struct PipeInfo {
* synchronized with the readable object. */
} PipeInfo;
-typedef struct ThreadSpecificData {
+typedef struct {
/*
* The following pointer refers to the head of the list of pipes that are
* being watched for file events.
@@ -158,7 +164,7 @@ static Tcl_ThreadDataKey dataKey;
* events are generated.
*/
-typedef struct PipeEvent {
+typedef struct {
Tcl_Event header; /* Information that is standard for all
* events. */
PipeInfo *infoPtr; /* Pointer to pipe info structure. Note that
@@ -192,7 +198,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(WCHAR name[MAX_PATH]);
+static int TempFileName(TCHAR name[MAX_PATH]);
static int WaitForRead(PipeInfo *infoPtr, int blocking);
static void PipeThreadActionProc(ClientData instanceData,
int action);
@@ -202,7 +208,7 @@ static void PipeThreadActionProc(ClientData instanceData,
* I/O.
*/
-static Tcl_ChannelType pipeChannelType = {
+static const Tcl_ChannelType pipeChannelType = {
"pipe", /* Type name. */
TCL_CHANNEL_VERSION_5, /* v5 channel */
TCL_CLOSE2PROC, /* Close proc. */
@@ -219,7 +225,7 @@ static Tcl_ChannelType pipeChannelType = {
NULL, /* handler proc. */
NULL, /* wide seek proc */
PipeThreadActionProc, /* thread action proc */
- NULL, /* truncate */
+ NULL /* truncate */
};
/*
@@ -404,7 +410,7 @@ PipeCheckProc(
if (needEvent) {
infoPtr->flags |= PIPE_PENDING;
- evPtr = (PipeEvent *) ckalloc(sizeof(PipeEvent));
+ evPtr = ckalloc(sizeof(PipeEvent));
evPtr->header.proc = PipeEventProc;
evPtr->infoPtr = infoPtr;
Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL);
@@ -435,7 +441,7 @@ TclWinMakeFile(
{
WinFile *filePtr;
- filePtr = (WinFile *) ckalloc(sizeof(WinFile));
+ filePtr = ckalloc(sizeof(WinFile));
filePtr->type = WIN_FILE;
filePtr->handle = handle;
@@ -464,27 +470,18 @@ TclWinMakeFile(
static int
TempFileName(
- WCHAR name[MAX_PATH]) /* Buffer in which name for temporary file
+ TCHAR name[MAX_PATH]) /* Buffer in which name for temporary file
* gets stored. */
{
- TCHAR *prefix;
-
- prefix = (tclWinProcs->useWide) ? (TCHAR *) L"TCL" : (TCHAR *) "TCL";
- if ((*tclWinProcs->getTempPathProc)(MAX_PATH, name) != 0) {
- if ((*tclWinProcs->getTempFileNameProc)((TCHAR *) name, prefix, 0,
- name) != 0) {
+ const TCHAR *prefix = TEXT("TCL");
+ if (GetTempPath(MAX_PATH, name) != 0) {
+ if (GetTempFileName(name, prefix, 0, name) != 0) {
return 1;
}
}
- if (tclWinProcs->useWide) {
- ((WCHAR *) name)[0] = '.';
- ((WCHAR *) name)[1] = '\0';
- } else {
- ((char *) name)[0] = '.';
- ((char *) name)[1] = '\0';
- }
- return (*tclWinProcs->getTempFileNameProc)((TCHAR *) name, prefix, 0,
- name);
+ name[0] = '.';
+ name[1] = '\0';
+ return GetTempFileName(name, prefix, 0, name);
}
/*
@@ -596,7 +593,7 @@ TclpOpenFile(
flags = 0;
if (!(mode & O_CREAT)) {
- flags = (*tclWinProcs->getFileAttributesProc)(nativePath);
+ flags = GetFileAttributes(nativePath);
if (flags == 0xFFFFFFFF) {
flags = 0;
}
@@ -612,8 +609,8 @@ TclpOpenFile(
* Now we get to create the file.
*/
- handle = (*tclWinProcs->createFileProc)(nativePath, accessMode,
- shareMode, NULL, createMode, flags, NULL);
+ handle = CreateFile(nativePath, accessMode, shareMode,
+ NULL, createMode, flags, NULL);
Tcl_DStringFree(&ds);
if (handle == INVALID_HANDLE_VALUE) {
@@ -660,7 +657,7 @@ TclFile
TclpCreateTempFile(
const char *contents) /* String to write into temp file, or NULL. */
{
- WCHAR name[MAX_PATH];
+ TCHAR name[MAX_PATH];
const char *native;
Tcl_DString dstring;
HANDLE handle;
@@ -669,7 +666,7 @@ TclpCreateTempFile(
return NULL;
}
- handle = (*tclWinProcs->createFileProc)((TCHAR *) name,
+ handle = CreateFile(name,
GENERIC_READ | GENERIC_WRITE, 0, NULL, CREATE_ALWAYS,
FILE_ATTRIBUTE_TEMPORARY|FILE_FLAG_DELETE_ON_CLOSE, NULL);
if (handle == INVALID_HANDLE_VALUE) {
@@ -731,7 +728,7 @@ TclpCreateTempFile(
TclWinConvertError(GetLastError());
CloseHandle(handle);
- (*tclWinProcs->deleteFileProc)((TCHAR *) name);
+ DeleteFile(name);
return NULL;
}
@@ -754,13 +751,13 @@ TclpCreateTempFile(
Tcl_Obj *
TclpTempFileName(void)
{
- WCHAR fileName[MAX_PATH];
+ TCHAR fileName[MAX_PATH];
if (TempFileName(fileName) == 0) {
return NULL;
}
- return TclpNativeToNormalized((ClientData) fileName);
+ return TclpNativeToNormalized(fileName);
}
/*
@@ -836,7 +833,7 @@ TclpCloseFile(
if (filePtr->handle != NULL &&
CloseHandle(filePtr->handle) == FALSE) {
TclWinConvertError(GetLastError());
- ckfree((char *) filePtr);
+ ckfree(filePtr);
return -1;
}
}
@@ -846,7 +843,7 @@ TclpCloseFile(
Tcl_Panic("TclpCloseFile: unexpected file type");
}
- ckfree((char *) filePtr);
+ ckfree(filePtr);
return 0;
}
@@ -900,7 +897,7 @@ TclpGetPid(
*
* The complete Windows search path is searched to find the specified
* executable. If an executable by the given name is not found,
- * automatically tries appending ".com", ".exe", and ".bat" to the
+ * automatically tries appending standard extensions to the
* executable name.
*
* Results:
@@ -947,7 +944,7 @@ TclpCreateProcess(
{
int result, applType, createFlags;
Tcl_DString cmdLine; /* Complete command line (TCHAR). */
- STARTUPINFOA startInfo;
+ STARTUPINFO startInfo;
PROCESS_INFORMATION procInfo;
SECURITY_ATTRIBUTES secAtts;
HANDLE hProcess, h, inputHandle, outputHandle, errorHandle;
@@ -1037,8 +1034,9 @@ TclpCreateProcess(
}
if (startInfo.hStdInput == INVALID_HANDLE_VALUE) {
TclWinConvertError(GetLastError());
- Tcl_AppendResult(interp, "couldn't duplicate input handle: ",
- Tcl_PosixError(interp), (char *) NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't duplicate input handle: %s",
+ Tcl_PosixError(interp)));
goto end;
}
@@ -1057,23 +1055,17 @@ TclpCreateProcess(
* sink.
*/
- if ((TclWinGetPlatformId() == VER_PLATFORM_WIN32_WINDOWS)
- && (applType == APPL_DOS)) {
- if (CreatePipe(&h, &startInfo.hStdOutput, &secAtts, 0) != FALSE) {
- CloseHandle(h);
- }
- } else {
- startInfo.hStdOutput = CreateFileA("NUL:", GENERIC_WRITE, 0,
- &secAtts, OPEN_ALWAYS, FILE_ATTRIBUTE_NORMAL, NULL);
- }
+ startInfo.hStdOutput = CreateFile(TEXT("NUL:"), GENERIC_WRITE, 0,
+ &secAtts, OPEN_ALWAYS, FILE_ATTRIBUTE_NORMAL, NULL);
} else {
DuplicateHandle(hProcess, outputHandle, hProcess,
&startInfo.hStdOutput, 0, TRUE, DUPLICATE_SAME_ACCESS);
}
if (startInfo.hStdOutput == INVALID_HANDLE_VALUE) {
TclWinConvertError(GetLastError());
- Tcl_AppendResult(interp, "couldn't duplicate output handle: ",
- Tcl_PosixError(interp), (char *) NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't duplicate output handle: %s",
+ Tcl_PosixError(interp)));
goto end;
}
@@ -1083,7 +1075,7 @@ TclpCreateProcess(
* sink.
*/
- startInfo.hStdError = CreateFileA("NUL:", GENERIC_WRITE, 0,
+ startInfo.hStdError = CreateFile(TEXT("NUL:"), GENERIC_WRITE, 0,
&secAtts, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL);
} else {
DuplicateHandle(hProcess, errorHandle, hProcess, &startInfo.hStdError,
@@ -1091,8 +1083,9 @@ TclpCreateProcess(
}
if (startInfo.hStdError == INVALID_HANDLE_VALUE) {
TclWinConvertError(GetLastError());
- Tcl_AppendResult(interp, "couldn't duplicate error handle: ",
- Tcl_PosixError(interp), (char *) NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't duplicate error handle: %s",
+ Tcl_PosixError(interp)));
goto end;
}
@@ -1124,7 +1117,7 @@ TclpCreateProcess(
startInfo.wShowWindow = SW_HIDE;
startInfo.dwFlags |= STARTF_USESHOWWINDOW;
createFlags = CREATE_NEW_CONSOLE;
- Tcl_DStringAppend(&cmdLine, "cmd.exe /c", -1);
+ TclDStringAppendLiteral(&cmdLine, "cmd.exe /c");
} else {
createFlags = DETACHED_PROCESS;
}
@@ -1136,82 +1129,12 @@ TclpCreateProcess(
}
if (applType == APPL_DOS) {
- /*
- * Under Windows 95, 16-bit DOS applications do not work well with
- * pipes:
- *
- * 1. EOF on a pipe between a detached 16-bit DOS application and
- * another application is not seen at the other end of the pipe,
- * so the listening process blocks forever on reads. This inablity
- * to detect EOF happens when either a 16-bit app or the 32-bit
- * app is the listener.
- *
- * 2. If a 16-bit DOS application (detached or not) blocks when
- * writing to a pipe, it will never wake up again, and it
- * eventually brings the whole system down around it.
- *
- * The 16-bit application is run as a normal process inside of a
- * hidden helper console app, and this helper may be run as a
- * detached process. If any of the stdio handles is a pipe, the
- * helper application accumulates information into temp files and
- * forwards it to or from the DOS application as appropriate.
- * This means that DOS apps must receive EOF from a stdin pipe
- * before they will actually begin, and must finish generating
- * stdout or stderr before the data will be sent to the next stage
- * of the pipe.
- *
- * The helper app should be located in the same directory as the
- * tcl dll.
- */
- Tcl_Obj *tclExePtr, *pipeDllPtr;
- char *start, *end;
- int i, fileExists;
- Tcl_DString pipeDll;
-
- if (createFlags != 0) {
- startInfo.wShowWindow = SW_HIDE;
- startInfo.dwFlags |= STARTF_USESHOWWINDOW;
- createFlags = CREATE_NEW_CONSOLE;
- }
-
- Tcl_DStringInit(&pipeDll);
- Tcl_DStringAppend(&pipeDll, TCL_PIPE_DLL, -1);
- tclExePtr = TclGetObjNameOfExecutable();
- Tcl_IncrRefCount(tclExePtr);
- start = Tcl_GetStringFromObj(tclExePtr, &i);
- for (end = start + (i-1); end > start; end--) {
- if (*end == '/') {
- break;
- }
- }
- if (*end != '/') {
- Tcl_AppendResult(interp, "no / in executable path name \"",
- start, "\"", (char *) NULL);
- Tcl_DecrRefCount(tclExePtr);
- Tcl_DStringFree(&pipeDll);
- goto end;
- }
- i = (end - start) + 1;
- pipeDllPtr = Tcl_NewStringObj(start, i);
- Tcl_AppendToObj(pipeDllPtr, Tcl_DStringValue(&pipeDll), -1);
- Tcl_IncrRefCount(pipeDllPtr);
- if (Tcl_FSConvertToPathType(interp, pipeDllPtr) != TCL_OK) {
- Tcl_Panic("Tcl_FSConvertToPathType failed");
- }
- fileExists = (Tcl_FSAccess(pipeDllPtr, F_OK) == 0);
- if (!fileExists) {
- Tcl_AppendResult(interp, "Tcl pipe dll \"",
- Tcl_DStringValue(&pipeDll), "\" not found",
- (char *) NULL);
- Tcl_DecrRefCount(tclExePtr);
- Tcl_DecrRefCount(pipeDllPtr);
- Tcl_DStringFree(&pipeDll);
- goto end;
- }
- Tcl_DStringAppend(&cmdLine, Tcl_DStringValue(&pipeDll), -1);
- Tcl_DecrRefCount(tclExePtr);
- Tcl_DecrRefCount(pipeDllPtr);
- Tcl_DStringFree(&pipeDll);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "DOS application process not supported on this platform",
+ -1));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "DOS_APP",
+ NULL);
+ goto end;
}
}
@@ -1235,12 +1158,12 @@ TclpCreateProcess(
BuildCommandLine(execPath, argc, argv, &cmdLine);
- if ((*tclWinProcs->createProcessProc)(NULL,
- (TCHAR *) Tcl_DStringValue(&cmdLine), NULL, NULL, TRUE,
- (DWORD) createFlags, NULL, NULL, &startInfo, &procInfo) == 0) {
+ if (CreateProcess(NULL, (TCHAR *) Tcl_DStringValue(&cmdLine),
+ NULL, NULL, TRUE, (DWORD) createFlags, NULL, NULL, &startInfo,
+ &procInfo) == 0) {
TclWinConvertError(GetLastError());
- Tcl_AppendResult(interp, "couldn't execute \"", argv[0],
- "\": ", Tcl_PosixError(interp), (char *) NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf("couldn't execute \"%s\": %s",
+ argv[0], Tcl_PosixError(interp)));
goto end;
}
@@ -1368,8 +1291,8 @@ ApplicationType(
IMAGE_DOS_HEADER header;
Tcl_DString nameBuf, ds;
const TCHAR *nativeName;
- WCHAR nativeFullPath[MAX_PATH];
- static const char extensions[][5] = {"", ".com", ".exe", ".bat"};
+ TCHAR nativeFullPath[MAX_PATH];
+ static const char extensions[][5] = {"", ".com", ".exe", ".bat", ".cmd"};
/*
* Look for the program as an external program. First try the name as it
@@ -1394,8 +1317,8 @@ ApplicationType(
Tcl_DStringAppend(&nameBuf, extensions[i], -1);
nativeName = Tcl_WinUtfToTChar(Tcl_DStringValue(&nameBuf),
Tcl_DStringLength(&nameBuf), &ds);
- found = (*tclWinProcs->searchPathProc)(NULL, nativeName, NULL,
- MAX_PATH, nativeFullPath, &rest);
+ found = SearchPath(NULL, nativeName, NULL, MAX_PATH,
+ nativeFullPath, &rest);
Tcl_DStringFree(&ds);
if (found == 0) {
continue;
@@ -1406,20 +1329,21 @@ ApplicationType(
* known type.
*/
- attr = (*tclWinProcs->getFileAttributesProc)((TCHAR *) nativeFullPath);
+ attr = GetFileAttributes(nativeFullPath);
if ((attr == 0xffffffff) || (attr & FILE_ATTRIBUTE_DIRECTORY)) {
continue;
}
- strcpy(fullName, Tcl_WinTCharToUtf((TCHAR *) nativeFullPath, -1, &ds));
+ strcpy(fullName, Tcl_WinTCharToUtf(nativeFullPath, -1, &ds));
Tcl_DStringFree(&ds);
ext = strrchr(fullName, '.');
- if ((ext != NULL) && (strcasecmp(ext, ".bat") == 0)) {
+ if ((ext != NULL) &&
+ (strcasecmp(ext, ".cmd") == 0 || strcasecmp(ext, ".bat") == 0)) {
applType = APPL_DOS;
break;
}
- hFile = (*tclWinProcs->createFileProc)((TCHAR *) nativeFullPath,
+ hFile = CreateFile(nativeFullPath,
GENERIC_READ, FILE_SHARE_READ, NULL, OPEN_EXISTING,
FILE_ATTRIBUTE_NORMAL, NULL);
if (hFile == INVALID_HANDLE_VALUE) {
@@ -1486,8 +1410,8 @@ ApplicationType(
if (applType == APPL_NONE) {
TclWinConvertError(GetLastError());
- Tcl_AppendResult(interp, "couldn't execute \"", originalName,
- "\": ", Tcl_PosixError(interp), (char *) NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf("couldn't execute \"%s\": %s",
+ originalName, Tcl_PosixError(interp)));
return APPL_NONE;
}
@@ -1499,9 +1423,8 @@ ApplicationType(
* application name from the arguments.
*/
- (*tclWinProcs->getShortPathNameProc)((TCHAR *) nativeFullPath,
- nativeFullPath, MAX_PATH);
- strcpy(fullName, Tcl_WinTCharToUtf((TCHAR *) nativeFullPath, -1, &ds));
+ GetShortPathName(nativeFullPath, nativeFullPath, MAX_PATH);
+ strcpy(fullName, Tcl_WinTCharToUtf(nativeFullPath, -1, &ds));
Tcl_DStringFree(&ds);
}
return applType;
@@ -1545,9 +1468,9 @@ BuildCommandLine(
* Prime the path. Add a space separator if we were primed with something.
*/
- Tcl_DStringAppend(&ds, Tcl_DStringValue(linePtr), -1);
+ TclDStringAppendDString(&ds, linePtr);
if (Tcl_DStringLength(linePtr) > 0) {
- Tcl_DStringAppend(&ds, " ", 1);
+ TclDStringAppendLiteral(&ds, " ");
}
for (i = 0; i < argc; i++) {
@@ -1555,7 +1478,7 @@ BuildCommandLine(
arg = executable;
} else {
arg = argv[i];
- Tcl_DStringAppend(&ds, " ", 1);
+ TclDStringAppendLiteral(&ds, " ");
}
quote = 0;
@@ -1564,6 +1487,7 @@ BuildCommandLine(
} else {
int count;
Tcl_UniChar ch;
+
for (start = arg; *start != '\0'; start += count) {
count = Tcl_UtfToUniChar(start, &ch);
if (Tcl_UniCharIsSpace(ch)) { /* INTL: ISO space. */
@@ -1573,7 +1497,7 @@ BuildCommandLine(
}
}
if (quote) {
- Tcl_DStringAppend(&ds, "\"", 1);
+ TclDStringAppendLiteral(&ds, "\"");
}
start = arg;
for (special = arg; ; ) {
@@ -1602,7 +1526,7 @@ BuildCommandLine(
}
if (*special == '"') {
Tcl_DStringAppend(&ds, start, (int) (special - start));
- Tcl_DStringAppend(&ds, "\\\"", 2);
+ TclDStringAppendLiteral(&ds, "\\\"");
start = special + 1;
}
if (*special == '\0') {
@@ -1612,7 +1536,7 @@ BuildCommandLine(
}
Tcl_DStringAppend(&ds, start, (int) (special - start));
if (quote) {
- Tcl_DStringAppend(&ds, "\"", 1);
+ TclDStringAppendLiteral(&ds, "\"");
}
}
Tcl_DStringFree(linePtr);
@@ -1648,7 +1572,7 @@ TclpCreateCommandChannel(
{
char channelName[16 + TCL_INTEGER_SPACE];
DWORD id;
- PipeInfo *infoPtr = (PipeInfo *) ckalloc((unsigned) sizeof(PipeInfo));
+ PipeInfo *infoPtr = ckalloc(sizeof(PipeInfo));
PipeInit();
@@ -1663,7 +1587,7 @@ TclpCreateCommandChannel(
infoPtr->writeBuf = 0;
infoPtr->writeBufLen = 0;
infoPtr->writeError = 0;
- infoPtr->channel = (Tcl_Channel) NULL;
+ infoPtr->channel = NULL;
infoPtr->validMask = 0;
@@ -1705,9 +1629,9 @@ TclpCreateCommandChannel(
* unique, in case channels share handles (stdin/stdout).
*/
- sprintf(channelName, "file%" TCL_I_MODIFIER "x", (size_t)infoPtr);
+ sprintf(channelName, "file%" TCL_I_MODIFIER "x", (size_t) infoPtr);
infoPtr->channel = Tcl_CreateChannel(&pipeChannelType, channelName,
- (ClientData) infoPtr, infoPtr->validMask);
+ infoPtr, infoPtr->validMask);
/*
* Pipes have AUTO translation mode on Windows and ^Z eof char, which
@@ -1715,16 +1639,58 @@ TclpCreateCommandChannel(
* Windows programs that expect a ^Z at EOF.
*/
- Tcl_SetChannelOption((Tcl_Interp *) NULL, infoPtr->channel,
- "-translation", "auto");
- Tcl_SetChannelOption((Tcl_Interp *) NULL, infoPtr->channel,
- "-eofchar", "\032 {}");
+ Tcl_SetChannelOption(NULL, infoPtr->channel, "-translation", "auto");
+ Tcl_SetChannelOption(NULL, infoPtr->channel, "-eofchar", "\032 {}");
return infoPtr->channel;
}
/*
*----------------------------------------------------------------------
*
+ * Tcl_CreatePipe --
+ *
+ * System dependent interface to create a pipe for the [chan pipe]
+ * command. Stolen from TclX.
+ *
+ * Results:
+ * TCL_OK or TCL_ERROR.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_CreatePipe(
+ Tcl_Interp *interp, /* Errors returned in result.*/
+ Tcl_Channel *rchan, /* Where to return the read side. */
+ Tcl_Channel *wchan, /* Where to return the write side. */
+ int flags) /* Reserved for future use. */
+{
+ HANDLE readHandle, writeHandle;
+ SECURITY_ATTRIBUTES sec;
+
+ sec.nLength = sizeof(SECURITY_ATTRIBUTES);
+ sec.lpSecurityDescriptor = NULL;
+ sec.bInheritHandle = FALSE;
+
+ if (!CreatePipe(&readHandle, &writeHandle, &sec, 0)) {
+ TclWinConvertError(GetLastError());
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "pipe creation failed: %s", Tcl_PosixError(interp)));
+ return TCL_ERROR;
+ }
+
+ *rchan = Tcl_MakeFileChannel((ClientData) readHandle, TCL_READABLE);
+ Tcl_RegisterChannel(interp, *rchan);
+
+ *wchan = Tcl_MakeFileChannel((ClientData) writeHandle, TCL_WRITABLE);
+ Tcl_RegisterChannel(interp, *wchan);
+
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TclGetAndDetachPids --
*
* Stores a list of the command PIDs for a command channel in the
@@ -1746,8 +1712,8 @@ TclGetAndDetachPids(
{
PipeInfo *pipePtr;
const Tcl_ChannelType *chanTypePtr;
+ Tcl_Obj *pidsObj;
int i;
- char buf[TCL_INTEGER_SPACE];
/*
* Punt if the channel is not a command channel.
@@ -1758,14 +1724,17 @@ TclGetAndDetachPids(
return;
}
- pipePtr = (PipeInfo *) Tcl_GetChannelInstanceData(chan);
+ pipePtr = Tcl_GetChannelInstanceData(chan);
+ TclNewObj(pidsObj);
for (i = 0; i < pipePtr->numPids; i++) {
- wsprintfA(buf, "%lu", TclpGetPid(pipePtr->pidPtr[i]));
- Tcl_AppendElement(interp, buf);
- Tcl_DetachPids(1, &(pipePtr->pidPtr[i]));
+ Tcl_ListObjAppendElement(NULL, pidsObj,
+ Tcl_NewWideIntObj((unsigned)
+ TclpGetPid(pipePtr->pidPtr[i])));
+ Tcl_DetachPids(1, &pipePtr->pidPtr[i]);
}
+ Tcl_SetObjResult(interp, pidsObj);
if (pipePtr->numPids > 0) {
- ckfree((char *) pipePtr->pidPtr);
+ ckfree(pipePtr->pidPtr);
pipePtr->numPids = 0;
}
}
@@ -1910,12 +1879,26 @@ PipeClose2Proc(
&& (pipePtr->writeFile != NULL)) {
if (pipePtr->writeThread) {
/*
- * Wait for the writer thread to finish the current buffer, then
- * terminate the thread and close the handles. If the channel is
- * nonblocking, there should be no pending write operations.
+ * Wait for the writer thread to finish the current buffer, then
+ * terminate the thread and close the handles. If the channel is
+ * nonblocking but blocked during exit, bail out since the worker
+ * thread is not interruptible and we want TIP#398-fast-exit.
*/
+ if (TclInExit()
+ && (pipePtr->flags & PIPE_ASYNC)) {
+
+ /* give it a chance to leave honorably */
+ SetEvent(pipePtr->stopWriter);
+
+ if (WaitForSingleObject(pipePtr->writable, 0) == WAIT_TIMEOUT) {
+ return EWOULDBLOCK;
+ }
+
+ } else {
+
+ WaitForSingleObject(pipePtr->writable, INFINITE);
- WaitForSingleObject(pipePtr->writable, INFINITE);
+ }
/*
* The thread may already have closed on it's own. Check its exit
@@ -2025,12 +2008,11 @@ PipeClose2Proc(
*/
if (pipePtr->errorFile) {
- WinFile *filePtr;
+ WinFile *filePtr = (WinFile *) pipePtr->errorFile;
- filePtr = (WinFile*)pipePtr->errorFile;
errChan = Tcl_MakeFileChannel((ClientData) filePtr->handle,
TCL_READABLE);
- ckfree((char *) filePtr);
+ ckfree(filePtr);
} else {
errChan = NULL;
}
@@ -2040,14 +2022,14 @@ PipeClose2Proc(
}
if (pipePtr->numPids > 0) {
- ckfree((char *) pipePtr->pidPtr);
+ ckfree(pipePtr->pidPtr);
}
if (pipePtr->writeBuf != NULL) {
ckfree(pipePtr->writeBuf);
}
- ckfree((char*) pipePtr);
+ ckfree(pipePtr);
if (errorCode == 0) {
return result;
@@ -2186,7 +2168,7 @@ PipeOutputProc(
* the channel is in non-blocking mode.
*/
- errno = EAGAIN;
+ errno = EWOULDBLOCK;
goto error;
}
@@ -2215,7 +2197,7 @@ PipeOutputProc(
ckfree(infoPtr->writeBuf);
}
infoPtr->writeBufLen = toWrite;
- infoPtr->writeBuf = ckalloc((unsigned int) toWrite);
+ infoPtr->writeBuf = ckalloc(toWrite);
}
memcpy(infoPtr->writeBuf, buf, (size_t) toWrite);
infoPtr->toWrite = toWrite;
@@ -2594,7 +2576,7 @@ Tcl_WaitPid(
*/
CloseHandle(infoPtr->hProcess);
- ckfree((char*)infoPtr);
+ ckfree(infoPtr);
return result;
}
@@ -2620,9 +2602,9 @@ Tcl_WaitPid(
void
TclWinAddProcess(
void *hProcess, /* Handle to process */
- unsigned long id) /* Global process identifier */
+ unsigned long id) /* Global process identifier */
{
- ProcInfo *procPtr = (ProcInfo *) ckalloc(sizeof(ProcInfo));
+ ProcInfo *procPtr = ckalloc(sizeof(ProcInfo));
PipeInit();
@@ -2664,17 +2646,15 @@ Tcl_PidObjCmd(
PipeInfo *pipePtr;
int i;
Tcl_Obj *resultPtr;
- char buf[TCL_INTEGER_SPACE];
if (objc > 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?channelId?");
return TCL_ERROR;
}
if (objc == 1) {
- wsprintfA(buf, "%lu", (unsigned long) getpid());
- Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, -1));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj((unsigned) getpid()));
} else {
- chan = Tcl_GetChannel(interp, Tcl_GetStringFromObj(objv[1], NULL),
+ chan = Tcl_GetChannel(interp, Tcl_GetString(objv[1]),
NULL);
if (chan == (Tcl_Channel) NULL) {
return TCL_ERROR;
@@ -2687,9 +2667,9 @@ Tcl_PidObjCmd(
pipePtr = (PipeInfo *) Tcl_GetChannelInstanceData(chan);
resultPtr = Tcl_NewObj();
for (i = 0; i < pipePtr->numPids; i++) {
- wsprintfA(buf, "%lu", TclpGetPid(pipePtr->pidPtr[i]));
Tcl_ListObjAppendElement(/*interp*/ NULL, resultPtr,
- Tcl_NewStringObj(buf, -1));
+ Tcl_NewWideIntObj((unsigned)
+ TclpGetPid(pipePtr->pidPtr[i])));
}
Tcl_SetObjResult(interp, resultPtr);
}
@@ -2739,7 +2719,7 @@ WaitForRead(
* is in non-blocking mode.
*/
- errno = EAGAIN;
+ errno = EWOULDBLOCK;
return -1;
}
@@ -2981,6 +2961,10 @@ PipeWriterThread(
* an error, so exit.
*/
+ if (waitResult == WAIT_OBJECT_0) {
+ SetEvent(infoPtr->writable);
+ }
+
break;
}
@@ -3081,6 +3065,100 @@ PipeThreadActionProc(
}
/*
+ *----------------------------------------------------------------------
+ *
+ * TclpOpenTemporaryFile --
+ *
+ * Creates a temporary file, possibly based on the supplied bits and
+ * pieces of template supplied in the first three arguments. If the
+ * fourth argument is non-NULL, it contains a Tcl_Obj to store the name
+ * of the temporary file in (and it is caller's responsibility to clean
+ * up). If the fourth argument is NULL, try to arrange for the temporary
+ * file to go away once it is no longer needed.
+ *
+ * Results:
+ * A read-write Tcl Channel open on the file.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Channel
+TclpOpenTemporaryFile(
+ Tcl_Obj *dirObj,
+ Tcl_Obj *basenameObj,
+ Tcl_Obj *extensionObj,
+ Tcl_Obj *resultingNameObj)
+{
+ TCHAR name[MAX_PATH];
+ char *namePtr;
+ HANDLE handle;
+ DWORD flags = FILE_ATTRIBUTE_TEMPORARY;
+ int length, counter, counter2;
+ Tcl_DString buf;
+
+ if (!resultingNameObj) {
+ flags |= FILE_FLAG_DELETE_ON_CLOSE;
+ }
+
+ namePtr = (char *) name;
+ length = GetTempPath(MAX_PATH, name);
+ if (length == 0) {
+ goto gotError;
+ }
+ namePtr += length * sizeof(TCHAR);
+ if (basenameObj) {
+ const char *string = Tcl_GetString(basenameObj);
+
+ Tcl_WinUtfToTChar(string, basenameObj->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);
+
+ memcpy(namePtr, baseStr, length);
+ namePtr += length;
+ }
+ counter = TclpGetClicks() % 65533;
+ counter2 = 1024; /* Only try this many times! Prevents
+ * an infinite loop. */
+
+ do {
+ char number[TCL_INTEGER_SPACE + 4];
+
+ sprintf(number, "%d.TMP", counter);
+ counter = (unsigned short) (counter + 1);
+ Tcl_WinUtfToTChar(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,
+ GENERIC_READ|GENERIC_WRITE, 0, NULL, CREATE_NEW, flags, NULL);
+ } while (handle == INVALID_HANDLE_VALUE
+ && --counter2 > 0
+ && GetLastError() == ERROR_FILE_EXISTS);
+ if (handle == INVALID_HANDLE_VALUE) {
+ goto gotError;
+ }
+
+ if (resultingNameObj) {
+ Tcl_Obj *tmpObj = TclpNativeToNormalized(name);
+
+ Tcl_AppendObjToObj(resultingNameObj, tmpObj);
+ TclDecrRefCount(tmpObj);
+ }
+
+ return Tcl_MakeFileChannel((ClientData) handle,
+ TCL_READABLE|TCL_WRITABLE);
+
+ gotError:
+ TclWinConvertError(GetLastError());
+ return NULL;
+}
+
+/*
* Local Variables:
* mode: c
* c-basic-offset: 4
diff --git a/win/tclWinPort.h b/win/tclWinPort.h
index b2bf1d7..159a708 100644
--- a/win/tclWinPort.h
+++ b/win/tclWinPort.h
@@ -14,11 +14,24 @@
#ifndef _TCLWINPORT
#define _TCLWINPORT
-#ifndef _WIN64
+#if !defined(_WIN64) && defined(BUILD_tcl)
/* See [Bug 3354324]: file mtime sets wrong time */
# define _USE_32BIT_TIME_T
#endif
+/*
+ * We must specify the lower version we intend to support.
+ *
+ * WINVER = 0x0500 means Windows 2000 and above
+ */
+
+#ifndef WINVER
+# define WINVER 0x0501
+#endif
+#ifndef _WIN32_WINNT
+# define _WIN32_WINNT 0x0501
+#endif
+
#define WIN32_LEAN_AND_MEAN
#include <windows.h>
#undef WIN32_LEAN_AND_MEAN
@@ -34,6 +47,10 @@ typedef DWORD_PTR * PDWORD_PTR;
*/
#define INCL_WINSOCK_API_TYPEDEFS 1
#include <winsock2.h>
+#include <ws2tcpip.h>
+#ifdef HAVE_WSPIAPI_H
+# include <wspiapi.h>
+#endif
#ifdef CHECK_UNICODE_CALLS
# define _UNICODE
@@ -45,6 +62,20 @@ typedef DWORD_PTR * PDWORD_PTR;
#endif /* CHECK_UNICODE_CALLS */
/*
+ * Pull in the typedef of TCHAR for windows.
+ */
+#include <tchar.h>
+#ifndef _TCHAR_DEFINED
+ /* Borland seems to forget to set this. */
+ typedef _TCHAR TCHAR;
+# define _TCHAR_DEFINED
+#endif
+#if defined(_MSC_VER) && defined(__STDC__)
+ /* VS2005 SP1 misses this. See [Bug #3110161] */
+ typedef _TCHAR TCHAR;
+#endif
+
+/*
*---------------------------------------------------------------------------
* The following sets of #includes and #ifdefs are required to get Tcl to
* compile under the windows compilers.
@@ -52,16 +83,14 @@ typedef DWORD_PTR * PDWORD_PTR;
*/
#include <time.h>
+#include <wchar.h>
#include <io.h>
-#include <stdio.h>
-#include <stdlib.h>
#include <errno.h>
#include <fcntl.h>
#include <float.h>
#include <malloc.h>
#include <process.h>
#include <signal.h>
-#include <string.h>
#include <limits.h>
#ifndef __GNUC__
@@ -85,108 +114,166 @@ typedef DWORD_PTR * PDWORD_PTR;
#endif /* __MWERKS__ */
/*
- * Define EINPROGRESS in terms of WSAEINPROGRESS.
- */
-
-#undef EINPROGRESS
-#define EINPROGRESS WSAEINPROGRESS
-
-/*
- * Define ENOTSUP to a value that will never occur.
- */
-
-#undef ENOTSUP
-#define ENOTSUP -1030507
-
-/* Those codes, from Visual Studio 2010, conflict with other values */
-#undef ENODATA
-#undef ENOMSG
-#undef ENOSR
-#undef ENOSTR
-#undef EPROTO
-
-/*
* The following defines redefine the Windows Socket errors as
* BSD errors so Tcl_PosixError can do the right thing.
*/
-#undef EWOULDBLOCK
-#define EWOULDBLOCK EAGAIN
-#undef EALREADY
-#define EALREADY 149 /* operation already in progress */
-#undef ENOTSOCK
-#define ENOTSOCK 95 /* Socket operation on non-socket */
-#undef EDESTADDRREQ
-#define EDESTADDRREQ 96 /* Destination address required */
-#undef EMSGSIZE
-#define EMSGSIZE 97 /* Message too long */
-#undef EPROTOTYPE
-#define EPROTOTYPE 98 /* Protocol wrong type for socket */
-#undef ENOPROTOOPT
-#define ENOPROTOOPT 99 /* Protocol not available */
-#undef EPROTONOSUPPORT
-#define EPROTONOSUPPORT 120 /* Protocol not supported */
-#undef ESOCKTNOSUPPORT
-#define ESOCKTNOSUPPORT 121 /* Socket type not supported */
-#undef EOPNOTSUPP
-#define EOPNOTSUPP 122 /* Operation not supported on socket */
-#undef EPFNOSUPPORT
-#define EPFNOSUPPORT 123 /* Protocol family not supported */
-#undef EAFNOSUPPORT
-#define EAFNOSUPPORT 124 /* Address family not supported */
-#undef EADDRINUSE
-#define EADDRINUSE 125 /* Address already in use */
-#undef EADDRNOTAVAIL
-#define EADDRNOTAVAIL 126 /* Can't assign requested address */
-#undef ENETDOWN
-#define ENETDOWN 127 /* Network is down */
-#undef ENETUNREACH
-#define ENETUNREACH 128 /* Network is unreachable */
-#undef ENETRESET
-#define ENETRESET 129 /* Network dropped connection on reset */
-#undef ECONNABORTED
-#define ECONNABORTED 130 /* Software caused connection abort */
-#undef ECONNRESET
-#define ECONNRESET 131 /* Connection reset by peer */
-#undef ENOBUFS
-#define ENOBUFS 132 /* No buffer space available */
-#undef EISCONN
-#define EISCONN 133 /* Socket is already connected */
-#undef ENOTCONN
-#define ENOTCONN 134 /* Socket is not connected */
-#undef ESHUTDOWN
-#define ESHUTDOWN 143 /* Can't send after socket shutdown */
-#undef ETOOMANYREFS
-#define ETOOMANYREFS 144 /* Too many references: can't splice */
-#undef ETIMEDOUT
-#define ETIMEDOUT 145 /* Connection timed out */
-#undef ECONNREFUSED
-#define ECONNREFUSED 146 /* Connection refused */
-#undef ELOOP
-#define ELOOP 90 /* Symbolic link loop */
-#undef EHOSTDOWN
-#define EHOSTDOWN 147 /* Host is down */
-#undef EHOSTUNREACH
-#define EHOSTUNREACH 148 /* No route to host */
-#undef ENOTEMPTY
-#define ENOTEMPTY 93 /* directory not empty */
-#undef EUSERS
-#define EUSERS 94 /* Too many users (for UFS) */
-#undef EDQUOT
-#define EDQUOT 69 /* Disc quota exceeded */
-#undef ESTALE
-#define ESTALE 151 /* Stale NFS file handle */
-#undef EREMOTE
-#define EREMOTE 66 /* The object is remote */
+#ifndef ENOTEMPTY
+# define ENOTEMPTY 41 /* Directory not empty */
+#endif
+#ifndef EREMOTE
+# define EREMOTE 66 /* The object is remote */
+#endif
+#ifndef EPFNOSUPPORT
+# define EPFNOSUPPORT 96 /* Protocol family not supported */
+#endif
+#ifndef EADDRINUSE
+# define EADDRINUSE 100 /* Address already in use */
+#endif
+#ifndef EADDRNOTAVAIL
+# define EADDRNOTAVAIL 101 /* Can't assign requested address */
+#endif
+#ifndef EAFNOSUPPORT
+# define EAFNOSUPPORT 102 /* Address family not supported */
+#endif
+#ifndef EALREADY
+# define EALREADY 103 /* Operation already in progress */
+#endif
+#ifndef EBADMSG
+# define EBADMSG 104 /* Not a data message */
+#endif
+#ifndef ECANCELED
+# define ECANCELED 105 /* Canceled */
+#endif
+#ifndef ECONNABORTED
+# define ECONNABORTED 106 /* Software caused connection abort */
+#endif
+#ifndef ECONNREFUSED
+# define ECONNREFUSED 107 /* Connection refused */
+#endif
+#ifndef ECONNRESET
+# define ECONNRESET 108 /* Connection reset by peer */
+#endif
+#ifndef EDESTADDRREQ
+# define EDESTADDRREQ 109 /* Destination address required */
+#endif
+#ifndef EHOSTUNREACH
+# define EHOSTUNREACH 110 /* No route to host */
+#endif
+#ifndef EIDRM
+# define EIDRM 111 /* Identifier removed */
+#endif
+#ifndef EINPROGRESS
+# define EINPROGRESS 112 /* Operation now in progress */
+#endif
+#ifndef EISCONN
+# define EISCONN 113 /* Socket is already connected */
+#endif
+#ifndef ELOOP
+# define ELOOP 114 /* Symbolic link loop */
+#endif
+#ifndef EMSGSIZE
+# define EMSGSIZE 115 /* Message too long */
+#endif
+#ifndef ENETDOWN
+# define ENETDOWN 116 /* Network is down */
+#endif
+#ifndef ENETRESET
+# define ENETRESET 117 /* Network dropped connection on reset */
+#endif
+#ifndef ENETUNREACH
+# define ENETUNREACH 118 /* Network is unreachable */
+#endif
+#ifndef ENOBUFS
+# define ENOBUFS 119 /* No buffer space available */
+#endif
+#ifndef ENODATA
+# define ENODATA 120 /* No data available */
+#endif
+#ifndef ENOLINK
+# define ENOLINK 121 /* Link has be severed */
+#endif
+#ifndef ENOMSG
+# define ENOMSG 122 /* No message of desired type */
+#endif
+#ifndef ENOPROTOOPT
+# define ENOPROTOOPT 123 /* Protocol not available */
+#endif
+#ifndef ENOSR
+# define ENOSR 124 /* Out of stream resources */
+#endif
+#ifndef ENOSTR
+# define ENOSTR 125 /* Not a stream device */
+#endif
+#ifndef ENOTCONN
+# define ENOTCONN 126 /* Socket is not connected */
+#endif
+#ifndef ENOTRECOVERABLE
+# define ENOTRECOVERABLE 127 /* Not recoverable */
+#endif
+#ifndef ENOTSOCK
+# define ENOTSOCK 128 /* Socket operation on non-socket */
+#endif
+#ifndef ENOTSUP
+# define ENOTSUP 129 /* Operation not supported */
+#endif
+#ifndef EOPNOTSUPP
+# define EOPNOTSUPP 130 /* Operation not supported on socket */
+#endif
+#ifndef EOTHER
+# define EOTHER 131 /* Other error */
+#endif
+#ifndef EOVERFLOW
+# define EOVERFLOW 132 /* File too big */
+#endif
+#ifndef EOWNERDEAD
+# define EOWNERDEAD 133 /* Owner dead */
+#endif
+#ifndef EPROTO
+# define EPROTO 134 /* Protocol error */
+#endif
+#ifndef EPROTONOSUPPORT
+# define EPROTONOSUPPORT 135 /* Protocol not supported */
+#endif
+#ifndef EPROTOTYPE
+# define EPROTOTYPE 136 /* Protocol wrong type for socket */
+#endif
+#ifndef ETIME
+# define ETIME 137 /* Timer expired */
+#endif
+#ifndef ETIMEDOUT
+# define ETIMEDOUT 138 /* Connection timed out */
+#endif
+#ifndef ETXTBSY
+# define ETXTBSY 139 /* Text file or pseudo-device busy */
+#endif
+#ifndef EWOULDBLOCK
+# define EWOULDBLOCK 140 /* Operation would block */
+#endif
-/*
- * It is very hard to determine how Windows reacts to attempting to
- * set a file pointer outside the input datatype's representable
- * region. So we fake the error code ourselves.
- */
-#undef EOVERFLOW
-#define EOVERFLOW EFBIG /* The object couldn't fit in the datatype */
+/* Visual Studio doesn't have these, so just choose some high numbers */
+#ifndef ESOCKTNOSUPPORT
+# define ESOCKTNOSUPPORT 240 /* Socket type not supported */
+#endif
+#ifndef ESHUTDOWN
+# define ESHUTDOWN 241 /* Can't send after socket shutdown */
+#endif
+#ifndef ETOOMANYREFS
+# define ETOOMANYREFS 242 /* Too many references: can't splice */
+#endif
+#ifndef EHOSTDOWN
+# define EHOSTDOWN 243 /* Host is down */
+#endif
+#ifndef EUSERS
+# define EUSERS 244 /* Too many users (for UFS) */
+#endif
+#ifndef EDQUOT
+# define EDQUOT 245 /* Disc quota exceeded */
+#endif
+#ifndef ESTALE
+# define ESTALE 246 /* Stale NFS file handle */
+#endif
/*
* Signals not known to the standard ANSI signal.h. These are used
@@ -273,6 +360,20 @@ typedef DWORD_PTR * PDWORD_PTR;
# define S_IFLNK 0120000 /* Symbolic Link */
#endif
+/*
+ * Windows compilers do not define S_IFBLK. However, Tcl uses it in
+ * GetTypeFromMode to identify blockSpecial devices based on the
+ * value in the statsbuf st_mode field. We have no other way to pass this
+ * from NativeStat on Windows so are forced to define it here.
+ * The definition here is essentially what is seen on Linux and MingW.
+ * XXX - the root problem is Tcl using Unix definitions instead of
+ * abstracting the structure into a platform independent one. Sigh - perhaps
+ * Tcl 9
+ */
+#ifndef S_IFBLK
+# define S_IFBLK (S_IFDIR | S_IFCHR)
+#endif
+
#ifndef S_ISREG
# ifdef S_IFREG
# define S_ISREG(m) (((m) & S_IFMT) == S_IFREG)
@@ -385,13 +486,6 @@ typedef DWORD_PTR * PDWORD_PTR;
# pragma warning(disable:4996)
#endif
-
-/*
- * There is no platform-specific panic routine for Windows in the Tcl internals.
- */
-
-#define TclpPanic ((Tcl_PanicProc *) NULL)
-
/*
*---------------------------------------------------------------------------
* The following macros and declarations represent the interface between
diff --git a/win/tclWinReg.c b/win/tclWinReg.c
index a6ce2ce..5f7fd31 100644
--- a/win/tclWinReg.c
+++ b/win/tclWinReg.c
@@ -12,36 +12,48 @@
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
+#undef STATIC_BUILD
+#ifndef USE_TCL_STUBS
+# define USE_TCL_STUBS
+#endif
#include "tclInt.h"
-#include "tclPort.h"
#ifdef _MSC_VER
# pragma comment (lib, "advapi32.lib")
#endif
#include <stdlib.h>
+#ifndef UNICODE
+# undef Tcl_WinTCharToUtf
+# define Tcl_WinTCharToUtf(a,b,c) Tcl_ExternalToUtfDString(NULL,a,b,c)
+# undef Tcl_WinUtfToTChar
+# define Tcl_WinUtfToTChar(a,b,c) Tcl_UtfToExternalDString(NULL,a,b,c)
+#endif /* !UNICODE */
+
/*
- * TCL_STORAGE_CLASS is set unconditionally to DLLEXPORT because the
- * Registry_Init declaration is in the source file itself, which is only
- * accessed when we are building a library.
+ * Ensure that we can say which registry is being accessed.
*/
-#undef TCL_STORAGE_CLASS
-#define TCL_STORAGE_CLASS DLLEXPORT
+#ifndef KEY_WOW64_64KEY
+# define KEY_WOW64_64KEY (0x0100)
+#endif
+#ifndef KEY_WOW64_32KEY
+# define KEY_WOW64_32KEY (0x0200)
+#endif
/*
* The maximum length of a sub-key name.
*/
#ifndef MAX_KEY_LENGTH
-#define MAX_KEY_LENGTH 256
+# define MAX_KEY_LENGTH 256
#endif
/*
* The following macros convert between different endian ints.
*/
-#define SWAPWORD(x) MAKEWORD(HIBYTE(x), LOBYTE(x))
-#define SWAPLONG(x) MAKELONG(SWAPWORD(HIWORD(x)), SWAPWORD(LOWORD(x)))
+#define SWAPWORD(x) MAKEWORD(HIBYTE(x), LOBYTE(x))
+#define SWAPLONG(x) MAKELONG(SWAPWORD(HIWORD(x)), SWAPWORD(LOWORD(x)))
/*
* The following flag is used in OpenKeys to indicate that the specified key
@@ -55,7 +67,7 @@
* system predefined keys.
*/
-static CONST char *rootKeyNames[] = {
+static const char *const rootKeyNames[] = {
"HKEY_LOCAL_MACHINE", "HKEY_USERS", "HKEY_CLASSES_ROOT",
"HKEY_CURRENT_USER", "HKEY_CURRENT_CONFIG",
"HKEY_PERFORMANCE_DATA", "HKEY_DYN_DATA", NULL
@@ -66,7 +78,7 @@ static const HKEY rootKeys[] = {
HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, HKEY_DYN_DATA
};
-static CONST char REGISTRY_ASSOC_KEY[] = "registry::command";
+static const char REGISTRY_ASSOC_KEY[] = "registry::command";
/*
* The following table maps from registry types to strings. Note that the
@@ -74,7 +86,7 @@ static CONST char REGISTRY_ASSOC_KEY[] = "registry::command";
* types so we don't need a separate table to hold the mapping.
*/
-static CONST char *typeNames[] = {
+static const char *const typeNames[] = {
"none", "sz", "expand_sz", "binary", "dword",
"dword_big_endian", "link", "multi_sz", "resource_list", NULL
};
@@ -82,100 +94,26 @@ static CONST char *typeNames[] = {
static DWORD lastType = REG_RESOURCE_LIST;
/*
- * The following structures allow us to select between the Unicode and ASCII
- * interfaces at run time based on whether Unicode APIs are available. The
- * Unicode APIs are preferable because they will handle characters outside of
- * the current code page.
- */
-
-typedef struct RegWinProcs {
- int useWide;
-
- LONG (WINAPI *regConnectRegistryProc)(CONST TCHAR *, HKEY, PHKEY);
- LONG (WINAPI *regCreateKeyExProc)(HKEY, CONST TCHAR *, DWORD, TCHAR *,
- DWORD, REGSAM, SECURITY_ATTRIBUTES *, HKEY *, DWORD *);
- LONG (WINAPI *regDeleteKeyProc)(HKEY, CONST TCHAR *);
- LONG (WINAPI *regDeleteValueProc)(HKEY, CONST TCHAR *);
- LONG (WINAPI *regEnumKeyProc)(HKEY, DWORD, TCHAR *, DWORD);
- LONG (WINAPI *regEnumKeyExProc)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *,
- TCHAR *, DWORD *, FILETIME *);
- LONG (WINAPI *regEnumValueProc)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *,
- DWORD *, BYTE *, DWORD *);
- LONG (WINAPI *regOpenKeyExProc)(HKEY, CONST TCHAR *, DWORD, REGSAM,
- HKEY *);
- LONG (WINAPI *regQueryValueExProc)(HKEY, CONST TCHAR *, DWORD *, DWORD *,
- BYTE *, DWORD *);
- LONG (WINAPI *regSetValueExProc)(HKEY, CONST TCHAR *, DWORD, DWORD,
- CONST BYTE*, DWORD);
-} RegWinProcs;
-
-static RegWinProcs *regWinProcs;
-
-static RegWinProcs asciiProcs = {
- 0,
-
- (LONG (WINAPI *)(CONST TCHAR *, HKEY, PHKEY)) RegConnectRegistryA,
- (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, TCHAR *,
- DWORD, REGSAM, SECURITY_ATTRIBUTES *, HKEY *,
- DWORD *)) RegCreateKeyExA,
- (LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteKeyA,
- (LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteValueA,
- (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD)) RegEnumKeyA,
- (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *,
- TCHAR *, DWORD *, FILETIME *)) RegEnumKeyExA,
- (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *,
- DWORD *, BYTE *, DWORD *)) RegEnumValueA,
- (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, REGSAM,
- HKEY *)) RegOpenKeyExA,
- (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD *, DWORD *,
- BYTE *, DWORD *)) RegQueryValueExA,
- (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, DWORD,
- CONST BYTE*, DWORD)) RegSetValueExA,
-};
-
-static RegWinProcs unicodeProcs = {
- 1,
-
- (LONG (WINAPI *)(CONST TCHAR *, HKEY, PHKEY)) RegConnectRegistryW,
- (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, TCHAR *,
- DWORD, REGSAM, SECURITY_ATTRIBUTES *, HKEY *,
- DWORD *)) RegCreateKeyExW,
- (LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteKeyW,
- (LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteValueW,
- (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD)) RegEnumKeyW,
- (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *,
- TCHAR *, DWORD *, FILETIME *)) RegEnumKeyExW,
- (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *,
- DWORD *, BYTE *, DWORD *)) RegEnumValueW,
- (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, REGSAM,
- HKEY *)) RegOpenKeyExW,
- (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD *, DWORD *,
- BYTE *, DWORD *)) RegQueryValueExW,
- (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, DWORD,
- CONST BYTE*, DWORD)) RegSetValueExW,
-};
-
-
-/*
* Declarations for functions defined in this file.
*/
static void AppendSystemError(Tcl_Interp *interp, DWORD error);
static int BroadcastValue(Tcl_Interp *interp, int objc,
- Tcl_Obj * CONST objv[]);
+ Tcl_Obj *const objv[]);
static DWORD ConvertDWORD(DWORD type, DWORD value);
static void DeleteCmd(ClientData clientData);
-static int DeleteKey(Tcl_Interp *interp, Tcl_Obj *keyNameObj);
+static int DeleteKey(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
+ REGSAM mode);
static int DeleteValue(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
- Tcl_Obj *valueNameObj);
+ Tcl_Obj *valueNameObj, REGSAM mode);
static int GetKeyNames(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
- Tcl_Obj *patternObj);
+ Tcl_Obj *patternObj, REGSAM mode);
static int GetType(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
- Tcl_Obj *valueNameObj);
+ Tcl_Obj *valueNameObj, REGSAM mode);
static int GetValue(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
- Tcl_Obj *valueNameObj);
+ Tcl_Obj *valueNameObj, REGSAM mode);
static int GetValueNames(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
- Tcl_Obj *patternObj);
+ Tcl_Obj *patternObj, REGSAM mode);
static int OpenKey(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
REGSAM mode, int flags, HKEY *keyPtr);
static DWORD OpenSubKey(char *hostName, HKEY rootKey,
@@ -185,16 +123,16 @@ static int ParseKeyName(Tcl_Interp *interp, char *name,
char **hostNamePtr, HKEY *rootKeyPtr,
char **keyNamePtr);
static DWORD RecursiveDeleteKey(HKEY hStartKey,
- CONST TCHAR * pKeyName);
+ const TCHAR * pKeyName, REGSAM mode);
static int RegistryObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
- Tcl_Obj * CONST objv[]);
+ Tcl_Obj *const objv[]);
static int SetValue(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
Tcl_Obj *valueNameObj, Tcl_Obj *dataObj,
- Tcl_Obj *typeObj);
+ Tcl_Obj *typeObj, REGSAM mode);
-EXTERN int Registry_Init(Tcl_Interp *interp);
-EXTERN int Registry_Unload(Tcl_Interp *interp, int flags);
+DLLEXPORT int Registry_Init(Tcl_Interp *interp);
+DLLEXPORT int Registry_Unload(Tcl_Interp *interp, int flags);
/*
*----------------------------------------------------------------------
@@ -218,25 +156,14 @@ Registry_Init(
{
Tcl_Command cmd;
- if (Tcl_InitStubs(interp, "8.1", 0) == NULL) {
+ if (Tcl_InitStubs(interp, "8.5", 0) == NULL) {
return TCL_ERROR;
}
- /*
- * Determine if the unicode interfaces are available and select the
- * appropriate registry function table.
- */
-
- if (TclWinGetPlatformId() == VER_PLATFORM_WIN32_NT) {
- regWinProcs = &unicodeProcs;
- } else {
- regWinProcs = &asciiProcs;
- }
-
cmd = Tcl_CreateObjCommand(interp, "registry", RegistryObjCmd,
- (ClientData)interp, DeleteCmd);
- Tcl_SetAssocData(interp, REGISTRY_ASSOC_KEY, NULL, (ClientData)cmd);
- return Tcl_PkgProvide(interp, "registry", "1.2.2");
+ interp, DeleteCmd);
+ Tcl_SetAssocData(interp, REGISTRY_ASSOC_KEY, NULL, cmd);
+ return Tcl_PkgProvide(interp, "registry", "1.3.2");
}
/*
@@ -276,7 +203,7 @@ Registry_Unload(
* Delete the originally registered command.
*/
- cmd = (Tcl_Command)Tcl_GetAssocData(interp, REGISTRY_ASSOC_KEY, NULL);
+ cmd = Tcl_GetAssocData(interp, REGISTRY_ASSOC_KEY, NULL);
if (cmd != NULL) {
Tcl_DeleteCommandFromToken(interp, cmd);
}
@@ -306,7 +233,8 @@ DeleteCmd(
ClientData clientData)
{
Tcl_Interp *interp = clientData;
- Tcl_SetAssocData(interp, REGISTRY_ASSOC_KEY, NULL, (ClientData)NULL);
+
+ Tcl_SetAssocData(interp, REGISTRY_ASSOC_KEY, NULL, NULL);
}
/*
@@ -330,89 +258,125 @@ RegistryObjCmd(
ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj * CONST objv[]) /* Argument values. */
+ Tcl_Obj *const objv[]) /* Argument values. */
{
- int index;
- char *errString = NULL;
+ int n = 1;
+ int index, argc;
+ REGSAM mode = 0;
+ const char *errString = NULL;
- static CONST char *subcommands[] = {
+ static const char *const subcommands[] = {
"broadcast", "delete", "get", "keys", "set", "type", "values", NULL
};
enum SubCmdIdx {
BroadcastIdx, DeleteIdx, GetIdx, KeysIdx, SetIdx, TypeIdx, ValuesIdx
};
+ static const char *const modes[] = {
+ "-32bit", "-64bit", NULL
+ };
if (objc < 2) {
- Tcl_WrongNumArgs(interp, objc, objv, "option ?arg arg ...?");
+ wrongArgs:
+ Tcl_WrongNumArgs(interp, 1, objv, "?-32bit|-64bit? option ?arg ...?");
return TCL_ERROR;
}
- if (Tcl_GetIndexFromObj(interp, objv[1], subcommands, "option", 0, &index)
- != TCL_OK) {
+ if (Tcl_GetString(objv[n])[0] == '-') {
+ if (Tcl_GetIndexFromObj(interp, objv[n++], modes, "mode", 0,
+ &index) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ switch (index) {
+ case 0: /* -32bit */
+ mode |= KEY_WOW64_32KEY;
+ break;
+ case 1: /* -64bit */
+ mode |= KEY_WOW64_64KEY;
+ break;
+ }
+ if (objc < 3) {
+ goto wrongArgs;
+ }
+ }
+
+ if (Tcl_GetIndexFromObj(interp, objv[n++], subcommands, "option", 0,
+ &index) != TCL_OK) {
return TCL_ERROR;
}
+ argc = (objc - n);
switch (index) {
case BroadcastIdx: /* broadcast */
- return BroadcastValue(interp, objc, objv);
+ if (argc == 1 || argc == 3) {
+ int res = BroadcastValue(interp, argc, objv + n);
+
+ if (res != TCL_BREAK) {
+ return res;
+ }
+ }
+ errString = "keyName ?-timeout milliseconds?";
break;
case DeleteIdx: /* delete */
- if (objc == 3) {
- return DeleteKey(interp, objv[2]);
- } else if (objc == 4) {
- return DeleteValue(interp, objv[2], objv[3]);
+ if (argc == 1) {
+ return DeleteKey(interp, objv[n], mode);
+ } else if (argc == 2) {
+ return DeleteValue(interp, objv[n], objv[n+1], mode);
}
errString = "keyName ?valueName?";
break;
case GetIdx: /* get */
- if (objc == 4) {
- return GetValue(interp, objv[2], objv[3]);
+ if (argc == 2) {
+ return GetValue(interp, objv[n], objv[n+1], mode);
}
errString = "keyName valueName";
break;
case KeysIdx: /* keys */
- if (objc == 3) {
- return GetKeyNames(interp, objv[2], NULL);
- } else if (objc == 4) {
- return GetKeyNames(interp, objv[2], objv[3]);
+ if (argc == 1) {
+ return GetKeyNames(interp, objv[n], NULL, mode);
+ } else if (argc == 2) {
+ return GetKeyNames(interp, objv[n], objv[n+1], mode);
}
errString = "keyName ?pattern?";
break;
case SetIdx: /* set */
- if (objc == 3) {
+ if (argc == 1) {
HKEY key;
/*
* Create the key and then close it immediately.
*/
- if (OpenKey(interp, objv[2], KEY_ALL_ACCESS, 1, &key) != TCL_OK) {
+ mode |= KEY_ALL_ACCESS;
+ if (OpenKey(interp, objv[n], mode, 1, &key) != TCL_OK) {
return TCL_ERROR;
}
RegCloseKey(key);
return TCL_OK;
- } else if (objc == 5 || objc == 6) {
- Tcl_Obj *typeObj = (objc == 5) ? NULL : objv[5];
- return SetValue(interp, objv[2], objv[3], objv[4], typeObj);
+ } else if (argc == 3) {
+ return SetValue(interp, objv[n], objv[n+1], objv[n+2], NULL,
+ mode);
+ } else if (argc == 4) {
+ return SetValue(interp, objv[n], objv[n+1], objv[n+2], objv[n+3],
+ mode);
}
errString = "keyName ?valueName data ?type??";
break;
case TypeIdx: /* type */
- if (objc == 4) {
- return GetType(interp, objv[2], objv[3]);
+ if (argc == 2) {
+ return GetType(interp, objv[n], objv[n+1], mode);
}
errString = "keyName valueName";
break;
case ValuesIdx: /* values */
- if (objc == 3) {
- return GetValueNames(interp, objv[2], NULL);
- } else if (objc == 4) {
- return GetValueNames(interp, objv[2], objv[3]);
+ if (argc == 1) {
+ return GetValueNames(interp, objv[n], NULL, mode);
+ } else if (argc == 2) {
+ return GetValueNames(interp, objv[n], objv[n+1], mode);
}
errString = "keyName ?pattern?";
break;
}
- Tcl_WrongNumArgs(interp, 2, objv, errString);
+ Tcl_WrongNumArgs(interp, (mode ? 3 : 2), objv, errString);
return TCL_ERROR;
}
@@ -435,21 +399,22 @@ RegistryObjCmd(
static int
DeleteKey(
Tcl_Interp *interp, /* Current interpreter. */
- Tcl_Obj *keyNameObj) /* Name of key to delete. */
+ Tcl_Obj *keyNameObj, /* Name of key to delete. */
+ REGSAM mode) /* Mode flags to pass. */
{
char *tail, *buffer, *hostName, *keyName;
- CONST char *nativeTail;
+ const TCHAR *nativeTail;
HKEY rootKey, subkey;
DWORD result;
- int length;
Tcl_DString buf;
+ REGSAM saveMode = mode;
/*
* Find the parent of the key being deleted and open it.
*/
- keyName = Tcl_GetStringFromObj(keyNameObj, &length);
- buffer = ckalloc((unsigned int) length + 1);
+ keyName = Tcl_GetString(keyNameObj);
+ buffer = ckalloc(keyNameObj->length + 1);
strcpy(buffer, keyName);
if (ParseKeyName(interp, buffer, &hostName, &rootKey,
@@ -459,8 +424,9 @@ DeleteKey(
}
if (*keyName == '\0') {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "bad key: cannot delete root keys", -1));
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj("bad key: cannot delete root keys", -1));
+ Tcl_SetErrorCode(interp, "WIN_REG", "DEL_ROOT_KEY", NULL);
ckfree(buffer);
return TCL_ERROR;
}
@@ -473,15 +439,15 @@ DeleteKey(
keyName = NULL;
}
- result = OpenSubKey(hostName, rootKey, keyName,
- KEY_ENUMERATE_SUB_KEYS | DELETE, 0, &subkey);
+ mode |= KEY_ENUMERATE_SUB_KEYS | DELETE;
+ result = OpenSubKey(hostName, rootKey, keyName, mode, 0, &subkey);
if (result != ERROR_SUCCESS) {
ckfree(buffer);
if (result == ERROR_FILE_NOT_FOUND) {
return TCL_OK;
}
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "unable to delete key: ", -1));
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj("unable to delete key: ", -1));
AppendSystemError(interp, result);
return TCL_ERROR;
}
@@ -491,7 +457,7 @@ DeleteKey(
*/
nativeTail = Tcl_WinUtfToTChar(tail, -1, &buf);
- result = RecursiveDeleteKey(subkey, nativeTail);
+ result = RecursiveDeleteKey(subkey, nativeTail, saveMode);
Tcl_DStringFree(&buf);
if (result != ERROR_SUCCESS && result != ERROR_FILE_NOT_FOUND) {
@@ -528,11 +494,12 @@ static int
DeleteValue(
Tcl_Interp *interp, /* Current interpreter. */
Tcl_Obj *keyNameObj, /* Name of key. */
- Tcl_Obj *valueNameObj) /* Name of value to delete. */
+ Tcl_Obj *valueNameObj, /* Name of value to delete. */
+ REGSAM mode) /* Mode flags to pass. */
{
HKEY key;
char *valueName;
- int length;
+ size_t length;
DWORD result;
Tcl_DString ds;
@@ -540,19 +507,20 @@ DeleteValue(
* Attempt to open the key for deletion.
*/
- if (OpenKey(interp, keyNameObj, KEY_SET_VALUE, 0, &key)
- != TCL_OK) {
+ mode |= KEY_SET_VALUE;
+ if (OpenKey(interp, keyNameObj, mode, 0, &key) != TCL_OK) {
return TCL_ERROR;
}
- valueName = Tcl_GetStringFromObj(valueNameObj, &length);
+ valueName = Tcl_GetString(valueNameObj);
+ length = valueNameObj->length;
Tcl_WinUtfToTChar(valueName, length, &ds);
- result = (*regWinProcs->regDeleteValueProc)(key, Tcl_DStringValue(&ds));
+ result = RegDeleteValue(key, (const TCHAR *)Tcl_DStringValue(&ds));
Tcl_DStringFree(&ds);
if (result != ERROR_SUCCESS) {
- Tcl_AppendResult(interp, "unable to delete value \"",
- Tcl_GetString(valueNameObj), "\" from key \"",
- Tcl_GetString(keyNameObj), "\": ", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "unable to delete value \"%s\" from key \"%s\": ",
+ Tcl_GetString(valueNameObj), Tcl_GetString(keyNameObj)));
AppendSystemError(interp, result);
result = TCL_ERROR;
} else {
@@ -585,11 +553,13 @@ static int
GetKeyNames(
Tcl_Interp *interp, /* Current interpreter. */
Tcl_Obj *keyNameObj, /* Key to enumerate. */
- Tcl_Obj *patternObj) /* Optional match pattern. */
+ Tcl_Obj *patternObj, /* Optional match pattern. */
+ REGSAM mode) /* Mode flags to pass. */
{
- char *pattern; /* Pattern being matched against subkeys */
+ const char *pattern; /* Pattern being matched against subkeys */
HKEY key; /* Handle to the key being examined */
- TCHAR buffer[MAX_KEY_LENGTH*2]; /* Buffer to hold the subkey name */
+ TCHAR buffer[MAX_KEY_LENGTH];
+ /* Buffer to hold the subkey name */
DWORD bufSize; /* Size of the buffer */
DWORD index; /* Position of the current subkey */
char *name; /* Subkey name */
@@ -603,39 +573,37 @@ GetKeyNames(
pattern = NULL;
}
- /* Attempt to open the key for enumeration. */
+ /*
+ * Attempt to open the key for enumeration.
+ */
- if (OpenKey(interp, keyNameObj,
- KEY_QUERY_VALUE | KEY_ENUMERATE_SUB_KEYS,
- 0, &key) != TCL_OK) {
+ mode |= KEY_QUERY_VALUE | KEY_ENUMERATE_SUB_KEYS;
+ if (OpenKey(interp, keyNameObj, mode, 0, &key) != TCL_OK) {
return TCL_ERROR;
}
- /* Enumerate the subkeys */
+ /*
+ * Enumerate the subkeys.
+ */
resultPtr = Tcl_NewObj();
for (index = 0;; ++index) {
bufSize = MAX_KEY_LENGTH;
- result = (*regWinProcs->regEnumKeyExProc)
- (key, index, buffer, &bufSize, NULL, NULL, NULL, NULL);
+ result = RegEnumKeyEx(key, index, buffer, &bufSize,
+ NULL, NULL, NULL, NULL);
if (result != ERROR_SUCCESS) {
if (result == ERROR_NO_MORE_ITEMS) {
result = TCL_OK;
} else {
- Tcl_SetObjResult(interp, Tcl_NewObj());
- Tcl_AppendResult(interp,
- "unable to enumerate subkeys of \"",
- Tcl_GetString(keyNameObj), "\": ", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "unable to enumerate subkeys of \"%s\": ",
+ Tcl_GetString(keyNameObj)));
AppendSystemError(interp, result);
result = TCL_ERROR;
}
break;
}
- if (regWinProcs->useWide) {
- Tcl_WinTCharToUtf((TCHAR *) buffer, bufSize * sizeof(WCHAR), &ds);
- } else {
- Tcl_WinTCharToUtf((TCHAR *) buffer, bufSize, &ds);
- }
+ Tcl_WinTCharToUtf(buffer, bufSize * sizeof(TCHAR), &ds);
name = Tcl_DStringValue(&ds);
if (pattern && !Tcl_StringMatch(name, pattern)) {
Tcl_DStringFree(&ds);
@@ -679,22 +647,22 @@ static int
GetType(
Tcl_Interp *interp, /* Current interpreter. */
Tcl_Obj *keyNameObj, /* Name of key. */
- Tcl_Obj *valueNameObj) /* Name of value to get. */
+ Tcl_Obj *valueNameObj, /* Name of value to get. */
+ REGSAM mode) /* Mode flags to pass. */
{
HKEY key;
- DWORD result;
- DWORD type;
+ DWORD result, type;
Tcl_DString ds;
- char *valueName;
- CONST char *nativeValue;
- int length;
+ const char *valueName;
+ const TCHAR *nativeValue;
+ size_t length;
/*
* Attempt to open the key for reading.
*/
- if (OpenKey(interp, keyNameObj, KEY_QUERY_VALUE, 0, &key)
- != TCL_OK) {
+ mode |= KEY_QUERY_VALUE;
+ if (OpenKey(interp, keyNameObj, mode, 0, &key) != TCL_OK) {
return TCL_ERROR;
}
@@ -702,17 +670,18 @@ GetType(
* Get the type of the value.
*/
- valueName = Tcl_GetStringFromObj(valueNameObj, &length);
+ valueName = Tcl_GetString(valueNameObj);
+ length = valueNameObj->length;
nativeValue = Tcl_WinUtfToTChar(valueName, length, &ds);
- result = (*regWinProcs->regQueryValueExProc)(key, nativeValue, NULL, &type,
+ result = RegQueryValueEx(key, nativeValue, NULL, &type,
NULL, NULL);
Tcl_DStringFree(&ds);
RegCloseKey(key);
if (result != ERROR_SUCCESS) {
- Tcl_AppendResult(interp, "unable to get type of value \"",
- Tcl_GetString(valueNameObj), "\" from key \"",
- Tcl_GetString(keyNameObj), "\": ", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "unable to get type of value \"%s\" from key \"%s\": ",
+ Tcl_GetString(valueNameObj), Tcl_GetString(keyNameObj)));
AppendSystemError(interp, result);
return TCL_ERROR;
}
@@ -751,20 +720,22 @@ static int
GetValue(
Tcl_Interp *interp, /* Current interpreter. */
Tcl_Obj *keyNameObj, /* Name of key. */
- Tcl_Obj *valueNameObj) /* Name of value to get. */
+ Tcl_Obj *valueNameObj, /* Name of value to get. */
+ REGSAM mode) /* Mode flags to pass. */
{
HKEY key;
- char *valueName;
- CONST char *nativeValue;
+ const char *valueName;
+ const TCHAR *nativeValue;
DWORD result, length, type;
Tcl_DString data, buf;
- int nameLen;
+ size_t nameLen;
/*
* Attempt to open the key for reading.
*/
- if (OpenKey(interp, keyNameObj, KEY_QUERY_VALUE, 0, &key) != TCL_OK) {
+ mode |= KEY_QUERY_VALUE;
+ if (OpenKey(interp, keyNameObj, mode, 0, &key) != TCL_OK) {
return TCL_ERROR;
}
@@ -780,12 +751,13 @@ GetValue(
Tcl_DStringInit(&data);
Tcl_DStringSetLength(&data, TCL_DSTRING_STATIC_SIZE - 1);
- length = TCL_DSTRING_STATIC_SIZE / (regWinProcs->useWide ? 2 : 1) - 1;
+ length = TCL_DSTRING_STATIC_SIZE/sizeof(TCHAR) - 1;
- valueName = Tcl_GetStringFromObj(valueNameObj, &nameLen);
+ valueName = Tcl_GetString(valueNameObj);
+ nameLen = valueNameObj->length;
nativeValue = Tcl_WinUtfToTChar(valueName, nameLen, &buf);
- result = (*regWinProcs->regQueryValueExProc)(key, nativeValue, NULL, &type,
+ result = RegQueryValueEx(key, nativeValue, NULL, &type,
(BYTE *) Tcl_DStringValue(&data), &length);
while (result == ERROR_MORE_DATA) {
/*
@@ -794,17 +766,17 @@ GetValue(
* HKEY_PERFORMANCE_DATA
*/
- length = Tcl_DStringLength(&data) * (regWinProcs->useWide ? 1 : 2);
- Tcl_DStringSetLength(&data, (int) length * (regWinProcs->useWide ? 2 : 1));
- result = (*regWinProcs->regQueryValueExProc)(key, (char *) nativeValue,
+ length = Tcl_DStringLength(&data) * (2 / sizeof(TCHAR));
+ Tcl_DStringSetLength(&data, (int) length * sizeof(TCHAR));
+ result = RegQueryValueEx(key, nativeValue,
NULL, &type, (BYTE *) Tcl_DStringValue(&data), &length);
}
Tcl_DStringFree(&buf);
RegCloseKey(key);
if (result != ERROR_SUCCESS) {
- Tcl_AppendResult(interp, "unable to get value \"",
- Tcl_GetString(valueNameObj), "\" from key \"",
- Tcl_GetString(keyNameObj), "\": ", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "unable to get value \"%s\" from key \"%s\": ",
+ Tcl_GetString(valueNameObj), Tcl_GetString(keyNameObj)));
AppendSystemError(interp, result);
Tcl_DStringFree(&data);
return TCL_ERROR;
@@ -819,7 +791,7 @@ GetValue(
if (type == REG_DWORD || type == REG_DWORD_BIG_ENDIAN) {
Tcl_SetObjResult(interp, Tcl_NewIntObj((int) ConvertDWORD(type,
- *((DWORD*) Tcl_DStringValue(&data)))));
+ *((DWORD *) Tcl_DStringValue(&data)))));
} else if (type == REG_MULTI_SZ) {
char *p = Tcl_DStringValue(&data);
char *end = Tcl_DStringValue(&data) + length;
@@ -831,19 +803,17 @@ GetValue(
* we get bogus data.
*/
- while (p < end && ((regWinProcs->useWide)
- ? *((Tcl_UniChar *)p) : *p) != 0) {
+ while ((p < end) && *((WCHAR *) p) != 0) {
+ WCHAR *wp;
+
Tcl_WinTCharToUtf((TCHAR *) p, -1, &buf);
Tcl_ListObjAppendElement(interp, resultPtr,
Tcl_NewStringObj(Tcl_DStringValue(&buf),
Tcl_DStringLength(&buf)));
- if (regWinProcs->useWide) {
- Tcl_UniChar* up = (Tcl_UniChar*) p;
- while (*up++ != 0) {}
- p = (char*) up;
- } else {
- while (*p++ != '\0') {}
- }
+ wp = (WCHAR *) p;
+
+ while (*wp++ != 0) {/* empty body */}
+ p = (char *) wp;
Tcl_DStringFree(&buf);
}
Tcl_SetObjResult(interp, resultPtr);
@@ -885,27 +855,27 @@ static int
GetValueNames(
Tcl_Interp *interp, /* Current interpreter. */
Tcl_Obj *keyNameObj, /* Key to enumerate. */
- Tcl_Obj *patternObj) /* Optional match pattern. */
+ Tcl_Obj *patternObj, /* Optional match pattern. */
+ REGSAM mode) /* Mode flags to pass. */
{
HKEY key;
Tcl_Obj *resultPtr;
DWORD index, size, result;
Tcl_DString buffer, ds;
- char *pattern, *name;
+ const char *pattern, *name;
/*
* Attempt to open the key for enumeration.
*/
- if (OpenKey(interp, keyNameObj, KEY_QUERY_VALUE, 0, &key)
- != TCL_OK) {
+ mode |= KEY_QUERY_VALUE;
+ if (OpenKey(interp, keyNameObj, mode, 0, &key) != TCL_OK) {
return TCL_ERROR;
}
resultPtr = Tcl_NewObj();
Tcl_DStringInit(&buffer);
- Tcl_DStringSetLength(&buffer,
- (int) ((regWinProcs->useWide) ? MAX_KEY_LENGTH*2 : MAX_KEY_LENGTH));
+ Tcl_DStringSetLength(&buffer, (int) (MAX_KEY_LENGTH * sizeof(TCHAR)));
index = 0;
result = TCL_OK;
@@ -922,13 +892,9 @@ GetValueNames(
*/
size = MAX_KEY_LENGTH;
- while ((*regWinProcs->regEnumValueProc)(key, index,
- Tcl_DStringValue(&buffer), &size, NULL, NULL, NULL, NULL)
- == ERROR_SUCCESS) {
-
- if (regWinProcs->useWide) {
- size *= 2;
- }
+ while (RegEnumValue(key,index, (TCHAR *)Tcl_DStringValue(&buffer),
+ &size, NULL, NULL, NULL, NULL) == ERROR_SUCCESS) {
+ size *= sizeof(TCHAR);
Tcl_WinTCharToUtf((TCHAR *) Tcl_DStringValue(&buffer), (int) size,
&ds);
@@ -978,12 +944,13 @@ OpenKey(
HKEY *keyPtr) /* Returned HKEY. */
{
char *keyName, *buffer, *hostName;
- int length;
+ size_t length;
HKEY rootKey;
DWORD result;
- keyName = Tcl_GetStringFromObj(keyNameObj, &length);
- buffer = ckalloc((unsigned int) length + 1);
+ keyName = Tcl_GetString(keyNameObj);
+ length = keyNameObj->length;
+ buffer = ckalloc(length + 1);
strcpy(buffer, keyName);
result = ParseKeyName(interp, buffer, &hostName, &rootKey, &keyName);
@@ -1039,7 +1006,7 @@ OpenSubKey(
if (hostName) {
hostName = (char *) Tcl_WinUtfToTChar(hostName, -1, &buf);
- result = (*regWinProcs->regConnectRegistryProc)(hostName, rootKey,
+ result = RegConnectRegistry((TCHAR *)hostName, rootKey,
&rootKey);
Tcl_DStringFree(&buf);
if (result != ERROR_SUCCESS) {
@@ -1055,17 +1022,19 @@ OpenSubKey(
keyName = (char *) Tcl_WinUtfToTChar(keyName, -1, &buf);
if (flags & REG_CREATE) {
DWORD create;
- result = (*regWinProcs->regCreateKeyExProc)(rootKey, keyName, 0, NULL,
+
+ result = RegCreateKeyEx(rootKey, (TCHAR *)keyName, 0, NULL,
REG_OPTION_NON_VOLATILE, mode, NULL, keyPtr, &create);
} else if (rootKey == HKEY_PERFORMANCE_DATA) {
/*
* Here we fudge it for this special root key. See MSDN for more info
* on HKEY_PERFORMANCE_DATA and the peculiarities surrounding it.
*/
+
*keyPtr = HKEY_PERFORMANCE_DATA;
result = ERROR_SUCCESS;
} else {
- result = (*regWinProcs->regOpenKeyExProc)(rootKey, keyName, 0, mode,
+ result = RegOpenKeyEx(rootKey, (TCHAR *)keyName, 0, mode,
keyPtr);
}
Tcl_DStringFree(&buf);
@@ -1129,8 +1098,9 @@ ParseKeyName(
rootName = name;
}
if (!rootName) {
- Tcl_AppendResult(interp, "bad key \"", name,
- "\": must start with a valid root", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad key \"%s\": must start with a valid root", name));
+ Tcl_SetErrorCode(interp, "WIN_REG", "NO_ROOT_KEY", NULL);
return TCL_ERROR;
}
@@ -1182,12 +1152,16 @@ ParseKeyName(
static DWORD
RecursiveDeleteKey(
HKEY startKey, /* Parent of key to be deleted. */
- CONST char *keyName) /* Name of key to be deleted in external
+ const TCHAR *keyName, /* Name of key to be deleted in external
* encoding, not UTF. */
+ REGSAM mode) /* Mode flags to pass. */
{
DWORD result, size;
Tcl_DString subkey;
HKEY hKey;
+ REGSAM saveMode = mode;
+ static int checkExProc = 0;
+ static FARPROC regDeleteKeyExProc = NULL;
/*
* Do not allow NULL or empty key name.
@@ -1197,29 +1171,50 @@ RecursiveDeleteKey(
return ERROR_BADKEY;
}
- result = (*regWinProcs->regOpenKeyExProc)(startKey, keyName, 0,
- KEY_ENUMERATE_SUB_KEYS | DELETE | KEY_QUERY_VALUE, &hKey);
+ mode |= KEY_ENUMERATE_SUB_KEYS | DELETE | KEY_QUERY_VALUE;
+ result = RegOpenKeyEx(startKey, keyName, 0, mode, &hKey);
if (result != ERROR_SUCCESS) {
return result;
}
Tcl_DStringInit(&subkey);
- Tcl_DStringSetLength(&subkey,
- (int) ((regWinProcs->useWide) ? MAX_KEY_LENGTH * 2 : MAX_KEY_LENGTH));
+ Tcl_DStringSetLength(&subkey, (int) (MAX_KEY_LENGTH * sizeof(TCHAR)));
+ mode = saveMode;
while (result == ERROR_SUCCESS) {
/*
* Always get index 0 because key deletion changes ordering.
*/
size = MAX_KEY_LENGTH;
- result=(*regWinProcs->regEnumKeyExProc)(hKey, 0,
- Tcl_DStringValue(&subkey), &size, NULL, NULL, NULL, NULL);
+ result = RegEnumKeyEx(hKey, 0, (TCHAR *)Tcl_DStringValue(&subkey),
+ &size, NULL, NULL, NULL, NULL);
if (result == ERROR_NO_MORE_ITEMS) {
- result = (*regWinProcs->regDeleteKeyProc)(startKey, keyName);
+ /*
+ * RegDeleteKeyEx doesn't exist on non-64bit XP platforms, so we
+ * can't compile with it in. We need to check for it at runtime
+ * and use it if we find it.
+ */
+
+ if (mode && !checkExProc) {
+ HINSTANCE dllH;
+
+ checkExProc = 1;
+ dllH = LoadLibrary(TEXT("advapi32.dll"));
+ if (dllH) {
+ regDeleteKeyExProc = (FARPROC)
+ GetProcAddress(dllH, "RegDeleteKeyExW");
+ }
+ }
+ if (mode && regDeleteKeyExProc) {
+ result = regDeleteKeyExProc(startKey, keyName, mode, 0);
+ } else {
+ result = RegDeleteKey(startKey, keyName);
+ }
break;
} else if (result == ERROR_SUCCESS) {
- result = RecursiveDeleteKey(hKey, Tcl_DStringValue(&subkey));
+ result = RecursiveDeleteKey(hKey,
+ (const TCHAR *) Tcl_DStringValue(&subkey), mode);
}
}
Tcl_DStringFree(&subkey);
@@ -1251,29 +1246,32 @@ SetValue(
Tcl_Obj *keyNameObj, /* Name of key. */
Tcl_Obj *valueNameObj, /* Name of value to set. */
Tcl_Obj *dataObj, /* Data to be written. */
- Tcl_Obj *typeObj) /* Type of data to be written. */
+ Tcl_Obj *typeObj, /* Type of data to be written. */
+ REGSAM mode) /* Mode flags to pass. */
{
int type;
+ size_t length;
DWORD result;
HKEY key;
- int length;
- char *valueName;
+ const char *valueName;
Tcl_DString nameBuf;
if (typeObj == NULL) {
type = REG_SZ;
} else if (Tcl_GetIndexFromObj(interp, typeObj, typeNames, "type",
0, (int *) &type) != TCL_OK) {
- if (Tcl_GetIntFromObj(NULL, typeObj, (int*) &type) != TCL_OK) {
+ if (Tcl_GetIntFromObj(NULL, typeObj, (int *) &type) != TCL_OK) {
return TCL_ERROR;
}
Tcl_ResetResult(interp);
}
- if (OpenKey(interp, keyNameObj, KEY_ALL_ACCESS, 1, &key) != TCL_OK) {
+ mode |= KEY_ALL_ACCESS;
+ if (OpenKey(interp, keyNameObj, mode, 1, &key) != TCL_OK) {
return TCL_ERROR;
}
- valueName = Tcl_GetStringFromObj(valueNameObj, &length);
+ valueName = Tcl_GetString(valueNameObj);
+ length = valueNameObj->length;
valueName = (char *) Tcl_WinUtfToTChar(valueName, length, &nameBuf);
if (type == REG_DWORD || type == REG_DWORD_BIG_ENDIAN) {
@@ -1285,8 +1283,8 @@ SetValue(
return TCL_ERROR;
}
- value = ConvertDWORD((DWORD)type, (DWORD)value);
- result = (*regWinProcs->regSetValueExProc)(key, valueName, 0,
+ value = ConvertDWORD((DWORD) type, (DWORD) value);
+ result = RegSetValueEx(key, (TCHAR *) valueName, 0,
(DWORD) type, (BYTE *) &value, sizeof(DWORD));
} else if (type == REG_MULTI_SZ) {
Tcl_DString data, buf;
@@ -1307,53 +1305,53 @@ SetValue(
Tcl_DStringInit(&data);
for (i = 0; i < objc; i++) {
- Tcl_DStringAppend(&data, Tcl_GetString(objv[i]), -1);
+ const char *bytes = Tcl_GetString(objv[i]);
+
+ length = objv[i]->length;
+ Tcl_DStringAppend(&data, bytes, length);
/*
- * Add a null character to separate this value from the next. We
- * accomplish this by growing the string by one byte. Since the
- * DString always tacks on an extra null byte, the new byte will
- * already be set to null.
+ * Add a null character to separate this value from the next.
*/
- Tcl_DStringSetLength(&data, Tcl_DStringLength(&data)+1);
+ Tcl_DStringAppend(&data, "", 1); /* NUL-terminated string */
}
Tcl_WinUtfToTChar(Tcl_DStringValue(&data), Tcl_DStringLength(&data)+1,
&buf);
- result = (*regWinProcs->regSetValueExProc)(key, valueName, 0,
- (DWORD) type, (BYTE *) Tcl_DStringValue(&buf),
+ result = RegSetValueEx(key, (TCHAR *) valueName, 0,
+ (DWORD) type, (BYTE *) Tcl_DStringValue(&buf),
(DWORD) Tcl_DStringLength(&buf));
Tcl_DStringFree(&data);
Tcl_DStringFree(&buf);
} else if (type == REG_SZ || type == REG_EXPAND_SZ) {
Tcl_DString buf;
- CONST char *data = Tcl_GetStringFromObj(dataObj, &length);
+ const char *data = Tcl_GetString(dataObj);
- data = Tcl_WinUtfToTChar(data, length, &buf);
+ length = dataObj->length;
+ data = (char *) Tcl_WinUtfToTChar(data, length, &buf);
/*
- * Include the null in the length, padding if needed for Unicode.
+ * Include the null in the length, padding if needed for WCHAR.
*/
- if (regWinProcs->useWide) {
- Tcl_DStringSetLength(&buf, Tcl_DStringLength(&buf)+1);
- }
+ Tcl_DStringSetLength(&buf, Tcl_DStringLength(&buf)+1);
length = Tcl_DStringLength(&buf) + 1;
- result = (*regWinProcs->regSetValueExProc)(key, valueName, 0,
- (DWORD) type, (BYTE *) data, (DWORD) length);
+ result = RegSetValueEx(key, (TCHAR *) valueName, 0,
+ (DWORD) type, (BYTE *) data, (DWORD) length);
Tcl_DStringFree(&buf);
} else {
BYTE *data;
+ int bytelength;
/*
* Store binary data in the registry.
*/
- data = (BYTE *) Tcl_GetByteArrayFromObj(dataObj, &length);
- result = (*regWinProcs->regSetValueExProc)(key, valueName, 0,
- (DWORD) type, data, (DWORD) length);
+ data = (BYTE *) Tcl_GetByteArrayFromObj(dataObj, &bytelength);
+ result = RegSetValueEx(key, (TCHAR *) valueName, 0,
+ (DWORD) type, data, (DWORD) bytelength);
}
Tcl_DStringFree(&nameBuf);
@@ -1389,35 +1387,33 @@ static int
BroadcastValue(
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument values. */
+ Tcl_Obj *const objv[]) /* Argument values. */
{
LRESULT result;
DWORD_PTR sendResult;
- UINT timeout = 3000;
- int len;
- CONST char *str;
+ int timeout = 3000;
+ size_t len;
+ const char *str;
Tcl_Obj *objPtr;
+ WCHAR *wstr;
+ Tcl_DString ds;
- if ((objc != 3) && (objc != 5)) {
- Tcl_WrongNumArgs(interp, 2, objv, "keyName ?-timeout millisecs?");
- return TCL_ERROR;
- }
-
- if (objc > 3) {
- str = Tcl_GetStringFromObj(objv[3], &len);
- if ((len < 2) || (*str != '-')
- || strncmp(str, "-timeout", (size_t) len)) {
- Tcl_WrongNumArgs(interp, 2, objv, "keyName ?-timeout millisecs?");
- return TCL_ERROR;
+ if (objc == 3) {
+ str = Tcl_GetString(objv[1]);
+ len = objv[1]->length;
+ if ((len < 2) || (*str != '-') || strncmp(str, "-timeout", len)) {
+ return TCL_BREAK;
}
- if (Tcl_GetIntFromObj(interp, objv[4], (int *) &timeout) != TCL_OK) {
+ if (Tcl_GetIntFromObj(interp, objv[2], &timeout) != TCL_OK) {
return TCL_ERROR;
}
}
- str = Tcl_GetStringFromObj(objv[2], &len);
- if (len == 0) {
- str = NULL;
+ str = Tcl_GetString(objv[0]);
+ len = objv[0]->length;
+ wstr = (WCHAR *) Tcl_WinUtfToTChar(str, len, &ds);
+ if (Tcl_DStringLength(&ds) == 0) {
+ wstr = NULL;
}
/*
@@ -1425,11 +1421,12 @@ BroadcastValue(
*/
result = SendMessageTimeout(HWND_BROADCAST, WM_SETTINGCHANGE,
- (WPARAM) 0, (LPARAM) str, SMTO_ABORTIFHUNG, timeout, &sendResult);
+ (WPARAM) 0, (LPARAM) wstr, SMTO_ABORTIFHUNG, (UINT) timeout, &sendResult);
+ Tcl_DStringFree(&ds);
objPtr = Tcl_NewObj();
- Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewLongObj((long) result));
- Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewLongObj((long) sendResult));
+ Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewWideIntObj((Tcl_WideInt) result));
+ Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewWideIntObj((Tcl_WideInt) sendResult));
Tcl_SetObjResult(interp, objPtr);
return TCL_OK;
@@ -1458,8 +1455,8 @@ AppendSystemError(
DWORD error) /* Result code from error. */
{
int length;
- WCHAR *wMsgPtr, **wMsgPtrPtr = &wMsgPtr;
- char *msg;
+ TCHAR *tMsgPtr, **tMsgPtrPtr = &tMsgPtr;
+ const char *msg;
char id[TCL_INTEGER_SPACE], msgBuf[24 + TCL_INTEGER_SPACE];
Tcl_DString ds;
Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
@@ -1467,52 +1464,34 @@ AppendSystemError(
if (Tcl_IsShared(resultPtr)) {
resultPtr = Tcl_DuplicateObj(resultPtr);
}
- length = FormatMessageW(FORMAT_MESSAGE_FROM_SYSTEM
+ length = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM
| FORMAT_MESSAGE_ALLOCATE_BUFFER, NULL, error,
- MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), (WCHAR *) wMsgPtrPtr,
+ MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), (TCHAR *) tMsgPtrPtr,
0, NULL);
if (length == 0) {
- char *msgPtr;
-
- length = FormatMessageA(FORMAT_MESSAGE_FROM_SYSTEM
- | FORMAT_MESSAGE_ALLOCATE_BUFFER, NULL, error,
- MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), (char *) &msgPtr,
- 0, NULL);
- if (length > 0) {
- wMsgPtr = (WCHAR *) LocalAlloc(LPTR, (length + 1) * sizeof(WCHAR));
- MultiByteToWideChar(CP_ACP, 0, msgPtr, length + 1, wMsgPtr,
- length + 1);
- LocalFree(msgPtr);
- }
- }
- if (length == 0) {
- if (error == ERROR_CALL_NOT_IMPLEMENTED) {
- msg = "function not supported under Win32s";
- } else {
- sprintf(msgBuf, "unknown error: %ld", error);
- msg = msgBuf;
- }
+ sprintf(msgBuf, "unknown error: %ld", error);
+ msg = msgBuf;
} else {
- Tcl_Encoding encoding;
+ char *msgPtr;
- encoding = Tcl_GetEncoding(NULL, "unicode");
- Tcl_ExternalToUtfDString(encoding, (char *) wMsgPtr, -1, &ds);
- Tcl_FreeEncoding(encoding);
- LocalFree(wMsgPtr);
+ Tcl_WinTCharToUtf(tMsgPtr, -1, &ds);
+ LocalFree(tMsgPtr);
- msg = Tcl_DStringValue(&ds);
+ msgPtr = Tcl_DStringValue(&ds);
length = Tcl_DStringLength(&ds);
/*
* Trim the trailing CR/LF from the system message.
*/
- if (msg[length-1] == '\n') {
- msg[--length] = 0;
+ if (msgPtr[length-1] == '\n') {
+ --length;
}
- if (msg[length-1] == '\r') {
- msg[--length] = 0;
+ if (msgPtr[length-1] == '\r') {
+ --length;
}
+ msgPtr[length] = 0;
+ msg = msgPtr;
}
sprintf(id, "%ld", error);
@@ -1547,14 +1526,15 @@ ConvertDWORD(
DWORD type, /* Either REG_DWORD or REG_DWORD_BIG_ENDIAN */
DWORD value) /* The value to be converted. */
{
- DWORD order = 1;
+ const DWORD order = 1;
DWORD localType;
/*
* Check to see if the low bit is in the first byte.
*/
- localType = (*((char*) &order) == 1) ? REG_DWORD : REG_DWORD_BIG_ENDIAN;
+ localType = (*((const char *) &order) == 1)
+ ? REG_DWORD : REG_DWORD_BIG_ENDIAN;
return (type != localType) ? (DWORD) SWAPLONG(value) : value;
}
diff --git a/win/tclWinSerial.c b/win/tclWinSerial.c
index 83f1866..0730a46 100644
--- a/win/tclWinSerial.c
+++ b/win/tclWinSerial.c
@@ -173,16 +173,16 @@ static ThreadSpecificData *SerialInit(void);
static int SerialInputProc(ClientData instanceData, char *buf,
int toRead, int *errorCode);
static int SerialOutputProc(ClientData instanceData,
- CONST char *buf, int toWrite, int *errorCode);
+ const char *buf, int toWrite, int *errorCode);
static void SerialSetupProc(ClientData clientData, int flags);
static void SerialWatchProc(ClientData instanceData, int mask);
static void ProcExitHandler(ClientData clientData);
static int SerialGetOptionProc(ClientData instanceData,
- Tcl_Interp *interp, CONST char *optionName,
+ Tcl_Interp *interp, const char *optionName,
Tcl_DString *dsPtr);
static int SerialSetOptionProc(ClientData instanceData,
- Tcl_Interp *interp, CONST char *optionName,
- CONST char *value);
+ Tcl_Interp *interp, const char *optionName,
+ const char *value);
static DWORD WINAPI SerialWriterThread(LPVOID arg);
static void SerialThreadActionProc(ClientData instanceData,
int action);
@@ -197,7 +197,7 @@ static int SerialBlockingWrite(SerialInfo *infoPtr, LPVOID buf,
* based IO.
*/
-static Tcl_ChannelType serialChannelType = {
+static const Tcl_ChannelType serialChannelType = {
"serial", /* Type name. */
TCL_CHANNEL_VERSION_5, /* v5 channel */
SerialCloseProc, /* Close proc. */
@@ -214,7 +214,7 @@ static Tcl_ChannelType serialChannelType = {
NULL, /* handler proc. */
NULL, /* wide seek proc */
SerialThreadActionProc, /* thread action proc */
- NULL, /* truncate */
+ NULL /* truncate */
};
/*
@@ -374,7 +374,7 @@ SerialGetMilliseconds(void)
{
Tcl_Time time;
- TclpGetTime(&time);
+ Tcl_GetTime(&time);
return (time.sec * 1000 + time.usec / 1000);
}
@@ -527,7 +527,7 @@ SerialCheckProc(
if (needEvent) {
infoPtr->flags |= SERIAL_PENDING;
- evPtr = (SerialEvent *) ckalloc(sizeof(SerialEvent));
+ evPtr = ckalloc(sizeof(SerialEvent));
evPtr->header.proc = SerialEventProc;
evPtr->infoPtr = infoPtr;
Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL);
@@ -706,7 +706,7 @@ SerialCloseProc(
ckfree(serialPtr->writeBuf);
serialPtr->writeBuf = NULL;
}
- ckfree((char*) serialPtr);
+ ckfree(serialPtr);
if (errorCode == 0) {
return result;
@@ -932,7 +932,7 @@ SerialInputProc(
bufSize = cStat.cbInQue;
}
} else {
- errno = *errorCode = EAGAIN;
+ errno = *errorCode = EWOULDBLOCK;
return -1;
}
} else {
@@ -996,7 +996,7 @@ SerialInputProc(
static int
SerialOutputProc(
ClientData instanceData, /* Serial state. */
- CONST char *buf, /* The data buffer. */
+ const char *buf, /* The data buffer. */
int toWrite, /* How many bytes to write? */
int *errorCode) /* Where to store error code. */
{
@@ -1071,7 +1071,7 @@ SerialOutputProc(
ckfree(infoPtr->writeBuf);
}
infoPtr->writeBufLen = toWrite;
- infoPtr->writeBuf = ckalloc((unsigned int) toWrite);
+ infoPtr->writeBuf = ckalloc(toWrite);
}
memcpy(infoPtr->writeBuf, buf, (size_t) toWrite);
infoPtr->toWrite = toWrite;
@@ -1415,7 +1415,7 @@ SerialWriterThread(
* Opens or Reopens the serial port with the OVERLAPPED FLAG set
*
* Results:
- * Returns the new handle, or INVALID_HANDLE_VALUE.
+ * Returns the new handle, or INVALID_HANDLE_VALUE.
* If an existing channel is specified it is closed and reopened.
*
* Side effects:
@@ -1427,7 +1427,7 @@ SerialWriterThread(
HANDLE
TclWinSerialOpen(
HANDLE handle,
- CONST TCHAR *name,
+ const TCHAR *name,
DWORD access)
{
SerialInit();
@@ -1446,8 +1446,8 @@ TclWinSerialOpen(
* finished
*/
- handle = (*tclWinProcs->createFileProc)(name, access, 0, 0,
- OPEN_EXISTING, FILE_FLAG_OVERLAPPED, 0);
+ handle = CreateFile(name, access, 0, 0, OPEN_EXISTING,
+ FILE_FLAG_OVERLAPPED, 0);
return handle;
}
@@ -1481,7 +1481,7 @@ TclWinOpenSerialChannel(
SerialInit();
- infoPtr = (SerialInfo *) ckalloc((unsigned) sizeof(SerialInfo));
+ infoPtr = ckalloc(sizeof(SerialInfo));
memset(infoPtr, 0, sizeof(SerialInfo));
infoPtr->validMask = permissions;
@@ -1502,10 +1502,10 @@ TclWinOpenSerialChannel(
* are shared between multiple channels (stdin/stdout).
*/
- sprintf(channelName, "file%" TCL_I_MODIFIER "x", (size_t)infoPtr);
+ sprintf(channelName, "file%" TCL_I_MODIFIER "x", (size_t) infoPtr);
infoPtr->channel = Tcl_CreateChannel(&serialChannelType, channelName,
- (ClientData) infoPtr, permissions);
+ infoPtr, permissions);
SetupComm(handle, infoPtr->sysBufRead, infoPtr->sysBufWrite);
@@ -1648,17 +1648,17 @@ static int
SerialSetOptionProc(
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. */
+ const char *optionName, /* Which option to set? */
+ const char *value) /* New value for option. */
{
SerialInfo *infoPtr;
DCB dcb;
BOOL result, flag;
size_t len, vlen;
Tcl_DString ds;
- CONST TCHAR *native;
+ const TCHAR *native;
int argc;
- CONST char **argv;
+ const char **argv;
infoPtr = (SerialInfo *) instanceData;
@@ -1676,19 +1676,18 @@ SerialSetOptionProc(
if ((len > 2) && (strncmp(optionName, "-mode", len) == 0)) {
if (!GetCommState(infoPtr->handle, &dcb)) {
- if (interp != NULL) {
- Tcl_AppendResult(interp, "can't get comm state", NULL);
- }
- return TCL_ERROR;
+ goto getStateFailed;
}
native = Tcl_WinUtfToTChar(value, -1, &ds);
- result = (*tclWinProcs->buildCommDCBProc)(native, &dcb);
+ result = BuildCommDCB(native, &dcb);
Tcl_DStringFree(&ds);
if (result == FALSE) {
if (interp != NULL) {
- Tcl_AppendResult(interp, "bad value \"", value,
- "\" for -mode: should be baud,parity,data,stop", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad value \"%s\" for -mode: should be baud,parity,data,stop",
+ value));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "SERIALMODE", NULL);
}
return TCL_ERROR;
}
@@ -1703,10 +1702,7 @@ SerialSetOptionProc(
dcb.fAbortOnError = FALSE;
if (!SetCommState(infoPtr->handle, &dcb)) {
- if (interp != NULL) {
- Tcl_AppendResult(interp, "can't set comm state", NULL);
- }
- return TCL_ERROR;
+ goto setStateFailed;
}
return TCL_OK;
}
@@ -1717,10 +1713,7 @@ SerialSetOptionProc(
if ((len > 1) && (strncmp(optionName, "-handshake", len) == 0)) {
if (!GetCommState(infoPtr->handle, &dcb)) {
- if (interp != NULL) {
- Tcl_AppendResult(interp, "can't get comm state", NULL);
- }
- return TCL_ERROR;
+ goto getStateFailed;
}
/*
@@ -1755,18 +1748,16 @@ SerialSetOptionProc(
dcb.fDtrControl = DTR_CONTROL_HANDSHAKE;
} else {
if (interp != NULL) {
- Tcl_AppendResult(interp, "bad value \"", value,
- "\" for -handshake: must be one of xonxoff, rtscts, "
- "dtrdsr or none", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad value \"%s\" for -handshake: must be one of"
+ " xonxoff, rtscts, dtrdsr or none", value));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "HANDSHAKE", NULL);
}
return TCL_ERROR;
}
if (!SetCommState(infoPtr->handle, &dcb)) {
- if (interp != NULL) {
- Tcl_AppendResult(interp, "can't set comm state", NULL);
- }
- return TCL_ERROR;
+ goto setStateFailed;
}
return TCL_OK;
}
@@ -1777,10 +1768,7 @@ SerialSetOptionProc(
if ((len > 1) && (strncmp(optionName, "-xchar", len) == 0)) {
if (!GetCommState(infoPtr->handle, &dcb)) {
- if (interp != NULL) {
- Tcl_AppendResult(interp, "can't get comm state", NULL);
- }
- return TCL_ERROR;
+ goto getStateFailed;
}
if (Tcl_SplitList(interp, value, &argc, &argv) == TCL_ERROR) {
@@ -1789,11 +1777,12 @@ SerialSetOptionProc(
if (argc != 2) {
badXchar:
if (interp != NULL) {
- Tcl_AppendResult(interp, "bad value for -xchar: should be "
- "a list of two elements with each a single character",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "bad value for -xchar: should be a list of"
+ " two elements with each a single character", -1));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "XCHAR", NULL);
}
- ckfree((char *) argv);
+ ckfree(argv);
return TCL_ERROR;
}
@@ -1824,13 +1813,10 @@ SerialSetOptionProc(
}
dcb.XoffChar = (char) character;
}
- ckfree((char *) argv);
+ ckfree(argv);
if (!SetCommState(infoPtr->handle, &dcb)) {
- if (interp != NULL) {
- Tcl_AppendResult(interp, "can't set comm state", NULL);
- }
- return TCL_ERROR;
+ goto setStateFailed;
}
return TCL_OK;
}
@@ -1847,11 +1833,12 @@ SerialSetOptionProc(
}
if ((argc % 2) == 1) {
if (interp != NULL) {
- Tcl_AppendResult(interp, "bad value \"", value,
- "\" for -ttycontrol: should be a list of "
- "signal,value pairs", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad value \"%s\" for -ttycontrol: should be "
+ "a list of signal,value pairs", value));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "TTYCONTROL", NULL);
}
- ckfree((char *) argv);
+ ckfree(argv);
return TCL_ERROR;
}
@@ -1864,7 +1851,10 @@ SerialSetOptionProc(
if (!EscapeCommFunction(infoPtr->handle,
(DWORD) (flag ? SETDTR : CLRDTR))) {
if (interp != NULL) {
- Tcl_AppendResult(interp, "can't set DTR signal", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "can't set DTR signal", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION",
+ "FCONFIGURE", "TTY_SIGNAL", NULL);
}
result = TCL_ERROR;
break;
@@ -1873,7 +1863,10 @@ SerialSetOptionProc(
if (!EscapeCommFunction(infoPtr->handle,
(DWORD) (flag ? SETRTS : CLRRTS))) {
if (interp != NULL) {
- Tcl_AppendResult(interp, "can't set RTS signal", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "can't set RTS signal", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION",
+ "FCONFIGURE", "TTY_SIGNAL", NULL);
}
result = TCL_ERROR;
break;
@@ -1882,15 +1875,20 @@ SerialSetOptionProc(
if (!EscapeCommFunction(infoPtr->handle,
(DWORD) (flag ? SETBREAK : CLRBREAK))) {
if (interp != NULL) {
- Tcl_AppendResult(interp,"can't set BREAK signal",NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "can't set BREAK signal", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION",
+ "FCONFIGURE", "TTY_SIGNAL", NULL);
}
result = TCL_ERROR;
break;
}
} else {
if (interp != NULL) {
- Tcl_AppendResult(interp, "bad signal name \"", argv[i],
- "\" for -ttycontrol: must be DTR, RTS or BREAK",
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad signal name \"%s\" for -ttycontrol: must be"
+ " DTR, RTS or BREAK", argv[i]));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "TTY_SIGNAL",
NULL);
}
result = TCL_ERROR;
@@ -1898,7 +1896,7 @@ SerialSetOptionProc(
}
}
- ckfree((char *) argv);
+ ckfree(argv);
return result;
}
@@ -1924,20 +1922,24 @@ SerialSetOptionProc(
inSize = atoi(argv[0]);
outSize = atoi(argv[1]);
}
- ckfree((char *) argv);
+ ckfree(argv);
if ((argc < 1) || (argc > 2) || (inSize <= 0) || (outSize <= 0)) {
if (interp != NULL) {
- Tcl_AppendResult(interp, "bad value \"", value,
- "\" for -sysbuffer: should be a list of one or two "
- "integers > 0", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad value \"%s\" for -sysbuffer: should be "
+ "a list of one or two integers > 0", value));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "SYS_BUFFER", NULL);
}
return TCL_ERROR;
}
if (!SetupComm(infoPtr->handle, inSize, outSize)) {
if (interp != NULL) {
- Tcl_AppendResult(interp, "can't setup comm buffers", NULL);
+ TclWinConvertError(GetLastError());
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "can't setup comm buffers: %s",
+ Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
@@ -1950,18 +1952,12 @@ SerialSetOptionProc(
*/
if (!GetCommState(infoPtr->handle, &dcb)) {
- if (interp != NULL) {
- Tcl_AppendResult(interp, "can't get comm state", NULL);
- }
- return TCL_ERROR;
+ goto getStateFailed;
}
dcb.XonLim = (WORD) (infoPtr->sysBufRead*1/2);
dcb.XoffLim = (WORD) (infoPtr->sysBufRead*1/4);
if (!SetCommState(infoPtr->handle, &dcb)) {
- if (interp != NULL) {
- Tcl_AppendResult(interp, "can't set comm state", NULL);
- }
- return TCL_ERROR;
+ goto setStateFailed;
}
return TCL_OK;
}
@@ -1991,7 +1987,10 @@ SerialSetOptionProc(
tout.ReadTotalTimeoutConstant = msec;
if (!SetCommTimeouts(infoPtr->handle, &tout)) {
if (interp != NULL) {
- Tcl_AppendResult(interp, "can't set comm timeouts", NULL);
+ TclWinConvertError(GetLastError());
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "can't set comm timeouts: %s",
+ Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
@@ -2001,6 +2000,22 @@ SerialSetOptionProc(
return Tcl_BadChannelOption(interp, optionName,
"mode handshake pollinterval sysbuffer timeout ttycontrol xchar");
+
+ getStateFailed:
+ if (interp != NULL) {
+ TclWinConvertError(GetLastError());
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "can't get comm state: %s", Tcl_PosixError(interp)));
+ }
+ return TCL_ERROR;
+
+ setStateFailed:
+ if (interp != NULL) {
+ TclWinConvertError(GetLastError());
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "can't set comm state: %s", Tcl_PosixError(interp)));
+ }
+ return TCL_ERROR;
}
/*
@@ -2028,7 +2043,7 @@ static int
SerialGetOptionProc(
ClientData instanceData, /* File state. */
Tcl_Interp *interp, /* For error reporting - can be NULL. */
- CONST char *optionName, /* Option to get. */
+ const char *optionName, /* Option to get. */
Tcl_DString *dsPtr) /* Where to store value(s). */
{
SerialInfo *infoPtr;
@@ -2053,12 +2068,14 @@ SerialGetOptionProc(
}
if (len==0 || (len>2 && (strncmp(optionName, "-mode", len) == 0))) {
char parity;
- char *stop;
+ const char *stop;
char buf[2 * TCL_INTEGER_SPACE + 16];
if (!GetCommState(infoPtr->handle, &dcb)) {
if (interp != NULL) {
- Tcl_AppendResult(interp, "can't get comm state", NULL);
+ TclWinConvertError(GetLastError());
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "can't get comm state: %s", Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
@@ -2126,7 +2143,9 @@ SerialGetOptionProc(
if (!GetCommState(infoPtr->handle, &dcb)) {
if (interp != NULL) {
- Tcl_AppendResult(interp, "can't get comm state", NULL);
+ TclWinConvertError(GetLastError());
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "can't get comm state: %s", Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
@@ -2202,7 +2221,9 @@ SerialGetOptionProc(
if (!GetCommModemStatus(infoPtr->handle, &status)) {
if (interp != NULL) {
- Tcl_AppendResult(interp, "can't get tty status", NULL);
+ TclWinConvertError(GetLastError());
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "can't get tty status: %s", Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
@@ -2212,10 +2233,9 @@ SerialGetOptionProc(
if (valid) {
return TCL_OK;
- } else {
- return Tcl_BadChannelOption(interp, optionName,
- "mode pollinterval lasterror queue sysbuffer ttystatus xchar");
}
+ return Tcl_BadChannelOption(interp, optionName,
+ "mode pollinterval lasterror queue sysbuffer ttystatus xchar");
}
/*
diff --git a/win/tclWinSock.c b/win/tclWinSock.c
index 8f565b9..da2e60a 100644
--- a/win/tclWinSock.c
+++ b/win/tclWinSock.c
@@ -9,6 +9,9 @@
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* -----------------------------------------------------------------------
+ * The order and naming of functions in this file should minimize
+ * the file diff to tclUnixSock.c.
+ * -----------------------------------------------------------------------
*
* General information on how this module works.
*
@@ -68,64 +71,126 @@
#undef setsockopt
/*
+ * Helper macros to make parts of this file clearer. The macros do exactly
+ * what they say on the tin. :-) They also only ever refer to their arguments
+ * once, and so can be used without regard to side effects.
+ */
+
+#define SET_BITS(var, bits) ((var) |= (bits))
+#define CLEAR_BITS(var, bits) ((var) &= ~(bits))
+
+/* "sock" + a pointer in hex + \0 */
+#define SOCK_CHAN_LENGTH (4 + sizeof(void *) * 2 + 1)
+#define SOCK_TEMPLATE "sock%p"
+
+/*
* The following variable is used to tell whether this module has been
* initialized. If 1, initialization of sockets was successful, if -1 then
* socket initialization failed (WSAStartup failed).
*/
static int initialized = 0;
+static const TCHAR classname[] = TEXT("TclSocket");
TCL_DECLARE_MUTEX(socketMutex)
/*
- * The following variable holds the network name of this host.
+ * The following defines declare the messages used on socket windows.
*/
-static TclInitProcessGlobalValueProc InitializeHostName;
-static ProcessGlobalValue hostName = {
- 0, 0, NULL, NULL, InitializeHostName, NULL, NULL
-};
+#define SOCKET_MESSAGE WM_USER+1
+#define SOCKET_SELECT WM_USER+2
+#define SOCKET_TERMINATE WM_USER+3
+#define SELECT TRUE
+#define UNSELECT FALSE
/*
- * The following defines declare the messages used on socket windows.
+ * This is needed to comply with the strict aliasing rules of GCC, but it also
+ * simplifies casting between the different sockaddr types.
*/
-#define SOCKET_MESSAGE WM_USER+1
-#define SOCKET_SELECT WM_USER+2
-#define SOCKET_TERMINATE WM_USER+3
-#define SELECT TRUE
-#define UNSELECT FALSE
+typedef union {
+ struct sockaddr sa;
+ struct sockaddr_in sa4;
+ struct sockaddr_in6 sa6;
+ struct sockaddr_storage sas;
+} address;
+
+#ifndef IN6_ARE_ADDR_EQUAL
+#define IN6_ARE_ADDR_EQUAL IN6_ADDR_EQUAL
+#endif
/*
- * The following structure is used to store the data associated with each
- * socket.
- * All members modified by the notifier thread are defined as volatile.
+ * This structure describes per-instance state of a tcp based channel.
*/
-typedef struct SocketInfo {
+typedef struct TcpState TcpState;
+
+typedef struct TcpFdList {
+ TcpState *statePtr;
+ SOCKET fd;
+ struct TcpFdList *next;
+} TcpFdList;
+
+struct TcpState {
Tcl_Channel channel; /* Channel associated with this socket. */
- SOCKET socket; /* Windows SOCKET handle. */
- volatile int flags; /* Bit field comprised of the flags described
+ struct TcpFdList *sockets; /* Windows SOCKET handle. */
+ int flags; /* Bit field comprised of the flags described
* below. */
int watchEvents; /* OR'ed combination of FD_READ, FD_WRITE,
* FD_CLOSE, FD_ACCEPT and FD_CONNECT that
* indicate which events are interesting. */
volatile int readyEvents; /* OR'ed combination of FD_READ, FD_WRITE,
* FD_CLOSE, FD_ACCEPT and FD_CONNECT that
- * indicate which events have occurred. */
+ * indicate which events have occurred.
+ * Set by notifier thread, access must be
+ * protected by semaphore */
int selectEvents; /* OR'ed combination of FD_READ, FD_WRITE,
* FD_CLOSE, FD_ACCEPT and FD_CONNECT that
* indicate which events are currently being
* selected. */
volatile int acceptEventCount;
/* Count of the current number of FD_ACCEPTs
- * that have arrived and not yet processed. */
+ * that have arrived and not yet processed.
+ * Set by notifier thread, access must be
+ * protected by semaphore */
Tcl_TcpAcceptProc *acceptProc;
/* Proc to call on accept. */
ClientData acceptProcData; /* The data for the accept proc. */
- volatile int lastError; /* Error code from last message. */
- struct SocketInfo *nextPtr; /* The next socket on the per-thread socket
+
+ /*
+ * Only needed for client sockets
+ */
+
+ struct addrinfo *addrlist; /* Addresses to connect to. */
+ struct addrinfo *addr; /* Iterator over addrlist. */
+ struct addrinfo *myaddrlist;/* Local address. */
+ struct addrinfo *myaddr; /* Iterator over myaddrlist. */
+ int connectError; /* Cache status of async socket. */
+ int cachedBlocking; /* Cache blocking mode of async socket. */
+ volatile int notifierConnectError;
+ /* Async connect error set by notifier thread.
+ * This error is still a windows error code.
+ * Access must be protected by semaphore */
+ struct TcpState *nextPtr; /* The next socket on the per-thread socket
* list. */
-} SocketInfo;
+};
+
+/*
+ * These bits may be ORed together into the "flags" field of a TcpState
+ * structure.
+ */
+
+#define TCP_NONBLOCKING (1<<0) /* Socket with non-blocking I/O */
+#define TCP_ASYNC_CONNECT (1<<1) /* Async connect in progress. */
+#define SOCKET_EOF (1<<2) /* A zero read happened on the
+ * socket. */
+#define SOCKET_PENDING (1<<3) /* A message has been sent for this
+ * socket */
+#define TCP_ASYNC_PENDING (1<<4) /* TcpConnect was called to
+ * process an async connect. This
+ * flag indicates that reentry is
+ * still pending */
+#define TCP_ASYNC_FAILED (1<<5) /* An async connect finally failed */
/*
* The following structure is what is added to the Tcl event queue when a
@@ -136,8 +201,8 @@ typedef struct {
Tcl_Event header; /* Information that is standard for all
* events. */
SOCKET socket; /* Socket descriptor that is ready. Used to
- * find the SocketInfo structure for the file
- * (can't point directly to the SocketInfo
+ * find the TcpState structure for the file
+ * (can't point directly to the TcpState
* structure because it could go away while
* the event is queued). */
} SocketEvent;
@@ -148,17 +213,6 @@ typedef struct {
#define TCP_BUFFER_SIZE 4096
-/*
- * The following macros may be used to set the flags field of a SocketInfo
- * structure.
- */
-
-#define SOCKET_ASYNC (1<<0) /* The socket is in blocking mode. */
-#define SOCKET_EOF (1<<1) /* A zero read happened on the
- * socket. */
-#define SOCKET_ASYNC_CONNECT (1<<2) /* This socket uses async connect. */
-#define SOCKET_PENDING (1<<3) /* A message has been sent for this
- * socket */
typedef struct {
HWND hwnd; /* Handle to window for socket messages. */
@@ -169,11 +223,11 @@ typedef struct {
* socketThread has been initialized and has
* started. */
HANDLE socketListLock; /* Win32 Event to lock the socketList */
- SocketInfo *pendingSocketInfo;
+ TcpState *pendingTcpState;
/* This socket is opened but not jet in the
* list. This value is also checked by
* the event structure. */
- SocketInfo *socketList; /* Every open socket in this thread has an
+ TcpState *socketList; /* Every open socket in this thread has an
* entry on this list. */
} ThreadSpecificData;
@@ -181,23 +235,23 @@ static Tcl_ThreadDataKey dataKey;
static WNDCLASS windowClass;
/*
- * Static functions defined in this file.
+ * Static routines for this file:
*/
-static SocketInfo * CreateSocket(Tcl_Interp *interp, int port,
- const char *host, int server, const char *myaddr,
- int myport, int async);
-static int CreateSocketAddress(LPSOCKADDR_IN sockaddrPtr,
- const char *host, int port);
+static int TcpConnect(Tcl_Interp *interp,
+ TcpState *state);
static void InitSockets(void);
-static SocketInfo * NewSocketInfo(SOCKET socket);
+static TcpState * NewSocketInfo(SOCKET socket);
static void SocketExitHandler(ClientData clientData);
static LRESULT CALLBACK SocketProc(HWND hwnd, UINT message, WPARAM wParam,
LPARAM lParam);
static int SocketsEnabled(void);
-static void TcpAccept(SocketInfo *infoPtr);
-static int WaitForSocketEvent(SocketInfo *infoPtr, int events,
+static void TcpAccept(TcpFdList *fds, SOCKET newSocket, address addr);
+static int WaitForConnect(TcpState *statePtr, int *errorCodePtr);
+static int WaitForSocketEvent(TcpState *statePtr, int events,
int *errorCodePtr);
+static void AddSocketInfoFd(TcpState *statePtr, SOCKET socket);
+static int FindFDInList(TcpState *statePtr, SOCKET socket);
static DWORD WINAPI SocketThread(LPVOID arg);
static void TcpThreadActionProc(ClientData instanceData,
int action);
@@ -205,8 +259,9 @@ static void TcpThreadActionProc(ClientData instanceData,
static Tcl_EventCheckProc SocketCheckProc;
static Tcl_EventProc SocketEventProc;
static Tcl_EventSetupProc SocketSetupProc;
-static Tcl_DriverBlockModeProc TcpBlockProc;
+static Tcl_DriverBlockModeProc TcpBlockModeProc;
static Tcl_DriverCloseProc TcpCloseProc;
+static Tcl_DriverClose2Proc TcpClose2Proc;
static Tcl_DriverSetOptionProc TcpSetOptionProc;
static Tcl_DriverGetOptionProc TcpGetOptionProc;
static Tcl_DriverInputProc TcpInputProc;
@@ -216,192 +271,180 @@ static Tcl_DriverGetHandleProc TcpGetHandleProc;
/*
* This structure describes the channel type structure for TCP socket
- * based IO.
+ * based IO:
*/
-static Tcl_ChannelType tcpChannelType = {
- "tcp", /* Type name. */
- TCL_CHANNEL_VERSION_5, /* v5 channel */
- TcpCloseProc, /* Close proc. */
- TcpInputProc, /* Input proc. */
- TcpOutputProc, /* Output proc. */
- NULL, /* Seek proc. */
- TcpSetOptionProc, /* Set option proc. */
- TcpGetOptionProc, /* Get option proc. */
- TcpWatchProc, /* Set up notifier to watch this channel. */
- TcpGetHandleProc, /* Get an OS handle from channel. */
- NULL, /* close2proc. */
- TcpBlockProc, /* Set socket into (non-)blocking mode. */
- NULL, /* flush proc. */
- NULL, /* handler proc. */
- NULL, /* wide seek proc */
- TcpThreadActionProc, /* thread action proc */
- NULL, /* truncate */
+static const Tcl_ChannelType tcpChannelType = {
+ "tcp", /* Type name. */
+ TCL_CHANNEL_VERSION_5, /* v5 channel */
+ TcpCloseProc, /* Close proc. */
+ TcpInputProc, /* Input proc. */
+ TcpOutputProc, /* Output proc. */
+ NULL, /* Seek proc. */
+ TcpSetOptionProc, /* Set option proc. */
+ TcpGetOptionProc, /* Get option proc. */
+ TcpWatchProc, /* Initialize notifier. */
+ TcpGetHandleProc, /* Get OS handles out of channel. */
+ TcpClose2Proc, /* Close2 proc. */
+ TcpBlockModeProc, /* Set blocking or non-blocking mode.*/
+ NULL, /* flush proc. */
+ NULL, /* handler proc. */
+ NULL, /* wide seek proc. */
+ TcpThreadActionProc, /* thread action proc. */
+ NULL /* truncate proc. */
};
+
+/*
+ * The following variable holds the network name of this host.
+ */
+
+static TclInitProcessGlobalValueProc InitializeHostName;
+static ProcessGlobalValue hostName =
+ {0, 0, NULL, NULL, InitializeHostName, NULL, NULL};
+
+/*
+ * Address print debug functions
+ */
+#if 0
+void printaddrinfo(struct addrinfo *ai, char *prefix)
+{
+ char host[NI_MAXHOST], port[NI_MAXSERV];
+ getnameinfo(ai->ai_addr, ai->ai_addrlen,
+ host, sizeof(host),
+ port, sizeof(port),
+ NI_NUMERICHOST|NI_NUMERICSERV);
+}
+void printaddrinfolist(struct addrinfo *addrlist, char *prefix)
+{
+ struct addrinfo *ai;
+ for (ai = addrlist; ai != NULL; ai = ai->ai_next) {
+ printaddrinfo(ai, prefix);
+ }
+}
+#endif
/*
*----------------------------------------------------------------------
*
- * InitSockets --
- *
- * Initialize the socket module. If winsock startup is successful,
- * registers the event window for the socket notifier code.
+ * InitializeHostName --
*
- * Assumes socketMutex is held.
+ * This routine sets the process global value of the name of the local
+ * host on which the process is running.
*
* Results:
* None.
*
- * Side effects:
- * Initializes winsock, registers a new window class and creates a
- * window for use in asynchronous socket notification.
- *
*----------------------------------------------------------------------
*/
-static void
-InitSockets(void)
+void
+InitializeHostName(
+ char **valuePtr,
+ int *lengthPtr,
+ Tcl_Encoding *encodingPtr)
{
- DWORD id;
- ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
- TclThreadDataKeyGet(&dataKey);
-
- if (!initialized) {
- initialized = 1;
- TclCreateLateExitHandler(SocketExitHandler, (ClientData) NULL);
+ TCHAR tbuf[MAX_COMPUTERNAME_LENGTH + 1];
+ DWORD length = MAX_COMPUTERNAME_LENGTH + 1;
+ Tcl_DString ds;
+ if (GetComputerName(tbuf, &length) != 0) {
/*
- * Create the async notification window with a new class. We must
- * create a new class to avoid a Windows 95 bug that causes us to get
- * the wrong message number for socket events if the message window is
- * a subclass of a static control.
+ * Convert string from native to UTF then change to lowercase.
*/
- windowClass.style = 0;
- windowClass.cbClsExtra = 0;
- windowClass.cbWndExtra = 0;
- windowClass.hInstance = TclWinGetTclInstance();
- windowClass.hbrBackground = NULL;
- windowClass.lpszMenuName = NULL;
- windowClass.lpszClassName = "TclSocket";
- windowClass.lpfnWndProc = SocketProc;
- windowClass.hIcon = NULL;
- windowClass.hCursor = NULL;
-
- if (!RegisterClassA(&windowClass)) {
- TclWinConvertError(GetLastError());
- goto initFailure;
- }
-
- }
-
- /*
- * Check for per-thread initialization.
- */
-
- if (tsdPtr == NULL) {
- tsdPtr = TCL_TSD_INIT(&dataKey);
- tsdPtr->pendingSocketInfo = NULL;
- tsdPtr->socketList = NULL;
- tsdPtr->hwnd = NULL;
- tsdPtr->threadId = Tcl_GetCurrentThread();
- tsdPtr->readyEvent = CreateEvent(NULL, FALSE, FALSE, NULL);
- if (tsdPtr->readyEvent == NULL) {
- goto initFailure;
- }
- tsdPtr->socketListLock = CreateEvent(NULL, FALSE, TRUE, NULL);
- if (tsdPtr->socketListLock == NULL) {
- goto initFailure;
- }
- tsdPtr->socketThread = CreateThread(NULL, 256, SocketThread, tsdPtr,
- 0, &id);
- if (tsdPtr->socketThread == NULL) {
- goto initFailure;
- }
-
- SetThreadPriority(tsdPtr->socketThread, THREAD_PRIORITY_HIGHEST);
+ Tcl_UtfToLower(Tcl_WinTCharToUtf(tbuf, -1, &ds));
- /*
- * Wait for the thread to signal when the window has been created and
- * if it is ready to go.
- */
+ } else {
+ Tcl_DStringInit(&ds);
+ if (TclpHasSockets(NULL) == TCL_OK) {
+ /*
+ * The buffer size of 256 is recommended by the MSDN page that
+ * documents gethostname() as being always adequate.
+ */
- WaitForSingleObject(tsdPtr->readyEvent, INFINITE);
+ Tcl_DString inDs;
- if (tsdPtr->hwnd == NULL) {
- goto initFailure; /* Trouble creating the window */
+ Tcl_DStringInit(&inDs);
+ Tcl_DStringSetLength(&inDs, 256);
+ if (gethostname(Tcl_DStringValue(&inDs),
+ Tcl_DStringLength(&inDs)) == 0) {
+ Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(&inDs), -1,
+ &ds);
+ }
+ Tcl_DStringFree(&inDs);
}
-
- Tcl_CreateEventSource(SocketSetupProc, SocketCheckProc, NULL);
}
- return;
- initFailure:
- TclpFinalizeSockets();
- initialized = -1;
- return;
+ *encodingPtr = Tcl_GetEncoding(NULL, "utf-8");
+ *lengthPtr = Tcl_DStringLength(&ds);
+ *valuePtr = ckalloc((*lengthPtr) + 1);
+ memcpy(*valuePtr, Tcl_DStringValue(&ds), (size_t)(*lengthPtr)+1);
+ Tcl_DStringFree(&ds);
}
/*
*----------------------------------------------------------------------
*
- * SocketsEnabled --
+ * Tcl_GetHostName --
*
- * Check that the WinSock was successfully initialized.
+ * Returns the name of the local host.
*
* Results:
- * 1 if it is.
+ * A string containing the network name for this machine, or an empty
+ * string if we can't figure out the name. The caller must not modify or
+ * free this string.
*
* Side effects:
- * None.
+ * Caches the name to return for future calls.
*
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
-static int
-SocketsEnabled(void)
+const char *
+Tcl_GetHostName(void)
{
- int enabled;
- Tcl_MutexLock(&socketMutex);
- enabled = (initialized == 1);
- Tcl_MutexUnlock(&socketMutex);
- return enabled;
+ return Tcl_GetString(TclGetProcessGlobalValue(&hostName));
}
-
/*
*----------------------------------------------------------------------
*
- * SocketExitHandler --
+ * TclpHasSockets --
*
- * Callback invoked during exit clean up to delete the socket
- * communication window and to release the WinSock DLL.
+ * This function determines whether sockets are available on the current
+ * system and returns an error in interp if they are not. Note that
+ * interp may be NULL.
*
* Results:
- * None.
+ * Returns TCL_OK if the system supports sockets, or TCL_ERROR with an
+ * error in interp (if non-NULL).
*
* Side effects:
- * None.
+ * If not already prepared, initializes the TSD structure and socket
+ * message handling thread associated to the calling thread for the
+ * subsystem of the driver.
*
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
-static void
-SocketExitHandler(
- ClientData clientData) /* Not used. */
+int
+TclpHasSockets(
+ Tcl_Interp *interp) /* Where to write an error message if sockets
+ * are not present, or NULL if no such message
+ * is to be written. */
{
Tcl_MutexLock(&socketMutex);
- /*
- * Make sure the socket event handling window is cleaned-up for, at
- * most, this thread.
- */
-
- TclpFinalizeSockets();
- UnregisterClass("TclSocket", TclWinGetTclInstance());
- initialized = 0;
+ InitSockets();
Tcl_MutexUnlock(&socketMutex);
+
+ if (SocketsEnabled()) {
+ return TCL_OK;
+ }
+ if (interp != NULL) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "sockets are not available on this system", -1));
+ }
+ return TCL_ERROR;
}
/*
@@ -426,346 +469,490 @@ SocketExitHandler(
void
TclpFinalizeSockets(void)
{
- ThreadSpecificData *tsdPtr;
+ ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey);
- tsdPtr = (ThreadSpecificData *) TclThreadDataKeyGet(&dataKey);
- if (tsdPtr != NULL) {
- if (tsdPtr->socketThread != NULL) {
- if (tsdPtr->hwnd != NULL) {
- if (PostMessage(tsdPtr->hwnd, SOCKET_TERMINATE, 0, 0)) {
- /*
- * Wait for the thread to exit. This ensures that we are
- * completely cleaned up before we leave this function.
- */
- WaitForSingleObject(tsdPtr->readyEvent, INFINITE);
- }
- tsdPtr->hwnd = NULL;
- }
- CloseHandle(tsdPtr->socketThread);
- tsdPtr->socketThread = NULL;
- }
- if (tsdPtr->readyEvent != NULL) {
- CloseHandle(tsdPtr->readyEvent);
- tsdPtr->readyEvent = NULL;
- }
- if (tsdPtr->socketListLock != NULL) {
- CloseHandle(tsdPtr->socketListLock);
- tsdPtr->socketListLock = NULL;
+ /*
+ * Careful! This is a finalizer!
+ */
+
+ if (tsdPtr == NULL) {
+ return;
+ }
+
+ if (tsdPtr->socketThread != NULL) {
+ if (tsdPtr->hwnd != NULL) {
+ PostMessage(tsdPtr->hwnd, SOCKET_TERMINATE, 0, 0);
+
+ /*
+ * Wait for the thread to exit. This ensures that we are
+ * completely cleaned up before we leave this function.
+ */
+
+ WaitForSingleObject(tsdPtr->readyEvent, INFINITE);
+ tsdPtr->hwnd = NULL;
}
- Tcl_DeleteEventSource(SocketSetupProc, SocketCheckProc, NULL);
+ CloseHandle(tsdPtr->socketThread);
+ tsdPtr->socketThread = NULL;
+ }
+ if (tsdPtr->readyEvent != NULL) {
+ CloseHandle(tsdPtr->readyEvent);
+ tsdPtr->readyEvent = NULL;
+ }
+ if (tsdPtr->socketListLock != NULL) {
+ CloseHandle(tsdPtr->socketListLock);
+ tsdPtr->socketListLock = NULL;
}
+ Tcl_DeleteEventSource(SocketSetupProc, SocketCheckProc, NULL);
}
/*
*----------------------------------------------------------------------
*
- * TclpHasSockets --
+ * TcpBlockModeProc --
*
- * This function determines whether sockets are available on the current
- * system and returns an error in interp if they are not. Note that
- * interp may be NULL.
+ * This function is invoked by the generic IO level to set blocking and
+ * nonblocking mode on a TCP socket based channel.
*
* Results:
- * Returns TCL_OK if the system supports sockets, or TCL_ERROR with an
- * error in interp (if non-NULL).
+ * 0 if successful, errno when failed.
*
* Side effects:
- * If not already prepared, initializes the TSD structure and socket
- * message handling thread associated to the calling thread for the
- * subsystem of the driver.
+ * Sets the device into blocking or nonblocking mode.
*
*----------------------------------------------------------------------
*/
-int
-TclpHasSockets(
- Tcl_Interp *interp) /* Where to write an error message if sockets
- * are not present, or NULL if no such message
- * is to be written. */
+ /* ARGSUSED */
+static int
+TcpBlockModeProc(
+ ClientData instanceData, /* Socket state. */
+ int mode) /* The mode to set. Can be one of
+ * TCL_MODE_BLOCKING or
+ * TCL_MODE_NONBLOCKING. */
{
- Tcl_MutexLock(&socketMutex);
- InitSockets();
- Tcl_MutexUnlock(&socketMutex);
+ TcpState *statePtr = instanceData;
- if (SocketsEnabled()) {
- return TCL_OK;
- }
- if (interp != NULL) {
- Tcl_AppendResult(interp, "sockets are not available on this system",
- NULL);
+ if (mode == TCL_MODE_NONBLOCKING) {
+ statePtr->flags |= TCP_NONBLOCKING;
+ } else {
+ statePtr->flags &= ~(TCP_NONBLOCKING);
}
- return TCL_ERROR;
+ return 0;
}
/*
*----------------------------------------------------------------------
*
- * SocketSetupProc --
+ * WaitForConnect --
*
- * This function is invoked before Tcl_DoOneEvent blocks waiting for an
- * event.
+ * Check the state of an async connect process. If a connection
+ * attempt terminated, process it, which may finalize it or may
+ * start the next attempt. If a connect error occures, it is saved
+ * in statePtr->connectError to be reported by 'fconfigure -error'.
+ *
+ * There are two modes of operation, defined by errorCodePtr:
+ * * non-NULL: Called by explicite read/write command. block if
+ * socket is blocking.
+ * May return two error codes:
+ * * EWOULDBLOCK: if connect is still in progress
+ * * ENOTCONN: if connect failed. This would be the error
+ * message of a rect or sendto syscall so this is
+ * emulated here.
+ * * Null: Called by a backround operation. Do not block and
+ * don't return any error code.
*
* Results:
- * None.
+ * 0 if the connection has completed, -1 if still in progress
+ * or there is an error.
*
* Side effects:
- * Adjusts the block time if needed.
+ * Processes socket events off the system queue.
+ * May process asynchroneous connect.
*
*----------------------------------------------------------------------
*/
-void
-SocketSetupProc(
- ClientData data, /* Not used. */
- int flags) /* Event flags as passed to Tcl_DoOneEvent. */
+static int
+WaitForConnect(
+ TcpState *statePtr, /* State of the socket. */
+ int *errorCodePtr) /* Where to store errors?
+ * A passed null-pointer activates background mode.
+ */
{
- SocketInfo *infoPtr;
- Tcl_Time blockTime = { 0, 0 };
- ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+ int result;
+ int oldMode;
+ ThreadSpecificData *tsdPtr;
- if (!(flags & TCL_FILE_EVENTS)) {
- return;
+ /*
+ * Check if an async connect failed already and error reporting is demanded,
+ * return the error ENOTCONN
+ */
+
+ if (errorCodePtr != NULL && (statePtr->flags & TCP_ASYNC_FAILED)) {
+ *errorCodePtr = ENOTCONN;
+ return -1;
}
/*
- * Check to see if there is a ready socket. If so, poll.
+ * Check if an async connect is running. If not return ok
*/
- WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
- for (infoPtr = tsdPtr->socketList; infoPtr != NULL;
- infoPtr = infoPtr->nextPtr) {
- if (infoPtr->readyEvents & infoPtr->watchEvents) {
- Tcl_SetMaxBlockTime(&blockTime);
- break;
- }
+ if (!(statePtr->flags & TCP_ASYNC_CONNECT)) {
+ return 0;
}
- SetEvent(tsdPtr->socketListLock);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * SocketCheckProc --
- *
- * This function is called by Tcl_DoOneEvent to check the socket event
- * source for events.
- *
- * Results:
- * None.
- *
- * Side effects:
- * May queue an event.
- *
- *----------------------------------------------------------------------
- */
-static void
-SocketCheckProc(
- ClientData data, /* Not used. */
- int flags) /* Event flags as passed to Tcl_DoOneEvent. */
-{
- SocketInfo *infoPtr;
- SocketEvent *evPtr;
- ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+ /*
+ * Be sure to disable event servicing so we are truly modal.
+ */
- if (!(flags & TCL_FILE_EVENTS)) {
- return;
- }
+ oldMode = Tcl_SetServiceMode(TCL_SERVICE_NONE);
/*
- * Queue events for any ready sockets that don't already have events
- * queued (caused by persistent states that won't generate WinSock
- * events).
+ * Loop in the blocking case until the connect signal is present
*/
- WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
- for (infoPtr = tsdPtr->socketList; infoPtr != NULL;
- infoPtr = infoPtr->nextPtr) {
- if ((infoPtr->readyEvents & infoPtr->watchEvents)
- && !(infoPtr->flags & SOCKET_PENDING)) {
- infoPtr->flags |= SOCKET_PENDING;
- evPtr = (SocketEvent *) ckalloc(sizeof(SocketEvent));
- evPtr->header.proc = SocketEventProc;
- evPtr->socket = infoPtr->socket;
- Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL);
+ while (1) {
+
+ /* get statePtr lock */
+ tsdPtr = TclThreadDataKeyGet(&dataKey);
+ WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
+
+ /* Check for connect event */
+ if (statePtr->readyEvents & FD_CONNECT) {
+
+ /* Consume the connect event */
+ statePtr->readyEvents &= ~(FD_CONNECT);
+
+ /*
+ * For blocking sockets and foreground processing
+ * disable async connect as we continue now synchoneously
+ */
+ if ( errorCodePtr != NULL &&
+ ! (statePtr->flags & TCP_NONBLOCKING) ) {
+ CLEAR_BITS(statePtr->flags, TCP_ASYNC_CONNECT);
+ }
+
+ /* Free list lock */
+ SetEvent(tsdPtr->socketListLock);
+
+ /*
+ * Continue connect.
+ * If switched to synchroneous connect, the connect is terminated.
+ */
+ result = TcpConnect(NULL, statePtr);
+
+ /* Restore event service mode */
+ (void) Tcl_SetServiceMode(oldMode);
+
+ /*
+ * Check for Succesfull connect or async connect restart
+ */
+
+ if (result == TCL_OK) {
+ /*
+ * Check for async connect restart
+ * (not possible for foreground blocking operation)
+ */
+ if ( statePtr->flags & TCP_ASYNC_PENDING ) {
+ if (errorCodePtr != NULL) {
+ *errorCodePtr = EWOULDBLOCK;
+ }
+ return -1;
+ }
+ return 0;
+ }
+
+ /*
+ * Connect finally failed.
+ * For foreground operation return ENOTCONN.
+ */
+
+ if (errorCodePtr != NULL) {
+ *errorCodePtr = ENOTCONN;
+ }
+ return -1;
+ }
+
+ /* Free list lock */
+ SetEvent(tsdPtr->socketListLock);
+
+ /*
+ * Background operation returns with no action as there was no connect
+ * event
+ */
+
+ if ( errorCodePtr == NULL ) {
+ return -1;
}
+
+ /*
+ * A non blocking socket waiting for an asyncronous connect
+ * returns directly the error EWOULDBLOCK
+ */
+
+ if (statePtr->flags & TCP_NONBLOCKING) {
+ *errorCodePtr = EWOULDBLOCK;
+ return -1;
+ }
+
+ /*
+ * Wait until something happens.
+ */
+
+ WaitForSingleObject(tsdPtr->readyEvent, INFINITE);
}
- SetEvent(tsdPtr->socketListLock);
}
/*
*----------------------------------------------------------------------
*
- * SocketEventProc --
+ * TcpInputProc --
*
- * This function is called by Tcl_ServiceEvent when a socket event
- * reaches the front of the event queue. This function is responsible for
- * notifying the generic channel code.
+ * This function is invoked by the generic IO level to read input from a
+ * TCP socket based channel.
*
* Results:
- * Returns 1 if the event was handled, meaning it should be removed from
- * the queue. Returns 0 if the event was not handled, meaning it should
- * stay on the queue. The only time the event isn't handled is if the
- * TCL_FILE_EVENTS flag bit isn't set.
+ * The number of bytes read is returned or -1 on error. An output
+ * argument contains the POSIX error code on error, or zero if no error
+ * occurred.
*
* Side effects:
- * Whatever the channel callback functions do.
+ * Reads input from the input device of the channel.
*
*----------------------------------------------------------------------
*/
+ /* ARGSUSED */
static int
-SocketEventProc(
- Tcl_Event *evPtr, /* Event to service. */
- int flags) /* Flags that indicate what events to handle,
- * such as TCL_FILE_EVENTS. */
+TcpInputProc(
+ ClientData instanceData, /* Socket state. */
+ char *buf, /* Where to store data read. */
+ int bufSize, /* How much space is available in the
+ * buffer? */
+ int *errorCodePtr) /* Where to store error code. */
{
- SocketInfo *infoPtr;
- SocketEvent *eventPtr = (SocketEvent *) evPtr;
- int mask = 0;
- int events;
- ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+ TcpState *statePtr = instanceData;
+ int bytesRead;
+ DWORD error;
+ ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey);
- if (!(flags & TCL_FILE_EVENTS)) {
- return 0;
- }
+ *errorCodePtr = 0;
/*
- * Find the specified socket on the socket list.
+ * Check that WinSock is initialized; do not call it if not, to prevent
+ * system crashes. This can happen at exit time if the exit handler for
+ * WinSock ran before other exit handlers that want to use sockets.
*/
- WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
- for (infoPtr = tsdPtr->socketList; infoPtr != NULL;
- infoPtr = infoPtr->nextPtr) {
- if (infoPtr->socket == eventPtr->socket) {
- break;
- }
+ if (!SocketsEnabled()) {
+ *errorCodePtr = EFAULT;
+ return -1;
}
- SetEvent(tsdPtr->socketListLock);
/*
- * Discard events that have gone stale.
+ * First check to see if EOF was already detected, to prevent calling the
+ * socket stack after the first time EOF is detected.
*/
- if (!infoPtr) {
- return 1;
+ if (statePtr->flags & SOCKET_EOF) {
+ return 0;
}
- infoPtr->flags &= ~SOCKET_PENDING;
-
/*
- * Handle connection requests directly.
+ * Check if there is an async connect running.
+ * For blocking sockets terminate connect, otherwise do one step.
+ * For a non blocking socket return EWOULDBLOCK if connect not terminated
*/
- if (infoPtr->readyEvents & FD_ACCEPT) {
- TcpAccept(infoPtr);
- return 1;
+ if (WaitForConnect(statePtr, errorCodePtr) != 0) {
+ return -1;
}
/*
- * Mask off unwanted events and compute the read/write mask so we can
- * notify the channel.
+ * No EOF, and it is connected, so try to read more from the socket. Note
+ * that we clear the FD_READ bit because read events are level triggered
+ * so a new event will be generated if there is still data available to be
+ * read. We have to simulate blocking behavior here since we are always
+ * using non-blocking sockets.
*/
- events = infoPtr->readyEvents & infoPtr->watchEvents;
+ while (1) {
+ SendMessage(tsdPtr->hwnd, SOCKET_SELECT,
+ (WPARAM) UNSELECT, (LPARAM) statePtr);
+ /* single fd operation: this proc is only called for a connected socket. */
+ bytesRead = recv(statePtr->sockets->fd, buf, bufSize, 0);
+ statePtr->readyEvents &= ~(FD_READ);
- if (events & FD_CLOSE) {
/*
- * If the socket was closed and the channel is still interested in
- * read events, then we need to ensure that we keep polling for this
- * event until someone does something with the channel. Note that we
- * do this before calling Tcl_NotifyChannel so we don't have to watch
- * out for the channel being deleted out from under us. This may cause
- * a redundant trip through the event loop, but it's simpler than
- * trying to do unwind protection.
+ * Check for end-of-file condition or successful read.
*/
- Tcl_Time blockTime = { 0, 0 };
- Tcl_SetMaxBlockTime(&blockTime);
- mask |= TCL_READABLE|TCL_WRITABLE;
- } else if (events & FD_READ) {
+ if (bytesRead == 0) {
+ statePtr->flags |= SOCKET_EOF;
+ }
+ if (bytesRead != SOCKET_ERROR) {
+ break;
+ }
+
/*
- * Throw the readable event if an async connect failed.
+ * If an error occurs after the FD_CLOSE has arrived, then ignore the
+ * error and report an EOF.
*/
- if (infoPtr->lastError) {
+ if (statePtr->readyEvents & FD_CLOSE) {
+ statePtr->flags |= SOCKET_EOF;
+ bytesRead = 0;
+ break;
+ }
- mask |= TCL_READABLE;
-
- } else {
- fd_set readFds;
- struct timeval timeout;
+ error = WSAGetLastError();
- /*
- * We must check to see if data is really available, since someone
- * could have consumed the data in the meantime. Turn off async
- * notification so select will work correctly. If the socket is still
- * readable, notify the channel driver, otherwise reset the async
- * select handler and keep waiting.
- */
+ /*
+ * If an RST comes, then ignore the error and report an EOF just like
+ * on unix.
+ */
- SendMessage(tsdPtr->hwnd, SOCKET_SELECT,
- (WPARAM) UNSELECT, (LPARAM) infoPtr);
+ if (error == WSAECONNRESET) {
+ statePtr->flags |= SOCKET_EOF;
+ bytesRead = 0;
+ break;
+ }
- FD_ZERO(&readFds);
- FD_SET(infoPtr->socket, &readFds);
- timeout.tv_usec = 0;
- timeout.tv_sec = 0;
+ /*
+ * Check for error condition or underflow in non-blocking case.
+ */
- if (select(0, &readFds, NULL, NULL, &timeout) != 0) {
- mask |= TCL_READABLE;
- } else {
- infoPtr->readyEvents &= ~(FD_READ);
- SendMessage(tsdPtr->hwnd, SOCKET_SELECT,
- (WPARAM) SELECT, (LPARAM) infoPtr);
- }
+ if ((statePtr->flags & TCP_NONBLOCKING) || (error != WSAEWOULDBLOCK)) {
+ TclWinConvertError(error);
+ *errorCodePtr = Tcl_GetErrno();
+ bytesRead = -1;
+ break;
}
- }
- /*
- * writable event
- */
+ /*
+ * In the blocking case, wait until the file becomes readable or
+ * closed and try again.
+ */
- if (events & FD_WRITE) {
- mask |= TCL_WRITABLE;
+ if (!WaitForSocketEvent(statePtr, FD_READ|FD_CLOSE, errorCodePtr)) {
+ bytesRead = -1;
+ break;
+ }
}
- if (mask) {
- Tcl_NotifyChannel(infoPtr->channel, mask);
- }
- return 1;
+ SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM)SELECT, (LPARAM)statePtr);
+
+ return bytesRead;
}
/*
*----------------------------------------------------------------------
*
- * TcpBlockProc --
+ * TcpOutputProc --
*
- * Sets a socket into blocking or non-blocking mode.
+ * This function is called by the generic IO level to write data to a
+ * socket based channel.
*
* Results:
- * 0 if successful, errno if there was an error.
+ * The number of bytes written or -1 on failure.
*
* Side effects:
- * None.
+ * Produces output on the socket.
*
*----------------------------------------------------------------------
*/
static int
-TcpBlockProc(
- ClientData instanceData, /* The socket to block/un-block. */
- int mode) /* TCL_MODE_BLOCKING or
- * TCL_MODE_NONBLOCKING. */
+TcpOutputProc(
+ ClientData instanceData, /* Socket state. */
+ const char *buf, /* The data buffer. */
+ int toWrite, /* How many bytes to write? */
+ int *errorCodePtr) /* Where to store error code. */
{
- SocketInfo *infoPtr = (SocketInfo *) instanceData;
+ TcpState *statePtr = instanceData;
+ int written;
+ DWORD error;
+ ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey);
- if (mode == TCL_MODE_NONBLOCKING) {
- infoPtr->flags |= SOCKET_ASYNC;
- } else {
- infoPtr->flags &= ~(SOCKET_ASYNC);
+ *errorCodePtr = 0;
+
+ /*
+ * Check that WinSock is initialized; do not call it if not, to prevent
+ * system crashes. This can happen at exit time if the exit handler for
+ * WinSock ran before other exit handlers that want to use sockets.
+ */
+
+ if (!SocketsEnabled()) {
+ *errorCodePtr = EFAULT;
+ return -1;
}
- return 0;
+
+ /*
+ * Check if there is an async connect running.
+ * For blocking sockets terminate connect, otherwise do one step.
+ * For a non blocking socket return EWOULDBLOCK if connect not terminated
+ */
+
+ if (WaitForConnect(statePtr, errorCodePtr) != 0) {
+ return -1;
+ }
+
+ while (1) {
+ SendMessage(tsdPtr->hwnd, SOCKET_SELECT,
+ (WPARAM) UNSELECT, (LPARAM) statePtr);
+
+ /* single fd operation: this proc is only called for a connected socket. */
+ written = send(statePtr->sockets->fd, buf, toWrite, 0);
+ if (written != SOCKET_ERROR) {
+ /*
+ * Since Windows won't generate a new write event until we hit an
+ * overflow condition, we need to force the event loop to poll
+ * until the condition changes.
+ */
+
+ if (statePtr->watchEvents & FD_WRITE) {
+ Tcl_Time blockTime = { 0, 0 };
+ Tcl_SetMaxBlockTime(&blockTime);
+ }
+ break;
+ }
+
+ /*
+ * Check for error condition or overflow. In the event of overflow, we
+ * need to clear the FD_WRITE flag so we can detect the next writable
+ * event. Note that Windows only sends a new writable event after a
+ * send fails with WSAEWOULDBLOCK.
+ */
+
+ error = WSAGetLastError();
+ if (error == WSAEWOULDBLOCK) {
+ statePtr->readyEvents &= ~(FD_WRITE);
+ if (statePtr->flags & TCP_NONBLOCKING) {
+ *errorCodePtr = EWOULDBLOCK;
+ written = -1;
+ break;
+ }
+ } else {
+ TclWinConvertError(error);
+ *errorCodePtr = Tcl_GetErrno();
+ written = -1;
+ break;
+ }
+
+ /*
+ * In the blocking case, wait until the file becomes writable or
+ * closed and try again.
+ */
+
+ if (!WaitForSocketEvent(statePtr, FD_WRITE|FD_CLOSE, errorCodePtr)) {
+ written = -1;
+ break;
+ }
+ }
+
+ SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM)SELECT, (LPARAM)statePtr);
+
+ return written;
}
/*
@@ -792,7 +979,7 @@ TcpCloseProc(
ClientData instanceData, /* The socket to close. */
Tcl_Interp *interp) /* Unused. */
{
- SocketInfo *infoPtr = (SocketInfo *) instanceData;
+ TcpState *statePtr = instanceData;
/* TIP #218 */
int errorCode = 0;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
@@ -810,24 +997,37 @@ TcpCloseProc(
* background.
*/
- if (closesocket(infoPtr->socket) == SOCKET_ERROR) {
- TclWinConvertWSAError((DWORD) WSAGetLastError());
- errorCode = Tcl_GetErrno();
+ while ( statePtr->sockets != NULL ) {
+ TcpFdList *thisfd = statePtr->sockets;
+ statePtr->sockets = thisfd->next;
+
+ if (closesocket(thisfd->fd) == SOCKET_ERROR) {
+ TclWinConvertError((DWORD) WSAGetLastError());
+ errorCode = Tcl_GetErrno();
+ }
+ ckfree(thisfd);
}
}
+ if (statePtr->addrlist != NULL) {
+ freeaddrinfo(statePtr->addrlist);
+ }
+ if (statePtr->myaddrlist != NULL) {
+ freeaddrinfo(statePtr->myaddrlist);
+ }
+
/*
* Clear an eventual tsd info list pointer.
* This may be called, if an async socket connect fails or is closed
* between connect and thread action callback.
*/
- if (tsdPtr->pendingSocketInfo != NULL
- && tsdPtr->pendingSocketInfo == infoPtr) {
+ if (tsdPtr->pendingTcpState != NULL
+ && tsdPtr->pendingTcpState == statePtr) {
/* get infoPtr lock, because this concerns the notifier thread */
WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
- tsdPtr->pendingSocketInfo = NULL;
+ tsdPtr->pendingTcpState = NULL;
/* Free list lock */
SetEvent(tsdPtr->socketListLock);
@@ -840,92 +1040,93 @@ TcpCloseProc(
* fear of damaging the list.
*/
- ckfree((char *) infoPtr);
+ ckfree(statePtr);
return errorCode;
}
/*
*----------------------------------------------------------------------
*
- * NewSocketInfo --
+ * TcpClose2Proc --
*
- * This function allocates and initializes a new SocketInfo structure.
+ * This function is called by the generic IO level to perform the channel
+ * type specific part of a half-close: namely, a shutdown() on a socket.
*
* Results:
- * Returns a newly allocated SocketInfo.
+ * 0 if successful, the value of errno if failed.
*
* Side effects:
- * None, except for allocation of memory.
+ * Shuts down one side of the socket.
*
*----------------------------------------------------------------------
*/
-static SocketInfo *
-NewSocketInfo(
- SOCKET socket)
+static int
+TcpClose2Proc(
+ ClientData instanceData, /* The socket to close. */
+ Tcl_Interp *interp, /* For error reporting. */
+ int flags) /* Flags that indicate which side to close. */
{
- SocketInfo *infoPtr;
- /* ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); */
-
- infoPtr = (SocketInfo *) ckalloc((unsigned) sizeof(SocketInfo));
- infoPtr->channel = 0;
- infoPtr->socket = socket;
- infoPtr->flags = 0;
- infoPtr->watchEvents = 0;
- infoPtr->readyEvents = 0;
- infoPtr->selectEvents = 0;
- infoPtr->acceptEventCount = 0;
- infoPtr->acceptProc = NULL;
- infoPtr->acceptProcData = NULL;
- infoPtr->lastError = 0;
+ TcpState *statePtr = instanceData;
+ int errorCode = 0;
+ int sd;
/*
- * TIP #218. Removed the code inserting the new structure into the global
- * list. This is now handled in the thread action callbacks, and only
- * there.
+ * Shutdown the OS socket handle.
*/
- infoPtr->nextPtr = NULL;
+ switch(flags) {
+ case TCL_CLOSE_READ:
+ sd = SD_RECEIVE;
+ break;
+ case TCL_CLOSE_WRITE:
+ sd = SD_SEND;
+ break;
+ default:
+ if (interp) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "socket close2proc called bidirectionally", -1));
+ }
+ return TCL_ERROR;
+ }
+
+ /* single fd operation: Tcl_OpenTcpServer() does not set TCL_READABLE or
+ * TCL_WRITABLE so this should never be called for a server socket. */
+ if (shutdown(statePtr->sockets->fd, sd) == SOCKET_ERROR) {
+ TclWinConvertError((DWORD) WSAGetLastError());
+ errorCode = Tcl_GetErrno();
+ }
- return infoPtr;
+ return errorCode;
}
/*
*----------------------------------------------------------------------
*
- * CreateSocket --
+ * TcpSetOptionProc --
*
- * This function opens a new socket and initializes the SocketInfo
- * structure.
+ * Sets Tcp channel specific options.
*
* Results:
- * Returns a new SocketInfo, or NULL with an error in interp.
+ * None, unless an error happens.
*
* Side effects:
- * None, except for allocation of memory.
+ * Changes attributes of the socket at the system level.
*
*----------------------------------------------------------------------
*/
-static SocketInfo *
-CreateSocket(
- Tcl_Interp *interp, /* For error reporting; can be NULL. */
- int port, /* Port number to open. */
- const char *host, /* Name of host on which to open port. */
- int server, /* 1 if socket should be a server socket, else
- * 0 for a client socket. */
- const char *myaddr, /* Optional client-side address */
- int myport, /* Optional client-side port */
- int async) /* If nonzero, connect client socket
- * asynchronously. */
+static int
+TcpSetOptionProc(
+ ClientData instanceData, /* Socket state. */
+ Tcl_Interp *interp, /* For error reporting - can be NULL. */
+ const char *optionName, /* Name of the option to set. */
+ const char *value) /* New value for option. */
{
- u_long flag = 1; /* Indicates nonblocking mode. */
- SOCKADDR_IN sockaddr; /* Socket address */
- SOCKADDR_IN mysockaddr; /* Socket address for client */
- SOCKET sock = INVALID_SOCKET;
- SocketInfo *infoPtr=NULL; /* The returned value. */
- ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
- TclThreadDataKeyGet(&dataKey);
+#ifdef TCL_FEATURE_KEEPALIVE_NAGLE
+ TcpState *statePtr = instanceData;
+ SOCKET sock;
+#endif /*TCL_FEATURE_KEEPALIVE_NAGLE*/
/*
* Check that WinSock is initialized; do not call it if not, to prevent
@@ -934,345 +1135,748 @@ CreateSocket(
*/
if (!SocketsEnabled()) {
- return NULL;
+ if (interp) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "winsock is not initialized", -1));
+ }
+ return TCL_ERROR;
}
- if (!CreateSocketAddress(&sockaddr, host, port)) {
- goto error;
- }
- if ((myaddr != NULL || myport != 0) &&
- !CreateSocketAddress(&mysockaddr, myaddr, myport)) {
- goto error;
- }
+#ifdef TCL_FEATURE_KEEPALIVE_NAGLE
+ #error "TCL_FEATURE_KEEPALIVE_NAGLE not reviewed for whether to treat statePtr->sockets as single fd or list"
+ sock = statePtr->sockets->fd;
- sock = socket(AF_INET, SOCK_STREAM, 0);
- if (sock == INVALID_SOCKET) {
- goto error;
+ if (!strcasecmp(optionName, "-keepalive")) {
+ BOOL val = FALSE;
+ int boolVar, rtn;
+
+ if (Tcl_GetBoolean(interp, value, &boolVar) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (boolVar) {
+ val = TRUE;
+ }
+ rtn = setsockopt(sock, SOL_SOCKET, SO_KEEPALIVE,
+ (const char *) &val, sizeof(BOOL));
+ if (rtn != 0) {
+ TclWinConvertError(WSAGetLastError());
+ if (interp) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't set socket option: %s",
+ Tcl_PosixError(interp)));
+ }
+ return TCL_ERROR;
+ }
+ return TCL_OK;
+ } else if (!strcasecmp(optionName, "-nagle")) {
+ BOOL val = FALSE;
+ int boolVar, rtn;
+
+ if (Tcl_GetBoolean(interp, value, &boolVar) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (!boolVar) {
+ val = TRUE;
+ }
+ rtn = setsockopt(sock, IPPROTO_TCP, TCP_NODELAY,
+ (const char *) &val, sizeof(BOOL));
+ if (rtn != 0) {
+ TclWinConvertError(WSAGetLastError());
+ if (interp) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't set socket option: %s",
+ Tcl_PosixError(interp)));
+ }
+ return TCL_ERROR;
+ }
+ return TCL_OK;
}
+ return Tcl_BadChannelOption(interp, optionName, "keepalive nagle");
+#else
+ return Tcl_BadChannelOption(interp, optionName, "");
+#endif /*TCL_FEATURE_KEEPALIVE_NAGLE*/
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TcpGetOptionProc --
+ *
+ * Computes an option value for a TCP socket based channel, or a list of
+ * all options and their values.
+ *
+ * Note: This code is based on code contributed by John Haxby.
+ *
+ * Results:
+ * A standard Tcl result. The value of the specified option or a list of
+ * all options and their values is returned in the supplied DString. Sets
+ * Error message if needed.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TcpGetOptionProc(
+ ClientData instanceData, /* Socket state. */
+ Tcl_Interp *interp, /* For error reporting - can be NULL. */
+ const char *optionName, /* Name of the option to retrieve the value
+ * for, or NULL to get all options and their
+ * values. */
+ Tcl_DString *dsPtr) /* Where to store the computed value;
+ * initialized by caller. */
+{
+ TcpState *statePtr = instanceData;
+ char host[NI_MAXHOST], port[NI_MAXSERV];
+ SOCKET sock;
+ size_t len = 0;
+ int reverseDNS = 0;
+#define SUPPRESS_RDNS_VAR "::tcl::unsupported::noReverseDNS"
+
/*
- * Win-NT has a misfeature that sockets are inherited in child processes
- * by default. Turn off the inherit bit.
+ * Check that WinSock is initialized; do not call it if not, to prevent
+ * system crashes. This can happen at exit time if the exit handler for
+ * WinSock ran before other exit handlers that want to use sockets.
*/
- SetHandleInformation((HANDLE) sock, HANDLE_FLAG_INHERIT, 0);
+ if (!SocketsEnabled()) {
+ if (interp) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "winsock is not initialized", -1));
+ }
+ return TCL_ERROR;
+ }
/*
- * Set kernel space buffering
+ * Go one step in async connect
+ * If any error is thrown save it as backround error to report eventually below
*/
+ WaitForConnect(statePtr, NULL);
- TclSockMinimumBuffers((void *)sock, TCP_BUFFER_SIZE);
-
- if (server) {
- /*
- * Bind to the specified port. Note that we must not call setsockopt
- * with SO_REUSEADDR because Microsoft allows addresses to be reused
- * even if they are still in use.
- *
- * Bind should not be affected by the socket having already been set
- * into nonblocking mode. If there is trouble, this is one place to
- * look for bugs.
- */
+ sock = statePtr->sockets->fd;
+ if (optionName != NULL) {
+ len = strlen(optionName);
+ }
- if (bind(sock, (SOCKADDR *) &sockaddr, sizeof(SOCKADDR_IN))
- == SOCKET_ERROR) {
- goto error;
- }
+ if ((len > 1) && (optionName[1] == 'e') &&
+ (strncmp(optionName, "-error", len) == 0)) {
/*
- * Set the maximum number of pending connect requests to the max value
- * allowed on each platform (Win32 and Win32s may be different, and
- * there may be differences between TCP/IP stacks).
- */
+ * Do not return any errors if async connect is running
+ */
+ if ( ! (statePtr->flags & TCP_ASYNC_PENDING) ) {
- if (listen(sock, SOMAXCONN) == SOCKET_ERROR) {
- goto error;
- }
- /*
- * Add this socket to the global list of sockets.
- */
+ if ( statePtr->flags & TCP_ASYNC_FAILED ) {
- infoPtr = NewSocketInfo(sock);
+ /*
+ * In case of a failed async connect, eventually report the
+ * connect error only once.
+ * Do not report the system error, as this comes again and again.
+ */
- /*
- * Set up the select mask for connection request events.
- */
+ if ( statePtr->connectError != 0 ) {
+ Tcl_DStringAppend(dsPtr,
+ Tcl_ErrnoMsg(statePtr->connectError), -1);
+ statePtr->connectError = 0;
+ }
- infoPtr->selectEvents = FD_ACCEPT;
- infoPtr->watchEvents |= FD_ACCEPT;
+ } else {
- /*
- * Register for interest in events in the select mask. Note that this
- * automatically places the socket into non-blocking mode.
- */
-
- ioctlsocket(sock, (long) FIONBIO, &flag);
- SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT,
- (LPARAM) infoPtr);
+ /*
+ * Report an eventual last error of the socket system
+ */
- } else {
- /*
- * Try to bind to a local port, if specified.
- */
+ int optlen;
+ int ret;
+ DWORD err;
- if (myaddr != NULL || myport != 0) {
- if (bind(sock, (SOCKADDR *) &mysockaddr, sizeof(SOCKADDR_IN))
- == SOCKET_ERROR) {
- goto error;
+ /*
+ * Populater the err Variable with a possix error
+ */
+ optlen = sizeof(int);
+ ret = getsockopt(sock, SOL_SOCKET, SO_ERROR,
+ (char *)&err, &optlen);
+ /*
+ * The error was not returned directly but should be
+ * taken from WSA
+ */
+ if (ret == SOCKET_ERROR) {
+ err = WSAGetLastError();
+ }
+ /*
+ * Return error message
+ */
+ if (err) {
+ TclWinConvertError(err);
+ Tcl_DStringAppend(dsPtr, Tcl_ErrnoMsg(Tcl_GetErrno()), -1);
+ }
}
}
+ return TCL_OK;
+ }
- /*
- * Allocate socket info structure
- */
-
- infoPtr = NewSocketInfo(sock);
-
- /*
- * Set the socket into nonblocking mode if the connect should be done
- * in the background. Activate connect notification.
- */
-
- if (async) {
+ if ((len > 1) && (optionName[1] == 'c') &&
+ (strncmp(optionName, "-connecting", len) == 0)) {
- /* get infoPtr lock */
- WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
+ Tcl_DStringAppend(dsPtr,
+ (statePtr->flags & TCP_ASYNC_PENDING)
+ ? "1" : "0", -1);
+ return TCL_OK;
+ }
- /*
- * Buffer new infoPtr in the tsd memory as long as it is not in
- * the info list. This allows the event procedure to process the
- * event.
- * Bugfig for 336441ed59 to not ignore notifications until the
- * infoPtr is in the list..
- */
+ if (interp != NULL && Tcl_GetVar(interp, SUPPRESS_RDNS_VAR, 0) != NULL) {
+ reverseDNS = NI_NUMERICHOST;
+ }
- tsdPtr->pendingSocketInfo = infoPtr;
+ if ((len == 0) || ((len > 1) && (optionName[1] == 'p') &&
+ (strncmp(optionName, "-peername", len) == 0))) {
+ address peername;
+ socklen_t size = sizeof(peername);
+ if ( (statePtr->flags & TCP_ASYNC_PENDING) ) {
/*
- * Set connect mask to connect events
- * This is activated by a SOCKET_SELECT message to the notifier
- * thread.
+ * In async connect output an empty string
*/
-
- infoPtr->selectEvents |= FD_CONNECT | FD_READ | FD_WRITE | FD_CLOSE;
- infoPtr->flags |= SOCKET_ASYNC_CONNECT;
-
+ if (len == 0) {
+ Tcl_DStringAppendElement(dsPtr, "-peername");
+ Tcl_DStringAppendElement(dsPtr, "");
+ } else {
+ return TCL_OK;
+ }
+ } else if ( getpeername(sock, (LPSOCKADDR) &(peername.sa), &size) == 0) {
/*
- * Free list lock
+ * Peername fetch succeeded - output list
*/
- SetEvent(tsdPtr->socketListLock);
+ if (len == 0) {
+ Tcl_DStringAppendElement(dsPtr, "-peername");
+ Tcl_DStringStartSublist(dsPtr);
+ }
+ getnameinfo(&(peername.sa), size, host, sizeof(host),
+ NULL, 0, NI_NUMERICHOST);
+ Tcl_DStringAppendElement(dsPtr, host);
+ getnameinfo(&(peername.sa), size, host, sizeof(host),
+ port, sizeof(port), reverseDNS | NI_NUMERICSERV);
+ Tcl_DStringAppendElement(dsPtr, host);
+ Tcl_DStringAppendElement(dsPtr, port);
+ if (len == 0) {
+ Tcl_DStringEndSublist(dsPtr);
+ } else {
+ return TCL_OK;
+ }
+ } else {
/*
- * Activate accept notification and put in async mode
- * Bug 336441ed59: activate notification before connect
- * so we do not miss a notification of a fialed connect.
+ * getpeername failed - but if we were asked for all the options
+ * (len==0), don't flag an error at that point because it could be
+ * an fconfigure request on a server socket (such sockets have no
+ * peer). {Copied from unix/tclUnixChan.c}
*/
- ioctlsocket(sock, (long) FIONBIO, &flag);
- SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT,
- (LPARAM) infoPtr);
+ if (len) {
+ TclWinConvertError((DWORD) WSAGetLastError());
+ if (interp) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "can't get peername: %s",
+ Tcl_PosixError(interp)));
+ }
+ return TCL_ERROR;
+ }
}
+ }
- /*
- * Attempt to connect to the remote socket.
- */
-
- if (connect(sock, (SOCKADDR *) &sockaddr,
- sizeof(SOCKADDR_IN)) == SOCKET_ERROR) {
- TclWinConvertWSAError((DWORD) WSAGetLastError());
- if (Tcl_GetErrno() != EWOULDBLOCK) {
- goto error;
- }
+ if ((len == 0) || ((len > 1) && (optionName[1] == 's') &&
+ (strncmp(optionName, "-sockname", len) == 0))) {
+ TcpFdList *fds;
+ address sockname;
+ socklen_t size;
+ int found = 0;
+ if (len == 0) {
+ Tcl_DStringAppendElement(dsPtr, "-sockname");
+ Tcl_DStringStartSublist(dsPtr);
+ }
+ if ( (statePtr->flags & TCP_ASYNC_PENDING ) ) {
/*
- * The connection is progressing in the background.
+ * In async connect output an empty string
*/
-
+ found = 1;
} else {
+ for (fds = statePtr->sockets; fds != NULL; fds = fds->next) {
+ sock = fds->fd;
+ size = sizeof(sockname);
+ if (getsockname(sock, &(sockname.sa), &size) >= 0) {
+ int flags = reverseDNS;
- /*
- * Set up the select mask for read/write events. If the connect
- * attempt has not completed, include connect events.
- */
+ found = 1;
+ getnameinfo(&sockname.sa, size, host, sizeof(host),
+ NULL, 0, NI_NUMERICHOST);
+ Tcl_DStringAppendElement(dsPtr, host);
- infoPtr->selectEvents = FD_READ | FD_WRITE | FD_CLOSE;
+ /*
+ * We don't want to resolve INADDR_ANY and sin6addr_any; they
+ * can sometimes cause problems (and never have a name).
+ */
+ flags |= NI_NUMERICSERV;
+ if (sockname.sa.sa_family == AF_INET) {
+ if (sockname.sa4.sin_addr.s_addr == INADDR_ANY) {
+ flags |= NI_NUMERICHOST;
+ }
+ } else if (sockname.sa.sa_family == AF_INET6) {
+ if ((IN6_ARE_ADDR_EQUAL(&sockname.sa6.sin6_addr,
+ &in6addr_any)) ||
+ (IN6_IS_ADDR_V4MAPPED(&sockname.sa6.sin6_addr)
+ && sockname.sa6.sin6_addr.s6_addr[12] == 0
+ && sockname.sa6.sin6_addr.s6_addr[13] == 0
+ && sockname.sa6.sin6_addr.s6_addr[14] == 0
+ && sockname.sa6.sin6_addr.s6_addr[15] == 0)) {
+ flags |= NI_NUMERICHOST;
+ }
+ }
+ getnameinfo(&sockname.sa, size, host, sizeof(host),
+ port, sizeof(port), flags);
+ Tcl_DStringAppendElement(dsPtr, host);
+ Tcl_DStringAppendElement(dsPtr, port);
+ }
+ }
+ }
+ if (found) {
+ if (len) {
+ return TCL_OK;
+ }
+ Tcl_DStringEndSublist(dsPtr);
+ } else {
+ if (interp) {
+ TclWinConvertError((DWORD) WSAGetLastError());
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "can't get sockname: %s", Tcl_PosixError(interp)));
+ }
+ return TCL_ERROR;
+ }
+ }
- /*
- * Register for interest in events in the select mask. Note that this
- * automatically places the socket into non-blocking mode.
- */
+#ifdef TCL_FEATURE_KEEPALIVE_NAGLE
+ if (len == 0 || !strncmp(optionName, "-keepalive", len)) {
+ int optlen;
+ BOOL opt = FALSE;
- ioctlsocket(sock, (long) FIONBIO, &flag);
- SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT,
- (LPARAM) infoPtr);
+ if (len == 0) {
+ Tcl_DStringAppendElement(dsPtr, "-keepalive");
+ }
+ optlen = sizeof(BOOL);
+ getsockopt(sock, SOL_SOCKET, SO_KEEPALIVE, (char *)&opt, &optlen);
+ if (opt) {
+ Tcl_DStringAppendElement(dsPtr, "1");
+ } else {
+ Tcl_DStringAppendElement(dsPtr, "0");
+ }
+ if (len > 0) {
+ return TCL_OK;
}
}
- return infoPtr;
+ if (len == 0 || !strncmp(optionName, "-nagle", len)) {
+ int optlen;
+ BOOL opt = FALSE;
- error:
- TclWinConvertWSAError((DWORD) WSAGetLastError());
- if (interp != NULL) {
- Tcl_AppendResult(interp, "couldn't open socket: ",
- Tcl_PosixError(interp), NULL);
+ if (len == 0) {
+ Tcl_DStringAppendElement(dsPtr, "-nagle");
+ }
+ optlen = sizeof(BOOL);
+ getsockopt(sock, IPPROTO_TCP, TCP_NODELAY, (char *)&opt, &optlen);
+ if (opt) {
+ Tcl_DStringAppendElement(dsPtr, "0");
+ } else {
+ Tcl_DStringAppendElement(dsPtr, "1");
+ }
+ if (len > 0) {
+ return TCL_OK;
+ }
}
- if (infoPtr != NULL) {
- /*
- * Free the allocated socket info structure and close the socket
- */
- TcpCloseProc(infoPtr, interp);
- } else if (sock != INVALID_SOCKET) {
- /*
- * No socket structure jet - just close
- */
- closesocket(sock);
+#endif /*TCL_FEATURE_KEEPALIVE_NAGLE*/
+
+ if (len > 0) {
+#ifdef TCL_FEATURE_KEEPALIVE_NAGLE
+ return Tcl_BadChannelOption(interp, optionName,
+ "connecting peername sockname keepalive nagle");
+#else
+ return Tcl_BadChannelOption(interp, optionName, "connecting peername sockname");
+#endif /*TCL_FEATURE_KEEPALIVE_NAGLE*/
}
- return NULL;
+
+ return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
- * CreateSocketAddress --
+ * TcpWatchProc --
*
- * This function initializes a sockaddr structure for a host and port.
+ * Informs the channel driver of the events that the generic channel code
+ * wishes to receive on this socket.
*
* Results:
- * 1 if the host was valid, 0 if the host could not be converted to an IP
- * address.
+ * None.
*
* Side effects:
- * Fills in the *sockaddrPtr structure.
+ * May cause the notifier to poll if any of the specified conditions are
+ * already true.
*
*----------------------------------------------------------------------
*/
-static int
-CreateSocketAddress(
- LPSOCKADDR_IN sockaddrPtr, /* Socket address */
- const char *host, /* Host. NULL implies INADDR_ANY */
- int port) /* Port number */
+static void
+TcpWatchProc(
+ ClientData instanceData, /* The socket state. */
+ int mask) /* Events of interest; an OR-ed combination of
+ * TCL_READABLE, TCL_WRITABLE and
+ * TCL_EXCEPTION. */
{
- struct hostent *hostent; /* Host database entry */
- struct in_addr addr; /* For 64/32 bit madness */
+ TcpState *statePtr = instanceData;
/*
- * Check that WinSock is initialized; do not call it if not, to prevent
- * system crashes. This can happen at exit time if the exit handler for
- * WinSock ran before other exit handlers that want to use sockets.
+ * Update the watch events mask. Only if the socket is not a server
+ * socket. [Bug 557878]
*/
- if (!SocketsEnabled()) {
- Tcl_SetErrno(EFAULT);
- return 0;
- }
+ if (!statePtr->acceptProc) {
+ statePtr->watchEvents = 0;
+ if (mask & TCL_READABLE) {
+ statePtr->watchEvents |= (FD_READ|FD_CLOSE);
+ }
+ if (mask & TCL_WRITABLE) {
+ statePtr->watchEvents |= (FD_WRITE|FD_CLOSE);
+ }
- ZeroMemory(sockaddrPtr, sizeof(SOCKADDR_IN));
- sockaddrPtr->sin_family = AF_INET;
- sockaddrPtr->sin_port = htons((unsigned short) (port & 0xFFFF));
- if (host == NULL) {
- addr.s_addr = INADDR_ANY;
- } else {
- addr.s_addr = inet_addr(host);
- if (addr.s_addr == INADDR_NONE) {
- hostent = gethostbyname(host);
- if (hostent != NULL) {
- memcpy(&addr, hostent->h_addr, (size_t) hostent->h_length);
- } else {
-#ifdef EHOSTUNREACH
- Tcl_SetErrno(EHOSTUNREACH);
-#else
-#ifdef ENXIO
- Tcl_SetErrno(ENXIO);
-#endif
-#endif
- return 0; /* Error. */
- }
+ /*
+ * If there are any conditions already set, then tell the notifier to
+ * poll rather than block.
+ */
+
+ if (statePtr->readyEvents & statePtr->watchEvents) {
+ Tcl_Time blockTime = { 0, 0 };
+
+ Tcl_SetMaxBlockTime(&blockTime);
}
}
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TcpGetHandleProc --
+ *
+ * Called from Tcl_GetChannelHandle to retrieve OS handles from inside a
+ * TCP socket based channel.
+ *
+ * Results:
+ * Returns TCL_OK with the fd in handlePtr, or TCL_ERROR if there is no
+ * handle for the specified direction.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
- /*
- * NOTE: On 64 bit machines the assignment below is rumored to not do the
- * right thing. Please report errors related to this if you observe
- * incorrect behavior on 64 bit machines such as DEC Alphas. Should we
- * modify this code to do an explicit memcpy?
- */
+ /* ARGSUSED */
+static int
+TcpGetHandleProc(
+ ClientData instanceData, /* The socket state. */
+ int direction, /* Not used. */
+ ClientData *handlePtr) /* Where to store the handle. */
+{
+ TcpState *statePtr = instanceData;
- sockaddrPtr->sin_addr.s_addr = addr.s_addr;
- return 1; /* Success. */
+ *handlePtr = INT2PTR(statePtr->sockets->fd);
+ return TCL_OK;
}
+
+
/*
*----------------------------------------------------------------------
*
- * WaitForSocketEvent --
+ * TcpConnect --
*
- * Waits until one of the specified events occurs on a socket.
+ * This function opens a new socket in client mode.
+ *
+ * This might be called in 3 circumstances:
+ * - By a regular socket command
+ * - By the event handler to continue an asynchroneous connect
+ * - By a blocking socket function (gets/puts) to terminate the
+ * connect synchroneously
*
* Results:
- * Returns 1 on success or 0 on failure, with an error code in
- * errorCodePtr.
+ * TCL_OK, if the socket was successfully connected or an asynchronous
+ * connection is in progress. If an error occurs, TCL_ERROR is returned
+ * and an error message is left in interp.
*
* Side effects:
- * Processes socket events off the system queue.
+ * Opens a socket.
+ *
+ * Remarks:
+ * A single host name may resolve to more than one IP address, e.g. for
+ * an IPv4/IPv6 dual stack host. For handling asyncronously connecting
+ * sockets in the background for such hosts, this function can act as a
+ * coroutine. On the first call, it sets up the control variables for the
+ * two nested loops over the local and remote addresses. Once the first
+ * connection attempt is in progress, it sets up itself as a writable
+ * event handler for that socket, and returns. When the callback occurs,
+ * control is transferred to the "reenter" label, right after the initial
+ * return and the loops resume as if they had never been interrupted.
+ * For syncronously connecting sockets, the loops work the usual way.
*
*----------------------------------------------------------------------
*/
static int
-WaitForSocketEvent(
- SocketInfo *infoPtr, /* Information about this socket. */
- int events, /* Events to look for. */
- int *errorCodePtr) /* Where to store errors? */
+TcpConnect(
+ Tcl_Interp *interp, /* For error reporting; can be NULL. */
+ TcpState *statePtr)
{
- int result = 1;
- int oldMode;
- ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
- TclThreadDataKeyGet(&dataKey);
-
+ DWORD error;
/*
- * Be sure to disable event servicing so we are truly modal.
+ * We are started with async connect and the connect notification
+ * was not jet received
*/
+ int async_connect = statePtr->flags & TCP_ASYNC_CONNECT;
+ /* We were called by the event procedure and continue our loop */
+ int async_callback = statePtr->flags & TCP_ASYNC_PENDING;
+ ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey);
- oldMode = Tcl_SetServiceMode(TCL_SERVICE_NONE);
+ if (async_callback) {
+ goto reenter;
+ }
+
+ for (statePtr->addr = statePtr->addrlist; statePtr->addr != NULL;
+ statePtr->addr = statePtr->addr->ai_next) {
+
+ for (statePtr->myaddr = statePtr->myaddrlist; statePtr->myaddr != NULL;
+ statePtr->myaddr = statePtr->myaddr->ai_next) {
+
+ /*
+ * No need to try combinations of local and remote addresses
+ * of different families.
+ */
+
+ if (statePtr->myaddr->ai_family != statePtr->addr->ai_family) {
+ continue;
+ }
+
+ /*
+ * Close the socket if it is still open from the last unsuccessful
+ * iteration.
+ */
+ if (statePtr->sockets->fd != INVALID_SOCKET) {
+ closesocket(statePtr->sockets->fd);
+ }
+
+ /* get statePtr lock */
+ WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
+
+ /*
+ * Reset last error from last try
+ */
+ statePtr->notifierConnectError = 0;
+ Tcl_SetErrno(0);
+
+ statePtr->sockets->fd = socket(statePtr->myaddr->ai_family, SOCK_STREAM, 0);
+
+ /* Free list lock */
+ SetEvent(tsdPtr->socketListLock);
+
+ /* continue on socket creation error */
+ if (statePtr->sockets->fd == INVALID_SOCKET) {
+ TclWinConvertError((DWORD) WSAGetLastError());
+ continue;
+ }
+
+ /*
+ * Win-NT has a misfeature that sockets are inherited in child
+ * processes by default. Turn off the inherit bit.
+ */
+
+ SetHandleInformation((HANDLE) statePtr->sockets->fd, HANDLE_FLAG_INHERIT, 0);
+
+ /*
+ * Set kernel space buffering
+ */
+
+ TclSockMinimumBuffers((void *) statePtr->sockets->fd, TCP_BUFFER_SIZE);
+
+ /*
+ * Try to bind to a local port.
+ */
+
+ if (bind(statePtr->sockets->fd, statePtr->myaddr->ai_addr,
+ statePtr->myaddr->ai_addrlen) == SOCKET_ERROR) {
+ TclWinConvertError((DWORD) WSAGetLastError());
+ continue;
+ }
+ /*
+ * For asyncroneous connect set the socket in nonblocking mode
+ * and activate connect notification
+ */
+ if (async_connect) {
+ TcpState *statePtr2;
+ int in_socket_list = 0;
+ /* get statePtr lock */
+ WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
+
+ /*
+ * Bugfig for 336441ed59 to not ignore notifications until the
+ * infoPtr is in the list.
+ * Check if my statePtr is already in the tsdPtr->socketList
+ * It is set after this call by TcpThreadActionProc and is set
+ * on a second round.
+ *
+ * If not, we buffer my statePtr in the tsd memory so it is not
+ * lost by the event procedure
+ */
+
+ for (statePtr2 = tsdPtr->socketList; statePtr2 != NULL;
+ statePtr2 = statePtr2->nextPtr) {
+ if (statePtr2 == statePtr) {
+ in_socket_list = 1;
+ break;
+ }
+ }
+ if (!in_socket_list) {
+ tsdPtr->pendingTcpState = statePtr;
+ }
+ /*
+ * Set connect mask to connect events
+ * This is activated by a SOCKET_SELECT message to the notifier
+ * thread.
+ */
+ statePtr->selectEvents |= FD_CONNECT;
+
+ /*
+ * Free list lock
+ */
+ SetEvent(tsdPtr->socketListLock);
+
+ /* activate accept notification */
+ SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT,
+ (LPARAM) statePtr);
+ }
+
+ /*
+ * Attempt to connect to the remote socket.
+ */
+
+ connect(statePtr->sockets->fd, statePtr->addr->ai_addr,
+ statePtr->addr->ai_addrlen);
+
+ error = WSAGetLastError();
+ TclWinConvertError(error);
+
+ if (async_connect && error == WSAEWOULDBLOCK) {
+ /*
+ * Asynchroneous connect
+ */
+
+ /*
+ * Remember that we jump back behind this next round
+ */
+ statePtr->flags |= TCP_ASYNC_PENDING;
+ return TCL_OK;
+
+ reenter:
+ /*
+ * Re-entry point for async connect after connect event or
+ * blocking operation
+ *
+ * Clear the reenter flag
+ */
+ statePtr->flags &= ~(TCP_ASYNC_PENDING);
+ /* get statePtr lock */
+ WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
+ /* Get signaled connect error */
+ TclWinConvertError((DWORD) statePtr->notifierConnectError);
+ /* Clear eventual connect flag */
+ statePtr->selectEvents &= ~(FD_CONNECT);
+ /* Free list lock */
+ SetEvent(tsdPtr->socketListLock);
+ }
+
+ /*
+ * Clear the tsd socket list pointer if we did not wait for
+ * the FD_CONNECT asyncroneously
+ */
+ tsdPtr->pendingTcpState = NULL;
+ if (Tcl_GetErrno() == 0) {
+ goto out;
+ }
+ }
+ }
+
+out:
/*
- * Reset WSAAsyncSelect so we have a fresh set of events pending.
- * Don't do that if we are waiting for a connect as we may miss
- * a connect (bug 336441ed59).
+ * Socket connected or connection failed
*/
- if ( 0 == (events & FD_CONNECT) ) {
- SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) UNSELECT,
- (LPARAM) infoPtr);
-
- SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT,
- (LPARAM) infoPtr);
- }
+ /*
+ * Async connect terminated
+ */
- while (1) {
- if (infoPtr->lastError) {
- *errorCodePtr = infoPtr->lastError;
- result = 0;
- break;
- } else if (infoPtr->readyEvents & events) {
- break;
- } else if (infoPtr->flags & SOCKET_ASYNC) {
- *errorCodePtr = EWOULDBLOCK;
- result = 0;
- break;
- }
+ CLEAR_BITS(statePtr->flags, TCP_ASYNC_CONNECT);
+ if ( Tcl_GetErrno() == 0 ) {
/*
- * Wait until something happens.
+ * Succesfully connected
+ */
+ /*
+ * Set up the select mask for read/write events.
*/
+ statePtr->selectEvents = FD_READ | FD_WRITE | FD_CLOSE;
- WaitForSingleObject(tsdPtr->readyEvent, INFINITE);
- }
+ /*
+ * Register for interest in events in the select mask. Note that this
+ * automatically places the socket into non-blocking mode.
+ */
- (void) Tcl_SetServiceMode(oldMode);
- return result;
+ SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT,
+ (LPARAM) statePtr);
+ } else {
+ /*
+ * Connect failed
+ */
+
+ /*
+ * For async connect schedule a writable event to report the fail.
+ */
+ if (async_callback) {
+ /*
+ * Set up the select mask for read/write events.
+ */
+ statePtr->selectEvents = FD_WRITE|FD_READ;
+ /* get statePtr lock */
+ WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
+ /* Signal ready readable and writable events */
+ statePtr->readyEvents |= FD_WRITE | FD_READ;
+ /* Flag error to event routine */
+ statePtr->flags |= TCP_ASYNC_FAILED;
+ /* Save connect error to be reported by 'fconfigure -error' */
+ statePtr->connectError = Tcl_GetErrno();
+ /* Free list lock */
+ SetEvent(tsdPtr->socketListLock);
+ }
+ /*
+ * Error message on syncroneous connect
+ */
+ if (interp != NULL) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't open socket: %s", Tcl_PosixError(interp)));
+ }
+ return TCL_ERROR;
+ }
+ return TCL_OK;
}
/*
@@ -1299,40 +1903,75 @@ Tcl_OpenTcpClient(
const char *host, /* Host on which to open port. */
const char *myaddr, /* Client-side address */
int myport, /* Client-side port */
- int async) /* If nonzero, should connect client socket
- * asynchronously. */
+ int async) /* If nonzero, attempt to do an asynchronous
+ * connect. Otherwise we do a blocking
+ * connect. */
{
- SocketInfo *infoPtr;
- char channelName[16 + TCL_INTEGER_SPACE];
+ TcpState *statePtr;
+ const char *errorMsg = NULL;
+ struct addrinfo *addrlist = NULL, *myaddrlist = NULL;
+ char channelName[SOCK_CHAN_LENGTH];
if (TclpHasSockets(interp) != TCL_OK) {
return NULL;
}
/*
- * Create a new client socket and wrap it in a channel.
+ * Check that WinSock is initialized; do not call it if not, to prevent
+ * system crashes. This can happen at exit time if the exit handler for
+ * WinSock ran before other exit handlers that want to use sockets.
*/
- infoPtr = CreateSocket(interp, port, host, 0, myaddr, myport, async);
- if (infoPtr == NULL) {
+ if (!SocketsEnabled()) {
return NULL;
}
- sprintf(channelName, "sock%" TCL_I_MODIFIER "u", (size_t)infoPtr->socket);
+ /*
+ * Do the name lookups for the local and remote addresses.
+ */
- infoPtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
- (ClientData) infoPtr, (TCL_READABLE | TCL_WRITABLE));
- if (Tcl_SetChannelOption(interp, infoPtr->channel, "-translation",
- "auto crlf") == TCL_ERROR) {
- Tcl_Close((Tcl_Interp *) NULL, infoPtr->channel);
- return (Tcl_Channel) NULL;
+ if (!TclCreateSocketAddress(interp, &addrlist, host, port, 0, &errorMsg)
+ || !TclCreateSocketAddress(interp, &myaddrlist, myaddr, myport, 1,
+ &errorMsg)) {
+ if (addrlist != NULL) {
+ freeaddrinfo(addrlist);
+ }
+ if (interp != NULL) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't open socket: %s", errorMsg));
+ }
+ return NULL;
}
- if (Tcl_SetChannelOption(NULL, infoPtr->channel, "-eofchar", "")
- == TCL_ERROR) {
- Tcl_Close((Tcl_Interp *) NULL, infoPtr->channel);
- return (Tcl_Channel) NULL;
+
+ statePtr = NewSocketInfo(INVALID_SOCKET);
+ statePtr->addrlist = addrlist;
+ statePtr->myaddrlist = myaddrlist;
+ if (async) {
+ statePtr->flags |= TCP_ASYNC_CONNECT;
+ }
+
+ /*
+ * Create a new client socket and wrap it in a channel.
+ */
+ if (TcpConnect(interp, statePtr) != TCL_OK) {
+ TcpCloseProc(statePtr, NULL);
+ return NULL;
+ }
+
+ sprintf(channelName, SOCK_TEMPLATE, statePtr);
+
+ statePtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
+ statePtr, (TCL_READABLE | TCL_WRITABLE));
+ if (TCL_ERROR == Tcl_SetChannelOption(NULL, statePtr->channel,
+ "-translation", "auto crlf")) {
+ Tcl_Close(NULL, statePtr->channel);
+ return NULL;
+ } else if (TCL_ERROR == Tcl_SetChannelOption(NULL, statePtr->channel,
+ "-eofchar", "")) {
+ Tcl_Close(NULL, statePtr->channel);
+ return NULL;
}
- return infoPtr->channel;
+ return statePtr->channel;
}
/*
@@ -1348,8 +1987,6 @@ Tcl_OpenTcpClient(
* Side effects:
* None.
*
- * NOTE: Code contributed by Mark Diekhans (markd@grizzly.com)
- *
*----------------------------------------------------------------------
*/
@@ -1357,15 +1994,15 @@ Tcl_Channel
Tcl_MakeTcpClientChannel(
ClientData sock) /* The socket to wrap up into a channel. */
{
- SocketInfo *infoPtr;
- char channelName[16 + TCL_INTEGER_SPACE];
+ TcpState *statePtr;
+ char channelName[SOCK_CHAN_LENGTH];
ThreadSpecificData *tsdPtr;
if (TclpHasSockets(NULL) != TCL_OK) {
return NULL;
}
- tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
+ tsdPtr = TclThreadDataKeyGet(&dataKey);
/*
* Set kernel space buffering and non-blocking.
@@ -1373,21 +2010,20 @@ Tcl_MakeTcpClientChannel(
TclSockMinimumBuffers(sock, TCP_BUFFER_SIZE);
- infoPtr = NewSocketInfo((SOCKET) sock);
+ statePtr = NewSocketInfo((SOCKET) sock);
/*
* Start watching for read/write events on the socket.
*/
- infoPtr->selectEvents = FD_READ | FD_CLOSE | FD_WRITE;
- SendMessage(tsdPtr->hwnd, SOCKET_SELECT,
- (WPARAM) SELECT, (LPARAM) infoPtr);
+ statePtr->selectEvents = FD_READ | FD_CLOSE | FD_WRITE;
+ SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM)SELECT, (LPARAM)statePtr);
- sprintf(channelName, "sock%" TCL_I_MODIFIER "u", (size_t)infoPtr->socket);
- infoPtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
- (ClientData) infoPtr, (TCL_READABLE | TCL_WRITABLE));
- Tcl_SetChannelOption(NULL, infoPtr->channel, "-translation", "auto crlf");
- return infoPtr->channel;
+ sprintf(channelName, SOCK_TEMPLATE, statePtr);
+ statePtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
+ statePtr, (TCL_READABLE | TCL_WRITABLE));
+ Tcl_SetChannelOption(NULL, statePtr->channel, "-translation", "auto crlf");
+ return statePtr->channel;
}
/*
@@ -1398,8 +2034,8 @@ Tcl_MakeTcpClientChannel(
* Opens a TCP server socket and creates a channel around it.
*
* Results:
- * The channel or NULL if failed. An error message is returned in the
- * interpreter on failure.
+ * The channel or NULL if failed. If an error occurred, an error message
+ * is left in the interp's result if interp is not NULL.
*
* Side effects:
* Opens a server socket and creates a new channel.
@@ -1411,115 +2047,205 @@ Tcl_Channel
Tcl_OpenTcpServer(
Tcl_Interp *interp, /* For error reporting - may be NULL. */
int port, /* Port number to open. */
- const char *host, /* Name of local host. */
+ const char *myHost, /* Name of local host. */
Tcl_TcpAcceptProc *acceptProc,
/* Callback for accepting connections from new
* clients. */
ClientData acceptProcData) /* Data for the callback. */
{
- SocketInfo *infoPtr;
- char channelName[16 + TCL_INTEGER_SPACE];
+ SOCKET sock = INVALID_SOCKET;
+ unsigned short chosenport = 0;
+ struct addrinfo *addrlist = NULL;
+ struct addrinfo *addrPtr; /* Socket address to listen on. */
+ TcpState *statePtr = NULL; /* The returned value. */
+ char channelName[SOCK_CHAN_LENGTH];
+ u_long flag = 1; /* Indicates nonblocking mode. */
+ const char *errorMsg = NULL;
if (TclpHasSockets(interp) != TCL_OK) {
return NULL;
}
/*
- * Create a new client socket and wrap it in a channel.
+ * Check that WinSock is initialized; do not call it if not, to prevent
+ * system crashes. This can happen at exit time if the exit handler for
+ * WinSock ran before other exit handlers that want to use sockets.
*/
- infoPtr = CreateSocket(interp, port, host, 1, NULL, 0, 0);
- if (infoPtr == NULL) {
+ if (!SocketsEnabled()) {
return NULL;
}
- infoPtr->acceptProc = acceptProc;
- infoPtr->acceptProcData = acceptProcData;
+ /*
+ * Construct the addresses for each end of the socket.
+ */
+
+ if (!TclCreateSocketAddress(interp, &addrlist, myHost, port, 1, &errorMsg)) {
+ goto error;
+ }
+
+ for (addrPtr = addrlist; addrPtr != NULL; addrPtr = addrPtr->ai_next) {
+ sock = socket(addrPtr->ai_family, addrPtr->ai_socktype,
+ addrPtr->ai_protocol);
+ if (sock == INVALID_SOCKET) {
+ TclWinConvertError((DWORD) WSAGetLastError());
+ continue;
+ }
+
+ /*
+ * Win-NT has a misfeature that sockets are inherited in child
+ * processes by default. Turn off the inherit bit.
+ */
+
+ SetHandleInformation((HANDLE) sock, HANDLE_FLAG_INHERIT, 0);
+
+ /*
+ * Set kernel space buffering
+ */
+
+ TclSockMinimumBuffers((void *)sock, TCP_BUFFER_SIZE);
+
+ /*
+ * Make sure we use the same port when opening two server sockets
+ * for IPv4 and IPv6.
+ *
+ * As sockaddr_in6 uses the same offset and size for the port
+ * member as sockaddr_in, we can handle both through the IPv4 API.
+ */
+
+ if (port == 0 && chosenport != 0) {
+ ((struct sockaddr_in *) addrPtr->ai_addr)->sin_port =
+ htons(chosenport);
+ }
+
+ /*
+ * Bind to the specified port. Note that we must not call
+ * setsockopt with SO_REUSEADDR because Microsoft allows addresses
+ * to be reused even if they are still in use.
+ *
+ * Bind should not be affected by the socket having already been
+ * set into nonblocking mode. If there is trouble, this is one
+ * place to look for bugs.
+ */
+
+ if (bind(sock, addrPtr->ai_addr, addrPtr->ai_addrlen)
+ == SOCKET_ERROR) {
+ TclWinConvertError((DWORD) WSAGetLastError());
+ closesocket(sock);
+ continue;
+ }
+ if (port == 0 && chosenport == 0) {
+ address sockname;
+ socklen_t namelen = sizeof(sockname);
+
+ /*
+ * Synchronize port numbers when binding to port 0 of multiple
+ * addresses.
+ */
+
+ if (getsockname(sock, &sockname.sa, &namelen) >= 0) {
+ chosenport = ntohs(sockname.sa4.sin_port);
+ }
+ }
+
+ /*
+ * Set the maximum number of pending connect requests to the max
+ * value allowed on each platform (Win32 and Win32s may be
+ * different, and there may be differences between TCP/IP stacks).
+ */
+
+ if (listen(sock, SOMAXCONN) == SOCKET_ERROR) {
+ TclWinConvertError((DWORD) WSAGetLastError());
+ closesocket(sock);
+ continue;
+ }
+
+ if (statePtr == NULL) {
+ /*
+ * Add this socket to the global list of sockets.
+ */
+ statePtr = NewSocketInfo(sock);
+ } else {
+ AddSocketInfoFd( statePtr, sock );
+ }
+ }
+
+error:
+ if (addrlist != NULL) {
+ freeaddrinfo(addrlist);
+ }
+
+ if (statePtr != NULL) {
+ ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey);
+
+ statePtr->acceptProc = acceptProc;
+ statePtr->acceptProcData = acceptProcData;
+ sprintf(channelName, SOCK_TEMPLATE, statePtr);
+ statePtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
+ statePtr, 0);
+ /*
+ * Set up the select mask for connection request events.
+ */
- sprintf(channelName, "sock%" TCL_I_MODIFIER "u", (size_t)infoPtr->socket);
+ statePtr->selectEvents = FD_ACCEPT;
- infoPtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
- (ClientData) infoPtr, 0);
- if (Tcl_SetChannelOption(interp, infoPtr->channel, "-eofchar", "")
+ /*
+ * Register for interest in events in the select mask. Note that this
+ * automatically places the socket into non-blocking mode.
+ */
+
+ ioctlsocket(sock, (long) FIONBIO, &flag);
+ SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT,
+ (LPARAM) statePtr);
+ if (Tcl_SetChannelOption(interp, statePtr->channel, "-eofchar", "")
== TCL_ERROR) {
- Tcl_Close((Tcl_Interp *) NULL, infoPtr->channel);
- return (Tcl_Channel) NULL;
+ Tcl_Close(NULL, statePtr->channel);
+ return NULL;
+ }
+ return statePtr->channel;
+ }
+
+ if (interp != NULL) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't open socket: %s",
+ (errorMsg ? errorMsg : Tcl_PosixError(interp))));
}
- return infoPtr->channel;
+ if (sock != INVALID_SOCKET) {
+ closesocket(sock);
+ }
+ return NULL;
}
/*
*----------------------------------------------------------------------
*
* TcpAccept --
- *
- * Accept a TCP socket connection. This is called by SocketEventProc and
- * it in turns calls the registered accept function.
+ * Accept a TCP socket connection. This is called by the event loop.
*
* Results:
* None.
*
* Side effects:
- * Invokes the accept proc which may invoke arbitrary Tcl code.
+ * Creates a new connection socket. Calls the registered callback for the
+ * connection acceptance mechanism.
*
*----------------------------------------------------------------------
*/
+ /* ARGSUSED */
static void
TcpAccept(
- SocketInfo *infoPtr) /* Socket to accept. */
+ TcpFdList *fds, /* Server socket that accepted newSocket. */
+ SOCKET newSocket, /* Newly accepted socket. */
+ address addr) /* Address of new socket. */
{
- SOCKET newSocket;
- SocketInfo *newInfoPtr;
- SOCKADDR_IN addr;
- int len;
- char channelName[16 + TCL_INTEGER_SPACE];
- ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
- TclThreadDataKeyGet(&dataKey);
-
- /*
- * Accept the incoming connection request.
- */
-
- len = sizeof(SOCKADDR_IN);
-
- newSocket = accept(infoPtr->socket, (SOCKADDR *)&addr,
- &len);
-
- /*
- * Protect access to sockets (acceptEventCount, readyEvents) in socketList
- * by the lock. Fix for SF Tcl Bug 3056775.
- */
- WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
-
- /*
- * Clear the ready mask so we can detect the next connection request. Note
- * that connection requests are level triggered, so if there is a request
- * already pending, a new event will be generated.
- */
-
- if (newSocket == INVALID_SOCKET) {
- infoPtr->acceptEventCount = 0;
- infoPtr->readyEvents &= ~(FD_ACCEPT);
-
- SetEvent(tsdPtr->socketListLock);
- return;
- }
-
- /*
- * It is possible that more than one FD_ACCEPT has been sent, so an extra
- * count must be kept. Decrement the count, and reset the readyEvent bit
- * if the count is no longer > 0.
- */
-
- infoPtr->acceptEventCount--;
-
- if (infoPtr->acceptEventCount <= 0) {
- infoPtr->readyEvents &= ~(FD_ACCEPT);
- }
-
- SetEvent(tsdPtr->socketListLock);
+ TcpState *newInfoPtr;
+ TcpState *statePtr = fds->statePtr;
+ int len = sizeof(addr);
+ char channelName[SOCK_CHAN_LENGTH];
+ char host[NI_MAXHOST], port[NI_MAXSERV];
+ ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey);
/*
* Win-NT has a misfeature that sockets are inherited in child processes
@@ -1529,7 +2255,7 @@ TcpAccept(
SetHandleInformation((HANDLE) newSocket, HANDLE_FLAG_INHERIT, 0);
/*
- * Allocate socket info structure
+ * Add this socket to the global list of sockets.
*/
newInfoPtr = NewSocketInfo(newSocket);
@@ -1539,20 +2265,20 @@ TcpAccept(
*/
newInfoPtr->selectEvents = (FD_READ | FD_WRITE | FD_CLOSE);
- SendMessage(tsdPtr->hwnd, SOCKET_SELECT,
- (WPARAM) SELECT, (LPARAM) newInfoPtr);
+ SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT,
+ (LPARAM) newInfoPtr);
- sprintf(channelName, "sock%" TCL_I_MODIFIER "u", (size_t)newInfoPtr->socket);
+ sprintf(channelName, SOCK_TEMPLATE, newInfoPtr);
newInfoPtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
- (ClientData) newInfoPtr, (TCL_READABLE | TCL_WRITABLE));
+ newInfoPtr, (TCL_READABLE | TCL_WRITABLE));
if (Tcl_SetChannelOption(NULL, newInfoPtr->channel, "-translation",
"auto crlf") == TCL_ERROR) {
- Tcl_Close((Tcl_Interp *) NULL, newInfoPtr->channel);
+ Tcl_Close(NULL, newInfoPtr->channel);
return;
}
if (Tcl_SetChannelOption(NULL, newInfoPtr->channel, "-eofchar", "")
== TCL_ERROR) {
- Tcl_Close((Tcl_Interp *) NULL, newInfoPtr->channel);
+ Tcl_Close(NULL, newInfoPtr->channel);
return;
}
@@ -1560,647 +2286,683 @@ TcpAccept(
* Invoke the accept callback function.
*/
- if (infoPtr->acceptProc != NULL) {
- (infoPtr->acceptProc) (infoPtr->acceptProcData, newInfoPtr->channel,
- inet_ntoa(addr.sin_addr), ntohs(addr.sin_port));
+ if (statePtr->acceptProc != NULL) {
+ getnameinfo(&(addr.sa), len, host, sizeof(host), port, sizeof(port),
+ NI_NUMERICHOST|NI_NUMERICSERV);
+ statePtr->acceptProc(statePtr->acceptProcData, newInfoPtr->channel,
+ host, atoi(port));
}
}
/*
*----------------------------------------------------------------------
*
- * TcpInputProc --
+ * InitSockets --
*
- * This function is called by the generic IO level to read data from a
- * socket based channel.
+ * Registers the event window for the socket notifier code.
+ *
+ * Assumes socketMutex is held.
*
* Results:
- * The number of bytes read or -1 on error.
+ * None.
*
* Side effects:
- * Consumes input from the socket.
+ * Register a new window class and creates a
+ * window for use in asynchronous socket notification.
*
*----------------------------------------------------------------------
*/
-static int
-TcpInputProc(
- ClientData instanceData, /* The socket state. */
- char *buf, /* Where to store data. */
- int toRead, /* Maximum number of bytes to read. */
- int *errorCodePtr) /* Where to store error codes. */
+static void
+InitSockets(void)
{
- SocketInfo *infoPtr = (SocketInfo *) instanceData;
- int bytesRead;
- DWORD error;
- ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
- TclThreadDataKeyGet(&dataKey);
+ DWORD id;
+ ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey);
- *errorCodePtr = 0;
+ if (!initialized) {
+ initialized = 1;
+ TclCreateLateExitHandler(SocketExitHandler, NULL);
- /*
- * Check that WinSock is initialized; do not call it if not, to prevent
- * system crashes. This can happen at exit time if the exit handler for
- * WinSock ran before other exit handlers that want to use sockets.
- */
+ /*
+ * Create the async notification window with a new class. We must
+ * create a new class to avoid a Windows 95 bug that causes us to get
+ * the wrong message number for socket events if the message window is
+ * a subclass of a static control.
+ */
- if (!SocketsEnabled()) {
- *errorCodePtr = EFAULT;
- return -1;
+ windowClass.style = 0;
+ windowClass.cbClsExtra = 0;
+ windowClass.cbWndExtra = 0;
+ windowClass.hInstance = TclWinGetTclInstance();
+ windowClass.hbrBackground = NULL;
+ windowClass.lpszMenuName = NULL;
+ windowClass.lpszClassName = classname;
+ windowClass.lpfnWndProc = SocketProc;
+ windowClass.hIcon = NULL;
+ windowClass.hCursor = NULL;
+
+ if (!RegisterClass(&windowClass)) {
+ TclWinConvertError(GetLastError());
+ goto initFailure;
+ }
}
/*
- * First check to see if EOF was already detected, to prevent calling the
- * socket stack after the first time EOF is detected.
+ * Check for per-thread initialization.
*/
- if (infoPtr->flags & SOCKET_EOF) {
- return 0;
+ if (tsdPtr != NULL) {
+ return;
}
/*
- * Check to see if the socket is connected before trying to read.
+ * OK, this thread has never done anything with sockets before. Construct
+ * a worker thread to handle asynchronous events related to sockets
+ * assigned to _this_ thread.
*/
- if ((infoPtr->flags & SOCKET_ASYNC_CONNECT)
- && !WaitForSocketEvent(infoPtr, FD_CONNECT, errorCodePtr)) {
- return -1;
+ tsdPtr = TCL_TSD_INIT(&dataKey);
+ tsdPtr->pendingTcpState = NULL;
+ tsdPtr->socketList = NULL;
+ tsdPtr->hwnd = NULL;
+ tsdPtr->threadId = Tcl_GetCurrentThread();
+ tsdPtr->readyEvent = CreateEvent(NULL, FALSE, FALSE, NULL);
+ if (tsdPtr->readyEvent == NULL) {
+ goto initFailure;
+ }
+ tsdPtr->socketListLock = CreateEvent(NULL, FALSE, TRUE, NULL);
+ if (tsdPtr->socketListLock == NULL) {
+ goto initFailure;
}
+ tsdPtr->socketThread = CreateThread(NULL, 256, SocketThread, tsdPtr, 0,
+ &id);
+ if (tsdPtr->socketThread == NULL) {
+ goto initFailure;
+ }
+
+ SetThreadPriority(tsdPtr->socketThread, THREAD_PRIORITY_HIGHEST);
/*
- * No EOF, and it is connected, so try to read more from the socket. Note
- * that we clear the FD_READ bit because read events are level triggered
- * so a new event will be generated if there is still data available to be
- * read. We have to simulate blocking behavior here since we are always
- * using non-blocking sockets.
+ * Wait for the thread to signal when the window has been created and if
+ * it is ready to go.
*/
- while (1) {
- SendMessage(tsdPtr->hwnd, SOCKET_SELECT,
- (WPARAM) UNSELECT, (LPARAM) infoPtr);
- bytesRead = recv(infoPtr->socket, buf, toRead, 0);
- infoPtr->readyEvents &= ~(FD_READ);
+ WaitForSingleObject(tsdPtr->readyEvent, INFINITE);
- /*
- * Check for end-of-file condition or successful read.
- */
-
- if (bytesRead == 0) {
- infoPtr->flags |= SOCKET_EOF;
- }
- if (bytesRead != SOCKET_ERROR) {
- break;
- }
-
- /*
- * If an error occurs after the FD_CLOSE has arrived, then ignore the
- * error and report an EOF.
- */
-
- if (infoPtr->readyEvents & FD_CLOSE) {
- infoPtr->flags |= SOCKET_EOF;
- bytesRead = 0;
- break;
- }
-
- error = WSAGetLastError();
-
- /*
- * If an RST comes, then ignore the error and report an EOF just like
- * on unix.
- */
-
- if (error == WSAECONNRESET) {
- infoPtr->flags |= SOCKET_EOF;
- bytesRead = 0;
- break;
- }
-
- /*
- * Check for error condition or underflow in non-blocking case.
- */
-
- if ((infoPtr->flags & SOCKET_ASYNC) || (error != WSAEWOULDBLOCK)) {
- TclWinConvertWSAError(error);
- *errorCodePtr = Tcl_GetErrno();
- bytesRead = -1;
- break;
- }
-
- /*
- * In the blocking case, wait until the file becomes readable or
- * closed and try again.
- */
-
- if (!WaitForSocketEvent(infoPtr, FD_READ|FD_CLOSE, errorCodePtr)) {
- bytesRead = -1;
- break;
- }
+ if (tsdPtr->hwnd == NULL) {
+ goto initFailure; /* Trouble creating the window. */
}
- SendMessage(tsdPtr->hwnd, SOCKET_SELECT,
- (WPARAM) SELECT, (LPARAM) infoPtr);
+ Tcl_CreateEventSource(SocketSetupProc, SocketCheckProc, NULL);
+ return;
- return bytesRead;
+ initFailure:
+ TclpFinalizeSockets();
+ initialized = -1;
+ return;
}
/*
*----------------------------------------------------------------------
*
- * TcpOutputProc --
+ * SocketsEnabled --
*
- * This function is called by the generic IO level to write data to a
- * socket based channel.
+ * Check that the WinSock was successfully initialized.
+ *
+ * Warning:
+ * This check was useful in times of Windows98 where WinSock may
+ * not be available. This is not the case any more.
+ * This function may be removed with TCL 9.0
*
* Results:
- * The number of bytes written or -1 on failure.
+ * 1 if it is.
*
* Side effects:
- * Produces output on the socket.
+ * None.
*
*----------------------------------------------------------------------
*/
+ /* ARGSUSED */
static int
-TcpOutputProc(
- ClientData instanceData, /* The socket state. */
- const char *buf, /* Where to get data. */
- int toWrite, /* Maximum number of bytes to write. */
- int *errorCodePtr) /* Where to store error codes. */
+SocketsEnabled(void)
{
- SocketInfo *infoPtr = (SocketInfo *) instanceData;
- int bytesWritten;
- DWORD error;
- ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
- TclThreadDataKeyGet(&dataKey);
+ int enabled;
- *errorCodePtr = 0;
+ Tcl_MutexLock(&socketMutex);
+ enabled = (initialized == 1);
+ Tcl_MutexUnlock(&socketMutex);
+ return enabled;
+}
- /*
- * Check that WinSock is initialized; do not call it if not, to prevent
- * system crashes. This can happen at exit time if the exit handler for
- * WinSock ran before other exit handlers that want to use sockets.
- */
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * SocketExitHandler --
+ *
+ * Callback invoked during exit clean up to delete the socket
+ * communication window.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
- if (!SocketsEnabled()) {
- *errorCodePtr = EFAULT;
- return -1;
- }
+ /* ARGSUSED */
+static void
+SocketExitHandler(
+ ClientData clientData) /* Not used. */
+{
+ Tcl_MutexLock(&socketMutex);
/*
- * Check to see if the socket is connected before trying to write.
+ * Make sure the socket event handling window is cleaned-up for, at
+ * most, this thread.
*/
- if ((infoPtr->flags & SOCKET_ASYNC_CONNECT)
- && !WaitForSocketEvent(infoPtr, FD_CONNECT, errorCodePtr)) {
- return -1;
- }
-
- while (1) {
- SendMessage(tsdPtr->hwnd, SOCKET_SELECT,
- (WPARAM) UNSELECT, (LPARAM) infoPtr);
-
- bytesWritten = send(infoPtr->socket, buf, toWrite, 0);
- if (bytesWritten != SOCKET_ERROR) {
- /*
- * Since Windows won't generate a new write event until we hit an
- * overflow condition, we need to force the event loop to poll
- * until the condition changes.
- */
-
- if (infoPtr->watchEvents & FD_WRITE) {
- Tcl_Time blockTime = { 0, 0 };
- Tcl_SetMaxBlockTime(&blockTime);
- }
- break;
- }
-
- /*
- * Check for error condition or overflow. In the event of overflow, we
- * need to clear the FD_WRITE flag so we can detect the next writable
- * event. Note that Windows only sends a new writable event after a
- * send fails with WSAEWOULDBLOCK.
- */
+ TclpFinalizeSockets();
+ UnregisterClass(classname, TclWinGetTclInstance());
+ initialized = 0;
+ Tcl_MutexUnlock(&socketMutex);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * SocketSetupProc --
+ *
+ * This function is invoked before Tcl_DoOneEvent blocks waiting for an
+ * event.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Adjusts the block time if needed.
+ *
+ *----------------------------------------------------------------------
+ */
- error = WSAGetLastError();
- if (error == WSAEWOULDBLOCK) {
- infoPtr->readyEvents &= ~(FD_WRITE);
- if (infoPtr->flags & SOCKET_ASYNC) {
- *errorCodePtr = EWOULDBLOCK;
- bytesWritten = -1;
- break;
- }
- } else {
- TclWinConvertWSAError(error);
- *errorCodePtr = Tcl_GetErrno();
- bytesWritten = -1;
- break;
- }
+void
+SocketSetupProc(
+ ClientData data, /* Not used. */
+ int flags) /* Event flags as passed to Tcl_DoOneEvent. */
+{
+ TcpState *statePtr;
+ Tcl_Time blockTime = { 0, 0 };
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
- /*
- * In the blocking case, wait until the file becomes writable or
- * closed and try again.
- */
+ if (!(flags & TCL_FILE_EVENTS)) {
+ return;
+ }
- if (!WaitForSocketEvent(infoPtr, FD_WRITE|FD_CLOSE, errorCodePtr)) {
- bytesWritten = -1;
+ /*
+ * Check to see if there is a ready socket. If so, poll.
+ */
+ WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
+ for (statePtr = tsdPtr->socketList; statePtr != NULL;
+ statePtr = statePtr->nextPtr) {
+ if (statePtr->readyEvents &
+ (statePtr->watchEvents | FD_CONNECT | FD_ACCEPT)
+ ) {
+ Tcl_SetMaxBlockTime(&blockTime);
break;
}
}
-
- SendMessage(tsdPtr->hwnd, SOCKET_SELECT,
- (WPARAM) SELECT, (LPARAM) infoPtr);
-
- return bytesWritten;
+ SetEvent(tsdPtr->socketListLock);
}
/*
*----------------------------------------------------------------------
*
- * TcpSetOptionProc --
+ * SocketCheckProc --
*
- * Sets Tcp channel specific options.
+ * This function is called by Tcl_DoOneEvent to check the socket event
+ * source for events.
*
* Results:
- * None, unless an error happens.
+ * None.
*
* Side effects:
- * Changes attributes of the socket at the system level.
+ * May queue an event.
*
*----------------------------------------------------------------------
*/
-static int
-TcpSetOptionProc(
- ClientData instanceData, /* Socket state. */
- Tcl_Interp *interp, /* For error reporting - can be NULL. */
- const char *optionName, /* Name of the option to set. */
- const char *value) /* New value for option. */
+static void
+SocketCheckProc(
+ ClientData data, /* Not used. */
+ int flags) /* Event flags as passed to Tcl_DoOneEvent. */
{
-#ifdef TCL_FEATURE_KEEPALIVE_NAGLE
- SocketInfo *infoPtr;
- SOCKET sock;
-#endif
-
- /*
- * Check that WinSock is initialized; do not call it if not, to prevent
- * system crashes. This can happen at exit time if the exit handler for
- * WinSock ran before other exit handlers that want to use sockets.
- */
+ TcpState *statePtr;
+ SocketEvent *evPtr;
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
- if (!SocketsEnabled()) {
- if (interp) {
- Tcl_AppendResult(interp, "winsock is not initialized", NULL);
- }
- return TCL_ERROR;
+ if (!(flags & TCL_FILE_EVENTS)) {
+ return;
}
-#ifdef TCL_FEATURE_KEEPALIVE_NAGLE
- infoPtr = (SocketInfo *) instanceData;
- sock = infoPtr->socket;
-
- if (!strcasecmp(optionName, "-keepalive")) {
- BOOL val = FALSE;
- int boolVar, rtn;
-
- if (Tcl_GetBoolean(interp, value, &boolVar) != TCL_OK) {
- return TCL_ERROR;
- }
- if (boolVar) {
- val = TRUE;
- }
- rtn = setsockopt(sock, SOL_SOCKET, SO_KEEPALIVE,
- (const char *) &val, sizeof(BOOL));
- if (rtn != 0) {
- TclWinConvertWSAError(WSAGetLastError());
- if (interp) {
- Tcl_AppendResult(interp, "couldn't set socket option: ",
- Tcl_PosixError(interp), NULL);
- }
- return TCL_ERROR;
- }
- return TCL_OK;
- } else if (!strcasecmp(optionName, "-nagle")) {
- BOOL val = FALSE;
- int boolVar, rtn;
+ /*
+ * Queue events for any ready sockets that don't already have events
+ * queued (caused by persistent states that won't generate WinSock
+ * events).
+ */
- if (Tcl_GetBoolean(interp, value, &boolVar) != TCL_OK) {
- return TCL_ERROR;
- }
- if (!boolVar) {
- val = TRUE;
- }
- rtn = setsockopt(sock, IPPROTO_TCP, TCP_NODELAY,
- (const char *) &val, sizeof(BOOL));
- if (rtn != 0) {
- TclWinConvertWSAError(WSAGetLastError());
- if (interp) {
- Tcl_AppendResult(interp, "couldn't set socket option: ",
- Tcl_PosixError(interp), NULL);
- }
- return TCL_ERROR;
+ WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
+ for (statePtr = tsdPtr->socketList; statePtr != NULL;
+ statePtr = statePtr->nextPtr) {
+ if ((statePtr->readyEvents &
+ (statePtr->watchEvents | FD_CONNECT | FD_ACCEPT))
+ && !(statePtr->flags & SOCKET_PENDING)
+ ) {
+ statePtr->flags |= SOCKET_PENDING;
+ evPtr = ckalloc(sizeof(SocketEvent));
+ evPtr->header.proc = SocketEventProc;
+ evPtr->socket = statePtr->sockets->fd;
+ Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL);
}
- return TCL_OK;
}
-
- return Tcl_BadChannelOption(interp, optionName, "keepalive nagle");
-#else
- return Tcl_BadChannelOption(interp, optionName, "");
-#endif /*TCL_FEATURE_KEEPALIVE_NAGLE*/
+ SetEvent(tsdPtr->socketListLock);
}
/*
*----------------------------------------------------------------------
*
- * TcpGetOptionProc --
- *
- * Computes an option value for a TCP socket based channel, or a list of
- * all options and their values.
+ * SocketEventProc --
*
- * Note: This code is based on code contributed by John Haxby.
+ * This function is called by Tcl_ServiceEvent when a socket event
+ * reaches the front of the event queue. This function is responsible for
+ * notifying the generic channel code.
*
* Results:
- * A standard Tcl result. The value of the specified option or a list of
- * all options and their values is returned in the supplied DString.
+ * Returns 1 if the event was handled, meaning it should be removed from
+ * the queue. Returns 0 if the event was not handled, meaning it should
+ * stay on the queue. The only time the event isn't handled is if the
+ * TCL_FILE_EVENTS flag bit isn't set.
*
* Side effects:
- * None.
+ * Whatever the channel callback functions do.
*
*----------------------------------------------------------------------
*/
static int
-TcpGetOptionProc(
- ClientData instanceData, /* Socket state. */
- Tcl_Interp *interp, /* For error reporting - can be NULL */
- const char *optionName, /* Name of the option to retrieve the value
- * for, or NULL to get all options and their
- * values. */
- Tcl_DString *dsPtr) /* Where to store the computed value;
- * initialized by caller. */
+SocketEventProc(
+ Tcl_Event *evPtr, /* Event to service. */
+ int flags) /* Flags that indicate what events to handle,
+ * such as TCL_FILE_EVENTS. */
{
- SocketInfo *infoPtr;
- SOCKADDR_IN sockname;
- SOCKADDR_IN peername;
- struct hostent *hostEntPtr;
- SOCKET sock;
- int size = sizeof(SOCKADDR_IN);
- size_t len = 0;
- char buf[TCL_INTEGER_SPACE];
+ TcpState *statePtr;
+ SocketEvent *eventPtr = (SocketEvent *) evPtr;
+ int mask = 0, events;
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+ TcpFdList *fds;
+ SOCKET newSocket;
+ address addr;
+ int len;
+
+ if (!(flags & TCL_FILE_EVENTS)) {
+ return 0;
+ }
/*
- * Check that WinSock is initialized; do not call it if not, to prevent
- * system crashes. This can happen at exit time if the exit handler for
- * WinSock ran before other exit handlers that want to use sockets.
+ * Find the specified socket on the socket list.
*/
- if (!SocketsEnabled()) {
- if (interp) {
- Tcl_AppendResult(interp, "winsock is not initialized", NULL);
+ WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
+ for (statePtr = tsdPtr->socketList; statePtr != NULL;
+ statePtr = statePtr->nextPtr) {
+ if (statePtr->sockets->fd == eventPtr->socket) {
+ break;
}
- return TCL_ERROR;
}
- infoPtr = (SocketInfo *) instanceData;
- sock = (int) infoPtr->socket;
- if (optionName != NULL) {
- len = strlen(optionName);
+ /*
+ * Discard events that have gone stale.
+ */
+
+ if (!statePtr) {
+ SetEvent(tsdPtr->socketListLock);
+ return 1;
}
- if ((len > 1) && (optionName[1] == 'e') &&
- (strncmp(optionName, "-error", len) == 0)) {
- int optlen;
- DWORD err;
- int ret;
+ /*
+ * Clear flag that (this) event is pending
+ */
- optlen = sizeof(int);
- ret = TclWinGetSockOpt((int)sock, SOL_SOCKET, SO_ERROR,
- (char *)&err, &optlen);
- if (ret == SOCKET_ERROR) {
- err = WSAGetLastError();
- }
- if (err) {
- TclWinConvertWSAError(err);
- Tcl_DStringAppend(dsPtr, Tcl_ErrnoMsg(Tcl_GetErrno()), -1);
- }
- return TCL_OK;
- }
+ statePtr->flags &= ~SOCKET_PENDING;
- if ((len == 0) || ((len > 1) && (optionName[1] == 'p') &&
- (strncmp(optionName, "-peername", len) == 0))) {
- if (getpeername(sock, (LPSOCKADDR) &peername, &size) == 0) {
- if (len == 0) {
- Tcl_DStringAppendElement(dsPtr, "-peername");
- Tcl_DStringStartSublist(dsPtr);
- }
- Tcl_DStringAppendElement(dsPtr, inet_ntoa(peername.sin_addr));
+ /*
+ * Continue async connect if pending and ready
+ */
+
+ if ( statePtr->readyEvents & FD_CONNECT ) {
+ if ( statePtr->flags & TCP_ASYNC_PENDING ) {
+
+ /*
+ * Do one step and save eventual connect error
+ */
+
+ SetEvent(tsdPtr->socketListLock);
+ WaitForConnect(statePtr,NULL);
- if (peername.sin_addr.s_addr == 0) {
- hostEntPtr = NULL;
- } else {
- hostEntPtr = gethostbyaddr((char *) &(peername.sin_addr),
- sizeof(peername.sin_addr), AF_INET);
- }
- if (hostEntPtr != NULL) {
- Tcl_DStringAppendElement(dsPtr, hostEntPtr->h_name);
- } else {
- Tcl_DStringAppendElement(dsPtr, inet_ntoa(peername.sin_addr));
- }
- TclFormatInt(buf, ntohs(peername.sin_port));
- Tcl_DStringAppendElement(dsPtr, buf);
- if (len == 0) {
- Tcl_DStringEndSublist(dsPtr);
- } else {
- return TCL_OK;
- }
} else {
+
/*
- * getpeername failed - but if we were asked for all the options
- * (len==0), don't flag an error at that point because it could be
- * an fconfigure request on a server socket (such sockets have no
- * peer). {Copied from unix/tclUnixChan.c}
+ * No async connect reenter pending. Just clear event.
*/
- if (len) {
- TclWinConvertWSAError((DWORD) WSAGetLastError());
- if (interp) {
- Tcl_AppendResult(interp, "can't get peername: ",
- Tcl_PosixError(interp), NULL);
- }
- return TCL_ERROR;
- }
+ statePtr->readyEvents &= ~(FD_CONNECT);
+ SetEvent(tsdPtr->socketListLock);
}
+ return 1;
}
- if ((len == 0) || ((len > 1) && (optionName[1] == 's') &&
- (strncmp(optionName, "-sockname", len) == 0))) {
- if (getsockname(sock, (LPSOCKADDR) &sockname, &size) == 0) {
- if (len == 0) {
- Tcl_DStringAppendElement(dsPtr, "-sockname");
- Tcl_DStringStartSublist(dsPtr);
- }
- Tcl_DStringAppendElement(dsPtr, inet_ntoa(sockname.sin_addr));
- if (sockname.sin_addr.s_addr == 0) {
- hostEntPtr = NULL;
- } else {
- hostEntPtr = gethostbyaddr((char *) &(sockname.sin_addr),
- sizeof(peername.sin_addr), AF_INET);
- }
- if (hostEntPtr != NULL) {
- Tcl_DStringAppendElement(dsPtr, hostEntPtr->h_name);
- } else {
- Tcl_DStringAppendElement(dsPtr, inet_ntoa(sockname.sin_addr));
- }
- TclFormatInt(buf, ntohs(sockname.sin_port));
- Tcl_DStringAppendElement(dsPtr, buf);
- if (len == 0) {
- Tcl_DStringEndSublist(dsPtr);
- } else {
- return TCL_OK;
+ /*
+ * Handle connection requests directly.
+ */
+ if (statePtr->readyEvents & FD_ACCEPT) {
+ for (fds = statePtr->sockets; fds != NULL; fds = fds->next) {
+
+ /*
+ * Accept the incoming connection request.
+ */
+ len = sizeof(address);
+
+ newSocket = accept(fds->fd, &(addr.sa), &len);
+
+ /* On Tcl server sockets with multiple OS fds we loop over the fds trying
+ * an accept() on each, so we expect INVALID_SOCKET. There are also other
+ * network stack conditions that can result in FD_ACCEPT but a subsequent
+ * failure on accept() by the time we get around to it.
+ * Access to sockets (acceptEventCount, readyEvents) in socketList
+ * is still protected by the lock (prevents reintroduction of
+ * SF Tcl Bug 3056775.
+ */
+
+ if (newSocket == INVALID_SOCKET) {
+ /* int err = WSAGetLastError(); */
+ continue;
}
- } else {
- if (interp) {
- TclWinConvertWSAError((DWORD) WSAGetLastError());
- Tcl_AppendResult(interp, "can't get sockname: ",
- Tcl_PosixError(interp), NULL);
+
+ /*
+ * It is possible that more than one FD_ACCEPT has been sent, so an extra
+ * count must be kept. Decrement the count, and reset the readyEvent bit
+ * if the count is no longer > 0.
+ */
+ statePtr->acceptEventCount--;
+
+ if (statePtr->acceptEventCount <= 0) {
+ statePtr->readyEvents &= ~(FD_ACCEPT);
}
- return TCL_ERROR;
- }
- }
-#ifdef TCL_FEATURE_KEEPALIVE_NAGLE
- if (len == 0 || !strncmp(optionName, "-keepalive", len)) {
- int optlen;
- BOOL opt = FALSE;
+ SetEvent(tsdPtr->socketListLock);
- if (len == 0) {
- Tcl_DStringAppendElement(dsPtr, "-keepalive");
- }
- optlen = sizeof(BOOL);
- getsockopt(sock, SOL_SOCKET, SO_KEEPALIVE, (char *)&opt, &optlen);
- if (opt) {
- Tcl_DStringAppendElement(dsPtr, "1");
- } else {
- Tcl_DStringAppendElement(dsPtr, "0");
- }
- if (len > 0) {
- return TCL_OK;
+ /* Caution: TcpAccept() has the side-effect of evaluating the server
+ * accept script (via AcceptCallbackProc() in tclIOCmd.c), which can
+ * close the server socket and invalidate statePtr and fds.
+ * If TcpAccept() accepts a socket we must return immediately and let
+ * SocketCheckProc queue additional FD_ACCEPT events.
+ */
+ TcpAccept(fds, newSocket, addr);
+ return 1;
}
+
+ /* Loop terminated with no sockets accepted; clear the ready mask so
+ * we can detect the next connection request. Note that connection
+ * requests are level triggered, so if there is a request already
+ * pending, a new event will be generated.
+ */
+ statePtr->acceptEventCount = 0;
+ statePtr->readyEvents &= ~(FD_ACCEPT);
+
+ SetEvent(tsdPtr->socketListLock);
+ return 1;
}
- if (len == 0 || !strncmp(optionName, "-nagle", len)) {
- int optlen;
- BOOL opt = FALSE;
+ SetEvent(tsdPtr->socketListLock);
+
+ /*
+ * Mask off unwanted events and compute the read/write mask so we can
+ * notify the channel.
+ */
+
+ events = statePtr->readyEvents & statePtr->watchEvents;
+
+ if (events & FD_CLOSE) {
+ /*
+ * If the socket was closed and the channel is still interested in
+ * read events, then we need to ensure that we keep polling for this
+ * event until someone does something with the channel. Note that we
+ * do this before calling Tcl_NotifyChannel so we don't have to watch
+ * out for the channel being deleted out from under us. This may cause
+ * a redundant trip through the event loop, but it's simpler than
+ * trying to do unwind protection.
+ */
+
+ Tcl_Time blockTime = { 0, 0 };
+
+ Tcl_SetMaxBlockTime(&blockTime);
+ mask |= TCL_READABLE|TCL_WRITABLE;
+ } else if (events & FD_READ) {
+
+ /*
+ * Throw the readable event if an async connect failed.
+ */
+
+ if ( statePtr->flags & TCP_ASYNC_FAILED ) {
+
+ mask |= TCL_READABLE;
- if (len == 0) {
- Tcl_DStringAppendElement(dsPtr, "-nagle");
- }
- optlen = sizeof(BOOL);
- getsockopt(sock, IPPROTO_TCP, TCP_NODELAY, (char *)&opt,
- &optlen);
- if (opt) {
- Tcl_DStringAppendElement(dsPtr, "0");
} else {
- Tcl_DStringAppendElement(dsPtr, "1");
- }
- if (len > 0) {
- return TCL_OK;
+ fd_set readFds;
+ struct timeval timeout;
+
+ /*
+ * We must check to see if data is really available, since someone
+ * could have consumed the data in the meantime. Turn off async
+ * notification so select will work correctly. If the socket is
+ * still readable, notify the channel driver, otherwise reset the
+ * async select handler and keep waiting.
+ */
+
+ SendMessage(tsdPtr->hwnd, SOCKET_SELECT,
+ (WPARAM) UNSELECT, (LPARAM) statePtr);
+
+ FD_ZERO(&readFds);
+ FD_SET(statePtr->sockets->fd, &readFds);
+ timeout.tv_usec = 0;
+ timeout.tv_sec = 0;
+
+ if (select(0, &readFds, NULL, NULL, &timeout) != 0) {
+ mask |= TCL_READABLE;
+ } else {
+ statePtr->readyEvents &= ~(FD_READ);
+ SendMessage(tsdPtr->hwnd, SOCKET_SELECT,
+ (WPARAM) SELECT, (LPARAM) statePtr);
+ }
}
}
-#endif /*TCL_FEATURE_KEEPALIVE_NAGLE*/
- if (len > 0) {
-#ifdef TCL_FEATURE_KEEPALIVE_NAGLE
- return Tcl_BadChannelOption(interp, optionName,
- "peername sockname keepalive nagle");
-#else
- return Tcl_BadChannelOption(interp, optionName, "peername sockname");
-#endif /*TCL_FEATURE_KEEPALIVE_NAGLE*/
+ /*
+ * writable event
+ */
+
+ if (events & FD_WRITE) {
+ mask |= TCL_WRITABLE;
}
- return TCL_OK;
+ /*
+ * Call registered event procedures
+ */
+
+ if (mask) {
+ Tcl_NotifyChannel(statePtr->channel, mask);
+ }
+ return 1;
}
/*
*----------------------------------------------------------------------
*
- * TcpWatchProc --
+ * AddSocketInfoFd --
*
- * Informs the channel driver of the events that the generic channel code
- * wishes to receive on this socket.
+ * This function adds a SOCKET file descriptor to the 'sockets' linked
+ * list of a TcpState structure.
*
* Results:
* None.
*
* Side effects:
- * May cause the notifier to poll if any of the specified conditions are
- * already true.
+ * None, except for allocation of memory.
*
*----------------------------------------------------------------------
*/
static void
-TcpWatchProc(
- ClientData instanceData, /* The socket state. */
- int mask) /* Events of interest; an OR-ed combination of
- * TCL_READABLE, TCL_WRITABLE and
- * TCL_EXCEPTION. */
+AddSocketInfoFd(
+ TcpState *statePtr,
+ SOCKET socket)
{
- SocketInfo *infoPtr = (SocketInfo *) instanceData;
+ TcpFdList *fds = statePtr->sockets;
+
+ if ( fds == NULL ) {
+ /* Add the first FD */
+ statePtr->sockets = ckalloc(sizeof(TcpFdList));
+ fds = statePtr->sockets;
+ } else {
+ /* Find end of list and append FD */
+ while ( fds->next != NULL ) {
+ fds = fds->next;
+ }
+
+ fds->next = ckalloc(sizeof(TcpFdList));
+ fds = fds->next;
+ }
+
+ /* Populate new FD */
+ fds->fd = socket;
+ fds->statePtr = statePtr;
+ fds->next = NULL;
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * NewSocketInfo --
+ *
+ * This function allocates and initializes a new TcpState structure.
+ *
+ * Results:
+ * Returns a newly allocated TcpState.
+ *
+ * Side effects:
+ * None, except for allocation of memory.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static TcpState *
+NewSocketInfo(SOCKET socket)
+{
+ TcpState *statePtr = ckalloc(sizeof(TcpState));
+
+ memset(statePtr, 0, sizeof(TcpState));
/*
- * Update the watch events mask. Only if the socket is not a server
- * socket. Fix for SF Tcl Bug #557878.
+ * TIP #218. Removed the code inserting the new structure into the global
+ * list. This is now handled in the thread action callbacks, and only
+ * there.
*/
- if (!infoPtr->acceptProc) {
- infoPtr->watchEvents = 0;
- if (mask & TCL_READABLE) {
- infoPtr->watchEvents |= (FD_READ|FD_CLOSE|FD_ACCEPT);
- }
- if (mask & TCL_WRITABLE) {
- infoPtr->watchEvents |= (FD_WRITE|FD_CLOSE|FD_CONNECT);
- }
-
- /*
- * If there are any conditions already set, then tell the notifier to
- * poll rather than block.
- */
+ AddSocketInfoFd(statePtr, socket);
- if (infoPtr->readyEvents & infoPtr->watchEvents) {
- Tcl_Time blockTime = { 0, 0 };
- Tcl_SetMaxBlockTime(&blockTime);
- }
- }
+ return statePtr;
}
/*
*----------------------------------------------------------------------
*
- * TcpGetProc --
+ * WaitForSocketEvent --
*
- * Called from Tcl_GetChannelHandle to retrieve an OS handle from inside
- * a TCP socket based channel.
+ * Waits until one of the specified events occurs on a socket.
+ * For event FD_CONNECT use WaitForConnect.
*
* Results:
- * Returns TCL_OK with the socket in handlePtr.
+ * Returns 1 on success or 0 on failure, with an error code in
+ * errorCodePtr.
*
* Side effects:
- * None.
+ * Processes socket events off the system queue.
*
*----------------------------------------------------------------------
*/
static int
-TcpGetHandleProc(
- ClientData instanceData, /* The socket state. */
- int direction, /* Not used. */
- ClientData *handlePtr) /* Where to store the handle. */
+WaitForSocketEvent(
+ TcpState *statePtr, /* Information about this socket. */
+ int events, /* Events to look for. May be one of
+ * FD_READ or FD_WRITE.
+ */
+ int *errorCodePtr) /* Where to store errors? */
{
- SocketInfo *statePtr = (SocketInfo *) instanceData;
+ int result = 1;
+ int oldMode;
+ ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey);
+ /*
+ * Be sure to disable event servicing so we are truly modal.
+ */
- *handlePtr = (ClientData) statePtr->socket;
- return TCL_OK;
+ oldMode = Tcl_SetServiceMode(TCL_SERVICE_NONE);
+
+ /*
+ * Reset WSAAsyncSelect so we have a fresh set of events pending.
+ */
+
+ SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) UNSELECT,
+ (LPARAM) statePtr);
+ SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT,
+ (LPARAM) statePtr);
+
+ while (1) {
+ int event_found;
+
+ /* get statePtr lock */
+ WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
+
+ /* Check if event occured */
+ event_found = (statePtr->readyEvents & events);
+
+ /* Free list lock */
+ SetEvent(tsdPtr->socketListLock);
+
+ /* exit loop if event occured */
+ if (event_found) {
+ break;
+ }
+
+ /* Exit loop if event did not occur but this is a non-blocking channel */
+ if (statePtr->flags & TCP_NONBLOCKING) {
+ *errorCodePtr = EWOULDBLOCK;
+ result = 0;
+ break;
+ }
+
+ /*
+ * Wait until something happens.
+ */
+
+ WaitForSingleObject(tsdPtr->readyEvent, INFINITE);
+ }
+
+ (void) Tcl_SetServiceMode(oldMode);
+ return result;
}
/*
@@ -2224,14 +2986,14 @@ SocketThread(
LPVOID arg)
{
MSG msg;
- ThreadSpecificData *tsdPtr = (ThreadSpecificData *)(arg);
+ ThreadSpecificData *tsdPtr = arg;
/*
* Create a dummy window receiving socket events.
*/
- tsdPtr->hwnd = CreateWindow("TclSocket", "TclSocket",
- WS_TILED, 0, 0, 0, 0, NULL, NULL, windowClass.hInstance, arg);
+ tsdPtr->hwnd = CreateWindow(classname, classname, WS_TILED, 0, 0, 0, 0,
+ NULL, NULL, windowClass.hInstance, arg);
/*
* Signalize thread creator that we are done creating the window.
@@ -2294,8 +3056,9 @@ SocketProc(
{
int event, error;
SOCKET socket;
- SocketInfo *infoPtr;
+ TcpState *statePtr;
int info_found = 0;
+ TcpFdList *fds = NULL;
ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
#ifdef _WIN64
GetWindowLongPtr(hwnd, GWLP_USERDATA);
@@ -2332,15 +3095,16 @@ SocketProc(
error = WSAGETSELECTERROR(lParam);
socket = (SOCKET) wParam;
+ WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
+
/*
* Find the specified socket on the socket list and update its
* eventState flag.
*/
- WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
- for (infoPtr = tsdPtr->socketList; infoPtr != NULL;
- infoPtr = infoPtr->nextPtr) {
- if (infoPtr->socket == socket) {
+ for (statePtr = tsdPtr->socketList; statePtr != NULL;
+ statePtr = statePtr->nextPtr) {
+ if ( FindFDInList(statePtr,socket) ) {
info_found = 1;
break;
}
@@ -2350,9 +3114,9 @@ SocketProc(
* list
*/
if ( !info_found
- && tsdPtr->pendingSocketInfo != NULL
- && tsdPtr->pendingSocketInfo->socket ==socket ) {
- infoPtr = tsdPtr->pendingSocketInfo;
+ && tsdPtr->pendingTcpState != NULL
+ && FindFDInList(tsdPtr->pendingTcpState,socket) ) {
+ statePtr = tsdPtr->pendingTcpState;
info_found = 1;
}
if (info_found) {
@@ -2366,44 +3130,29 @@ SocketProc(
*/
if (event & FD_CLOSE) {
- infoPtr->acceptEventCount = 0;
- infoPtr->readyEvents &= ~(FD_WRITE|FD_ACCEPT);
+ statePtr->acceptEventCount = 0;
+ statePtr->readyEvents &= ~(FD_WRITE|FD_ACCEPT);
} else if (event & FD_ACCEPT) {
- infoPtr->acceptEventCount++;
+ statePtr->acceptEventCount++;
}
if (event & FD_CONNECT) {
/*
- * The socket is now connected, clear the async connect
- * flag.
- */
-
- infoPtr->flags &= ~(SOCKET_ASYNC_CONNECT);
-
- /*
* Remember any error that occurred so we can report
* connection failures.
*/
-
if (error != ERROR_SUCCESS) {
- /* Async Connect error */
- TclWinConvertWSAError((DWORD) error);
- infoPtr->lastError = Tcl_GetErrno();
- /* Fire also readable event on connect failure */
- infoPtr->readyEvents |= FD_READ;
+ statePtr->notifierConnectError = error;
}
-
- /* fire writable event on connect */
- infoPtr->readyEvents |= FD_WRITE;
-
}
-
- infoPtr->readyEvents |= event;
+ /*
+ * Inform main thread about signaled events
+ */
+ statePtr->readyEvents |= event;
/*
* Wake up the Main Thread.
*/
-
SetEvent(tsdPtr->readyEvent);
Tcl_ThreadAlert(tsdPtr->threadId);
}
@@ -2411,20 +3160,18 @@ SocketProc(
break;
case SOCKET_SELECT:
- infoPtr = (SocketInfo *) lParam;
- if (wParam == SELECT) {
- /*
- * Start notification by windows messages on socket events
- */
-
- WSAAsyncSelect(infoPtr->socket, hwnd,
- SOCKET_MESSAGE, infoPtr->selectEvents);
- } else {
- /*
- * UNSELECT: Clear the selection mask
- */
+ statePtr = (TcpState *) lParam;
+ for (fds = statePtr->sockets; fds != NULL; fds = fds->next) {
+ if (wParam == SELECT) {
+ WSAAsyncSelect(fds->fd, hwnd,
+ SOCKET_MESSAGE, statePtr->selectEvents);
+ } else {
+ /*
+ * Clear the selection mask
+ */
- WSAAsyncSelect(infoPtr->socket, hwnd, 0, 0);
+ WSAAsyncSelect(fds->fd, hwnd, 0, 0);
+ }
}
break;
@@ -2439,83 +3186,31 @@ SocketProc(
/*
*----------------------------------------------------------------------
*
- * Tcl_GetHostName --
+ * FindFDInList --
*
- * Returns the name of the local host.
+ * Return true, if the given file descriptior is contained in the
+ * file descriptor list.
*
* Results:
- * A string containing the network name for this machine. The caller must
- * not modify or free this string.
+ * true if found.
*
* Side effects:
- * Caches the name to return for future calls.
*
*----------------------------------------------------------------------
*/
-const char *
-Tcl_GetHostName(void)
-{
- return Tcl_GetString(TclGetProcessGlobalValue(&hostName));
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * InitializeHostName --
- *
- * This routine sets the process global value of the name of the local
- * host on which the process is running.
- *
- * Results:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-void
-InitializeHostName(
- char **valuePtr,
- int *lengthPtr,
- Tcl_Encoding *encodingPtr)
+static int
+FindFDInList(
+ TcpState *statePtr,
+ SOCKET socket)
{
- WCHAR wbuf[MAX_COMPUTERNAME_LENGTH + 1];
- DWORD length = sizeof(wbuf) / sizeof(WCHAR);
- Tcl_DString ds;
-
- if ((*tclWinProcs->getComputerNameProc)(wbuf, &length) != 0) {
- /*
- * Convert string from native to UTF then change to lowercase.
- */
-
- Tcl_UtfToLower(Tcl_WinTCharToUtf((TCHAR *) wbuf, -1, &ds));
-
- } else {
- Tcl_DStringInit(&ds);
- if (TclpHasSockets(NULL) == TCL_OK) {
- /*
- * The buffer size of 256 is recommended by the MSDN page that
- * documents gethostname() as being always adequate.
- */
-
- Tcl_DString inDs;
-
- Tcl_DStringInit(&inDs);
- Tcl_DStringSetLength(&inDs, 256);
- if (gethostname(Tcl_DStringValue(&inDs),
- Tcl_DStringLength(&inDs)) == 0) {
- Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(&inDs), -1,
- &ds);
- }
- Tcl_DStringFree(&inDs);
+ TcpFdList *fds;
+ for (fds = statePtr->sockets; fds != NULL; fds = fds->next) {
+ if (fds->fd == socket) {
+ return 1;
}
}
-
- *encodingPtr = Tcl_GetEncoding(NULL, "utf-8");
- *lengthPtr = Tcl_DStringLength(&ds);
- *valuePtr = ckalloc((unsigned int) (*lengthPtr)+1);
- memcpy(*valuePtr, Tcl_DStringValue(&ds), (size_t)(*lengthPtr)+1);
- Tcl_DStringFree(&ds);
+ return 0;
}
/*
@@ -2523,10 +3218,11 @@ InitializeHostName(
*
* TclWinGetSockOpt, et al. --
*
- * These functions are wrappers that let us bind the WinSock API
- * dynamically so we can run on systems that don't have the wsock32.dll.
- * We need wrappers for these interfaces because they are called from the
- * generic Tcl code.
+ * Those functions are historically exported by the stubs table and
+ * just use the original system calls now.
+ *
+ * Warning:
+ * Those functions are depreciated and will be removed with TCL 9.0.
*
* Results:
* As defined for each function.
@@ -2539,26 +3235,35 @@ InitializeHostName(
#undef TclWinGetSockOpt
int
-TclWinGetSockOpt(SOCKET s, int level, int optname, char *optval,
- int *optlen)
+TclWinGetSockOpt(
+ SOCKET s,
+ int level,
+ int optname,
+ char *optval,
+ int *optlen)
{
+
return getsockopt(s, level, optname, optval, optlen);
}
-
#undef TclWinSetSockOpt
int
-TclWinSetSockOpt(SOCKET s, int level, int optname, const char *optval,
+TclWinSetSockOpt(
+ SOCKET s,
+ int level,
+ int optname,
+ const char *optval,
int optlen)
{
return setsockopt(s, level, optname, optval, optlen);
}
+#undef TclpInetNtoa
char *
-TclpInetNtoa(struct in_addr addr)
+TclpInetNtoa(
+ struct in_addr addr)
{
return inet_ntoa(addr);
}
-
#undef TclWinGetServByName
struct servent *
TclWinGetServByName(
@@ -2590,7 +3295,7 @@ TcpThreadActionProc(
int action)
{
ThreadSpecificData *tsdPtr;
- SocketInfo *infoPtr = (SocketInfo *) instanceData;
+ TcpState *statePtr = instanceData;
int notifyCmd;
if (action == TCL_CHANNEL_THREAD_INSERT) {
@@ -2606,18 +3311,18 @@ TcpThreadActionProc(
tsdPtr = TCL_TSD_INIT(&dataKey);
WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
- infoPtr->nextPtr = tsdPtr->socketList;
- tsdPtr->socketList = infoPtr;
-
- if (infoPtr == tsdPtr->pendingSocketInfo) {
- tsdPtr->pendingSocketInfo = NULL;
+ statePtr->nextPtr = tsdPtr->socketList;
+ tsdPtr->socketList = statePtr;
+
+ if (statePtr == tsdPtr->pendingTcpState) {
+ tsdPtr->pendingTcpState = NULL;
}
-
+
SetEvent(tsdPtr->socketListLock);
notifyCmd = SELECT;
} else {
- SocketInfo **nextPtrPtr;
+ TcpState **nextPtrPtr;
int removed = 0;
tsdPtr = TCL_TSD_INIT(&dataKey);
@@ -2630,8 +3335,8 @@ TcpThreadActionProc(
WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
for (nextPtrPtr = &(tsdPtr->socketList); (*nextPtrPtr) != NULL;
nextPtrPtr = &((*nextPtrPtr)->nextPtr)) {
- if ((*nextPtrPtr) == infoPtr) {
- (*nextPtrPtr) = infoPtr->nextPtr;
+ if ((*nextPtrPtr) == statePtr) {
+ (*nextPtrPtr) = statePtr->nextPtr;
removed = 1;
break;
}
@@ -2657,7 +3362,7 @@ TcpThreadActionProc(
*/
SendMessage(tsdPtr->hwnd, SOCKET_SELECT,
- (WPARAM) notifyCmd, (LPARAM) infoPtr);
+ (WPARAM) notifyCmd, (LPARAM) statePtr);
}
/*
@@ -2665,5 +3370,7 @@ TcpThreadActionProc(
* mode: c
* c-basic-offset: 4
* fill-column: 78
+ * tab-width: 8
+ * indent-tabs-mode: nil
* End:
*/
diff --git a/win/tclWinTest.c b/win/tclWinTest.c
index e493fbf..b3ad626 100644
--- a/win/tclWinTest.c
+++ b/win/tclWinTest.c
@@ -9,12 +9,15 @@
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
+#ifndef USE_TCL_STUBS
+# define USE_TCL_STUBS
+#endif
#include "tclInt.h"
/*
* For TestplatformChmod on Windows
*/
-#ifdef __WIN32__
+#ifdef _WIN32
#include <aclapi.h>
#endif
@@ -29,9 +32,8 @@
* Forward declarations of functions defined later in this file:
*/
-int TclplatformtestInit(Tcl_Interp *interp);
-static int TesteventloopCmd(ClientData dummy, Tcl_Interp *interp,
- int argc, const char **argv);
+static int TesteventloopCmd(ClientData dummy, Tcl_Interp* interp,
+ int objc, Tcl_Obj *const objv[]);
static int TestvolumetypeCmd(ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
@@ -41,8 +43,8 @@ static int TestwinsleepCmd(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, int argc, const char **argv);
+static int TestchmodCmd(ClientData dummy, Tcl_Interp* interp,
+ int objc, Tcl_Obj *const objv[]);
/*
*----------------------------------------------------------------------
@@ -69,8 +71,8 @@ TclplatformtestInit(
* Add commands for platform specific tests for Windows here.
*/
- Tcl_CreateCommand(interp, "testchmod", TestchmodCmd, NULL, NULL);
- Tcl_CreateCommand(interp, "testeventloop", TesteventloopCmd, NULL, NULL);
+ Tcl_CreateObjCommand(interp, "testchmod", TestchmodCmd, NULL, NULL);
+ Tcl_CreateObjCommand(interp, "testeventloop", TesteventloopCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testvolumetype", TestvolumetypeCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testwinclock", TestwinclockCmd, NULL, NULL);
@@ -101,21 +103,20 @@ static int
TesteventloopCmd(
ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
- int argc, /* Number of arguments. */
- const char **argv) /* Argument strings. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
static int *framePtr = NULL;/* Pointer to integer on stack frame of
* innermost invocation of the "wait"
* subcommand. */
- if (argc < 2) {
- Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
- " option ... \"", NULL);
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "option ...");
return TCL_ERROR;
}
- if (strcmp(argv[1], "done") == 0) {
+ if (strcmp(Tcl_GetString(objv[1]), "done") == 0) {
*framePtr = 1;
- } else if (strcmp(argv[1], "wait") == 0) {
+ } else if (strcmp(Tcl_GetString(objv[1]), "wait") == 0) {
int *oldFramePtr, done;
int oldMode = Tcl_SetServiceMode(TCL_SERVICE_ALL);
@@ -150,7 +151,7 @@ TesteventloopCmd(
(void) Tcl_SetServiceMode(oldMode);
framePtr = oldFramePtr;
} else {
- Tcl_AppendResult(interp, "bad option \"", argv[1],
+ Tcl_AppendResult(interp, "bad option \"", Tcl_GetString(objv[1]),
"\": must be done or wait", NULL);
return TCL_ERROR;
}
@@ -184,7 +185,7 @@ TestvolumetypeCmd(
#define VOL_BUF_SIZE 32
int found;
char volType[VOL_BUF_SIZE];
- char *path;
+ const char *path;
if (objc > 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?name?");
@@ -209,7 +210,7 @@ TestvolumetypeCmd(
TclWinConvertError(GetLastError());
return TCL_ERROR;
}
- Tcl_SetResult(interp, volType, TCL_VOLATILE);
+ Tcl_AppendResult(interp, volType, NULL);
return TCL_OK;
#undef VOL_BUF_SIZE
}
@@ -339,7 +340,7 @@ TestExceptionCmd(
int objc, /* Argument count */
Tcl_Obj *const objv[]) /* Argument vector */
{
- static const char *cmds[] = {
+ static const char *const cmds[] = {
"access_violation", "datatype_misalignment", "array_bounds",
"float_denormal", "float_divbyzero", "float_inexact",
"float_invalidop", "float_overflow", "float_stack", "float_underflow",
@@ -396,28 +397,6 @@ TestplatformChmod(
const char *nativePath,
int pmode)
{
- typedef DWORD (WINAPI *getSidLengthRequiredDef)(UCHAR);
- typedef BOOL (WINAPI *initializeSidDef)(PSID, PSID_IDENTIFIER_AUTHORITY,
- BYTE);
- typedef PDWORD (WINAPI *getSidSubAuthorityDef)(PSID, DWORD);
- typedef DWORD (WINAPI *setNamedSecurityInfoADef)(IN LPSTR,
- IN SE_OBJECT_TYPE, IN SECURITY_INFORMATION, IN PSID, IN PSID,
- IN PACL, IN PACL);
- typedef BOOL (WINAPI *getAceDef)(PACL, DWORD, LPVOID *);
- typedef BOOL (WINAPI *addAceDef)(PACL, DWORD, DWORD, LPVOID, DWORD);
- typedef BOOL (WINAPI *equalSidDef)(PSID, PSID);
- typedef BOOL (WINAPI *addAccessDeniedAceDef)(PACL, DWORD, DWORD, PSID);
- typedef BOOL (WINAPI *initializeAclDef)(PACL, DWORD, DWORD);
- typedef DWORD (WINAPI *getLengthSidDef)(PSID);
- typedef BOOL (WINAPI *getAclInformationDef)(PACL, LPVOID, DWORD,
- ACL_INFORMATION_CLASS);
- typedef BOOL (WINAPI *getSecurityDescriptorDaclDef)(PSECURITY_DESCRIPTOR,
- LPBOOL, PACL *, LPBOOL);
- typedef BOOL (WINAPI *lookupAccountNameADef)(LPCSTR, LPCSTR, PSID,
- PDWORD, LPSTR, LPDWORD, PSID_NAME_USE);
- typedef BOOL (WINAPI *getFileSecurityADef)(LPCSTR, SECURITY_INFORMATION,
- PSECURITY_DESCRIPTOR, DWORD, LPDWORD);
-
static const SECURITY_INFORMATION infoBits = OWNER_SECURITY_INFORMATION
| GROUP_SECURITY_INFORMATION | DACL_SECURITY_INFORMATION;
static const DWORD readOnlyMask = FILE_DELETE_CHILD | FILE_ADD_FILE
@@ -428,22 +407,6 @@ TestplatformChmod(
* References to security functions (only available on NT and later).
*/
- static getSidLengthRequiredDef getSidLengthRequiredProc;
- static initializeSidDef initializeSidProc;
- static getSidSubAuthorityDef getSidSubAuthorityProc;
- static setNamedSecurityInfoADef setNamedSecurityInfoProc;
- static getAceDef getAceProc;
- static addAceDef addAceProc;
- static equalSidDef equalSidProc;
- static addAccessDeniedAceDef addAccessDeniedAceProc;
- static initializeAclDef initializeAclProc;
- static getLengthSidDef getLengthSidProc;
- static getAclInformationDef getAclInformationProc;
- static getSecurityDescriptorDaclDef getSecurityDescriptorDaclProc;
- static lookupAccountNameADef lookupAccountNameProc;
- static getFileSecurityADef getFileSecurityProc;
- static int initialized = 0;
-
const BOOL set_readOnly = !(pmode & 0222);
BOOL acl_readOnly_found = FALSE, curAclPresent, curAclDefaulted;
SID_IDENTIFIER_AUTHORITY userSidAuthority = {
@@ -455,72 +418,14 @@ TestplatformChmod(
PACL curAcl, newAcl = 0;
WORD j;
SID *userSid = 0;
- TCHAR *userDomain = 0;
+ char *userDomain = 0;
int res = 0;
/*
- * One time initialization, dynamically load Windows NT features
- */
-
- if (!initialized) {
- TCL_DECLARE_MUTEX(initializeMutex)
- Tcl_MutexLock(&initializeMutex);
- if (!initialized) {
- HINSTANCE hInstance = LoadLibrary("Advapi32");
-
- if (hInstance != NULL) {
- setNamedSecurityInfoProc = (setNamedSecurityInfoADef)
- GetProcAddress(hInstance, "SetNamedSecurityInfoA");
- getFileSecurityProc = (getFileSecurityADef)
- GetProcAddress(hInstance, "GetFileSecurityA");
- getAceProc = (getAceDef)
- GetProcAddress(hInstance, "GetAce");
- addAceProc = (addAceDef)
- GetProcAddress(hInstance, "AddAce");
- equalSidProc = (equalSidDef)
- GetProcAddress(hInstance, "EqualSid");
- addAccessDeniedAceProc = (addAccessDeniedAceDef)
- GetProcAddress(hInstance, "AddAccessDeniedAce");
- initializeAclProc = (initializeAclDef)
- GetProcAddress(hInstance, "InitializeAcl");
- getLengthSidProc = (getLengthSidDef)
- GetProcAddress(hInstance, "GetLengthSid");
- getAclInformationProc = (getAclInformationDef)
- GetProcAddress(hInstance, "GetAclInformation");
- getSecurityDescriptorDaclProc = (getSecurityDescriptorDaclDef)
- GetProcAddress(hInstance, "GetSecurityDescriptorDacl");
- lookupAccountNameProc = (lookupAccountNameADef)
- GetProcAddress(hInstance, "LookupAccountNameA");
- getSidLengthRequiredProc = (getSidLengthRequiredDef)
- GetProcAddress(hInstance, "GetSidLengthRequired");
- initializeSidProc = (initializeSidDef)
- GetProcAddress(hInstance, "InitializeSid");
- getSidSubAuthorityProc = (getSidSubAuthorityDef)
- GetProcAddress(hInstance, "GetSidSubAuthority");
-
- if (setNamedSecurityInfoProc && getAceProc && addAceProc
- && equalSidProc && addAccessDeniedAceProc
- && initializeAclProc && getLengthSidProc
- && getAclInformationProc
- && getSecurityDescriptorDaclProc
- && lookupAccountNameProc && getFileSecurityProc
- && getSidLengthRequiredProc && initializeSidProc
- && getSidSubAuthorityProc) {
- initialized = 1;
- }
- }
- if (!initialized) {
- initialized = -1;
- }
- }
- Tcl_MutexUnlock(&initializeMutex);
- }
-
- /*
* Process the chmod request.
*/
- attr = GetFileAttributes(nativePath);
+ attr = GetFileAttributesA(nativePath);
/*
* nativePath not found
@@ -532,11 +437,10 @@ TestplatformChmod(
}
/*
- * If no ACL API is present or nativePath is not a directory, there is no
- * special handling.
+ * If nativePath is not a directory, there is no special handling.
*/
- if (initialized < 0 || !(attr & FILE_ATTRIBUTE_DIRECTORY)) {
+ if (!(attr & FILE_ATTRIBUTE_DIRECTORY)) {
goto done;
}
@@ -552,15 +456,15 @@ TestplatformChmod(
* obtains the size of the security descriptor.
*/
- if (!getFileSecurityProc(nativePath, infoBits, NULL, 0, &secDescLen)) {
+ if (!GetFileSecurityA(nativePath, infoBits, NULL, 0, &secDescLen)) {
DWORD secDescLen2 = 0;
if (GetLastError() != ERROR_INSUFFICIENT_BUFFER) {
goto done;
}
- secDesc = (BYTE *) ckalloc(secDescLen);
- if (!getFileSecurityProc(nativePath, infoBits,
+ secDesc = ckalloc(secDescLen);
+ if (!GetFileSecurityA(nativePath, infoBits,
(PSECURITY_DESCRIPTOR) secDesc, secDescLen, &secDescLen2)
|| (secDescLen < secDescLen2)) {
goto done;
@@ -571,22 +475,22 @@ TestplatformChmod(
* Get the World SID.
*/
- userSid = (SID *) ckalloc(getSidLengthRequiredProc((UCHAR) 1));
- initializeSidProc(userSid, &userSidAuthority, (BYTE) 1);
- *(getSidSubAuthorityProc(userSid, 0)) = SECURITY_WORLD_RID;
+ userSid = ckalloc(GetSidLengthRequired((UCHAR) 1));
+ InitializeSid(userSid, &userSidAuthority, (BYTE) 1);
+ *(GetSidSubAuthority(userSid, 0)) = SECURITY_WORLD_RID;
/*
* If curAclPresent == false then curAcl and curAclDefaulted not valid.
*/
- if (!getSecurityDescriptorDaclProc((PSECURITY_DESCRIPTOR) secDesc,
+ if (!GetSecurityDescriptorDacl((PSECURITY_DESCRIPTOR) secDesc,
&curAclPresent, &curAcl, &curAclDefaulted)) {
goto done;
}
if (!curAclPresent || !curAcl) {
ACLSize.AclBytesInUse = 0;
ACLSize.AceCount = 0;
- } else if (!getAclInformationProc(curAcl, &ACLSize, sizeof(ACLSize),
+ } else if (!GetAclInformation(curAcl, &ACLSize, sizeof(ACLSize),
AclSizeInformation)) {
goto done;
}
@@ -596,14 +500,14 @@ TestplatformChmod(
*/
newAclSize = ACLSize.AclBytesInUse + sizeof(ACCESS_DENIED_ACE)
- + getLengthSidProc(userSid) - sizeof(DWORD);
- newAcl = (ACL *) ckalloc(newAclSize);
+ + GetLengthSid(userSid) - sizeof(DWORD);
+ newAcl = ckalloc(newAclSize);
/*
* Initialize the new ACL.
*/
- if (!initializeAclProc(newAcl, newAclSize, ACL_REVISION)) {
+ if (!InitializeAcl(newAcl, newAclSize, ACL_REVISION)) {
goto done;
}
@@ -611,7 +515,7 @@ TestplatformChmod(
* Add denied to make readonly, this will be known as a "read-only tag".
*/
- if (set_readOnly && !addAccessDeniedAceProc(newAcl, ACL_REVISION,
+ if (set_readOnly && !AddAccessDeniedAce(newAcl, ACL_REVISION,
readOnlyMask, userSid)) {
goto done;
}
@@ -621,7 +525,7 @@ TestplatformChmod(
LPVOID pACE2;
ACE_HEADER *phACE2;
- if (!getAceProc(curAcl, j, &pACE2)) {
+ if (!GetAce(curAcl, j, &pACE2)) {
goto done;
}
@@ -644,7 +548,7 @@ TestplatformChmod(
ACCESS_DENIED_ACE *pACEd = (ACCESS_DENIED_ACE *) phACE2;
if (pACEd->Mask == readOnlyMask
- && equalSidProc(userSid, (PSID) &pACEd->SidStart)) {
+ && EqualSid(userSid, (PSID) &pACEd->SidStart)) {
acl_readOnly_found = TRUE;
continue;
}
@@ -654,7 +558,7 @@ TestplatformChmod(
* Copy the current ACE from the old to the new ACL.
*/
- if (!addAceProc(newAcl, ACL_REVISION, MAXDWORD, (PACL *)pACE2,
+ if (!AddAce(newAcl, ACL_REVISION, MAXDWORD, (PACL *) pACE2,
((PACE_HEADER) pACE2)->AceSize)) {
goto done;
}
@@ -664,7 +568,7 @@ TestplatformChmod(
* Apply the new ACL.
*/
- if (set_readOnly == acl_readOnly_found || setNamedSecurityInfoProc(
+ if (set_readOnly == acl_readOnly_found || SetNamedSecurityInfoA(
(LPSTR) nativePath, SE_FILE_OBJECT, DACL_SECURITY_INFORMATION,
NULL, NULL, newAcl, NULL) == ERROR_SUCCESS) {
res = 0;
@@ -672,13 +576,13 @@ TestplatformChmod(
done:
if (secDesc) {
- ckfree((char *) secDesc);
+ ckfree(secDesc);
}
if (newAcl) {
- ckfree((char *) newAcl);
+ ckfree(newAcl);
}
if (userSid) {
- ckfree((char *) userSid);
+ ckfree(userSid);
}
if (userDomain) {
ckfree(userDomain);
@@ -718,29 +622,25 @@ static int
TestchmodCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
- int argc, /* Number of arguments. */
- const char **argv) /* Argument strings. */
+ int objc, /* Parameter count */
+ Tcl_Obj *const * objv) /* Parameter vector */
{
int i, mode;
- char *rest;
- if (argc < 2) {
- usage:
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " mode file ?file ...?", NULL);
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "mode file ?file ...?");
return TCL_ERROR;
}
- mode = (int) strtol(argv[1], &rest, 8);
- if ((rest == argv[1]) || (*rest != '\0')) {
- goto usage;
+ if (Tcl_GetIntFromObj(interp, objv[1], &mode) != TCL_OK) {
+ return TCL_ERROR;
}
- for (i = 2; i < argc; i++) {
+ for (i = 2; i < objc; i++) {
Tcl_DString buffer;
const char *translated;
- translated = Tcl_TranslateFileName(interp, argv[i], &buffer);
+ translated = Tcl_TranslateFileName(interp, Tcl_GetString(objv[i]), &buffer);
if (translated == NULL) {
return TCL_ERROR;
}
diff --git a/win/tclWinThrd.c b/win/tclWinThrd.c
index 7828e65..8f3ddb9 100644
--- a/win/tclWinThrd.c
+++ b/win/tclWinThrd.c
@@ -5,6 +5,7 @@
*
* Copyright (c) 1998 by Sun Microsystems, Inc.
* Copyright (c) 1999 by Scriptics Corporation
+ * Copyright (c) 2008 by George Peter Staplin
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -207,7 +208,7 @@ TclWinThreadStart(
int
TclpThreadCreate(
Tcl_ThreadId *idPtr, /* Return, the ID of the thread. */
- Tcl_ThreadCreateProc proc, /* Main() function of the thread. */
+ Tcl_ThreadCreateProc *proc, /* Main() function of the thread. */
ClientData clientData, /* The one argument to Main(). */
int stackSize, /* Size of stack for the new thread. */
int flags) /* Flags controlling behaviour of the new
@@ -331,7 +332,7 @@ TclpThreadExit(
Tcl_ThreadId
Tcl_GetCurrentThread(void)
{
- return (Tcl_ThreadId) INT2PTR(GetCurrentThreadId());
+ return (Tcl_ThreadId)(size_t)GetCurrentThreadId();
}
/*
@@ -573,7 +574,7 @@ Tcl_MutexLock(
*/
if (*mutexPtr == NULL) {
- csPtr = (CRITICAL_SECTION *) ckalloc(sizeof(CRITICAL_SECTION));
+ csPtr = ckalloc(sizeof(CRITICAL_SECTION));
InitializeCriticalSection(csPtr);
*mutexPtr = (Tcl_Mutex)csPtr;
TclRememberMutex(mutexPtr);
@@ -634,7 +635,7 @@ TclpFinalizeMutex(
if (csPtr != NULL) {
DeleteCriticalSection(csPtr);
- ckfree((char *) csPtr);
+ ckfree(csPtr);
*mutexPtr = NULL;
}
}
@@ -665,7 +666,7 @@ void
Tcl_ConditionWait(
Tcl_Condition *condPtr, /* Really (WinCondition **) */
Tcl_Mutex *mutexPtr, /* Really (CRITICAL_SECTION **) */
- Tcl_Time *timePtr) /* Timeout on waiting period */
+ const Tcl_Time *timePtr) /* Timeout on waiting period */
{
WinCondition *winCondPtr; /* Per-condition queue head */
CRITICAL_SECTION *csPtr; /* Caller's Mutex, after casting */
@@ -704,8 +705,7 @@ Tcl_ConditionWait(
* and initializing that may drop back into the Master Lock.
*/
- Tcl_CreateThreadExitHandler(FinalizeConditionEvent,
- (ClientData) tsdPtr);
+ Tcl_CreateThreadExitHandler(FinalizeConditionEvent, tsdPtr);
}
}
@@ -717,7 +717,7 @@ Tcl_ConditionWait(
*/
if (*condPtr == NULL) {
- winCondPtr = (WinCondition *) ckalloc(sizeof(WinCondition));
+ winCondPtr = ckalloc(sizeof(WinCondition));
InitializeCriticalSection(&winCondPtr->condLock);
winCondPtr->firstPtr = NULL;
winCondPtr->lastPtr = NULL;
@@ -766,7 +766,8 @@ Tcl_ConditionWait(
while (!timeout && (tsdPtr->flags & WIN_THREAD_BLOCKED)) {
ResetEvent(tsdPtr->condEvent);
LeaveCriticalSection(&winCondPtr->condLock);
- if (WaitForSingleObject(tsdPtr->condEvent, wtime) == WAIT_TIMEOUT) {
+ if (WaitForSingleObjectEx(tsdPtr->condEvent, wtime,
+ TRUE) == WAIT_TIMEOUT) {
timeout = 1;
}
EnterCriticalSection(&winCondPtr->condLock);
@@ -927,7 +928,7 @@ TclpFinalizeCondition(
if (winCondPtr != NULL) {
DeleteCriticalSection(&winCondPtr->condLock);
- ckfree((char *) winCondPtr);
+ ckfree(winCondPtr);
*condPtr = NULL;
}
}
@@ -970,7 +971,7 @@ TclpFreeAllocMutex(
void *
TclpGetAllocCache(void)
{
- VOID *result;
+ void *result;
if (!once) {
/*
@@ -1011,8 +1012,10 @@ TclpFreeAllocCache(
if (ptr != NULL) {
/*
- * Called by us in TclpFinalizeThreadData when a thread exits and
- * destroys the tsd key which stores allocator caches.
+ * Called by TclFinalizeThreadAlloc() and
+ * TclFinalizeThreadAllocThread() during Tcl_Finalize() or
+ * Tcl_FinalizeThread(). This function destroys the tsd key which
+ * stores allocator caches in thread local storage.
*/
TclFreeAllocCache(ptr);
@@ -1035,6 +1038,61 @@ TclpFreeAllocCache(
}
#endif /* USE_THREAD_ALLOC */
+
+
+void *
+TclpThreadCreateKey(void)
+{
+ DWORD *key;
+
+ key = TclpSysAlloc(sizeof *key, 0);
+ if (key == NULL) {
+ Tcl_Panic("unable to allocate thread key!");
+ }
+
+ *key = TlsAlloc();
+
+ if (*key == TLS_OUT_OF_INDEXES) {
+ Tcl_Panic("unable to allocate thread-local storage");
+ }
+
+ return key;
+}
+
+void
+TclpThreadDeleteKey(
+ void *keyPtr)
+{
+ DWORD *key = keyPtr;
+
+ if (!TlsFree(*key)) {
+ Tcl_Panic("unable to delete key");
+ }
+
+ TclpSysFree(keyPtr);
+}
+
+void
+TclpThreadSetMasterTSD(
+ void *tsdKeyPtr,
+ void *ptr)
+{
+ DWORD *key = tsdKeyPtr;
+
+ if (!TlsSetValue(*key, ptr)) {
+ Tcl_Panic("unable to set master TSD value");
+ }
+}
+
+void *
+TclpThreadGetMasterTSD(
+ void *tsdKeyPtr)
+{
+ DWORD *key = tsdKeyPtr;
+
+ return TlsGetValue(*key);
+}
+
#endif /* TCL_THREADS */
/*
diff --git a/win/tclWinThrd.h b/win/tclWinThrd.h
deleted file mode 100644
index 41bc7aa..0000000
--- a/win/tclWinThrd.h
+++ /dev/null
@@ -1,19 +0,0 @@
-/*
- * tclWinThrd.h --
- *
- * This header file defines things for thread support.
- *
- * Copyright (c) 1998 Sun Microsystems, Inc.
- *
- * See the file "license.terms" for information on usage and redistribution
- * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
- */
-
-#ifndef _TCLWINTHRD
-#define _TCLWINTHRD
-
-#ifdef TCL_THREADS
-
-#endif /* TCL_THREADS */
-
-#endif /* _TCLWINTHRD */
diff --git a/win/tclWinTime.c b/win/tclWinTime.c
index 0163723..7045c72 100644
--- a/win/tclWinTime.c
+++ b/win/tclWinTime.c
@@ -87,7 +87,7 @@ typedef struct TimeInfo {
} TimeInfo;
static TimeInfo timeInfo = {
- { NULL },
+ { NULL, 0, 0, NULL, NULL, 0 },
0,
0,
(HANDLE) NULL,
@@ -156,7 +156,7 @@ TclpGetSeconds(void)
{
Tcl_Time t;
- (*tclGetTimeProcPtr) (&t, tclTimeClientData); /* Tcl_GetTime inlined. */
+ tclGetTimeProcPtr(&t, tclTimeClientData); /* Tcl_GetTime inlined. */
return t.sec;
}
@@ -190,7 +190,7 @@ TclpGetClicks(void)
Tcl_Time now; /* Current Tcl time */
unsigned long retval; /* Value to return */
- (*tclGetTimeProcPtr) (&now, tclTimeClientData); /* Tcl_GetTime inlined */
+ tclGetTimeProcPtr(&now, tclTimeClientData); /* Tcl_GetTime inlined */
retval = (now.sec * 1000000) + now.usec;
return retval;
@@ -200,35 +200,6 @@ TclpGetClicks(void)
/*
*----------------------------------------------------------------------
*
- * TclpGetTimeZone --
- *
- * Determines the current timezone. The method varies wildly between
- * different Platform implementations, so its hidden in this function.
- *
- * Results:
- * Minutes west of GMT.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclpGetTimeZone(
- unsigned long currentTime)
-{
- int timeZone;
-
- tzset();
- timeZone = timezone / 60;
-
- return timeZone;
-}
-
-/*
- *----------------------------------------------------------------------
- *
* Tcl_GetTime --
*
* Gets the current system time in seconds and microseconds since the
@@ -252,7 +223,7 @@ void
Tcl_GetTime(
Tcl_Time *timePtr) /* Location to store time information. */
{
- (*tclGetTimeProcPtr) (timePtr, tclTimeClientData);
+ tclGetTimeProcPtr(timePtr, tclTimeClientData);
}
/*
@@ -414,7 +385,7 @@ NativeGetTime(
WaitForSingleObject(timeInfo.readyEvent, INFINITE);
CloseHandle(timeInfo.readyEvent);
- Tcl_CreateExitHandler(StopCalibration, (ClientData) NULL);
+ Tcl_CreateExitHandler(StopCalibration, NULL);
}
timeInfo.initialized = TRUE;
}
@@ -518,93 +489,6 @@ StopCalibration(
/*
*----------------------------------------------------------------------
*
- * TclpGetTZName --
- *
- * Gets the current timezone string.
- *
- * Results:
- * Returns a pointer to a static string, or NULL on failure.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-char *
-TclpGetTZName(
- int dst)
-{
- int len;
- char *zone, *p;
- TIME_ZONE_INFORMATION tz;
- Tcl_Encoding encoding;
- ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
- char *name = tsdPtr->tzName;
-
- /*
- * tzset() under Borland doesn't seem to set up tzname[] at all.
- * tzset() under MSVC has the following weird observed behavior:
- * First time we call "clock format [clock seconds] -format %Z -gmt 1"
- * we get "GMT", but on all subsequent calls we get the current time
- * ezone string, even though env(TZ) is GMT and the variable _timezone
- * is 0.
- */
-
- name[0] = '\0';
-
- zone = getenv("TZ");
- if (zone != NULL) {
- /*
- * TZ is of form "NST-4:30NDT", where "NST" would be the name of the
- * standard time zone for this area, "-4:30" is the offset from GMT in
- * hours, and "NDT is the name of the daylight savings time zone in
- * this area. The offset and DST strings are optional.
- */
-
- len = strlen(zone);
- if (len > 3) {
- len = 3;
- }
- if (dst != 0) {
- /*
- * Skip the offset string and get the DST string.
- */
-
- p = zone + len;
- p += strspn(p, "+-:0123456789");
- if (*p != '\0') {
- zone = p;
- len = strlen(zone);
- if (len > 3) {
- len = 3;
- }
- }
- }
- Tcl_ExternalToUtf(NULL, NULL, zone, len, 0, NULL, name,
- sizeof(tsdPtr->tzName), NULL, NULL, NULL);
- }
- if (name[0] == '\0') {
- if (GetTimeZoneInformation(&tz) == TIME_ZONE_ID_UNKNOWN) {
- /*
- * MSDN: On NT this is returned if DST is not used in the current
- * TZ
- */
-
- dst = 0;
- }
- encoding = Tcl_GetEncoding(NULL, "unicode");
- Tcl_ExternalToUtf(NULL, encoding,
- (char *) ((dst) ? tz.DaylightName : tz.StandardName), -1,
- 0, NULL, name, sizeof(tsdPtr->tzName), NULL, NULL, NULL);
- Tcl_FreeEncoding(encoding);
- }
- return name;
-}
-
-/*
- *----------------------------------------------------------------------
- *
* TclpGetDate --
*
* This function converts between seconds and struct tm. If useGMT is
@@ -622,7 +506,7 @@ TclpGetTZName(
struct tm *
TclpGetDate(
- CONST time_t *t,
+ const time_t *t,
int useGMT)
{
struct tm *tmPtr;
@@ -1168,7 +1052,7 @@ AccumulateSample(
struct tm *
TclpGmtime(
- CONST time_t *timePtr) /* Pointer to the number of seconds since the
+ const time_t *timePtr) /* Pointer to the number of seconds since the
* local system's epoch */
{
/*
@@ -1199,9 +1083,8 @@ TclpGmtime(
struct tm *
TclpLocaltime(
- CONST time_t *timePtr) /* Pointer to the number of seconds since the
+ const time_t *timePtr) /* Pointer to the number of seconds since the
* local system's epoch */
-
{
/*
* The MS implementation of localtime is thread safe because it returns
diff --git a/win/tclooConfig.sh b/win/tclooConfig.sh
new file mode 100644
index 0000000..ee10b81
--- /dev/null
+++ b/win/tclooConfig.sh
@@ -0,0 +1,19 @@
+# tclooConfig.sh --
+#
+# This shell script (for sh) is generated automatically by TclOO's configure
+# script, or would be except it has no values that we substitute. It will
+# create shell variables for most of the configuration options discovered by
+# the configure script. This script is intended to be included by TEA-based
+# configure scripts for TclOO extensions so that they don't have to figure
+# this all out for themselves.
+#
+# The information in this file is specific to a single platform.
+
+# These are mostly empty because no special steps are ever needed from Tcl 8.6
+# onwards; all libraries and include files are just part of Tcl.
+TCLOO_LIB_SPEC=""
+TCLOO_STUB_LIB_SPEC=""
+TCLOO_INCLUDE_SPEC=""
+TCLOO_PRIVATE_INCLUDE_SPEC=""
+TCLOO_CFLAGS=""
+TCLOO_VERSION=1.0.4
diff --git a/win/tclsh.ico b/win/tclsh.ico
index 8bcaf48..e254318 100644
--- a/win/tclsh.ico
+++ b/win/tclsh.ico
Binary files differ