diff options
Diffstat (limited to 'win')
37 files changed, 4646 insertions, 4508 deletions
diff --git a/win/Makefile.in b/win/Makefile.in index 6748f1b..0c6704b 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -80,7 +80,12 @@ CFLAGS_OPTIMIZE = @CFLAGS_OPTIMIZE@ #CFLAGS = $(CFLAGS_DEBUG) #CFLAGS = $(CFLAGS_OPTIMIZE) #CFLAGS = $(CFLAGS_DEBUG) $(CFLAGS_OPTIMIZE) -CFLAGS = @CFLAGS@ @CFLAGS_DEFAULT@ +CFLAGS = @CFLAGS@ @CFLAGS_DEFAULT@ -DUNICODE -D_UNICODE + +# To compile without backward compatibility and deprecated code uncomment the +# following +NO_DEPRECATED_FLAGS = +#NO_DEPRECATED_FLAGS = -DTCL_NO_DEPRECATED # To enable compilation debugging reverse the comment characters on one of the # following lines. @@ -88,15 +93,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@ @@ -112,7 +117,7 @@ ROOT_DIR_NATIVE = $(shell $(CYGPATH) '$(ROOT_DIR)' | sed 's!\\!/!g') # 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)' | sed 's!\\!/!g') DLLSUFFIX = @DLLSUFFIX@ LIBSUFFIX = @LIBSUFFIX@ @@ -129,37 +134,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} +REG_LIB_FILE = @LIBPREFIX@tclreg$(REGVER)${LIBSUFFIX} +TEST_DLL_FILE = tcltest$(VER)${DLLSUFFIX} +TEST_LIB_FILE = @LIBPREFIX@tcltest$(VER)${LIBSUFFIX} +ZLIB_DLL_FILE = zlib1.dll -SHARED_LIBRARIES = $(TCL_DLL_FILE) $(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 - -# 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@ @@ -177,10 +178,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@ @ZLIB_LIBS@ RMDIR = rm -rf MKDIR = mkdir -p @@ -188,7 +189,7 @@ SHELL = @SHELL@ RM = rm -f COPY = cp -CC_SWITCHES = ${CFLAGS} ${CFLAGS_WARNING} ${TCL_SHLIB_CFLAGS} \ +CC_SWITCHES = ${CFLAGS} ${CFLAGS_WARNING} ${TCL_SHLIB_CFLAGS} -I"${ZLIB_DIR}" \ -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} @@ -206,8 +207,7 @@ TCLTEST_OBJS = \ tclTestObj.$(OBJEXT) \ tclTestProcBodyObj.$(OBJEXT) \ tclThreadTest.$(OBJEXT) \ - tclWinTest.$(OBJEXT) \ - testMain.$(OBJEXT) + tclWinTest.$(OBJEXT) GENERIC_OBJS = \ regcomp.$(OBJEXT) \ @@ -215,6 +215,7 @@ GENERIC_OBJS = \ regfree.$(OBJEXT) \ regerror.$(OBJEXT) \ tclAlloc.$(OBJEXT) \ + tclAssembly.$(OBJEXT) \ tclAsync.$(OBJEXT) \ tclBasic.$(OBJEXT) \ tclBinary.$(OBJEXT) \ @@ -224,12 +225,15 @@ GENERIC_OBJS = \ tclCmdIL.$(OBJEXT) \ tclCmdMZ.$(OBJEXT) \ tclCompCmds.$(OBJEXT) \ + tclCompCmdsGR.$(OBJEXT) \ + tclCompCmdsSZ.$(OBJEXT) \ tclCompExpr.$(OBJEXT) \ tclCompile.$(OBJEXT) \ tclConfig.$(OBJEXT) \ tclDate.$(OBJEXT) \ tclDictObj.$(OBJEXT) \ tclEncoding.$(OBJEXT) \ + tclEnsemble.$(OBJEXT) \ tclEnv.$(OBJEXT) \ tclEvent.$(OBJEXT) \ tclExecute.$(OBJEXT) \ @@ -244,6 +248,7 @@ GENERIC_OBJS = \ tclIOCmd.$(OBJEXT) \ tclIOGT.$(OBJEXT) \ tclIORChan.$(OBJEXT) \ + tclIORTrans.$(OBJEXT) \ tclIOSock.$(OBJEXT) \ tclIOUtil.$(OBJEXT) \ tclLink.$(OBJEXT) \ @@ -251,9 +256,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) \ @@ -270,7 +284,6 @@ GENERIC_OBJS = \ tclStringObj.$(OBJEXT) \ tclStrToD.$(OBJEXT) \ tclStubInit.$(OBJEXT) \ - tclStubLib.$(OBJEXT) \ tclThread.$(OBJEXT) \ tclThreadAlloc.$(OBJEXT) \ tclThreadJoin.$(OBJEXT) \ @@ -280,7 +293,8 @@ GENERIC_OBJS = \ tclTrace.$(OBJEXT) \ tclUtf.$(OBJEXT) \ tclUtil.$(OBJEXT) \ - tclVar.$(OBJEXT) + tclVar.$(OBJEXT) \ + tclZlib.$(OBJEXT) TOMMATH_OBJS = \ bncore.${OBJEXT} \ @@ -365,45 +379,46 @@ 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) +binaries: $(TCL_STUB_LIB_FILE) @LIBRARIES@ $(DDE_DLL_FILE) $(REG_DLL_FILE) $(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 - -$(MAN2TCL): $(ROOT_DIR)/tools/man2tcl.c - $(CC) $(CFLAGS_OPTIMIZE) $(MAN2TCLFLAGS) -o $(MAN2TCL) "$(ROOT_DIR_NATIVE)"/tools/man2tcl.c - -$(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@ - -$(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@ @@ -421,37 +436,33 @@ ${TCL_STUB_LIB_FILE}: ${STUB_OBJS} @MAKE_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} @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} @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} +${TEST_DLL_FILE}: ${TCLTEST_OBJS} ${TCL_STUB_LIB_FILE} + @$(RM) ${TEST_DLL_FILE} ${TEST_LIB_FILE} + @MAKE_DLL@ ${TCLTEST_OBJS} $(TCL_STUB_LIB_FILE) $(SHLIB_LD_LIBS) -# PIPE_DLL_FILE is actually an executable, don't build it like a DLL. - -${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}/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. @@ -466,31 +477,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. # @@ -522,6 +515,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 @@ -547,11 +545,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)" ; \ @@ -563,7 +561,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"; \ @@ -571,14 +569,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)/"; \ @@ -587,23 +585,23 @@ 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 @@ -616,7 +614,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"; \ @@ -626,6 +624,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"; \ @@ -642,8 +641,8 @@ install-libraries: libraries install-tzdata install-msgs do \ $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/http1.0"; \ done; - @echo "Installing package http 2.7.12 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/http/http.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.4/http-2.7.12.tm; + @echo "Installing package http 2.8.7 as a Tcl Module"; + @$(COPY) $(ROOT_DIR)/library/http/http.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.6/http-2.8.7.tm; @echo "Installing library opt0.4 directory"; @for j in $(ROOT_DIR)/library/opt/*.tcl; \ do \ @@ -651,8 +650,8 @@ install-libraries: libraries install-tzdata install-msgs 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.5 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/tcltest-2.3.5.tm; + @echo "Installing package tcltest 2.3.6 as a Tcl Module"; + @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/tcltest-2.3.6.tm; @echo "Installing package platform 1.0.12 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/platform/platform.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.4/platform-1.0.12.tm; @echo "Installing package platform::shell 1.1.4 as a Tcl Module"; @@ -664,14 +663,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 @@ -689,6 +686,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)"; \ @@ -698,17 +696,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.0 [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.0 [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` @@ -730,16 +732,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=`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 = `pwd -P`"; \ + $$i/configure --with-tcl=$$builddir --with-tclinclude=$(GENERIC_DIR) $(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. # @@ -753,8 +833,27 @@ 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 @@ -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 @@ -81,7 +81,7 @@ structure. Note that in order to run tclsh85.exe, you must ensure that tcl85.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 0c9b3ac..e4f0a30 100644..100755 --- 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 @@ -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 a0be0c4..fc453f8 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_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 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_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 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=".15" +TCL_MINOR_VERSION=6 +TCL_PATCH_LEVEL=".0" 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 @@ -3500,14 +3512,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 -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' @@ -3521,17 +3599,14 @@ echo $ECHO_N "checking compiler flags... $ECHO_C" >&6 MAKE_EXE="\${CC} -o \$@" LIBPREFIX="lib" - extra_cflags="-pipe" - extra_ldflags="-pipe" + extra_cflags="$extra_cflags -pipe" + extra_ldflags="$extra_ldflags -pipe" if test "${SHARED_BUILD}" = "0" ; then # static 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,30 +3624,30 @@ 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. Make sure CFLAGS is - # included so -mno-cygwin passed the correct libs to the linker. - SHLIB_LD='${CC} -shared ${CFLAGS}' - 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. Make sure CFLAGS is + # included so -mno-cygwin passed the correct libs to the linker. + SHLIB_LD='${CC} -shared ${CFLAGS}' + 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= @@ -3673,28 +3748,23 @@ 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" 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. @@ -3727,7 +3797,7 @@ echo "${ECHO_T} Using 64-bit $MACHINE mode" >&6 fi fi - LIBS="user32.lib advapi32.lib ws2_32.lib" + LIBS="netapi32.lib kernel32.lib user32.lib advapi32.lib ws2_32.lib" if test "$do64bit" != "no" ; then # The space-based-path will work for the Makefile, but will # not work if AC_TRY_COMPILE is called. TEA has the @@ -3925,6 +3995,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 @@ -4259,6 +4330,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}/win64/libz.dll.a + + +else + + ZLIB_LIBS=\${ZLIB_DIR}/win64/zdll.lib + + +fi + + +else + + ZLIB_LIBS=\${ZLIB_DIR}/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 @@ -4530,6 +4667,7 @@ _ACEOF fi + #-------------------------------------------------------------------- # Perform additinal compiler tests. #-------------------------------------------------------------------- @@ -4607,6 +4745,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 @@ -4763,12 +5112,6 @@ eval "TCL_SRC_DIR=\"`cd $srcdir/..; 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`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`pwd` ${TCL_STUB_LIB_FLAG}\"" @@ -4776,6 +5119,10 @@ eval "TCL_STUB_LIB_SPEC=\"-L${libdir} ${TCL_STUB_LIB_FLAG}\"" eval "TCL_BUILD_STUB_LIB_PATH=\"`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`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}\"" @@ -4828,6 +5175,12 @@ fi + + + + + + # empty on win @@ -5568,6 +5921,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 @@ -5576,8 +5932,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 ea25843..373cfcc 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=".15" +TCL_MINOR_VERSION=6 +TCL_PATCH_LEVEL=".0" 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}/win64/libz.dll.a]) + ], [ + AC_SUBST(ZLIB_LIBS,[\${ZLIB_DIR}/win64/zdll.lib]) + ]) + ], [ + AC_SUBST(ZLIB_LIBS,[\${ZLIB_DIR}/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/..; 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`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`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=\"`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`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}\"" @@ -252,9 +354,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 3310b01..a962bc6 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,15 @@ 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)\tclEncoding.obj \ + $(TMPDIR)\tclEnsemble.obj \ $(TMPDIR)\tclEnv.obj \ $(TMPDIR)\tclEvent.obj \ $(TMPDIR)\tclExecute.obj \ @@ -231,7 +231,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 +254,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 +274,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 +289,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 +342,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 +391,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 +414,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 +427,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 +454,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 +462,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 +483,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 +528,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 diff --git a/win/makefile.vc b/win/makefile.vc index 3d17331..cddb253 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -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,15 @@ 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)\tclEncoding.obj \ + $(TMP_DIR)\tclEnsemble.obj \ $(TMP_DIR)\tclEnv.obj \ $(TMP_DIR)\tclEvent.obj \ $(TMP_DIR)\tclExecute.obj \ @@ -285,14 +299,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 +333,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 +343,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 +422,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 +460,7 @@ GENERICDIR = $(ROOT)\generic TOMMATHDIR = $(ROOT)\libtommath TOOLSDIR = $(ROOT)\tools WINDIR = $(ROOT)\win +PKGSDIR = $(ROOT)\pkgs #--------------------------------------------------------------------- # Compile flags @@ -453,7 +502,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) @@ -496,7 +545,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 ws2_32.lib # Avoid 'unresolved external symbol __security_cookie' errors. # c.f. http://support.microsoft.com/?id=894573 !if "$(MACHINE)" == "IA64" || "$(MACHINE)" == "AMD64" @@ -518,27 +567,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.0 [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.0 "$(TCLREGLIB:\=/)" registry] << type tests.log | more !endif @@ -570,7 +619,6 @@ $** $** << $(_VC_MANIFEST_EMBED_DLL) - -@del $*.exp !endif $(TCLSTUBLIB): $(TCLSTUBOBJS) @@ -584,11 +632,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:$@ $** @@ -597,8 +640,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) @@ -609,10 +650,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 \ @@ -630,6 +701,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 @@ -845,6 +918,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$@ $? @@ -854,6 +931,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:\=\\)\"" \ @@ -899,6 +979,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$@ $? + #--------------------------------------------------------------------- # Generate the source dependencies. Having dependency rules will # improve incremental build accuracy without having to resort to a @@ -934,7 +1020,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:: @@ -957,6 +1045,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)" \ -d DEBUG=$(DEBUG) -d UNCHECKED=$(UNCHECKED) \ @@ -983,10 +1076,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)\" @@ -1007,9 +1096,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)\" @@ -1027,6 +1120,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\" @@ -1035,7 +1129,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" @@ -1106,7 +1200,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 ... diff --git a/win/nmakehlp.c b/win/nmakehlp.c index d0edcf0..b1a1517 100644 --- a/win/nmakehlp.c +++ b/win/nmakehlp.c @@ -498,9 +498,10 @@ GetVersionFromFile( p = strstr(szBuffer, match); if (p != NULL) { /* - * Skip to first digit. + * Skip to first digit after the match. */ + p += strlen(match); while (*p && !isdigit(*p)) { ++p; } @@ -630,11 +631,11 @@ SubstituteFile( } } #endif - + /* * Run the substitutions over each line of the input */ - + while (fgets(szBuffer, cbBuffer, fp) != NULL) { list_item_t *p = NULL; for (p = substPtr; p != NULL; p = p->nextPtr) { @@ -654,7 +655,7 @@ SubstituteFile( } printf(szBuffer); } - + list_free(&substPtr); } fclose(fp); diff --git a/win/rules.vc b/win/rules.vc index bbf7485..1513198 100644 --- a/win/rules.vc +++ b/win/rules.vc @@ -159,7 +159,7 @@ DEBUGFLAGS = $(DEBUGFLAGS) -RTC1 DEBUGFLAGS = $(DEBUGFLAGS) -GZ !endif -COMPILERFLAGS =-W3 +COMPILERFLAGS =-W3 -DUNICODE -D_UNICODE # 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"] @@ -246,13 +246,13 @@ 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 +585,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 +598,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 b3de0ff..57ec6bf 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 0d01f35..3bdccbe 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 @@ -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) ]) @@ -556,6 +556,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 -w, echo) @@ -645,13 +646,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 -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' @@ -665,16 +684,13 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ MAKE_EXE="\${CC} -o \[$]@" LIBPREFIX="lib" - extra_cflags="-pipe" - extra_ldflags="-pipe" + extra_cflags="$extra_cflags -pipe" + extra_ldflags="$extra_ldflags -pipe" if test "${SHARED_BUILD}" = "0" ; then # 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 @@ -688,30 +704,30 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ fi runtime= - # Link with gcc since ld does not link to default libs like - # -luser32 and -lmsvcrt by default. Make sure CFLAGS is - # included so -mno-cygwin passed the correct libs to the linker. - SHLIB_LD='${CC} -shared ${CFLAGS}' - 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. Make sure CFLAGS is + # included so -mno-cygwin passed the correct libs to the linker. + SHLIB_LD='${CC} -shared ${CFLAGS}' + 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,27 +782,22 @@ 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" 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. @@ -816,7 +827,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ fi fi - LIBS="user32.lib advapi32.lib ws2_32.lib" + LIBS="netapi32.lib kernel32.lib user32.lib advapi32.lib ws2_32.lib" if test "$do64bit" != "no" ; then # The space-based-path will work for the Makefile, but will # not work if AC_TRY_COMPILE is called. TEA has the @@ -941,6 +952,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 @@ -1100,13 +1112,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 0edd2c3..88699d3 100644 --- a/win/tclAppInit.c +++ b/win/tclAppInit.c @@ -2,30 +2,64 @@ * 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 #include <windows.h> +#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__) -static void setargv(int *argcPtr, char ***argvPtr); -#endif /* __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 +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 /* *---------------------------------------------------------------------- @@ -35,53 +69,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. @@ -98,7 +124,6 @@ main( #endif Tcl_Main(argc, argv, TCL_LOCAL_APPINIT); - return 0; /* Needed only to prevent compiler warning. */ } @@ -107,9 +132,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 @@ -125,57 +150,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. */ /* @@ -185,7 +197,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; } @@ -216,17 +229,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 @@ -245,10 +258,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; @@ -306,7 +324,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 6c863b9..0d3b683 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 @@ -71,150 +50,14 @@ typedef struct EXCEPTION_REGISTRATION { #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 @@ -223,8 +66,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 @@ -243,8 +86,6 @@ TCL_DECLARE_MUTEX(mountPointMap) * We will need this below. */ -extern Tcl_FSDupInternalRepProc TclNativeDupInternalRep; - #ifdef __WIN32__ #ifndef STATIC_BUILD @@ -287,10 +128,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. * *---------------------------------------------------------------------- */ @@ -301,105 +139,16 @@ DllMain( DWORD reason, /* Reason this function is being called. */ LPVOID reserved) /* Not used. */ { -#if defined(HAVE_NO_SEH) && !defined(_WIN64) - EXCEPTION_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 EXCEPTION_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 EXCEPTION_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 EXCEPTION_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 EXCEPTION_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 - * EXCEPTION_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; @@ -457,15 +206,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(); } /* @@ -478,9 +230,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. @@ -526,95 +279,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. @@ -626,115 +295,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 @@ -750,13 +322,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. @@ -766,8 +336,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); @@ -779,8 +349,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. @@ -793,7 +361,10 @@ TclWinResetInterfaceEncodings(void) void TclWinResetInterfaces(void) { - tclWinProcs = &asciiProcs; + if (winTCharEncoding != NULL) { + Tcl_FreeEncoding(winTCharEncoding); + winTCharEncoding = NULL; + } } /* @@ -820,11 +391,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 @@ -835,28 +406,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; } } @@ -883,8 +454,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 @@ -907,23 +478,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; } } } @@ -934,9 +505,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; } } @@ -945,11 +516,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; } @@ -1006,27 +577,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); } /* @@ -1054,11 +625,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 8aa2772..52b9e32 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, @@ -100,7 +100,7 @@ static DWORD FileGetType(HANDLE handle); * 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. */ }; #ifdef HAVE_NO_SEH @@ -128,11 +128,11 @@ static Tcl_ChannelType fileChannelType = { */ typedef struct EXCEPTION_REGISTRATION { - struct EXCEPTION_REGISTRATION* link; + struct EXCEPTION_REGISTRATION *link; EXCEPTION_DISPOSITION (*handler)( struct _EXCEPTION_RECORD*, void*, struct _CONTEXT*, void*); - void* ebp; - void* esp; + void *ebp; + void *esp; int status; } EXCEPTION_REGISTRATION; #endif @@ -274,7 +274,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); @@ -357,7 +357,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, @@ -395,7 +395,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; @@ -441,7 +441,7 @@ FileCloseProc( break; } } - ckfree((char *)fileInfoPtr); + ckfree(fileInfoPtr); return errorCode; } @@ -470,7 +470,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; @@ -548,7 +548,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; @@ -597,7 +597,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; /* @@ -673,11 +673,10 @@ 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; /* * Note that we will block on reads from a console buffer until a full @@ -721,11 +720,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; @@ -772,7 +771,7 @@ FileWatchProc( * of TCL_READABLE, TCL_WRITABLE and * TCL_EXCEPTION. */ { - FileInfo *infoPtr = (FileInfo *) instanceData; + FileInfo *infoPtr = instanceData; Tcl_Time blockTime = { 0, 0 }; /* @@ -810,7 +809,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; @@ -850,12 +849,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) { return NULL; } @@ -914,7 +913,7 @@ TclpOpenFileChannel( flags = FILE_ATTRIBUTE_READONLY; } } else { - flags = (*tclWinProcs->getFileAttributesProc)(nativeName); + flags = GetFileAttributes(nativeName); if (flags == 0xFFFFFFFF) { flags = 0; } @@ -930,8 +929,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(); @@ -941,8 +940,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; } @@ -960,9 +960,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; } @@ -996,8 +996,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; } @@ -1223,8 +1226,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) { @@ -1323,7 +1326,7 @@ TclWinOpenFileChannel( } } - infoPtr = (FileInfo *) ckalloc((unsigned) sizeof(FileInfo)); + infoPtr = ckalloc(sizeof(FileInfo)); /* * TIP #218. Removed the code inserting the new structure into the global @@ -1337,10 +1340,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 @@ -1414,7 +1417,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; diff --git a/win/tclWinConsole.c b/win/tclWinConsole.c index 361fb3d..65e4aed 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,32 @@ 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); + + result = ReadConsole(hConsole, lpBuffer, nbytes / tcharsize, &ntchars, + NULL); + 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 +266,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 +280,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 +308,7 @@ ConsoleInit(void) static void ConsoleExitHandler( - ClientData clientData) /* Old window proc */ + ClientData clientData) /* Old window proc. */ { Tcl_DeleteEventSource(ConsoleSetupProc, ConsoleCheckProc, NULL); } @@ -310,7 +332,7 @@ ConsoleExitHandler( static void ProcExitHandler( - ClientData clientData) /* Old window proc */ + ClientData clientData) /* Old window proc. */ { Tcl_MutexLock(&consoleMutex); initialized = 0; @@ -355,7 +377,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 +416,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 +440,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 +453,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 +463,6 @@ ConsoleCheckProc( } } - /* *---------------------------------------------------------------------- * @@ -462,7 +485,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 +498,7 @@ ConsoleBlockModeProc( if (mode == TCL_MODE_NONBLOCKING) { infoPtr->flags |= CONSOLE_ASYNC; } else { - infoPtr->flags &= ~(CONSOLE_ASYNC); + infoPtr->flags &= ~CONSOLE_ASYNC; } return 0; } @@ -483,6 +506,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 +602,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 +613,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 +624,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. + * prevent infinite wait on exit. [Python Bug 216289] */ - SetEvent(consolePtr->stopWriter); - - /* - * Wait at most 20 milliseconds for the writer thread to close. - */ - - 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 +663,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 +672,7 @@ ConsoleCloseProc( ckfree(consolePtr->writeBuf); consolePtr->writeBuf = 0; } - ckfree((char*) consolePtr); + ckfree(consolePtr); return errorCode; } @@ -688,7 +703,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 +738,7 @@ ConsoleInputProc( bytesRead = infoPtr->bytesRead - infoPtr->offset; /* - * Reset the buffer + * Reset the buffer. */ infoPtr->readFlags &= ~CONSOLE_BUFFERED; @@ -739,8 +754,8 @@ 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) { buf[count] = '\0'; return count; } @@ -769,16 +784,17 @@ 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. @@ -813,12 +829,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 +842,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 +882,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 +901,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 +922,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 +970,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 +982,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 +1025,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 +1063,7 @@ WaitForRead( { DWORD timeout, count; HANDLE *handle = infoPtr->handle; + ConsoleThreadInfo *threadInfo = &infoPtr->reader; INPUT_RECORD input; while (1) { @@ -1054,7 +1072,8 @@ 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. @@ -1113,8 +1132,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 +1160,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 +1194,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 +1202,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 +1214,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 +1228,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 +1260,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 +1298,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 +1312,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 +1348,7 @@ ConsoleWriterThread( * Returns the new channel, or NULL. * * Side effects: - * May open the channel + * May open the channel. * *---------------------------------------------------------------------- */ @@ -1336,7 +1361,7 @@ TclWinOpenConsoleChannel( { char encoding[4 + TCL_INTEGER_SPACE]; ConsoleInfo *infoPtr; - DWORD id, modes; + DWORD modes; ConsoleInit(); @@ -1344,7 +1369,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 +1386,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 +1402,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 +1416,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 +1445,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..49eeed3 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,8 +291,8 @@ static CONST unsigned char errorTable[] = { * errno errors. */ -static CONST int wsaErrorTable[] = { - EWOULDBLOCK, /* WSAEWOULDBLOCK */ +static const unsigned char wsaErrorTable[] = { + EAGAIN, /* WSAEWOULDBLOCK */ EINPROGRESS, /* WSAEINPROGRESS */ EALREADY, /* WSAEALREADY */ ENOTSOCK, /* WSAENOTSOCK */ @@ -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. */ +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 d918b4a..0476915 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}, @@ -90,7 +90,7 @@ typedef struct EXCEPTION_REGISTRATION { * 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); /* @@ -101,18 +101,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, @@ -170,9 +170,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) @@ -275,7 +275,7 @@ DoRenameFile( [registration] "m" (registration), [nativeDst] "m" (nativeDst), [nativeSrc] "m" (nativeSrc), - [moveFile] "r" (tclWinProcs->moveFileProc) + [moveFile] "r" (MoveFile) : "%eax", "%ebx", "%ecx", "%edx", "memory" ); @@ -286,7 +286,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 @@ -300,10 +300,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; @@ -311,7 +311,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; @@ -327,28 +327,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 @@ -395,8 +395,8 @@ DoRenameFile( Tcl_SetErrno(EXDEV); } - ckfree((char *) srcArgv); - ckfree((char *) dstArgv); + ckfree(srcArgv); + ckfree(dstArgv); } /* @@ -427,7 +427,7 @@ DoRenameFile( * directory back, for completeness. */ - if ((*tclWinProcs->moveFileProc)(nativeSrc, + if (MoveFile(nativeSrc, nativeDst) != FALSE) { return TCL_OK; } @@ -438,8 +438,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. @@ -466,22 +466,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 @@ -489,19 +487,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); } } @@ -564,8 +559,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) EXCEPTION_REGISTRATION registration; @@ -668,7 +663,7 @@ DoCopyFile( [registration] "m" (registration), [nativeDst] "m" (nativeDst), [nativeSrc] "m" (nativeSrc), - [copyFile] "r" (tclWinProcs->copyFileProc) + [copyFile] "r" (CopyFile) : "%eax", "%ebx", "%ecx", "%edx", "memory" ); @@ -679,7 +674,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 @@ -699,8 +694,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; @@ -716,9 +711,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; } @@ -729,7 +724,7 @@ DoCopyFile( */ TclWinConvertError(GetLastError()); - (*tclWinProcs->setFileAttributesProc)(nativeDst, dstAttr); + SetFileAttributes(nativeDst, dstAttr); } } } @@ -770,34 +765,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; } } @@ -811,21 +807,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) { /* @@ -882,11 +878,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; } @@ -1015,13 +1011,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); } @@ -1033,7 +1028,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. */ @@ -1053,7 +1048,7 @@ DoRemoveJustDirectory( goto end; } - attr = (*tclWinProcs->getFileAttributesProc)(nativePath); + attr = GetFileAttributes(nativePath); if (attr & FILE_ATTRIBUTE_REPARSE_POINT) { /* @@ -1067,7 +1062,7 @@ DoRemoveJustDirectory( * Ordinary directory. */ - if ((*tclWinProcs->removeDirectoryProc)(nativePath) != FALSE) { + if (RemoveDirectory(nativePath) != FALSE) { return TCL_OK; } } @@ -1075,7 +1070,7 @@ DoRemoveJustDirectory( TclWinConvertError(GetLastError()); if (Tcl_GetErrno() == EACCES) { - attr = (*tclWinProcs->getFileAttributesProc)(nativePath); + attr = GetFileAttributes(nativePath); if (attr != 0xffffffff) { if ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0) { /* @@ -1099,60 +1094,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); - } } } @@ -1192,7 +1144,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)) { @@ -1246,7 +1198,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; @@ -1257,7 +1209,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; @@ -1268,7 +1220,7 @@ TraverseWinTree( * Process the symbolic link */ - return (*traverseProc)(nativeSource, nativeTarget, DOTREE_LINK, + return traverseProc(nativeSource, nativeTarget, DOTREE_LINK, errorPtr); } @@ -1277,18 +1229,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. @@ -1299,67 +1247,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. @@ -1404,8 +1329,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); } @@ -1440,8 +1365,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. */ @@ -1459,9 +1384,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; } @@ -1506,8 +1431,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. */ @@ -1562,8 +1487,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))); } /* @@ -1593,11 +1518,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); @@ -1615,7 +1540,7 @@ GetWinFileAttributes( */ int len; - char *str = Tcl_GetStringFromObj(fileName,&len); + const char *str = Tcl_GetStringFromObj(fileName,&len); if (len < 4) { if (len == 0) { @@ -1681,9 +1606,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; } @@ -1724,10 +1651,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; @@ -1743,7 +1670,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 @@ -1752,7 +1679,7 @@ ConvertFileNameFormat( * root directory */ - attr = (*tclWinProcs->getFileAttributesProc)(nativeName); + attr = GetFileAttributes(nativeName); if ((attr!=0xFFFFFFFF) && (attr & FILE_ATTRIBUTE_DIRECTORY)) { Tcl_DStringFree(&ds); goto simple; @@ -1766,27 +1693,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; } } @@ -1804,22 +1718,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); } } @@ -1932,12 +1845,11 @@ SetWinFileAttributes( Tcl_Obj *attributePtr) /* The new value of the attribute. */ { DWORD fileAttributes; - int yesNo; - int result; - CONST TCHAR *nativeName; + int yesNo, result; + const TCHAR *nativeName; nativeName = Tcl_FSGetNativePath(fileName); - fileAttributes = (*tclWinProcs->getFileAttributesProc)(nativeName); + fileAttributes = GetFileAttributes(nativeName); if (fileAttributes == 0xffffffff) { StatError(interp, fileName); @@ -1955,7 +1867,7 @@ SetWinFileAttributes( fileAttributes &= ~(attributeArray[objIndex]); } - if (!(*tclWinProcs->setFileAttributesProc)(nativeName, fileAttributes)) { + if (!SetFileAttributes(nativeName, fileAttributes)) { StatError(interp, fileName); return TCL_ERROR; } @@ -1986,13 +1898,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; } - /* *--------------------------------------------------------------------------- @@ -2010,7 +1922,7 @@ CannotSetAttribute( *--------------------------------------------------------------------------- */ -Tcl_Obj* +Tcl_Obj * TclpObjListVolumes(void) { Tcl_Obj *resultPtr, *elemPtr; diff --git a/win/tclWinFile.c b/win/tclWinFile.c index 676c443..f69ad23 100644 --- a/win/tclWinFile.c +++ b/win/tclWinFile.c @@ -16,7 +16,7 @@ #include "tclFileSystem.h" #include <winioctl.h> #include <shlobj.h> -#include <lmaccess.h> /* For TclpGetUserHome(). */ +#include <lm.h> /* For TclpGetUserHome(). */ /* * The number of 100-ns intervals between the Windows system epoch (1601-01-01 @@ -140,28 +140,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. */ @@ -169,14 +147,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); - /* * Declarations for local functions defined in this file: */ @@ -202,6 +172,7 @@ static int WinLink(const TCHAR *LinkSource, const TCHAR *LinkTarget, int linkAction); static int WinSymLinkDirectory(const TCHAR *LinkDirectory, const TCHAR *LinkTarget); +MODULE_SCOPE void tclWinDebugPanic(const char *format, ...); /* *-------------------------------------------------------------------- @@ -219,7 +190,7 @@ WinLink( const TCHAR *linkTargetPath, int linkAction) { - WCHAR tempFileName[MAX_PATH]; + TCHAR tempFileName[MAX_PATH]; TCHAR *tempFilePart; DWORD attr; @@ -227,8 +198,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. */ @@ -241,7 +212,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; @@ -251,8 +222,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. */ @@ -265,43 +236,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 { /* @@ -318,12 +282,11 @@ WinLink( */ Tcl_SetErrno(EISDIR); - return -1; } else { Tcl_SetErrno(ENODEV); - return -1; } } + return -1; } /* @@ -340,7 +303,7 @@ static Tcl_Obj * WinReadLink( const TCHAR *linkSourcePath) { - WCHAR tempFileName[MAX_PATH]; + TCHAR tempFileName[MAX_PATH]; TCHAR *tempFilePart; DWORD attr; @@ -348,8 +311,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. */ @@ -362,7 +325,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. @@ -378,9 +341,9 @@ WinReadLink( Tcl_SetErrno(ENOTDIR); return NULL; - } else { - return WinReadLinkDirectory(linkSourcePath); } + + return WinReadLinkDirectory(linkSourcePath); } /* @@ -519,9 +482,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, @@ -535,7 +497,7 @@ TclWinSymLinkDelete( } else { CloseHandle(hFile); if (!linkOnly) { - (*tclWinProcs->removeDirectoryProc)(linkOrigPath); + RemoveDirectory(linkOrigPath); } return 0; } @@ -575,7 +537,7 @@ WinReadLinkDirectory( Tcl_DString ds; const char *copy; - attr = (*tclWinProcs->getFileAttributesProc)(linkDirPath); + attr = GetFileAttributes(linkDirPath); if (!(attr & FILE_ATTRIBUTE_REPARSE_POINT)) { goto invalidError; } @@ -600,6 +562,7 @@ WinReadLinkDirectory( */ offset = 0; +#ifdef UNICODE if (reparseBuffer->MountPointReparseBuffer.PathBuffer[0] == L'\\') { /* * Check whether this is a mounted volume. @@ -661,8 +624,9 @@ WinReadLinkDirectory( offset = 4; } } +#endif /* UNICODE */ - Tcl_WinTCharToUtf((const char *) + Tcl_WinTCharToUtf((const TCHAR *) reparseBuffer->MountPointReparseBuffer.PathBuffer, (int) reparseBuffer->MountPointReparseBuffer .SubstituteNameLength, &ds); @@ -704,9 +668,8 @@ NativeReadReparse( HANDLE hFile; DWORD returnedLength; - hFile = (*tclWinProcs->createFileProc)(linkDirPath, desiredAccess, 0, - NULL, OPEN_EXISTING, - FILE_FLAG_OPEN_REPARSE_POINT|FILE_FLAG_BACKUP_SEMANTICS, NULL); + hFile = CreateFile(linkDirPath, desiredAccess, 0, NULL, OPEN_EXISTING, + FILE_FLAG_OPEN_REPARSE_POINT | FILE_FLAG_BACKUP_SEMANTICS, NULL); if (hFile == INVALID_HANDLE_VALUE) { /* @@ -764,7 +727,7 @@ NativeWriteReparse( * Create the directory - it must not already exist. */ - if ((*tclWinProcs->createDirectoryProc)(linkDirPath, NULL) == 0) { + if (CreateDirectory(linkDirPath, NULL) == 0) { /* * Error creating directory. */ @@ -772,9 +735,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. @@ -797,7 +760,7 @@ NativeWriteReparse( TclWinConvertError(GetLastError()); CloseHandle(hFile); - (*tclWinProcs->removeDirectoryProc)(linkDirPath); + RemoveDirectory(linkDirPath); return -1; } CloseHandle(hFile); @@ -810,6 +773,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. + * + *---------------------------------------------------------------------- + */ + +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 -- @@ -828,28 +850,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); } @@ -895,6 +922,7 @@ TclpMatchInDirectory( if (pattern == NULL || (*pattern == '\0')) { Tcl_Obj *norm = Tcl_FSGetNormalizedPath(NULL, pathPtr); + if (norm != NULL) { /* * Match a single file directly. @@ -902,23 +930,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); @@ -928,7 +949,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; @@ -957,9 +978,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; } @@ -974,7 +996,7 @@ TclpMatchInDirectory( lastChar = dirName[dirLength -1]; if ((lastChar != '\\') && (lastChar != '/') && (lastChar != ':')) { - Tcl_DStringAppend(&dsOrig, "/", 1); + TclDStringAppendLiteral(&dsOrig, "/"); dirLength++; } dirName = Tcl_DStringValue(&dsOrig); @@ -994,25 +1016,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) { /* @@ -1026,10 +1048,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; @@ -1069,14 +1090,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) { @@ -1119,6 +1134,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 { @@ -1136,7 +1152,7 @@ TclpMatchInDirectory( */ Tcl_DStringFree(&ds); - } while ((*tclWinProcs->findNextFileProc)(handle, &data) == TRUE); + } while (FindNextFile(handle, &data) == TRUE); FindClose(handle); Tcl_DStringFree(&dsOrig); @@ -1309,81 +1325,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; @@ -1410,80 +1425,56 @@ 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; + 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); + 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 + * "{Windows Drive}:/users/default". + */ - netapiInst = LoadLibraryA("netapi32.dll"); - if (netapiInst != NULL) { - NETAPIBUFFERFREEPROC *netApiBufferFreeProc; - NETGETDCNAMEPROC *netGetDCNameProc; - NETUSERGETINFOPROC *netUserGetInfoProc; - - netApiBufferFreeProc = (NETAPIBUFFERFREEPROC *) - GetProcAddress(netapiInst, "NetApiBufferFree"); - netGetDCNameProc = (NETGETDCNAMEPROC *) - GetProcAddress(netapiInst, "NetGetDCName"); - netUserGetInfoProc = (NETUSERGETINFOPROC *) - GetProcAddress(netapiInst, "NetUserGetInfo"); - if ((netUserGetInfoProc != NULL) && (netGetDCNameProc != NULL) - && (netApiBufferFreeProc != 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 - * "{Windows Drive}:/users/default". - */ - - GetWindowsDirectoryW(buf, MAX_PATH); - Tcl_UniCharToUtfDString(buf, 2, bufferPtr); - Tcl_DStringAppend(bufferPtr, "/users/default", -1); - } - result = Tcl_DStringValue(bufferPtr); - (*netApiBufferFreeProc)((void *) uiPtr); - } - Tcl_DStringFree(&ds); - } - if (wDomain != NULL) { - (*netApiBufferFreeProc)((void *) wDomain); + GetWindowsDirectoryW(buf, MAX_PATH); + Tcl_UniCharToUtfDString(buf, 2, bufferPtr); + TclDStringAppendLiteral(bufferPtr, "/users/default"); } + result = Tcl_DStringValue(bufferPtr); + NetApiBufferFree((void *) uiPtr); } - FreeLibrary(netapiInst); + Tcl_DStringFree(&ds); + } + if (wDomain != NULL) { + NetApiBufferFree((void *) wDomain); } if (result == NULL) { /* @@ -1539,9 +1530,9 @@ NativeAccess( { DWORD attr; - attr = (*tclWinProcs->getFileAttributesProc)(nativePath); + attr = GetFileAttributes(nativePath); - if (attr == 0xffffffff) { + if (attr == INVALID_FILE_ATTRIBUTES) { /* * File might not exist. */ @@ -1597,7 +1588,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; @@ -1612,11 +1604,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); @@ -1650,7 +1642,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)) { @@ -1686,14 +1678,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. @@ -1702,7 +1694,7 @@ NativeAccess( goto accessError; } - (*tclWinProcs->revertToSelfProc)(); + RevertToSelf(); /* * Setup desiredAccess according to the access priveleges we are @@ -1729,7 +1721,7 @@ NativeAccess( * Perform access check using the token. */ - if (!(*tclWinProcs->accessCheckProc)(sdPtr, hToken, desiredAccess, + if (!AccessCheck(sdPtr, hToken, desiredAccess, &genMap, &privSet, &privSetSize, &grantedAccess, &accessYesNo)) { /* @@ -1759,6 +1751,7 @@ NativeAccess( } } +#endif /* !UNICODE */ return 0; } @@ -1778,55 +1771,22 @@ 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; - } - - 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++; + int len = _tcslen(path); - /* - * 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, "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("bat")) == 0)) { + return 1; } return 0; } @@ -1854,9 +1814,9 @@ TclpObjChdir( int result; const TCHAR *nativePath; - nativePath = (const TCHAR *) Tcl_FSGetNativePath(pathPtr); + nativePath = Tcl_FSGetNativePath(pathPtr); - result = (*tclWinProcs->setCurrentDirectoryProc)(nativePath); + result = SetCurrentDirectory(nativePath); if (result == 0) { TclWinConvertError(GetLastError()); @@ -1893,14 +1853,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; } @@ -1909,25 +1871,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. @@ -1954,8 +1903,7 @@ TclpObjStat( TclWinFlushDirtyChannels(); - return NativeStat((const TCHAR *) Tcl_FSGetNativePath(pathPtr), - statPtr, 0); + return NativeStat(Tcl_FSGetNativePath(pathPtr), statPtr, 0); } /* @@ -2001,7 +1949,7 @@ NativeStat( * simpler routines. */ - 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); @@ -2040,24 +1988,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; @@ -2073,46 +2021,6 @@ 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); @@ -2144,14 +2052,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; @@ -2167,15 +2073,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", @@ -2287,8 +2192,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; } @@ -2318,34 +2224,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 @@ -2353,7 +2245,7 @@ TclpObjAccess( Tcl_Obj *pathPtr, int mode) { - return NativeAccess((const TCHAR *) Tcl_FSGetNativePath(pathPtr), mode); + return NativeAccess(Tcl_FSGetNativePath(pathPtr), mode); } int @@ -2369,8 +2261,7 @@ TclpObjLstat( TclWinFlushDirtyChannels(); - return NativeStat((const TCHAR *) Tcl_FSGetNativePath(pathPtr), - statPtr, 1); + return NativeStat(Tcl_FSGetNativePath(pathPtr), statPtr, 1); } #ifdef S_IFLNK @@ -2382,15 +2273,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; @@ -2402,7 +2293,7 @@ TclpObjLink( return NULL; } } else { - TCHAR *LinkSource = (TCHAR *) Tcl_FSGetNativePath(pathPtr); + const TCHAR *LinkSource = Tcl_FSGetNativePath(pathPtr); if (LinkSource == NULL) { return NULL; @@ -2410,7 +2301,7 @@ TclpObjLink( return WinReadLink(LinkSource); } } -#endif +#endif /* S_IFLNK */ /* *--------------------------------------------------------------------------- @@ -2436,7 +2327,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); @@ -2451,16 +2342,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); } @@ -2468,13 +2357,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 } @@ -2524,377 +2409,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. - */ + int len = WinIsReserved(path); - 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; - - /* - * Path is just dots. We shouldn't really ever see a - * path like that. However, to be nice we at least - * don't mangle the path - we just add the dots as a - * path segment and continue - */ - - Tcl_DStringAppend(&dsNorm, (TCHAR *) - (nativePath + Tcl_DStringLength(&ds)-dotLen), - dotLen); - } else { + if (len > 0) { /* - * Normal path. + * Actually it does exist - COM1, etc. */ - 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; - } - - /* - * This is usually the '/' in 'c:/' at end of - * string. - */ + int i; - Tcl_DStringAppend(&dsNorm,"/", 1); - } else { - char *nativeName; + for (i=0 ; i<len ; i++) { + WCHAR wc = ((WCHAR *) nativePath)[i]; - 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 /* @@ -2903,10 +2630,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. @@ -2915,10 +2642,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 */ } /* @@ -2933,11 +2661,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. @@ -2947,7 +2673,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); @@ -2958,10 +2684,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); @@ -2973,6 +2698,7 @@ TclpObjNormalizePath( if (temp != NULL) { Tcl_DecrRefCount(temp); } + return nextCheckpoint; } @@ -3112,7 +2838,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); @@ -3207,17 +2933,13 @@ TclNativeCreateNativeRep( } } Tcl_WinUtfToTChar(str, len, &ds); - if (tclWinProcs->useWide) { - len = Tcl_DStringLength(&ds) + sizeof(WCHAR); - } else { - len = Tcl_DStringLength(&ds) + sizeof(char); - } + len = Tcl_DStringLength(&ds) + sizeof(WCHAR); Tcl_DecrRefCount(validPathPtr); - nativePathPtr = ckalloc((unsigned) len); + nativePathPtr = ckalloc(len); memcpy(nativePathPtr, Tcl_DStringValue(&ds), (size_t) len); Tcl_DStringFree(&ds); - return (ClientData) nativePathPtr; + return nativePathPtr; } /* @@ -3248,23 +2970,11 @@ TclNativeDupInternalRep( return NULL; } - if (tclWinProcs->useWide) { - /* - * Unicode representation when running on NT/2K/XP. - */ - - 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); - } + len = sizeof(TCHAR) * (_tcslen((const TCHAR *) clientData) + 1); - copy = (char *) ckalloc(len); + copy = ckalloc(len); memcpy(copy, clientData, len); - return (ClientData) copy; + return copy; } /* @@ -3299,9 +3009,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; @@ -3312,8 +3022,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)) { diff --git a/win/tclWinInit.c b/win/tclWinInit.c index 5baf020..d82944e 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); /* *--------------------------------------------------------------------------- @@ -182,7 +182,7 @@ TclpInitLibraryPath( #define LIBRARY_SIZE 64 Tcl_Obj *pathPtr; char installLib[LIBRARY_SIZE]; - char *bytes; + const char *bytes; pathPtr = Tcl_NewObj(); @@ -219,7 +219,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); } @@ -246,14 +246,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; /* @@ -299,8 +299,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 @@ -310,14 +308,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); } } @@ -417,7 +414,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); } @@ -440,7 +437,7 @@ InitializeSourceLibraryDir( static int ToUtf( - CONST WCHAR *wSrc, + const WCHAR *wSrc, char *dst) { char *start; @@ -457,31 +454,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 @@ -514,18 +486,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) { @@ -557,7 +524,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; @@ -565,7 +532,7 @@ TclpSetVariables( } sys; OSVERSIONINFOA osInfo; Tcl_DString ds; - WCHAR szUserName[UNLEN+1]; + TCHAR szUserName[UNLEN+1]; DWORD cchUserNameLen = UNLEN; Tcl_SetVar2Ex(interp, "tclDefaultLibrary", NULL, @@ -594,7 +561,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 @@ -639,15 +606,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); } /* @@ -672,7 +645,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 @@ -680,7 +653,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; @@ -689,7 +662,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 2f6659c..882b811 100644 --- a/win/tclWinInt.h +++ b/win/tclWinInt.h @@ -15,14 +15,6 @@ #include "tclInt.h" /* - * 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. @@ -42,124 +34,12 @@ #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); @@ -169,12 +49,11 @@ MODULE_SCOPE Tcl_Channel TclWinOpenFileChannel(HANDLE handle, char *channelName, int permissions, int appendMode); MODULE_SCOPE Tcl_Channel TclWinOpenSerialChannel(HANDLE handle, char *channelName, int permissions); -MODULE_SCOPE void TclWinResetInterfaceEncodings(); -MODULE_SCOPE HANDLE TclWinSerialReopen(HANDLE handle, CONST TCHAR *name, +MODULE_SCOPE HANDLE TclWinSerialReopen(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); #if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC) MODULE_SCOPE void TclWinFreeAllocCache(void); diff --git a/win/tclWinLoad.c b/win/tclWinLoad.c index c4d08e8..3e11224 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, @@ -107,38 +104,55 @@ TclpDlopen( switch (lastError) { case ERROR_MOD_NOT_FOUND: + Tcl_SetErrorCode(interp, "WIN_LOAD", "MOD_NOT_FOUND", NULL); + goto notFoundMsg; case ERROR_DLL_NOT_FOUND: - Tcl_AppendResult(interp, "this library or a dependent library" - " could not be found in library path", NULL); + 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_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); + 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_AppendResult(interp, "this library or a dependent library" - " is damaged", NULL); + 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_AppendResult(interp, "the library initialization" - " routine failed", NULL); + Tcl_SetErrorCode(interp, "WIN_LOAD", "DLL_INIT_FAILED", NULL); + Tcl_AppendToObj(errMsg, "the library initialization" + " routine failed", -1); break; default: TclWinConvertError(lastError); - Tcl_AppendResult(interp, Tcl_PosixError(interp), NULL); + 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 +165,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 +216,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 +250,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 +259,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(¬ifierMutex); - 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(¬ifierMutex); + if (notifierCount == 0) { + class.style = 0; + class.cbClsExtra = 0; + class.cbWndExtra = 0; + class.hInstance = TclWinGetTclInstance(); + class.hbrBackground = NULL; + class.lpszMenuName = NULL; + class.lpszClassName = classname; + class.lpfnWndProc = NotifierProc; + class.hIcon = NULL; + class.hCursor = NULL; + + if (!RegisterClass(&class)) { + Tcl_Panic("Unable to register TclNotifier window class"); + } } - } - notifierCount++; - Tcl_MutexUnlock(¬ifierMutex); + notifierCount++; + Tcl_MutexUnlock(¬ifierMutex); - 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(¬ifierMutex); - notifierCount--; - if (notifierCount == 0) { - UnregisterClassA("TclNotifier", TclWinGetTclInstance()); + Tcl_MutexLock(¬ifierMutex); + notifierCount--; + if (notifierCount == 0) { + UnregisterClass(classname, TclWinGetTclInstance()); + } + Tcl_MutexUnlock(¬ifierMutex); } - Tcl_MutexUnlock(¬ifierMutex); } /* @@ -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..13caba9 100644 --- a/win/tclWinPipe.c +++ b/win/tclWinPipe.c @@ -192,7 +192,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 +202,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 +219,7 @@ static Tcl_ChannelType pipeChannelType = { NULL, /* handler proc. */ NULL, /* wide seek proc */ PipeThreadActionProc, /* thread action proc */ - NULL, /* truncate */ + NULL /* truncate */ }; /* @@ -404,7 +404,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 +435,7 @@ TclWinMakeFile( { WinFile *filePtr; - filePtr = (WinFile *) ckalloc(sizeof(WinFile)); + filePtr = ckalloc(sizeof(WinFile)); filePtr->type = WIN_FILE; filePtr->handle = handle; @@ -464,27 +464,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 +587,7 @@ TclpOpenFile( flags = 0; if (!(mode & O_CREAT)) { - flags = (*tclWinProcs->getFileAttributesProc)(nativePath); + flags = GetFileAttributes(nativePath); if (flags == 0xFFFFFFFF) { flags = 0; } @@ -612,8 +603,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 +651,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 +660,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 +722,7 @@ TclpCreateTempFile( TclWinConvertError(GetLastError()); CloseHandle(handle); - (*tclWinProcs->deleteFileProc)((TCHAR *) name); + DeleteFile(name); return NULL; } @@ -754,13 +745,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 +827,7 @@ TclpCloseFile( if (filePtr->handle != NULL && CloseHandle(filePtr->handle) == FALSE) { TclWinConvertError(GetLastError()); - ckfree((char *) filePtr); + ckfree(filePtr); return -1; } } @@ -846,7 +837,7 @@ TclpCloseFile( Tcl_Panic("TclpCloseFile: unexpected file type"); } - ckfree((char *) filePtr); + ckfree(filePtr); return 0; } @@ -947,7 +938,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 +1028,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 +1049,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 +1069,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 +1077,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 +1111,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 +1123,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 +1152,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,7 +1285,7 @@ ApplicationType( IMAGE_DOS_HEADER header; Tcl_DString nameBuf, ds; const TCHAR *nativeName; - WCHAR nativeFullPath[MAX_PATH]; + TCHAR nativeFullPath[MAX_PATH]; static const char extensions[][5] = {"", ".com", ".exe", ".bat"}; /* @@ -1394,8 +1311,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,11 +1323,11 @@ 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, '.'); @@ -1419,7 +1336,7 @@ ApplicationType( 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 +1403,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 +1416,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 +1461,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 +1471,7 @@ BuildCommandLine( arg = executable; } else { arg = argv[i]; - Tcl_DStringAppend(&ds, " ", 1); + TclDStringAppendLiteral(&ds, " "); } quote = 0; @@ -1564,6 +1480,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 +1490,7 @@ BuildCommandLine( } } if (quote) { - Tcl_DStringAppend(&ds, "\"", 1); + TclDStringAppendLiteral(&ds, "\""); } start = arg; for (special = arg; ; ) { @@ -1602,7 +1519,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 +1529,7 @@ BuildCommandLine( } Tcl_DStringAppend(&ds, start, (int) (special - start)); if (quote) { - Tcl_DStringAppend(&ds, "\"", 1); + TclDStringAppendLiteral(&ds, "\""); } } Tcl_DStringFree(linePtr); @@ -1648,7 +1565,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 +1580,7 @@ TclpCreateCommandChannel( infoPtr->writeBuf = 0; infoPtr->writeBufLen = 0; infoPtr->writeError = 0; - infoPtr->channel = (Tcl_Channel) NULL; + infoPtr->channel = NULL; infoPtr->validMask = 0; @@ -1705,9 +1622,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 +1632,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 +1705,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 +1717,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 +1872,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); - WaitForSingleObject(pipePtr->writable, INFINITE); + if (WaitForSingleObject(pipePtr->writable, 0) == WAIT_TIMEOUT) { + return EAGAIN; + } + + } else { + + WaitForSingleObject(pipePtr->writable, INFINITE); + + } /* * The thread may already have closed on it's own. Check its exit @@ -2025,12 +2001,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 +2015,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; @@ -2215,7 +2190,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 +2569,7 @@ Tcl_WaitPid( */ CloseHandle(infoPtr->hProcess); - ckfree((char*)infoPtr); + ckfree(infoPtr); return result; } @@ -2620,9 +2595,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,15 +2639,13 @@ 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), NULL); @@ -2687,9 +2660,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); } @@ -2981,6 +2954,10 @@ PipeWriterThread( * an error, so exit. */ + if (waitResult == WAIT_OBJECT_0) { + SetEvent(infoPtr->writable); + } + break; } @@ -3081,6 +3058,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_GetStringFromObj(basenameObj, &length); + + Tcl_WinUtfToTChar(string, length, &buf); + memcpy(namePtr, Tcl_DStringValue(&buf), Tcl_DStringLength(&buf)); + namePtr += Tcl_DStringLength(&buf); + Tcl_DStringFree(&buf); + } else { + const TCHAR *baseStr = TEXT("TCL"); + int length = 3 * sizeof(TCHAR); + + 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 ec9e867..61f149b 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 @@ -385,13 +472,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..327e4a3 100644 --- a/win/tclWinReg.c +++ b/win/tclWinReg.c @@ -12,36 +12,57 @@ * 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 /* + * 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. + */ + +#undef TCL_STORAGE_CLASS +#define TCL_STORAGE_CLASS DLLEXPORT + +/* * 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 +76,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 +87,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 +95,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 +103,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,13 +132,13 @@ 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); @@ -218,25 +165,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.0"); } /* @@ -276,7 +212,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 +242,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 +267,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 +408,23 @@ 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); + buffer = ckalloc(length + 1); strcpy(buffer, keyName); if (ParseKeyName(interp, buffer, &hostName, &rootKey, @@ -459,8 +434,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 +449,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 +467,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,7 +504,8 @@ 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; @@ -540,19 +517,19 @@ 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); 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 +562,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 +582,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 +656,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; + const char *valueName; + const TCHAR *nativeValue; int 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; } @@ -704,15 +681,15 @@ GetType( valueName = Tcl_GetStringFromObj(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,11 +728,12 @@ 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; @@ -764,7 +742,8 @@ GetValue( * 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 +759,12 @@ 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); 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 +773,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 +798,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 +810,17 @@ GetValue( * we get bogus data. */ - while (p < end && ((regWinProcs->useWide) - ? *((Tcl_UniChar *)p) : *p) != 0) { + while ((p < end) && *((Tcl_UniChar *) p) != 0) { + Tcl_UniChar *up; + 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') {} - } + up = (Tcl_UniChar *) p; + + while (*up++ != 0) {/* empty body */} + p = (char *) up; Tcl_DStringFree(&buf); } Tcl_SetObjResult(interp, resultPtr); @@ -885,27 +862,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 +899,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); @@ -983,7 +956,7 @@ OpenKey( DWORD result; keyName = Tcl_GetStringFromObj(keyNameObj, &length); - buffer = ckalloc((unsigned int) length + 1); + buffer = ckalloc(length + 1); strcpy(buffer, keyName); result = ParseKeyName(interp, buffer, &hostName, &rootKey, &keyName); @@ -1039,7 +1012,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 +1028,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 +1104,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 +1158,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 +1177,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,25 +1252,26 @@ 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; + int type, 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; } @@ -1285,8 +1287,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,42 +1309,39 @@ SetValue( Tcl_DStringInit(&data); for (i = 0; i < objc; i++) { - Tcl_DStringAppend(&data, Tcl_GetString(objv[i]), -1); + const char *bytes = Tcl_GetStringFromObj(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_GetStringFromObj(dataObj, &length); - data = Tcl_WinUtfToTChar(data, length, &buf); + data = (char *) Tcl_WinUtfToTChar(data, length, &buf); /* * Include the null in the length, padding if needed for Unicode. */ - 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; @@ -1352,8 +1351,8 @@ SetValue( */ data = (BYTE *) Tcl_GetByteArrayFromObj(dataObj, &length); - result = (*regWinProcs->regSetValueExProc)(key, valueName, 0, - (DWORD) type, data, (DWORD) length); + result = RegSetValueEx(key, (TCHAR *) valueName, 0, + (DWORD) type, data, (DWORD) length); } Tcl_DStringFree(&nameBuf); @@ -1389,33 +1388,27 @@ 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; + const char *str; Tcl_Obj *objPtr; - 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 (objc == 3) { + str = Tcl_GetStringFromObj(objv[1], &len); if ((len < 2) || (*str != '-') || strncmp(str, "-timeout", (size_t) len)) { - Tcl_WrongNumArgs(interp, 2, objv, "keyName ?-timeout millisecs?"); - return TCL_ERROR; + return TCL_BREAK; } - if (Tcl_GetIntFromObj(interp, objv[4], (int *) &timeout) != TCL_OK) { + if (Tcl_GetIntFromObj(interp, objv[2], (int *) &timeout) != TCL_OK) { return TCL_ERROR; } } - str = Tcl_GetStringFromObj(objv[2], &len); + str = Tcl_GetStringFromObj(objv[0], &len); if (len == 0) { str = NULL; } @@ -1424,7 +1417,7 @@ BroadcastValue( * Use the ignore the result. */ - result = SendMessageTimeout(HWND_BROADCAST, WM_SETTINGCHANGE, + result = SendMessageTimeoutA(HWND_BROADCAST, WM_SETTINGCHANGE, (WPARAM) 0, (LPARAM) str, SMTO_ABORTIFHUNG, timeout, &sendResult); objPtr = Tcl_NewObj(); @@ -1458,8 +1451,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 +1460,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 +1522,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 d5244ac..75d5ffc 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; @@ -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. */ { @@ -1034,7 +1034,7 @@ SerialOutputProc( * the channel is in non-blocking mode. */ - errno = EWOULDBLOCK; + errno = EAGAIN; goto error1; } @@ -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; @@ -1428,7 +1428,7 @@ SerialWriterThread( HANDLE TclWinSerialReopen( HANDLE handle, - CONST TCHAR *name, + const TCHAR *name, DWORD access) { SerialInit(); @@ -1442,8 +1442,8 @@ TclWinSerialReopen( if (CloseHandle(handle) == FALSE) { return INVALID_HANDLE_VALUE; } - 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; } @@ -1476,7 +1476,7 @@ TclWinOpenSerialChannel( SerialInit(); - infoPtr = (SerialInfo *) ckalloc((unsigned) sizeof(SerialInfo)); + infoPtr = ckalloc(sizeof(SerialInfo)); memset(infoPtr, 0, sizeof(SerialInfo)); infoPtr->validMask = permissions; @@ -1497,10 +1497,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); @@ -1643,17 +1643,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; @@ -1671,19 +1671,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; } @@ -1698,10 +1697,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; } @@ -1712,10 +1708,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; } /* @@ -1750,18 +1743,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; } @@ -1772,10 +1763,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) { @@ -1784,11 +1772,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; } @@ -1819,13 +1808,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; } @@ -1842,11 +1828,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; } @@ -1859,7 +1846,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; @@ -1868,7 +1858,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; @@ -1877,15 +1870,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; @@ -1893,7 +1891,7 @@ SerialSetOptionProc( } } - ckfree((char *) argv); + ckfree(argv); return result; } @@ -1919,20 +1917,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; } @@ -1945,18 +1947,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; } @@ -1986,7 +1982,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; } @@ -1996,6 +1995,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; } /* @@ -2023,7 +2038,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; @@ -2048,12 +2063,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; } @@ -2121,7 +2138,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; } @@ -2197,7 +2216,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; } @@ -2207,10 +2228,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 9fa01c9..f4d5a90 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -47,6 +47,13 @@ #include "tclWinInt.h" +/* + * Which version of the winsock API do we want? + */ + +#define WSA_VERSION_MAJOR 1 +#define WSA_VERSION_MINOR 1 + #ifdef _MSC_VER # pragma comment (lib, "ws2_32") #endif @@ -74,6 +81,7 @@ */ static int initialized = 0; +static const TCHAR classname[] = TEXT("TclSocket"); TCL_DECLARE_MUTEX(socketMutex) /* @@ -89,20 +97,44 @@ static ProcessGlobalValue hostName = { * The following defines declare the messages used on socket windows. */ -#define SOCKET_MESSAGE WM_USER+1 -#define SOCKET_SELECT WM_USER+2 -#define SOCKET_TERMINATE WM_USER+3 -#define SELECT TRUE -#define UNSELECT FALSE +#define SOCKET_MESSAGE WM_USER+1 +#define SOCKET_SELECT WM_USER+2 +#define SOCKET_TERMINATE WM_USER+3 +#define SELECT TRUE +#define UNSELECT FALSE + +/* + * This is needed to comply with the strict aliasing rules of GCC, but it also + * simplifies casting between the different sockaddr types. + */ + +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 + +typedef struct SocketInfo SocketInfo; + +typedef struct TcpFdList { + SocketInfo *infoPtr; + SOCKET fd; + struct TcpFdList *next; +} TcpFdList; /* * The following structure is used to store the data associated with each * socket. */ -typedef struct SocketInfo { +struct SocketInfo { Tcl_Channel channel; /* Channel associated with this socket. */ - SOCKET socket; /* Windows SOCKET handle. */ + 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, @@ -123,7 +155,7 @@ typedef struct SocketInfo { int lastError; /* Error code from last message. */ struct SocketInfo *nextPtr; /* The next socket on the per-thread socket * list. */ -} SocketInfo; +}; /* * The following structure is what is added to the Tcl event queue when a @@ -181,15 +213,13 @@ static WNDCLASS windowClass; 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 void InitSockets(void); static SocketInfo * 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 void TcpAccept(TcpFdList *fds, SOCKET newSocket, address addr); static int WaitForSocketEvent(SocketInfo *infoPtr, int events, int *errorCodePtr); static DWORD WINAPI SocketThread(LPVOID arg); @@ -201,6 +231,7 @@ static Tcl_EventProc SocketEventProc; static Tcl_EventSetupProc SocketSetupProc; static Tcl_DriverBlockModeProc TcpBlockProc; static Tcl_DriverCloseProc TcpCloseProc; +static Tcl_DriverClose2Proc TcpClose2Proc; static Tcl_DriverSetOptionProc TcpSetOptionProc; static Tcl_DriverGetOptionProc TcpGetOptionProc; static Tcl_DriverInputProc TcpInputProc; @@ -213,7 +244,7 @@ static Tcl_DriverGetHandleProc TcpGetHandleProc; * based IO. */ -static Tcl_ChannelType tcpChannelType = { +static const Tcl_ChannelType tcpChannelType = { "tcp", /* Type name. */ TCL_CHANNEL_VERSION_5, /* v5 channel */ TcpCloseProc, /* Close proc. */ @@ -224,13 +255,13 @@ static Tcl_ChannelType tcpChannelType = { TcpGetOptionProc, /* Get option proc. */ TcpWatchProc, /* Set up notifier to watch this channel. */ TcpGetHandleProc, /* Get an OS handle from channel. */ - NULL, /* close2proc. */ + TcpClose2Proc, /* Close2proc. */ TcpBlockProc, /* Set socket into (non-)blocking mode. */ NULL, /* flush proc. */ NULL, /* handler proc. */ NULL, /* wide seek proc */ TcpThreadActionProc, /* thread action proc */ - NULL, /* truncate */ + NULL /* truncate */ }; /* @@ -256,15 +287,13 @@ static Tcl_ChannelType tcpChannelType = { static void InitSockets(void) { - DWORD id; + DWORD id, err; WSADATA wsaData; - DWORD err; - ThreadSpecificData *tsdPtr = (ThreadSpecificData *) - TclThreadDataKeyGet(&dataKey); + ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); if (!initialized) { initialized = 1; - TclCreateLateExitHandler(SocketExitHandler, (ClientData) NULL); + TclCreateLateExitHandler(SocketExitHandler, NULL); /* * Create the async notification window with a new class. We must @@ -279,12 +308,12 @@ InitSockets(void) windowClass.hInstance = TclWinGetTclInstance(); windowClass.hbrBackground = NULL; windowClass.lpszMenuName = NULL; - windowClass.lpszClassName = "TclSocket"; + windowClass.lpszClassName = classname; windowClass.lpfnWndProc = SocketProc; windowClass.hIcon = NULL; windowClass.hCursor = NULL; - if (!RegisterClassA(&windowClass)) { + if (!RegisterClass(&windowClass)) { TclWinConvertError(GetLastError()); goto initFailure; } @@ -295,72 +324,73 @@ InitSockets(void) * that it not be less than 1.1. */ -#define WSA_VERSION_MAJOR 1 -#define WSA_VERSION_MINOR 1 -#define WSA_VERSION_REQD MAKEWORD(WSA_VERSION_MAJOR, WSA_VERSION_MINOR) - - err = WSAStartup((WORD)WSA_VERSION_REQD, &wsaData); + err = WSAStartup((WORD) MAKEWORD(WSA_VERSION_MAJOR,WSA_VERSION_MINOR), + &wsaData); if (err != 0) { - TclWinConvertWSAError(err); + TclWinConvertError(err); goto initFailure; } /* - * Note the byte positions are swapped for the comparison, so that - * 0x0002 (2.0, MAKEWORD(2,0)) doesn't look less than 0x0101 (1.1). - * We want the comparison to be 0x0200 < 0x0101. + * Note the byte positions ae swapped for the comparison, so that + * 0x0002 (2.0, MAKEWORD(2,0)) doesn't look less than 0x0101 (1.1). We + * want the comparison to be 0x0200 < 0x0101. */ if (MAKEWORD(HIBYTE(wsaData.wVersion), LOBYTE(wsaData.wVersion)) < MAKEWORD(WSA_VERSION_MINOR, WSA_VERSION_MAJOR)) { - TclWinConvertWSAError(WSAVERNOTSUPPORTED); + TclWinConvertError(WSAVERNOTSUPPORTED); WSACleanup(); goto initFailure; } - -#undef WSA_VERSION_REQD -#undef WSA_VERSION_MAJOR -#undef WSA_VERSION_MINOR } /* * Check for per-thread initialization. */ - if (tsdPtr == NULL) { - tsdPtr = TCL_TSD_INIT(&dataKey); - 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; - } + if (tsdPtr != NULL) { + return; + } - SetThreadPriority(tsdPtr->socketThread, THREAD_PRIORITY_HIGHEST); + /* + * 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. + */ - /* - * Wait for the thread to signal when the window has been created and - * if it is ready to go. - */ + tsdPtr = TCL_TSD_INIT(&dataKey); + 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; + } - WaitForSingleObject(tsdPtr->readyEvent, INFINITE); + SetThreadPriority(tsdPtr->socketThread, THREAD_PRIORITY_HIGHEST); - if (tsdPtr->hwnd == NULL) { - goto initFailure; /* Trouble creating the window */ - } + /* + * Wait for the thread to signal when the window has been created and if + * it is ready to go. + */ + + WaitForSingleObject(tsdPtr->readyEvent, INFINITE); - Tcl_CreateEventSource(SocketSetupProc, SocketCheckProc, NULL); + if (tsdPtr->hwnd == NULL) { + goto initFailure; /* Trouble creating the window. */ } + + Tcl_CreateEventSource(SocketSetupProc, SocketCheckProc, NULL); return; initFailure: @@ -390,6 +420,7 @@ static int SocketsEnabled(void) { int enabled; + Tcl_MutexLock(&socketMutex); enabled = (initialized == 1); Tcl_MutexUnlock(&socketMutex); @@ -420,13 +451,14 @@ SocketExitHandler( ClientData clientData) /* Not used. */ { Tcl_MutexLock(&socketMutex); + /* * Make sure the socket event handling window is cleaned-up for, at * most, this thread. */ TclpFinalizeSockets(); - UnregisterClass("TclSocket", TclWinGetTclInstance()); + UnregisterClass(classname, TclWinGetTclInstance()); WSACleanup(); initialized = 0; Tcl_MutexUnlock(&socketMutex); @@ -454,34 +486,40 @@ 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); } /* @@ -519,8 +557,8 @@ TclpHasSockets( return TCL_OK; } if (interp != NULL) { - Tcl_AppendResult(interp, "sockets are not available on this system", - NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "sockets are not available on this system", -1)); } return TCL_ERROR; } @@ -612,9 +650,9 @@ SocketCheckProc( if ((infoPtr->readyEvents & infoPtr->watchEvents) && !(infoPtr->flags & SOCKET_PENDING)) { infoPtr->flags |= SOCKET_PENDING; - evPtr = (SocketEvent *) ckalloc(sizeof(SocketEvent)); + evPtr = ckalloc(sizeof(SocketEvent)); evPtr->header.proc = SocketEventProc; - evPtr->socket = infoPtr->socket; + evPtr->socket = infoPtr->sockets->fd; Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL); } } @@ -650,9 +688,12 @@ SocketEventProc( { SocketInfo *infoPtr; SocketEvent *eventPtr = (SocketEvent *) evPtr; - int mask = 0; - int events; + 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; @@ -665,17 +706,17 @@ SocketEventProc( WaitForSingleObject(tsdPtr->socketListLock, INFINITE); for (infoPtr = tsdPtr->socketList; infoPtr != NULL; infoPtr = infoPtr->nextPtr) { - if (infoPtr->socket == eventPtr->socket) { + if (infoPtr->sockets->fd == eventPtr->socket) { break; } } - SetEvent(tsdPtr->socketListLock); /* * Discard events that have gone stale. */ if (!infoPtr) { + SetEvent(tsdPtr->socketListLock); return 1; } @@ -686,10 +727,66 @@ SocketEventProc( */ if (infoPtr->readyEvents & FD_ACCEPT) { - TcpAccept(infoPtr); + for (fds = infoPtr->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; + } + + /* + * 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); + + /* 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 infoPtr 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. + */ + infoPtr->acceptEventCount = 0; + infoPtr->readyEvents &= ~(FD_ACCEPT); + + SetEvent(tsdPtr->socketListLock); return 1; } + SetEvent(tsdPtr->socketListLock); + /* * Mask off unwanted events and compute the read/write mask so we can * notify the channel. @@ -709,6 +806,7 @@ SocketEventProc( */ Tcl_Time blockTime = { 0, 0 }; + Tcl_SetMaxBlockTime(&blockTime); mask |= TCL_READABLE|TCL_WRITABLE; } else if (events & FD_READ) { @@ -727,7 +825,7 @@ SocketEventProc( (WPARAM) UNSELECT, (LPARAM) infoPtr); FD_ZERO(&readFds); - FD_SET(infoPtr->socket, &readFds); + FD_SET(infoPtr->sockets->fd, &readFds); timeout.tv_usec = 0; timeout.tv_sec = 0; @@ -778,7 +876,7 @@ TcpBlockProc( int mode) /* TCL_MODE_BLOCKING or * TCL_MODE_NONBLOCKING. */ { - SocketInfo *infoPtr = (SocketInfo *) instanceData; + SocketInfo *infoPtr = instanceData; if (mode == TCL_MODE_NONBLOCKING) { infoPtr->flags |= SOCKET_ASYNC; @@ -812,7 +910,7 @@ TcpCloseProc( ClientData instanceData, /* The socket to close. */ Tcl_Interp *interp) /* Unused. */ { - SocketInfo *infoPtr = (SocketInfo *) instanceData; + SocketInfo *infoPtr = instanceData; /* TIP #218 */ int errorCode = 0; /* ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); */ @@ -830,9 +928,15 @@ TcpCloseProc( * background. */ - if (closesocket(infoPtr->socket) == SOCKET_ERROR) { - TclWinConvertWSAError((DWORD) WSAGetLastError()); - errorCode = Tcl_GetErrno(); + while ( infoPtr->sockets != NULL ) { + TcpFdList *thisfd = infoPtr->sockets; + infoPtr->sockets = thisfd->next; + + if (closesocket(thisfd->fd) == SOCKET_ERROR) { + TclWinConvertError((DWORD) WSAGetLastError()); + errorCode = Tcl_GetErrno(); + } + ckfree(thisfd); } } @@ -843,13 +947,113 @@ TcpCloseProc( * fear of damaging the list. */ - ckfree((char *) infoPtr); + ckfree(infoPtr); + return errorCode; +} + +/* + *---------------------------------------------------------------------- + * + * TcpClose2Proc -- + * + * 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: + * 0 if successful, the value of errno if failed. + * + * Side effects: + * Shuts down one side of the 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 = instanceData; + int errorCode = 0, sd; + + /* + * Shutdown the OS socket handle. + */ + + 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(infoPtr->sockets->fd, sd) == SOCKET_ERROR) { + TclWinConvertError((DWORD) WSAGetLastError()); + errorCode = Tcl_GetErrno(); + } + return errorCode; } /* *---------------------------------------------------------------------- * + * AddSocketInfoFd -- + * + * This function adds a SOCKET file descriptor to the 'sockets' linked + * list of a SocketInfo structure. + * + * Results: + * None. + * + * Side effects: + * None, except for allocation of memory. + * + *---------------------------------------------------------------------- + */ + +static void +AddSocketInfoFd( + SocketInfo *infoPtr, + SOCKET socket) +{ + TcpFdList *fds = infoPtr->sockets; + + if ( fds == NULL ) { + /* Add the first FD */ + infoPtr->sockets = ckalloc(sizeof(TcpFdList)); + fds = infoPtr->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->infoPtr = infoPtr; + fds->next = NULL; +} + + +/* + *---------------------------------------------------------------------- + * * NewSocketInfo -- * * This function allocates and initializes a new SocketInfo structure. @@ -867,12 +1071,11 @@ static SocketInfo * NewSocketInfo( SOCKET socket) { - SocketInfo *infoPtr; - /* ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); */ + SocketInfo *infoPtr = ckalloc(sizeof(SocketInfo)); - infoPtr = (SocketInfo *) ckalloc((unsigned) sizeof(SocketInfo)); + /* ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); */ infoPtr->channel = 0; - infoPtr->socket = socket; + infoPtr->sockets = NULL; infoPtr->flags = 0; infoPtr->watchEvents = 0; infoPtr->readyEvents = 0; @@ -890,6 +1093,8 @@ NewSocketInfo( infoPtr->nextPtr = NULL; + AddSocketInfoFd(infoPtr, socket); + return infoPtr; } @@ -925,12 +1130,16 @@ CreateSocket( u_long flag = 1; /* Indicates nonblocking mode. */ int asyncConnect = 0; /* Will be 1 if async connect is in * progress. */ - SOCKADDR_IN sockaddr; /* Socket address */ - SOCKADDR_IN mysockaddr; /* Socket address for client */ + unsigned short chosenport = 0; + void *addrlist = NULL, *myaddrlist = NULL; + struct addrinfo *addrPtr; + /* Socket address to connect to. */ + struct addrinfo *myaddrPtr; + /* Socket address for our side. */ + const char *errorMsg = NULL; SOCKET sock = INVALID_SOCKET; - SocketInfo *infoPtr; /* The returned value. */ - ThreadSpecificData *tsdPtr = (ThreadSpecificData *) - TclThreadDataKeyGet(&dataKey); + SocketInfo *infoPtr = NULL; /* The returned value. */ + ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); /* * Check that WinSock is initialized; do not call it if not, to prevent @@ -942,112 +1151,195 @@ CreateSocket( return NULL; } - if (!CreateSocketAddress(&sockaddr, host, port)) { - goto error; - } - if ((myaddr != NULL || myport != 0) && - !CreateSocketAddress(&mysockaddr, myaddr, myport)) { + /* + * Construct the addresses for each end of the socket. + */ + + if (!TclCreateSocketAddress(interp, &addrlist, host, port, server, + &errorMsg)) { goto error; } - - sock = socket(AF_INET, SOCK_STREAM, 0); - if (sock == INVALID_SOCKET) { + if (!TclCreateSocketAddress(interp, &myaddrlist, myaddr, myport, 1, + &errorMsg)) { goto error; } - /* - * Win-NT has a misfeature that sockets are inherited in child processes - * by default. Turn off the inherit bit. - */ + if (server) { - SetHandleInformation((HANDLE) sock, HANDLE_FLAG_INHERIT, 0); + for (addrPtr = addrlist; addrPtr != NULL; addrPtr = addrPtr->ai_next) { + sock = socket(addrPtr->ai_family, SOCK_STREAM, 0); + if (sock == INVALID_SOCKET) { + TclWinConvertError((DWORD) WSAGetLastError()); + continue; + } - /* - * Set kernel space buffering - */ + /* + * Win-NT has a misfeature that sockets are inherited in child + * processes by default. Turn off the inherit bit. + */ - TclSockMinimumBuffers((void *)sock, TCP_BUFFER_SIZE); + SetHandleInformation((HANDLE) sock, HANDLE_FLAG_INHERIT, 0); - 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. - */ + /* + * Set kernel space buffering + */ - if (bind(sock, (SOCKADDR *) &sockaddr, sizeof(SOCKADDR_IN)) - == SOCKET_ERROR) { - goto error; - } + TclSockMinimumBuffers((void *)sock, TCP_BUFFER_SIZE); - /* - * 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). - */ + /* + * 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 (listen(sock, SOMAXCONN) == SOCKET_ERROR) { - goto error; - } + if (port == 0 && chosenport != 0) { + ((struct sockaddr_in *) addrPtr->ai_addr)->sin_port = + htons(chosenport); + } - /* - * Add this socket to the global list of sockets. - */ + /* + * 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. + */ - infoPtr = NewSocketInfo(sock); + 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); - /* - * Set up the select mask for connection request events. - */ + /* + * Synchronize port numbers when binding to port 0 of multiple + * addresses. + */ - infoPtr->selectEvents = FD_ACCEPT; - infoPtr->watchEvents |= FD_ACCEPT; + if (getsockname(sock, &sockname.sa, &namelen) >= 0) { + chosenport = ntohs(sockname.sa4.sin_port); + } + } - } else { - /* - * Try to bind to a local port, if specified. - */ + /* + * 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 (myaddr != NULL || myport != 0) { - if (bind(sock, (SOCKADDR *) &mysockaddr, sizeof(SOCKADDR_IN)) - == SOCKET_ERROR) { - goto error; + if (listen(sock, SOMAXCONN) == SOCKET_ERROR) { + TclWinConvertError((DWORD) WSAGetLastError()); + closesocket(sock); + continue; } - } - /* - * Set the socket into nonblocking mode if the connect should be done - * in the background. - */ + if (infoPtr == NULL) { + /* + * Add this socket to the global list of sockets. + */ + + infoPtr = NewSocketInfo(sock); + + /* + * Set up the select mask for connection request events. + */ + + infoPtr->selectEvents = FD_ACCEPT; + infoPtr->watchEvents |= FD_ACCEPT; - if (async) { - if (ioctlsocket(sock, (long) FIONBIO, &flag) == SOCKET_ERROR) { - goto error; + } else { + AddSocketInfoFd( infoPtr, sock ); } } + } else { + for (addrPtr = addrlist; addrPtr != NULL; + addrPtr = addrPtr->ai_next) { + for (myaddrPtr = myaddrlist; myaddrPtr != NULL; + myaddrPtr = myaddrPtr->ai_next) { + /* + * No need to try combinations of local and remote addresses + * of different families. + */ - /* - * Attempt to connect to the remote socket. - */ + if (myaddrPtr->ai_family != addrPtr->ai_family) { + continue; + } - if (connect(sock, (SOCKADDR *) &sockaddr, - sizeof(SOCKADDR_IN)) == SOCKET_ERROR) { - TclWinConvertWSAError((DWORD) WSAGetLastError()); - if (Tcl_GetErrno() != EWOULDBLOCK) { - goto error; - } + sock = socket(myaddrPtr->ai_family, SOCK_STREAM, 0); + if (sock == INVALID_SOCKET) { + TclWinConvertError((DWORD) WSAGetLastError()); + continue; + } - /* - * The connection is progressing in the background. - */ + /* + * 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); - asyncConnect = 1; + /* + * Set kernel space buffering + */ + + TclSockMinimumBuffers((void *) sock, TCP_BUFFER_SIZE); + + /* + * Try to bind to a local port. + */ + + if (bind(sock, myaddrPtr->ai_addr, myaddrPtr->ai_addrlen) + == SOCKET_ERROR) { + TclWinConvertError((DWORD) WSAGetLastError()); + goto looperror; + } + /* + * Set the socket into nonblocking mode if the connect should + * be done in the background. + */ + if (async && ioctlsocket(sock, (long) FIONBIO, &flag) + == SOCKET_ERROR) { + TclWinConvertError((DWORD) WSAGetLastError()); + goto looperror; + } + + /* + * Attempt to connect to the remote socket. + */ + + if (connect(sock, addrPtr->ai_addr, addrPtr->ai_addrlen) + == SOCKET_ERROR) { + TclWinConvertError((DWORD) WSAGetLastError()); + if (Tcl_GetErrno() != EAGAIN) { + goto looperror; + } + + /* + * The connection is progressing in the background. + */ + + asyncConnect = 1; + } + goto connected; + + looperror: + if (sock != INVALID_SOCKET) { + closesocket(sock); + sock = INVALID_SOCKET; + } + } } + goto error; + connected: /* * Add this socket to the global list of sockets. */ @@ -1066,22 +1358,33 @@ CreateSocket( } } + error: + if (addrlist == NULL) { + freeaddrinfo(addrlist); + } + if (myaddrlist == NULL) { + freeaddrinfo(myaddrlist); + } + /* * 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); + if (infoPtr != NULL) { + ioctlsocket(sock, (long) FIONBIO, &flag); + SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT, + (LPARAM) infoPtr); - return infoPtr; + return infoPtr; + } - error: - TclWinConvertWSAError((DWORD) WSAGetLastError()); if (interp != NULL) { - Tcl_AppendResult(interp, "couldn't open socket: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't open socket: %s", + (errorMsg ? errorMsg : Tcl_PosixError(interp)))); } + if (sock != INVALID_SOCKET) { closesocket(sock); } @@ -1091,78 +1394,6 @@ CreateSocket( /* *---------------------------------------------------------------------- * - * CreateSocketAddress -- - * - * This function initializes a sockaddr structure for a host and port. - * - * Results: - * 1 if the host was valid, 0 if the host could not be converted to an IP - * address. - * - * Side effects: - * Fills in the *sockaddrPtr structure. - * - *---------------------------------------------------------------------- - */ - -static int -CreateSocketAddress( - LPSOCKADDR_IN sockaddrPtr, /* Socket address */ - const char *host, /* Host. NULL implies INADDR_ANY */ - int port) /* Port number */ -{ - struct hostent *hostent; /* Host database entry */ - struct in_addr addr; /* For 64/32 bit madness */ - - /* - * 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()) { - Tcl_SetErrno(EFAULT); - return 0; - } - - 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. */ - } - } - } - - /* - * 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? - */ - - sockaddrPtr->sin_addr.s_addr = addr.s_addr; - return 1; /* Success. */ -} - -/* - *---------------------------------------------------------------------- - * * WaitForSocketEvent -- * * Waits until one of the specified events occurs on a socket. @@ -1185,8 +1416,7 @@ WaitForSocketEvent( { int result = 1; int oldMode; - ThreadSpecificData *tsdPtr = (ThreadSpecificData *) - TclThreadDataKeyGet(&dataKey); + ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); /* * Be sure to disable event servicing so we are truly modal. @@ -1200,7 +1430,6 @@ WaitForSocketEvent( SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) UNSELECT, (LPARAM) infoPtr); - SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT, (LPARAM) infoPtr); @@ -1212,7 +1441,7 @@ WaitForSocketEvent( } else if (infoPtr->readyEvents & events) { break; } else if (infoPtr->flags & SOCKET_ASYNC) { - *errorCodePtr = EWOULDBLOCK; + *errorCodePtr = EAGAIN; result = 0; break; } @@ -1271,19 +1500,18 @@ Tcl_OpenTcpClient( return NULL; } - sprintf(channelName, "sock%" TCL_I_MODIFIER "u", (size_t)infoPtr->socket); + sprintf(channelName, "sock%" TCL_I_MODIFIER "u", (size_t) infoPtr->sockets->fd); 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 (Tcl_SetChannelOption(NULL, infoPtr->channel, "-eofchar", "") - == TCL_ERROR) { - Tcl_Close((Tcl_Interp *) NULL, infoPtr->channel); - return (Tcl_Channel) NULL; + infoPtr, (TCL_READABLE | TCL_WRITABLE)); + if (TCL_ERROR == Tcl_SetChannelOption(NULL, infoPtr->channel, + "-translation", "auto crlf")) { + Tcl_Close(NULL, infoPtr->channel); + return NULL; + } else if (TCL_ERROR == Tcl_SetChannelOption(NULL, infoPtr->channel, + "-eofchar", "")) { + Tcl_Close(NULL, infoPtr->channel); + return NULL; } return infoPtr->channel; } @@ -1318,7 +1546,7 @@ Tcl_MakeTcpClientChannel( return NULL; } - tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey); + tsdPtr = TclThreadDataKeyGet(&dataKey); /* * Set kernel space buffering and non-blocking. @@ -1333,12 +1561,11 @@ Tcl_MakeTcpClientChannel( */ infoPtr->selectEvents = FD_READ | FD_CLOSE | FD_WRITE; - SendMessage(tsdPtr->hwnd, SOCKET_SELECT, - (WPARAM) SELECT, (LPARAM) infoPtr); + SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM)SELECT, (LPARAM)infoPtr); - sprintf(channelName, "sock%" TCL_I_MODIFIER "u", (size_t)infoPtr->socket); + sprintf(channelName, "sock%" TCL_I_MODIFIER "u", (size_t) infoPtr->sockets->fd); infoPtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName, - (ClientData) infoPtr, (TCL_READABLE | TCL_WRITABLE)); + infoPtr, (TCL_READABLE | TCL_WRITABLE)); Tcl_SetChannelOption(NULL, infoPtr->channel, "-translation", "auto crlf"); return infoPtr->channel; } @@ -1389,14 +1616,14 @@ Tcl_OpenTcpServer( infoPtr->acceptProc = acceptProc; infoPtr->acceptProcData = acceptProcData; - sprintf(channelName, "sock%" TCL_I_MODIFIER "u", (size_t)infoPtr->socket); + sprintf(channelName, "sock%" TCL_I_MODIFIER "u", (size_t) infoPtr->sockets->fd); infoPtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName, - (ClientData) infoPtr, 0); + infoPtr, 0); if (Tcl_SetChannelOption(interp, infoPtr->channel, "-eofchar", "") == TCL_ERROR) { - Tcl_Close((Tcl_Interp *) NULL, infoPtr->channel); - return (Tcl_Channel) NULL; + Tcl_Close(NULL, infoPtr->channel); + return NULL; } return infoPtr->channel; @@ -1407,8 +1634,9 @@ Tcl_OpenTcpServer( * * TcpAccept -- * - * Accept a TCP socket connection. This is called by SocketEventProc and - * it in turns calls the registered accept function. + * Creates a channel for a newly accepted socket connection. This is + * called by SocketEventProc and it in turns calls the registered + * accept function. * * Results: * None. @@ -1421,58 +1649,16 @@ Tcl_OpenTcpServer( 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; + SocketInfo *infoPtr = fds->infoPtr; + int len = sizeof(addr); 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); + char host[NI_MAXHOST], port[NI_MAXSERV]; + ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); /* * Win-NT has a misfeature that sockets are inherited in child processes @@ -1492,20 +1678,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%" TCL_I_MODIFIER "u", (size_t) newInfoPtr->sockets->fd); 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; } @@ -1514,8 +1700,10 @@ TcpAccept( */ if (infoPtr->acceptProc != NULL) { - (infoPtr->acceptProc) (infoPtr->acceptProcData, newInfoPtr->channel, - inet_ntoa(addr.sin_addr), ntohs(addr.sin_port)); + getnameinfo(&(addr.sa), len, host, sizeof(host), port, sizeof(port), + NI_NUMERICHOST|NI_NUMERICSERV); + infoPtr->acceptProc(infoPtr->acceptProcData, newInfoPtr->channel, + host, atoi(port)); } } @@ -1543,11 +1731,10 @@ TcpInputProc( int toRead, /* Maximum number of bytes to read. */ int *errorCodePtr) /* Where to store error codes. */ { - SocketInfo *infoPtr = (SocketInfo *) instanceData; + SocketInfo *infoPtr = instanceData; int bytesRead; DWORD error; - ThreadSpecificData *tsdPtr = (ThreadSpecificData *) - TclThreadDataKeyGet(&dataKey); + ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); *errorCodePtr = 0; @@ -1591,7 +1778,8 @@ TcpInputProc( while (1) { SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) UNSELECT, (LPARAM) infoPtr); - bytesRead = recv(infoPtr->socket, buf, toRead, 0); + /* single fd operation: this proc is only called for a connected socket. */ + bytesRead = recv(infoPtr->sockets->fd, buf, toRead, 0); infoPtr->readyEvents &= ~(FD_READ); /* @@ -1634,7 +1822,7 @@ TcpInputProc( */ if ((infoPtr->flags & SOCKET_ASYNC) || (error != WSAEWOULDBLOCK)) { - TclWinConvertWSAError(error); + TclWinConvertError(error); *errorCodePtr = Tcl_GetErrno(); bytesRead = -1; break; @@ -1651,8 +1839,7 @@ TcpInputProc( } } - SendMessage(tsdPtr->hwnd, SOCKET_SELECT, - (WPARAM) SELECT, (LPARAM) infoPtr); + SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM)SELECT, (LPARAM)infoPtr); return bytesRead; } @@ -1681,11 +1868,10 @@ TcpOutputProc( int toWrite, /* Maximum number of bytes to write. */ int *errorCodePtr) /* Where to store error codes. */ { - SocketInfo *infoPtr = (SocketInfo *) instanceData; + SocketInfo *infoPtr = instanceData; int bytesWritten; DWORD error; - ThreadSpecificData *tsdPtr = (ThreadSpecificData *) - TclThreadDataKeyGet(&dataKey); + ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); *errorCodePtr = 0; @@ -1713,7 +1899,8 @@ TcpOutputProc( SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) UNSELECT, (LPARAM) infoPtr); - bytesWritten = send(infoPtr->socket, buf, toWrite, 0); + /* single fd operation: this proc is only called for a connected socket. */ + bytesWritten = send(infoPtr->sockets->fd, buf, toWrite, 0); if (bytesWritten != SOCKET_ERROR) { /* * Since Windows won't generate a new write event until we hit an @@ -1739,12 +1926,12 @@ TcpOutputProc( if (error == WSAEWOULDBLOCK) { infoPtr->readyEvents &= ~(FD_WRITE); if (infoPtr->flags & SOCKET_ASYNC) { - *errorCodePtr = EWOULDBLOCK; + *errorCodePtr = EAGAIN; bytesWritten = -1; break; } } else { - TclWinConvertWSAError(error); + TclWinConvertError(error); *errorCodePtr = Tcl_GetErrno(); bytesWritten = -1; break; @@ -1761,8 +1948,7 @@ TcpOutputProc( } } - SendMessage(tsdPtr->hwnd, SOCKET_SELECT, - (WPARAM) SELECT, (LPARAM) infoPtr); + SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM)SELECT, (LPARAM)infoPtr); return bytesWritten; } @@ -1791,9 +1977,9 @@ TcpSetOptionProc( const char *value) /* New value for option. */ { #ifdef TCL_FEATURE_KEEPALIVE_NAGLE - SocketInfo *infoPtr; + SocketInfo *infoPtr = instanceData; SOCKET sock; -#endif +#endif /*TCL_FEATURE_KEEPALIVE_NAGLE*/ /* * Check that WinSock is initialized; do not call it if not, to prevent @@ -1803,14 +1989,15 @@ TcpSetOptionProc( if (!SocketsEnabled()) { if (interp) { - Tcl_AppendResult(interp, "winsock is not initialized", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "winsock is not initialized", -1)); } return TCL_ERROR; } #ifdef TCL_FEATURE_KEEPALIVE_NAGLE - infoPtr = (SocketInfo *) instanceData; - sock = infoPtr->socket; + #error "TCL_FEATURE_KEEPALIVE_NAGLE not reviewed for whether to treat infoPtr->sockets as single fd or list" + sock = infoPtr->sockets->fd; if (!strcasecmp(optionName, "-keepalive")) { BOOL val = FALSE; @@ -1825,10 +2012,11 @@ TcpSetOptionProc( rtn = setsockopt(sock, SOL_SOCKET, SO_KEEPALIVE, (const char *) &val, sizeof(BOOL)); if (rtn != 0) { - TclWinConvertWSAError(WSAGetLastError()); + TclWinConvertError(WSAGetLastError()); if (interp) { - Tcl_AppendResult(interp, "couldn't set socket option: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't set socket option: %s", + Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -1846,10 +2034,11 @@ TcpSetOptionProc( rtn = setsockopt(sock, IPPROTO_TCP, TCP_NODELAY, (const char *) &val, sizeof(BOOL)); if (rtn != 0) { - TclWinConvertWSAError(WSAGetLastError()); + TclWinConvertError(WSAGetLastError()); if (interp) { - Tcl_AppendResult(interp, "couldn't set socket option: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't set socket option: %s", + Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -1892,14 +2081,12 @@ TcpGetOptionProc( Tcl_DString *dsPtr) /* Where to store the computed value; * initialized by caller. */ { - SocketInfo *infoPtr; - SOCKADDR_IN sockname; - SOCKADDR_IN peername; - struct hostent *hostEntPtr; + SocketInfo *infoPtr = instanceData; + char host[NI_MAXHOST], port[NI_MAXSERV]; SOCKET sock; - int size = sizeof(SOCKADDR_IN); size_t len = 0; - char buf[TCL_INTEGER_SPACE]; + int reverseDNS = 0; +#define SUPPRESS_RDNS_VAR "::tcl::unsupported::noReverseDNS" /* * Check that WinSock is initialized; do not call it if not, to prevent @@ -1909,13 +2096,13 @@ TcpGetOptionProc( if (!SocketsEnabled()) { if (interp) { - Tcl_AppendResult(interp, "winsock is not initialized", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "winsock is not initialized", -1)); } return TCL_ERROR; } - infoPtr = (SocketInfo *) instanceData; - sock = (int) infoPtr->socket; + sock = infoPtr->sockets->fd; if (optionName != NULL) { len = strlen(optionName); } @@ -1927,40 +2114,40 @@ TcpGetOptionProc( int ret; optlen = sizeof(int); - ret = TclWinGetSockOpt((int)sock, SOL_SOCKET, SO_ERROR, + ret = TclWinGetSockOpt(sock, SOL_SOCKET, SO_ERROR, (char *)&err, &optlen); if (ret == SOCKET_ERROR) { err = WSAGetLastError(); } if (err) { - TclWinConvertWSAError(err); + TclWinConvertError(err); Tcl_DStringAppend(dsPtr, Tcl_ErrnoMsg(Tcl_GetErrno()), -1); } return TCL_OK; } + if (interp != NULL && Tcl_GetVar(interp, SUPPRESS_RDNS_VAR, 0) != NULL) { + reverseDNS = NI_NUMERICHOST; + } + if ((len == 0) || ((len > 1) && (optionName[1] == 'p') && (strncmp(optionName, "-peername", len) == 0))) { - if (getpeername(sock, (LPSOCKADDR) &peername, &size) == 0) { + address peername; + socklen_t size = sizeof(peername); + + if (getpeername(sock, (LPSOCKADDR) &(peername.sa), &size) == 0) { if (len == 0) { Tcl_DStringAppendElement(dsPtr, "-peername"); Tcl_DStringStartSublist(dsPtr); } - Tcl_DStringAppendElement(dsPtr, inet_ntoa(peername.sin_addr)); - 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); + 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 { @@ -1975,10 +2162,11 @@ TcpGetOptionProc( */ if (len) { - TclWinConvertWSAError((DWORD) WSAGetLastError()); + TclWinConvertError((DWORD) WSAGetLastError()); if (interp) { - Tcl_AppendResult(interp, "can't get peername: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't get peername: %s", + Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -1987,25 +2175,53 @@ TcpGetOptionProc( 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)); + TcpFdList *fds; + address sockname; + socklen_t size; + int found = 0; + + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-sockname"); + Tcl_DStringStartSublist(dsPtr); + } + for (fds = infoPtr->sockets; fds != NULL; fds = fds->next) { + sock = fds->fd; + size = sizeof(sockname); + if (getsockname(sock, &(sockname.sa), &size) >= 0) { + int flags = reverseDNS; + + found = 1; + getnameinfo(&sockname.sa, size, host, sizeof(host), + NULL, 0, NI_NUMERICHOST); + Tcl_DStringAppendElement(dsPtr, host); + + /* + * 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); } - TclFormatInt(buf, ntohs(sockname.sin_port)); - Tcl_DStringAppendElement(dsPtr, buf); + } + if (found) { if (len == 0) { Tcl_DStringEndSublist(dsPtr); } else { @@ -2013,9 +2229,9 @@ TcpGetOptionProc( } } else { if (interp) { - TclWinConvertWSAError((DWORD) WSAGetLastError()); - Tcl_AppendResult(interp, "can't get sockname: ", - Tcl_PosixError(interp), NULL); + TclWinConvertError((DWORD) WSAGetLastError()); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't get sockname: %s", Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -2049,8 +2265,7 @@ TcpGetOptionProc( Tcl_DStringAppendElement(dsPtr, "-nagle"); } optlen = sizeof(BOOL); - getsockopt(sock, IPPROTO_TCP, TCP_NODELAY, (char *)&opt, - &optlen); + getsockopt(sock, IPPROTO_TCP, TCP_NODELAY, (char *)&opt, &optlen); if (opt) { Tcl_DStringAppendElement(dsPtr, "0"); } else { @@ -2099,11 +2314,11 @@ TcpWatchProc( * TCL_READABLE, TCL_WRITABLE and * TCL_EXCEPTION. */ { - SocketInfo *infoPtr = (SocketInfo *) instanceData; + SocketInfo *infoPtr = instanceData; /* * Update the watch events mask. Only if the socket is not a server - * socket. Fix for SF Tcl Bug #557878. + * socket. [Bug 557878] */ if (!infoPtr->acceptProc) { @@ -2122,6 +2337,7 @@ TcpWatchProc( if (infoPtr->readyEvents & infoPtr->watchEvents) { Tcl_Time blockTime = { 0, 0 }; + Tcl_SetMaxBlockTime(&blockTime); } } @@ -2150,9 +2366,9 @@ TcpGetHandleProc( int direction, /* Not used. */ ClientData *handlePtr) /* Where to store the handle. */ { - SocketInfo *statePtr = (SocketInfo *) instanceData; + SocketInfo *statePtr = instanceData; - *handlePtr = (ClientData) statePtr->socket; + *handlePtr = INT2PTR(statePtr->sockets->fd); return TCL_OK; } @@ -2177,14 +2393,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. @@ -2248,6 +2464,7 @@ SocketProc( int event, error; SOCKET socket; SocketInfo *infoPtr; + TcpFdList *fds = NULL; ThreadSpecificData *tsdPtr = (ThreadSpecificData *) #ifdef _WIN64 GetWindowLongPtr(hwnd, GWLP_USERDATA); @@ -2292,58 +2509,60 @@ SocketProc( WaitForSingleObject(tsdPtr->socketListLock, INFINITE); for (infoPtr = tsdPtr->socketList; infoPtr != NULL; infoPtr = infoPtr->nextPtr) { - if (infoPtr->socket == socket) { - /* - * Update the socket state. - * - * A count of FD_ACCEPTS is stored, so if an FD_CLOSE event - * happens, then clear the FD_ACCEPT count. Otherwise, - * increment the count if the current event is an FD_ACCEPT. - */ - - if (event & FD_CLOSE) { - infoPtr->acceptEventCount = 0; - infoPtr->readyEvents &= ~(FD_WRITE|FD_ACCEPT); - } else if (event & FD_ACCEPT) { - infoPtr->acceptEventCount++; - } - - if (event & FD_CONNECT) { + for (fds = infoPtr->sockets; fds != NULL; fds = fds->next) { + if (fds->fd == socket) { /* - * The socket is now connected, clear the async connect - * flag. + * Update the socket state. + * + * A count of FD_ACCEPTS is stored, so if an FD_CLOSE event + * happens, then clear the FD_ACCEPT count. Otherwise, + * increment the count if the current event is an FD_ACCEPT. */ - infoPtr->flags &= ~(SOCKET_ASYNC_CONNECT); + if (event & FD_CLOSE) { + infoPtr->acceptEventCount = 0; + infoPtr->readyEvents &= ~(FD_WRITE|FD_ACCEPT); + } else if (event & FD_ACCEPT) { + infoPtr->acceptEventCount++; + } - /* - * Remember any error that occurred so we can report - * connection failures. - */ + 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) { - TclWinConvertWSAError((DWORD) error); - infoPtr->lastError = Tcl_GetErrno(); + if (error != ERROR_SUCCESS) { + TclWinConvertError((DWORD) error); + infoPtr->lastError = Tcl_GetErrno(); + } } - } - if (infoPtr->flags & SOCKET_ASYNC_CONNECT) { - infoPtr->flags &= ~(SOCKET_ASYNC_CONNECT); - if (error != ERROR_SUCCESS) { - TclWinConvertWSAError((DWORD) error); - infoPtr->lastError = Tcl_GetErrno(); + if (infoPtr->flags & SOCKET_ASYNC_CONNECT) { + infoPtr->flags &= ~(SOCKET_ASYNC_CONNECT); + if (error != ERROR_SUCCESS) { + TclWinConvertError((DWORD) error); + infoPtr->lastError = Tcl_GetErrno(); + } + infoPtr->readyEvents |= FD_WRITE; } - infoPtr->readyEvents |= FD_WRITE; - } - infoPtr->readyEvents |= event; + infoPtr->readyEvents |= event; - /* - * Wake up the Main Thread. - */ + /* + * Wake up the Main Thread. + */ - SetEvent(tsdPtr->readyEvent); - Tcl_ThreadAlert(tsdPtr->threadId); - break; + SetEvent(tsdPtr->readyEvent); + Tcl_ThreadAlert(tsdPtr->threadId); + break; + } } } SetEvent(tsdPtr->socketListLock); @@ -2351,15 +2570,18 @@ SocketProc( case SOCKET_SELECT: infoPtr = (SocketInfo *) lParam; - if (wParam == SELECT) { - WSAAsyncSelect(infoPtr->socket, hwnd, - SOCKET_MESSAGE, infoPtr->selectEvents); - } else { - /* - * Clear the selection mask - */ + for (fds = infoPtr->sockets; fds != NULL; fds = fds->next) { + infoPtr = (SocketInfo *) lParam; + if (wParam == SELECT) { + WSAAsyncSelect(fds->fd, hwnd, + SOCKET_MESSAGE, infoPtr->selectEvents); + } else { + /* + * Clear the selection mask + */ - WSAAsyncSelect(infoPtr->socket, hwnd, 0, 0); + WSAAsyncSelect(fds->fd, hwnd, 0, 0); + } } break; @@ -2414,16 +2636,16 @@ InitializeHostName( int *lengthPtr, Tcl_Encoding *encodingPtr) { - WCHAR wbuf[MAX_COMPUTERNAME_LENGTH + 1]; - DWORD length = sizeof(wbuf) / sizeof(WCHAR); + TCHAR tbuf[MAX_COMPUTERNAME_LENGTH + 1]; + DWORD length = MAX_COMPUTERNAME_LENGTH + 1; Tcl_DString ds; - if ((*tclWinProcs->getComputerNameProc)(wbuf, &length) != 0) { + if (GetComputerName(tbuf, &length) != 0) { /* * Convert string from native to UTF then change to lowercase. */ - Tcl_UtfToLower(Tcl_WinTCharToUtf((TCHAR *) wbuf, -1, &ds)); + Tcl_UtfToLower(Tcl_WinTCharToUtf(tbuf, -1, &ds)); } else { Tcl_DStringInit(&ds); @@ -2448,7 +2670,7 @@ InitializeHostName( *encodingPtr = Tcl_GetEncoding(NULL, "utf-8"); *lengthPtr = Tcl_DStringLength(&ds); - *valuePtr = ckalloc((unsigned int) (*lengthPtr)+1); + *valuePtr = ckalloc((*lengthPtr) + 1); memcpy(*valuePtr, Tcl_DStringValue(&ds), (size_t)(*lengthPtr)+1); Tcl_DStringFree(&ds); } @@ -2473,8 +2695,12 @@ InitializeHostName( */ int -TclWinGetSockOpt(SOCKET s, int level, int optname, char *optval, - int *optlen) +TclWinGetSockOpt( + SOCKET s, + int level, + int optname, + char *optval, + int *optlen) { /* * Check that WinSock is initialized; do not call it if not, to prevent @@ -2490,7 +2716,11 @@ TclWinGetSockOpt(SOCKET s, int level, int optname, char *optval, } int -TclWinSetSockOpt(SOCKET s, int level, int optname, const char *optval, +TclWinSetSockOpt( + SOCKET s, + int level, + int optname, + const char *optval, int optlen) { /* @@ -2506,8 +2736,10 @@ TclWinSetSockOpt(SOCKET s, int level, int optname, const char *optval, return setsockopt(s, level, optname, optval, optlen); } +#undef TclpInetNtoa char * -TclpInetNtoa(struct in_addr addr) +TclpInetNtoa( + struct in_addr addr) { /* * Check that WinSock is initialized; do not call it if not, to prevent @@ -2562,7 +2794,7 @@ TcpThreadActionProc( int action) { ThreadSpecificData *tsdPtr; - SocketInfo *infoPtr = (SocketInfo *) instanceData; + SocketInfo *infoPtr = instanceData; int notifyCmd; if (action == TCL_CHANNEL_THREAD_INSERT) { diff --git a/win/tclWinTest.c b/win/tclWinTest.c index e493fbf..b83c0ba 100644 --- a/win/tclWinTest.c +++ b/win/tclWinTest.c @@ -9,6 +9,9 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ +#ifndef USE_TCL_STUBS +# define USE_TCL_STUBS +#endif #include "tclInt.h" /* @@ -29,7 +32,6 @@ * 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 TestvolumetypeCmd(ClientData dummy, @@ -184,7 +186,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 +211,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 +341,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 +398,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 +408,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 +419,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 +438,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 +457,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 +476,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 +501,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 +516,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 +526,7 @@ TestplatformChmod( LPVOID pACE2; ACE_HEADER *phACE2; - if (!getAceProc(curAcl, j, &pACE2)) { + if (!GetAce(curAcl, j, &pACE2)) { goto done; } @@ -644,7 +549,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 +559,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 +569,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 +577,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); diff --git a/win/tclWinThrd.c b/win/tclWinThrd.c index 2413a78..1c9d483 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. @@ -210,7 +211,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 @@ -334,7 +335,7 @@ TclpThreadExit( Tcl_ThreadId Tcl_GetCurrentThread(void) { - return (Tcl_ThreadId) INT2PTR(GetCurrentThreadId()); + return (Tcl_ThreadId)(size_t)GetCurrentThreadId(); } /* @@ -576,7 +577,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); @@ -637,7 +638,7 @@ TclpFinalizeMutex( if (csPtr != NULL) { DeleteCriticalSection(csPtr); - ckfree((char *) csPtr); + ckfree(csPtr); *mutexPtr = NULL; } } @@ -668,7 +669,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 */ @@ -707,8 +708,7 @@ Tcl_ConditionWait( * and initializing that may drop back into the Master Lock. */ - Tcl_CreateThreadExitHandler(FinalizeConditionEvent, - (ClientData) tsdPtr); + Tcl_CreateThreadExitHandler(FinalizeConditionEvent, tsdPtr); } } @@ -720,7 +720,7 @@ Tcl_ConditionWait( */ if (*condPtr == NULL) { - winCondPtr = (WinCondition *) ckalloc(sizeof(WinCondition)); + winCondPtr = ckalloc(sizeof(WinCondition)); InitializeCriticalSection(&winCondPtr->condLock); winCondPtr->firstPtr = NULL; winCondPtr->lastPtr = NULL; @@ -769,7 +769,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); @@ -930,7 +931,7 @@ TclpFinalizeCondition( if (winCondPtr != NULL) { DeleteCriticalSection(&winCondPtr->condLock); - ckfree((char *) winCondPtr); + ckfree(winCondPtr); *condPtr = NULL; } } @@ -973,7 +974,7 @@ TclpFreeAllocMutex( void * TclpGetAllocCache(void) { - VOID *result; + void *result; if (!once) { /* @@ -1038,6 +1039,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..08cc4c5 --- /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.1 diff --git a/win/tclsh.ico b/win/tclsh.ico Binary files differindex 8bcaf48..e254318 100644 --- a/win/tclsh.ico +++ b/win/tclsh.ico |